diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,108 @@ +# Revision history for PenroseKiteDart + +## 1.0.0 -- 2024-04-08 + +Release candidate: +Added upper bounds on dependencies +Added new drawEmpire and changed drawEmpire1, drawEmpire2 to showEmpire1, showEmpire2 + +## 0.10.0.0 -- 2024-04-1 + +Removed some examples in TgraphExamples and export of some auxiliary functions in Tgraph.Relabelling + +## 0.9.1.0 -- 2024-03-12 + +Tgraph.Try as a separate module (instead of part of Tgraph.Prelude) +Added labelColourSize in DrawableLabelled with labelSize as special case +Changes to labelSize and line widths in some diagrams and drawing functions. +Removed labelSmall, labelLarge. +Added drawTrackedTgraphAligned. +Both restrictVP and relevantVP now check for missing locations. + +## 0.8.0.2 -- 2024-02-25 + +Documentation changes only. + +## 0.8.0.1 -- 2024-02-24 + +Fewer exported functions (Tgraph.Prelude, Tgraph.Relabelling), some renaming + +## 0.7.0.0 -- 2024-02-18 + +Export of modules specified and changed (with more hiding) + +## 0.6.0.0 -- 2024-02-17 + +Now as a standalone library + +## 0.5.2.0 -- 2024-02-14 + +Added PKD (overall wrapper module). + +## 0.5.1.0 -- 2024-02-13 + +Removed Tgraph.Convert (Conversions now included in Tgraph.Prelude) + +## 0.5.0.0 -- 2024-01-26 + +(Removed ChosenBackEnd) +Only Main now imports a Backend (in preparation for creating library only). +Types have been generalised in modules that were previously using Backend B +e.g. + + pCompFig :: Diagram B + +has become + + pCompFig :: Renderable (Path V2 Double) b => Diagram2D b + + +## 0.4.0.0 -- 2023-10-27 + +Tgraphs now defined as newType + +## 0.3.0.0 -- 2023-10-19 + +Modules: + src/ + HalfTile.hs -- (Half)Tile constructors - used by TileLib and Tgraph.Prelude + ChosenBackend.hs -- switch between e.g. SVG or PostScript + TileLib.hs -- Drawing of Pieces (and Patches) + Tgraphs.hs -- Main Graph Ops (imports and reexports all modules in Tgraph and adds extra ops) + Tgraph/ + Tgraph.Prelude.hs -- (imports and reexports HalfTile) + Tgraph.Decompose.hs + Tgraph.Compose.hs + Tgraph.Force.hs + Tgraph.Convert.hs -- Converting Tgraphs to VPatches (and drawing both) + TgraphExamples.hs + +## 0.2.0.0 -- 2022-03-31 + +Restructured modules + +Graphs and Graph ops are collected in Tgraphs.hs +Converting functions (and VPatch definition) are in Tgraph.Convert.hs +Graph example figures are in TgraphExamples.hs + +Original underlying Tile ops and tile drawing are in TileLib.hs + +## 0.2.0.0 -- 2021-06-18 + +New Graph representations and operations on graphs (decomposeG, composeG, force, and more) +Tools to convert to Patches for drawing etc and also intermediate VPatches, to display Vertex information. + +Key changes to original TileLib.hs : + +1. New versions of tile halves using polymorphic versions of constructors in HalfTile.hs +2. Pieces (replaces Components) +3. Redefining Patches as a list of Located Pieces (Pieces with point position rather than an offset vector) +4. Making Patches transformable (so that scale, rotate, translate can be used instead of specialised versions) + +also fillDK became fillDK' with new version of fillDK + +## 0.1.0.0 -- 2021-03-16 + +First version. +Vector representations and drawing tools for tile components and patches plus decompose and inflate operations. +Described in diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Reade (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Reade nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/PenroseKiteDart.cabal b/PenroseKiteDart.cabal new file mode 100644 --- /dev/null +++ b/PenroseKiteDart.cabal @@ -0,0 +1,81 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: PenroseKiteDart +version: 1.0.0 +synopsis: Library to explore Penrose's Kite and Dart Tilings. +description: Library to explore Penrose's Kite and Dart Tilings using Haskell Diagrams. Please see README.md +category: Graphics +homepage: https://github.com/chrisreade/PenroseKiteDart#readme +bug-reports: https://github.com/chrisreade/PenroseKiteDart/issues +author: Chris Reade +maintainer: chrisreade@mac.com +copyright: 2021 Chris Reade +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/chrisreade/PenroseKiteDart + +library + exposed-modules: + PKD + HalfTile + TileLib + Tgraphs + Tgraph.Prelude + Tgraph.Decompose + Tgraph.Compose + Tgraph.Force + Tgraph.Relabelling + Tgraph.Try + TgraphExamples + other-modules: + Paths_PenroseKiteDart + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , containers >=0.6.7 && <0.8 + , diagrams-lib >=1.4.6 && <1.5 + default-language: Haskell2010 + +test-suite PenroseKiteDart-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_PenroseKiteDart + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + PenroseKiteDart + , base >=4.7 && <5 + , containers >=0.6.7 && <0.8 + , diagrams-lib >=1.4.6 && <1.5 + , hspec >=2.10.10 && <2.12 + default-language: Haskell2010 + +benchmark PenroseKiteDart-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Paths_PenroseKiteDart + hs-source-dirs: + benchmark + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + PenroseKiteDart + , base >=4.7 && <5 + , containers >=0.6.7 && <0.8 + , diagrams-lib >=1.4.6 && <1.5 + default-language: Haskell2010 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,90 @@ +# PenroseKiteDart + +Author: Chris Reade + +March 2021 - 2024 + +See LICENSE file + +## Penrose Kites and Darts + +Penrose\'s kite and dart tiles have the property that they can tile the entire plane aperiodicly. +There are rules to ensure legal tilings with the kites and darts. +Tilings can still get stuck (so cannot be continued to cover the entire plane) - these are called incorrect. + +This package is a Haskell library of tools to build, draw and explore finite tilings with kites and darts, making use of the +Haskell Diagrams package. + +## Using the Package + +You will need the Haskell Diagrams package +to be installed as well as this package (PenroseKiteDart). (See [Haskell Diagrams](https://diagrams.github.io)). +Once installed, a Main.hs module to produce diagrams should import a chosen backend for Diagrams such as the default (SVG) +along with Diagrams.Prelude + + module Main (main) where + + import Diagrams.Backend.SVG.CmdLine + import Diagrams.Prelude + +plus (for Penrose Kite and Dart tilings) + + import PKD + +and optionally + + import TgraphExamples + +Then to ouput someExample figure + + fig::Diagram B + fig = someExample + + main :: IO () + main = mainWith fig + +When the code is executed it will generate an SVG file. +(See the Haskell Diagrams package for more details on producing diagrams.) + +## Tgraphs to Describe Finite Tilings + +Tile Graphs (`Tgraph`s) use a simple planar graph representation for finite patches of tiles. +A `Tgraph` is made from a list of faces with type `TileFace` each of which is a half-dart or a half-kite. +Each `TileFace` is thus a triangle with three positive Int vertices and a constructor +`LD` (left dart), `RD` (right dart), `LK` (left kite), `RK` (right kite). + +For example a fool consists of two kites and a dart (= 4 half kites and 2 half darts): + + fool :: Tgraph + fool = makeTgraph [RD (1,2,3),LD (1,3,4) -- right and left dart + ,LK (5,3,2),RK (5,2,7) -- left and right kite + ,RK (5,4,3),LK (5,6,4) -- right and left kite + ] + +The function + + makeTgraph :: [TileFace] -> Tgraph + +performs checks to make sure the tiling is legal, raising an error if there is a problem. +To produce a diagram, we simply draw the `Tgraph` + + foolFigure :: Diagram B + foolFigure = labelled draw fool + + +## Modules + +Module `PKD` is the main module which imports and rexports `Tgraphs` and `TileLib`. +`Tgraphs` imports and re-exports the contents of the other Tgraph modules, namely +`Tgraph.Compose`, `Tgraph.Decompose`, `Tgraph.Force`, `Tgraph.Relabelling`, `Tgraph.Prelude`. +`TileLib` contains underlying drawing tools for tiles. +`Tgraph.Try` is imported and re-exported by `Tgraph.Prelude` - used for results of partial functions. +`HalfTile` is imported and re-exported by `Tgraph.Prelude` - (with the constructors `LD`,`RD`,`LK`,`RK`). + +## Further Information + +A more detailed User Guide for the PenroseKiteDart package can be found at + +- [PenroseKiteDart User Guides](https://readerunner.wordpress.com/2024/04/08/penrosekitedart-user-guides/) + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Bench.hs @@ -0,0 +1,34 @@ +import Tgraphs +import TgraphExamples +import TileLib (draw) +import Diagrams.Prelude + +main :: IO () +main = + do putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is " + ++ show (length (faces kD)) + putStrLn $ "Number of faces of force (" ++ sn ++ " times decomposed King) is " + ++ show (length (faces fkD)) + + putStrLn $ "Width of figure for force (" ++ sn ++ " times decomposed King) is " + ++ show w + + putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is " + ++ show (length (faces cfkD)) + +{- + putStrLn $ "Number of faces of reforced force (" ++ sn ++ " times decomposed King) is " + ++ show (length (faces rcfkD)) +-} + + where + sn = show n + n = 4 + kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n + fkD ={-# SCC "forcing" #-} force kD + cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate compose fkD + + fig = {-# SCC "drawing" #-} draw fkD + w = width fig + + diff --git a/src/HalfTile.hs b/src/HalfTile.hs new file mode 100644 --- /dev/null +++ b/src/HalfTile.hs @@ -0,0 +1,99 @@ +{-| +Module : HalfTile +Description : Introducing a generic type for half tiles of darts and kites +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +-} +{-# LANGUAGE TypeFamilies #-} -- needed for Transformable Instance +{-# LANGUAGE FlexibleInstances #-} -- needed for Transformable Instance + +module HalfTile + ( HalfTile(..) + , tileRep + , isLD + , isRD + , isLK + , isRK + , isDart + , isKite + , HalfTileLabel + , tileLabel + , isMatched + ) where + +import Diagrams.Prelude (V,N, Transformable(..)) -- needed to make HalfTile a Transformable when a is Transformable + +{-| +Representing Half Tile Pieces Polymorphicly. +Common code for both graphs and vector representations of tilings. +For Pieces - rep is V2 Double +For TileFaces (in Tgraphs) rep is (Vertex,Vertex,Vertex) +-} +data HalfTile rep = LD rep -- ^ Left Dart + | RD rep -- ^ Right Dart + | LK rep -- ^ Left Kite + | RK rep -- ^ Right Kite + deriving (Show,Eq) + +-- | Note this ignores the tileLabels when comparing. +-- However we should never have 2 different HalfTiles with the same rep +instance Ord rep => Ord (HalfTile rep) where + compare t1 t2 = compare (tileRep t1) (tileRep t2) + +-- |Make Halftile a Functor +instance Functor HalfTile where + fmap f (LD rep) = LD (f rep) + fmap f (RD rep) = RD (f rep) + fmap f (LK rep) = LK (f rep) + fmap f (RK rep) = RK (f rep) + +-- |Needed for Transformable instance of HalfTile - requires TypeFamilies +type instance N (HalfTile a) = N a +-- |Needed for Transformable instance of HalfTile - requires TypeFamilies +type instance V (HalfTile a) = V a +-- |HalfTile inherits Transformable - Requires FlexibleInstances +instance Transformable a => Transformable (HalfTile a) where + transform t = fmap (transform t) + + + + + + +{-# INLINE tileRep #-} +-- |return the representation of a half-tile +tileRep:: HalfTile rep -> rep +tileRep (LD r) = r +tileRep (RD r) = r +tileRep (LK r) = r +tileRep (RK r) = r + +-- |half-tile predicate +isLD,isRD,isLK,isRK,isDart,isKite :: HalfTile rep -> Bool +isLD (LD _) = True +isLD _ = False +isRD (RD _) = True +isRD _ = False +isLK (LK _) = True +isLK _ = False +isRK (RK _) = True +isRK _ = False +isDart x = isLD x || isRD x +isKite x = isLK x || isRK x + +-- |By having () as the half tile representation we treat the constructors as just labels +type HalfTileLabel = HalfTile () +-- |convert a half tile to its label (HalfTileLabel can be compared for equality) +tileLabel :: HalfTile a -> HalfTileLabel +tileLabel = fmap $ const () -- functor HalfTile + +-- | isMatched t1 t2 is True if t1 and t2 have the same HalfTileLabel +-- (i.e. use the same constructor - both LD or both RD or both LK or both RK) +isMatched :: HalfTile rep1 -> HalfTile rep2 -> Bool +isMatched t1 t2 = tileLabel t1 == tileLabel t2 + + + diff --git a/src/PKD.hs b/src/PKD.hs new file mode 100644 --- /dev/null +++ b/src/PKD.hs @@ -0,0 +1,23 @@ +{-| +Module : PKD +Description : A wrapper module including Tgraphs and TileLib +Copyright : (c) Chris Reade, 2024 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This is the main module to import Tgraphs and TileLib (which includes Halftile) modules. +-} +-- {-# LANGUAGE NoMonomorphismRestriction #-} +-- {-# LANGUAGE FlexibleContexts #-} +-- {-# LANGUAGE TypeFamilies #-} +-- {-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch +-- {-# LANGUAGE TypeOperators #-} -- needed for type equality constraints ~ + +module PKD ( module Tgraphs + , module TileLib + ) where + +import Tgraphs +import TileLib + diff --git a/src/Tgraph/Compose.hs b/src/Tgraph/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Compose.hs @@ -0,0 +1,230 @@ +{-| +Module : Tgraph.Compose +Description : A compose operation for Tgraphs +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This module includes the main composition operations compose, partCompose, tryPartCompose but also exposes +getDartWingInfo (and type DartWingInfo) and composedFaceGroups for debugging and experimenting. +-} +module Tgraph.Compose + ( compose + , partCompose + , tryPartCompose + , uncheckedCompose + , uncheckedPartCompose + , partComposeFaces + , composedFaces + , DartWingInfo(..) + , getDartWingInfo + , composedFaceGroups + ) where + +import Data.List ((\\), find, foldl',nub) +import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!)) +import Data.Maybe (mapMaybe) + +import Tgraph.Prelude + +{------------------------------------------------------------------------- +*************************************************************************** +COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose +*************************************************************************** +---------------------------------------------------------------------------} + +-- |The main compose function which simply drops the remainder faces from partCompose to return just +-- the composed Tgraph. It will raise an error if the result is not a valid Tgraph +-- (i.e. if it fails the connectedness, no crossing boundary check) +compose:: Tgraph -> Tgraph +compose = snd . partCompose + +-- |This does the same as compose but without checks for connectedness and no crossing boundaries in the result. +-- It is intended for use on forced Tgraphs where we have a proof that the checks are not needed. +uncheckedCompose:: Tgraph -> Tgraph +uncheckedCompose = snd . uncheckedPartCompose + +-- |partCompose g produces a pair consisting of remainder faces (faces from g which will not compose) +-- and a composed Tgraph. +-- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails. +partCompose:: Tgraph -> ([TileFace],Tgraph) +partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g + +-- |tryPartCompose g tries to produce a Tgraph by composing faces which uniquely compose in g, +-- It checks the resulting new faces for connectedness and no crossing boundaries. +-- If the check is OK it produces Right (remainder, g') where g' is the composed Tgraph and remainder is a list +-- of faces from g which will not compose. If the check fails it produces Left s where s is a failure report. +tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) +tryPartCompose g = + do let (remainder,newFaces) = partComposeFaces g + checked <- onFail "tryPartCompose:/n" $ tryConnectedNoCross newFaces + return (remainder,checked) + +-- |uncheckedPartCompose g produces a pair of the remainder faces (faces from g which will not compose) +-- and a Tgraph made from the composed faces without checking that the Tgraph is valid. +-- I.e. it does NOT check the composition Tgraph for connectedness and no crossing boundaries. +-- This is intended for use when we know the check is not needed (e.g. when g is forced). +uncheckedPartCompose:: Tgraph -> ([TileFace],Tgraph) +uncheckedPartCompose g = (remainder, makeUncheckedTgraph newfaces) where + (remainder,newfaces) = partComposeFaces g + +-- |partComposeFaces produces a pair of the remainder faces (faces from the original which will not compose) +-- and the composed faces (which may or may not constitute faces of a valid Tgraph). +partComposeFaces:: Tgraph -> ([TileFace],[TileFace]) +partComposeFaces g = (remainder,newfaces) where + compositions = composedFaceGroups $ getDartWingInfo g + newfaces = map fst compositions + groups = map snd compositions + remainder = faces g \\ concat groups + +-- |composedFaces g produces the composed faces of g (which may or may not constitute faces of a valid Tgraph). +composedFaces:: Tgraph -> [TileFace] +composedFaces = snd . partComposeFaces + + +-- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. +-- It includes a faceMap from dart wings to faces at that vertex. +data DartWingInfo = DartWingInfo + { largeKiteCentres :: [Vertex] + , largeDartBases :: [Vertex] + , unknowns :: [Vertex] + , faceMap :: VMap.IntMap [TileFace] + } deriving Show + +-- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, +-- returning as DartWingInfo. +getDartWingInfo:: Tgraph -> DartWingInfo +getDartWingInfo g = DartWingInfo {largeKiteCentres = allKcs, largeDartBases = allDbs, unknowns = allUnks, faceMap = dwFMap} where + drts = darts g + dwFMap = vertexFacesMap (nub $ fmap wingV drts) (faces g) + (allKcs,allDbs,allUnks) = foldl' processD ([],[],[]) drts +-- kcs = kite centres of larger kites, +-- dbs = dart bases of larger darts, +-- unks = unclassified dart wing tips +-- gps is a mapping of dart wing tips to the group of faces found at that vertex + processD (kcs, dbs, unks) rd@(RD (orig, w, _)) = -- classify wing tip w + if w `elem` kcs || w `elem` dbs then (kcs, dbs, unks) else-- already classified + let + fcs = dwFMap VMap.! w -- faces at w +-- Just fcs = VMap.lookup w dwFMap -- faces at w + in + if length fcs ==1 then (kcs, dbs, w:unks) else -- lone dart wing => unknown + if w `elem` fmap originV (filter isKite fcs) then (kcs,w:dbs,unks) else + -- wing is a half kite origin => largeDartBases + if (w,orig) `elem` fmap longE (filter isLD fcs) then (w:kcs,dbs,unks) else + -- long edge rd shared with an ld => largeKiteCentres + case findFarK rd fcs of + Nothing -> (kcs,dbs,w:unks) -- unknown if incomplete kite attached to short edge of rd + Just rk@(RK _) -> + case find (matchingShortE rk) fcs of + Just (LK _) -> (w:kcs,dbs,unks) -- short edge rk shared with an lk => largeKiteCentres + Just (LD _) -> (kcs,w:dbs,unks) -- short edge rk shared with an ld => largeDartBases + _ -> let + newfcs = filter (isAtV (wingV rk)) (faces g) -- faces at rk wing + in + case find (matchingLongE rk) newfcs of -- short edge rk has nothing attached + Nothing -> (kcs,dbs,w:unks) -- long edge of rk has nothing attached => unknown + Just (LD _) -> (w:kcs,dbs,unks) -- long edge rk shared with ld => largeKiteCentres + Just lk@(LK _) -> -- long edge rk shared with lk + case find (matchingShortE lk) newfcs of + Just (RK _) -> (w:kcs,dbs,unks) + -- short edge of this lk shared with another rk => largeKiteCentres + Just (RD _) -> (kcs,w:dbs,unks) + -- short edge of this lk shared with rd => largeDartBases + _ -> (kcs,dbs,w:unks) + Just _ -> error "getDartWingInfo: illegal case for matchingLongE of a right kite" + -- short edge of this lk has nothing attached => unknown + Just _ -> error "getDartWingInfo: non-kite returned by findFarK" + + processD (kcs, dbs, unks) ld@(LD (orig, _, w)) = -- classify wing tip w + if w `elem` kcs || w `elem` dbs then (kcs, dbs, unks) else -- already classified + let + fcs = dwFMap VMap.! w -- faces at w + in + if length fcs ==1 then (kcs, dbs, w:unks) else -- lone dart wing => unknown + if w `elem` fmap originV (filter isKite fcs) then (kcs,w:dbs,unks) else + -- wing is a half kite origin => nodeDB + if (w,orig) `elem` fmap longE (filter isRD fcs) then (w:kcs,dbs,unks) else + -- long edge ld shared with an rd => nodeKC + case findFarK ld fcs of + Nothing -> (kcs,dbs,w:unks) -- unknown if incomplete kite attached to short edge of ld + Just lk@(LK _) -> + case find (matchingShortE lk) fcs of + Just (RK _) -> (w:kcs,dbs,unks) -- short edge lk shared with an rk => largeKiteCentres + Just (RD _) -> (kcs,w:dbs,unks) -- short edge lk shared with an rd => largeDartBases + _ -> let + newfcs = filter (isAtV (wingV lk)) (faces g) -- faces at lk wing + in + case find (matchingLongE lk) newfcs of -- short edge lk has nothing attached + Nothing -> (kcs,dbs,w:unks) -- long edge of lk has nothing attached => unknown + Just (RD _) -> (w:kcs,dbs,unks) -- long edge lk shared with rd => largeKiteCentres + Just rk@(RK _) -> -- long edge lk is shared with an rk + case find (matchingShortE rk) newfcs of + Just (LK _) -> (w:kcs,dbs,unks) + -- short edge of this rk shared with another lk => largeKiteCentres + Just (LD _) -> (kcs,w:dbs,unks) + -- short edge of this rk shared with ld => largeDartBases + _ -> (kcs,dbs,w:unks) -- short edge of this rk has nothing attached => unknown + Just _ -> error "getDartWingInfo: illegal case for matchingLongE of a left kite" + + Just _ -> error "getDartWingInfo: non-kite returned by findFarK" + + processD _ _ = error "getDartWingInfo: processD applied to non-dart" + + -- find the two kite halves below a dart half, return the half kite furthest away (not attached to dart). + -- Returns a Maybe. rd produces an rk (or Nothing) ld produces an lk (or Nothing) + findFarK :: TileFace -> [TileFace] -> Maybe TileFace + findFarK rd@(RD _) fcs = do lk <- find (matchingShortE rd) (filter isLK fcs) + find (matchingJoinE lk) (filter isRK fcs) + findFarK ld@(LD _) fcs = do rk <- find (matchingShortE ld) (filter isRK fcs) + find (matchingJoinE rk) (filter isLK fcs) + findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" + +-- | Auxiliary function for uncheckedPartCompose. +-- Creates a list of new composed faces, each paired with a list of old faces (components of the new face) +-- using dart wing information. +composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] +composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where + + faceGroupRDs = fmap (\gp -> (makeRD gp,gp)) groupRDs + groupRDs = mapMaybe groupRD (largeDartBases dwInfo) + makeRD [rd,lk] = RD(originV lk, originV rd, oppV lk) + makeRD _ = error "composedFaceGroups: RD case" + groupRD v = do fcs <- VMap.lookup v (faceMap dwInfo) + rd <- find isRD fcs + lk <- find (matchingShortE rd) fcs + return [rd,lk] + + faceGroupLDs = fmap (\gp -> (makeLD gp,gp)) groupLDs + groupLDs = mapMaybe groupLD (largeDartBases dwInfo) + makeLD [ld,rk] = LD(originV rk, oppV rk, originV ld) + makeLD _ = error "composedFaceGroups: LD case" + groupLD v = do fcs <- VMap.lookup v (faceMap dwInfo) + ld <- find isLD fcs + rk <- find (matchingShortE ld) fcs + return [ld,rk] + + faceGroupRKs = fmap (\gp -> (makeRK gp,gp)) groupRKs + groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) + makeRK [rd,_,rk] = RK(originV rd, wingV rk, originV rk) + makeRK _ = error "composedFaceGroups: RK case" + groupRK v = do fcs <- VMap.lookup v (faceMap dwInfo) + rd <- find isRD fcs + lk <- find (matchingShortE rd) fcs + rk <- find (matchingJoinE lk) fcs + return [rd,lk,rk] + + faceGroupLKs = fmap (\gp -> (makeLK gp,gp)) groupLKs + groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) + makeLK [ld,_,lk] = LK(originV ld, originV lk, wingV lk) + makeLK _ = error "composedFaceGroups: LK case" + groupLK v = do fcs <- VMap.lookup v (faceMap dwInfo) + ld <- find isLD fcs + rk <- find (matchingShortE ld) fcs + lk <- find (matchingJoinE rk) fcs + return [ld,rk,lk] + + + + diff --git a/src/Tgraph/Decompose.hs b/src/Tgraph/Decompose.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Decompose.hs @@ -0,0 +1,73 @@ +{-| +Module : Tgraph.Decompose +Description : A decompose operation for Tgraphs +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This module defines decompose and decompositions for Tgraphs, but also exposes +two auxiliary functions for debugging and experimenting. +-} +module Tgraph.Decompose + ( decompose + , decompositions + , phiVMap + , decompFace + ) where + +import qualified Data.Map.Strict as Map (Map, (!), fromList) +import Data.List(sort) + +import Tgraph.Prelude + + + +{------------------------------- +************************************** +DECOMPOSING - decompose +************************************** +----------------------------------} + + +-- |Decompose a Tgraph. +decompose :: Tgraph -> Tgraph +decompose g = makeUncheckedTgraph newFaces where + newFaces = concatMap (decompFace (phiVMap g)) (faces g) + +-- |phiVMap g produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in g. +-- Both (a,b) and (b,a) get the same new vertex number. +-- (Sort is used to fix order of assigned numbers). +-- (Exported for use in TrackedTgraphs in Tgraphs module). + +phiVMap :: Tgraph -> Map.Map Dedge Vertex +phiVMap g = edgeVMap where + phiReps = sort [(a,b) | (a,b) <- phiEdges g, a TileFace -> [TileFace] +decompFace newVFor fc = case fc of + RK(a,b,c) -> [RK(c,x,b), LK(c,y,x), RD(a,x,y)] + where x = (Map.!) newVFor (a,b) + y = (Map.!) newVFor (c,a) + LK(a,b,c) -> [LK(b,c,y), RK(b,y,x), LD(a,x,y)] + where x = (Map.!) newVFor (a,b) + y = (Map.!) newVFor (c,a) + RD(a,b,c) -> [LK(a,x,c), RD(b,c,x)] + where x = (Map.!) newVFor (a,b) + LD(a,b,c) -> [RK(a,b,x), LD(c,x,b)] + where x = (Map.!) newVFor (a,c) + +-- |infinite list of decompositions of a Tgraph +decompositions :: Tgraph -> [Tgraph] +decompositions = iterate decompose + + + diff --git a/src/Tgraph/Force.hs b/src/Tgraph/Force.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Force.hs @@ -0,0 +1,1286 @@ +{-| +Module : Tgraph.Force +Description : The force functions for Tgraphs +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This module includes force and tryForce plus related operations for testing and experimenting +such as tryStepForce, tryAddHalfKite and tryAddHalfDart. +It introduces BoundaryState and ForceState types and includes a Forcible class with instances for +Tgraph, BoundaryState, and ForceState. +It exposes the calculation of relative angle of edges at boundary vertices used to find existing edges. +It imports a touching check for adding new vertices (with locateVertices and addVPoint). +-} + +module Tgraph.Force + (-- * Touching vertex checking + touchCheck + -- * BoundaryState operations + , BoundaryState(..) + , makeBoundaryState + , recoverGraph + , changeVFMap + , facesAtBV + , boundaryFaces + -- * Types: Update, UpdateMap, UpdateGenerator, ForceState + , Update(..) + , UpdateMap + , ForceState(..) + , UpdateGenerator + -- * Forcible class and Instances (ForceState, BoundaryState, Tgraph) + , Forcible(..) + -- * Generalised forcing operations + , tryForceWith + , tryStepForceWith + , tryFSOp + , tryForce + , force + , wholeTiles + , forceWith + , tryInitFS + , initFS + , tryStepForce + , stepForce + , tryChangeBoundary + -- * Force Related Functions + , addHalfKite + , tryAddHalfKite + , addHalfDart + , tryAddHalfDart + -- * Specialised forcing operations (used for inspecting steps) + , tryOneStepWith + , tryOneStepF + -- * Updating BoundaryState and ForceState after a single force step + , BoundaryChange(..) + , affectedBoundary +-- , mustFind + , tryReviseUpdates + , tryReviseFSWith + -- * Auxiliary Functions for doing a force step + , findSafeUpdate + , tryUnsafes + , checkUnsafeUpdate + , trySafeUpdate +-- , commonVs + , tryUpdate + -- * Recalibrating versions of force and tryForce + , recalculateBVLocs + , tryRecalibratingForce + , recalibratingForce + -- * Main All Update Generators + , defaultAllUGen + , allUGenerator + -- * Tools for making update generators + , UFinder + , UChecker + , boundaryFilter + , makeUpdate + , makeGenerator + -- * BoundaryState vertex predicates and properties + , mustbeStar + , mustbeSun + , mustbeDeuce + , mustbeKing + , isKiteWing + , isKiteOppV + , isDartOrigin + , mustbeQueen + , kiteWingCount + , mustbeJack +-- , hasAnyMatchingE + -- * Forcing Rules and Individual Update Generators (with corresponding Finders) for each rule. + -- $rules + , wholeTileUpdates + , incompleteHalves + , aceKiteUpdates + , nonKDarts + , queenOrKingUpdates + , kitesWingDartOrigin + , deuceDartUpdates + , kiteGaps + , jackDartUpdates + , noTouchingDart + , sunStarUpdates + , almostSunStar + , jackKiteUpdates + , jackMissingKite + , kingDartUpdates + , kingMissingThirdDart + , queenDartUpdates + , queenMissingDarts + , queenKiteUpdates + , queenMissingKite + -- * Six Update Checkers + , completeHalf + , addKiteShortE + , addDartShortE + , completeSunStar + , addKiteLongE + , addDartLongE +{- + , anglesForJoinRD + , anglesForJoinLD + , anglesForJoinRK + , anglesForJoinLK + , anglesForLongLD + , anglesForLongRD + , anglesForLongRK + , anglesForLongLK + , anglesForShortLD + , anglesForShortRD + , anglesForShortLK + , anglesForShortRK +-} +-- , inspectBDedge + -- * Auxiliary Functions for adding faces: externalAngle and tryFindThirdV. $Additions + , tryFindThirdV + , externalAngle +{- + , intAngleAt + , faceIntAngles +-} + ) where + +import Data.List ((\\), intersect, nub, find,foldl') +import qualified Data.Map as Map (Map, empty, delete, elems, insert, union, keys) -- used for UpdateMap +import qualified Data.IntMap.Strict as VMap (elems, filterWithKey, alter, delete, lookup, (!)) + -- used for BoundaryState locations AND faces at boundary vertices +import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate +-- import Tgraph.Convert(touching, locateVertices, addVPoint) +import Tgraph.Prelude + +{- +*************************************************************************** +Efficient FORCING with + BoundaryState, ForceState + Touching Vertex Check + Incremented Update Maps +*************************************************************************** +-} + + + +{------------------------- +************************* +Touching vertex checking +******************************************** +requires Diagrams.Prelude for Point and V2 +--------------------------------------------} + +-- |touchCheck p vpMap - check if a vertex location p touches (is too close to) any other vertex location in the mapping vpMap +touchCheck:: Point V2 Double -> VertexMap (Point V2 Double) -> Bool +touchCheck p vpMap = any (touching p) (VMap.elems vpMap) + + +{-| A BoundaryState records +the boundary directed edges (directed so that faces are on LHS and exterior is on RHS) +plus +a mapping of boundary vertices to their incident faces, plus +a mapping of boundary vertices to positions (using Tgraph.Prelude.locateVertices). +It also keeps track of all the faces +and the next vertex label to be used when adding a new vertex. +-} +data BoundaryState + = BoundaryState + { boundary:: [Dedge] -- ^ boundary directed edges (face on LHS, exterior on RHS) + , bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex. + , bvLocMap:: VertexMap (Point V2 Double) -- ^ position of each boundary vertex. + , allFaces:: [TileFace] -- ^ all the tile faces + , nextVertex:: Vertex -- ^ next vertex number + } deriving (Show) + +-- |Calculates BoundaryState information from a Tgraph +-- also checks for no crossing boundaries as these could cause difficult to trace errors in forcing. +makeBoundaryState:: Tgraph -> BoundaryState +makeBoundaryState g = + let bdes = graphBoundary g + bvs = fmap fst bdes -- (fmap snd bdes would also do) for all boundary vertices + bvLocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces g + in if not $ null $ crossingVertices bdes then error $ "makeBoundaryState: found crossing boundary in faces:\n"++show (faces g)++"\n" + else + BoundaryState + { boundary = bdes + , bvFacesMap = vertexFacesMap bvs (faces g) + , bvLocMap = bvLocs + , allFaces = faces g + , nextVertex = 1+ maxV g + } + +-- |Converts a BoundaryState back to a Tgraph +recoverGraph:: BoundaryState -> Tgraph +recoverGraph bd = makeUncheckedTgraph (allFaces bd) + +-- |changeVFMap f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap +changeVFMap:: TileFace -> VertexMap [TileFace] -> VertexMap [TileFace] +changeVFMap f vfm = foldl' insertf vfm (faceVList f) where + insertf vmap v = VMap.alter consf v vmap + consf Nothing = Just [f] + consf (Just fs) = Just (f:fs) + +-- |facesAtBV bd v - returns the faces found at v (which must be a boundary vertex) +facesAtBV:: BoundaryState -> Vertex -> [TileFace] +facesAtBV bd v = case VMap.lookup v (bvFacesMap bd) of + Just fcs -> fcs + Nothing -> error $ "facesAtBV: Not a boundary vertex? No faces found at " ++ show v ++ "\n" + +-- |return a list of faces which have a boundary vertex from a BoundaryState +boundaryFaces :: BoundaryState -> [TileFace] +boundaryFaces bd = nub $ concatMap (facesAtBV bd) bvs where + bvs = fmap fst $ boundary bd +-- boundaryFaces = nub . concat . VMap.elems . bvFacesMap +-- relies on the map containing no extra info for non boundary vertices + + + +-- |An Update is either safe or unsafe. +-- A safe update has a new face involving 3 existing vertices. +-- An unsafe update has a makeFace function to create the new face when given a fresh third vertex. +data Update = SafeUpdate TileFace + | UnsafeUpdate (Vertex -> TileFace) + +-- | 0 is used as a dummy variable to show unsafe updates (to display the function explicitly) +instance Show Update where + show (SafeUpdate f) = "SafeUpdate (" ++ show f ++ ")" + show (UnsafeUpdate mf) = "UnsafeUpdate (\0 -> " ++ show (mf 0)++ ")" + +-- |UpdateMap: partial map associating updates with (some) boundary directed edges. +-- (Any boundary directed edge will have the opposite direction in some face.) +type UpdateMap = Map.Map Dedge Update + +-- |ForceState: The force state records information between executing single face updates during forcing +-- (a BoundaryState and an UpdateMap). +data ForceState = ForceState + { boundaryState:: BoundaryState + , updateMap:: UpdateMap + } + +{-|UpdateGenerator abbreviates the type of functions which capture one or more of the forcing rules. +They produce a (Try) UpdateMap when given a BoundaryState and a focus list of particular directed boundary edges. +Each forcing rule has a particular UpdateGenerator, +but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGenerator). +-} +type UpdateGenerator = BoundaryState -> [Dedge] -> Try UpdateMap + + + +-- | Forcible class has operations to (indirectly) implement forcing and single step forcing +-- (tryForceWith, tryStepForceWith) for any Forcible. The class operations are more general to allow for other +-- force related operations to be generalised for use on any Forcible. +-- Both tryForceWith and tryStepForceWith are implemented using tryFSOpWith, and +-- tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundaryWith. +-- +-- To improve performance of a sequence of force related operations, express each as a +-- ForceState -> Try ForceState, then use (<=<) or (>=>) to combine and pass to tryFSOpWith. +-- This ensures there are no unnecessary conversions between steps. +class Forcible a where + -- | tryFSOpWith (try ForseState Operation with) when given an update generator, generalises a (try) ForceState operation to a (try) Forcible operation. + -- The update generator is only used to initialise a ForceState when there is not one + -- already available (i.e not used when the Forcible is a ForceState) + tryFSOpWith :: UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a + -- | tryInitFSWith (try initialising a ForceState with) when given an update generator tries to create an initial ForceState (ready for forcing) from a Forcible. + -- Again, the update generator is not used when the instance is a ForceState. + tryInitFSWith :: UpdateGenerator -> a -> Try ForceState + -- | tryChangeBoundaryWith when given an update generator, converts a (try) BoundaryState changing operation to a (try) Forcible operation. + -- The update generator is only used when the instance is a ForceState (to revise the update map in the result). + tryChangeBoundaryWith :: UpdateGenerator -> (BoundaryState -> Try BoundaryChange) -> a -> Try a +{- + -- | construct or recover the BoundaryState from a Forcible + getBoundaryState :: a -> BoundaryState +-} + +-- |ForceStates are Forcible +instance Forcible ForceState where + tryFSOpWith _ = id -- update generator not used + tryInitFSWith _ = return -- update generator not used + tryChangeBoundaryWith ugen f fs = do + bdC <- f (boundaryState fs) + tryReviseFSWith ugen bdC fs +-- getBoundaryState = boundaryState + +-- | BoundaryStates are Forcible +instance Forcible BoundaryState where + tryFSOpWith ugen f bd = do + fs <- tryInitFSWith ugen bd + fs' <- f fs + return $ boundaryState fs' + tryInitFSWith ugen bd = do + umap <- ugen bd (boundary bd) + return $ ForceState { boundaryState = bd , updateMap = umap } + tryChangeBoundaryWith _ f bd = do -- update generator not used + bdC <- f bd + return $ newBoundaryState bdC +-- getBoundaryState = id + +-- | Tgraphs are Forcible +instance Forcible Tgraph where + tryFSOpWith ugen f g = recoverGraph <$> tryFSOpWith ugen f (makeBoundaryState g) + tryInitFSWith ugen g = tryInitFSWith ugen (makeBoundaryState g) + tryChangeBoundaryWith ugen f g = -- update generator not used + recoverGraph <$> tryChangeBoundaryWith ugen f (makeBoundaryState g) +-- getBoundaryState = makeBoundaryState + + +-- | try forcing using a given UpdateGenerator. +-- tryForceWith uGen fs - recursively does updates using uGen until there are no more updates. +-- It produces Left report if it encounters a Forcible representing a stuck/incorrect Tgraph. +tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a +tryForceWith ugen = tryFSOpWith ugen (tryForceStateWith ugen) where +-- tryForceStateWith :: UpdateGenerator -> ForceState -> Try ForceState + tryForceStateWith uGen = retry where + retry fs = case findSafeUpdate (updateMap fs) of + Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u + fs' <- tryReviseFSWith uGen bdChange fs + retry fs' + _ -> do maybeBdC <- tryUnsafes fs + case maybeBdC of + Nothing -> Right fs -- no more updates + -- Nothing -> tryFinalStuckCheck fs -- No Longer used + Just bdC -> do fs' <- tryReviseFSWith uGen bdC fs + retry fs' + +-- | try a given number of force steps using a given UpdateGenerator. +tryStepForceWith :: Forcible a => UpdateGenerator -> Int -> a -> Try a +tryStepForceWith ugen n = tryFSOpWith ugen $ count n where + count 0 fs = return fs + count m fs = do result <- tryOneStepWith ugen fs + case result of + Nothing -> return fs + Just (fs', _) -> count (m-1) fs' +{- +tryStepForceWith ugen n = tryFSOpWith ugen $ tryStepForceStateWith ugen n where +-- tryStepForceStateWith :: UpdateGenerator -> Int -> ForceState -> Try ForceState + tryStepForceStateWith updateGen = count where + count 0 fs = return fs + count m fs = do result <- tryOneStepWith updateGen fs + case result of + Nothing -> return fs + Just (fs', _) -> count (m-1) fs' + -} + +-- |A version of tryFSOpWith using defaultAllUGen representing all 10 rules for updates. +tryFSOp :: Forcible a => (ForceState -> Try ForceState) -> a -> Try a +tryFSOp = tryFSOpWith defaultAllUGen + +-- |A version of the main force function using defaultAllUGen representing all 10 rules for updates. +-- This returns Left report on discovering a stuck Tgraph and Right a (with a the resulting forcible) otherwise. +tryForce:: Forcible a => a -> Try a +tryForce = tryForceWith defaultAllUGen + +-- |The main force function using defaultAllUGen representing all 10 rules for updates. +-- This raises an error on discovering a stuck/incorrect Forcible. +force:: Forcible a => a -> a +force = runTry . tryForce + +-- |special case of forcing only half tiles to whole tiles +wholeTiles:: Forcible a => a -> a +wholeTiles = forceWith wholeTileUpdates + +-- | forceWith ugen: force using the given UpdateGenerator +forceWith:: Forcible a => UpdateGenerator -> a -> a +forceWith ugen = runTry . tryForceWith ugen + +-- | try to initialize a force state with the default UpdateGenerator. +-- Returns a Left report if it finds a stuck forcible. +tryInitFS :: Forcible a => a -> Try ForceState +tryInitFS = tryInitFSWith defaultAllUGen + +-- | initialize a force state with the default UpdateGenerator. +-- Raises aan error if it finds a stuck forcible. +initFS :: Forcible a => a -> ForceState +initFS = runTry . tryInitFS + +-- |tryStepForce n a - produces a (Right) intermediate Forcible after n steps (n face additions) starting from Forcible a. +-- or a Left report if it encounters a stuck/incorrect Forcible within n steps. +-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible. +tryStepForce :: Forcible a => Int -> a -> Try a +tryStepForce = tryStepForceWith defaultAllUGen-- Was called tryStepForceFrom + +-- |stepForce n a - produces an intermediate intermediate Forcible after n steps (n face additions) starting from Forcible a. +-- It raises an error if it encounters a stuck/incorrect Tgraph/Forcible within n steps. +-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible. +stepForce :: Forcible a => Int -> a -> a +stepForce n = runTry . tryStepForce n + +-- |specialises tryChangeBoundaryWith to the default update generator. +tryChangeBoundary:: Forcible a => (BoundaryState -> Try BoundaryChange) -> a -> Try a +tryChangeBoundary = tryChangeBoundaryWith defaultAllUGen + + + +-- |addHalfKite is for adding a single half kite on a chosen boundary Dedge of a Forcible. +-- The Dedge must be a boundary edge but the direction is not important as +-- the correct direction is automatically calculated. +-- It will raise an error if the edge is a dart join or if a conflict (stuck graph) is detected +-- or if the edge is not a boundary edge. +addHalfKite :: Forcible a => Dedge -> a -> a +addHalfKite e = runTry . tryAddHalfKite e + +-- |tryAddHalfKite is a version of addHalfKite which returns a Try +-- with a Left report if it finds a stuck/incorrect graph, or +-- if the edge is a dart join, or +-- if the edge is not a boundary edge. +tryAddHalfKite :: Forcible a => Dedge -> a -> Try a +tryAddHalfKite = tryChangeBoundary . tryAddHalfKiteBoundary where +-- |tryAddHalfKiteBoundary implements tryAddHalfKite as a BoundaryState change +-- tryAddHalfKiteBoundary :: Dedge -> BoundaryState -> Try BoundaryChange + tryAddHalfKiteBoundary e bd = + do de <- case [e, reverseD e] `intersect` boundary bd of + [de] -> Right de + _ -> Left $ "tryAddHalfKiteBoundary: on non-boundary edge " ++ show e ++ "\n" + let (fc,etype) = inspectBDedge bd de + let tryU | etype == Long = addKiteLongE bd fc + | etype == Short = addKiteShortE bd fc + | etype == Join && isKite fc = completeHalf bd fc + | otherwise = Left "tryAddHalfKiteBoundary: applied to dart join (not possible).\n" + u <- tryU + tryUpdate bd u + +-- |addHalfDart is for adding a single half dart on a chosen boundary Dedge of a Forcible. +-- The Dedge must be a boundary edge but the direction is not important as +-- the correct direction is automatically calculated. +-- It will raise an error if the edge is a dart short edge or kite join +-- or if a conflict (stuck graph) is detected or if +-- the edge is not a boundary edge. +addHalfDart :: Forcible a => Dedge -> a -> a +addHalfDart e = runTry . tryAddHalfDart e + +-- |tryAddHalfDart is a version of addHalfDart which returns a Try +-- with a Left report if it finds a stuck/incorrect graph, or +-- if the edge is a dart short edge or kite join, or +-- if the edge is not a boundary edge. +tryAddHalfDart :: Forcible a => Dedge -> a -> Try a +tryAddHalfDart = tryChangeBoundary . tryAddHalfDartBoundary where +-- |tryAddHalfDartBoundary implements tryAddHalfDart as a BoundaryState change +-- tryAddHalfDartBoundary :: Dedge -> BoundaryState -> Try BoundaryChange + tryAddHalfDartBoundary e bd = + do de <- case [e, reverseD e] `intersect` boundary bd of + [de] -> Right de + _ -> Left $ "tryAddHalfDartBoundary: on non-boundary edge " ++ show e ++ "\n" + let (fc,etype) = inspectBDedge bd de + let tryU | etype == Long = addDartLongE bd fc + | etype == Short && isKite fc = addDartShortE bd fc + | etype == Join && isDart fc = completeHalf bd fc + | otherwise = Left "tryAddHalfDartBoundary: applied to short edge of dart or to kite join (not possible).\n" + u <- tryU + tryUpdate bd u + + +-- |tryOneStepWith uGen fs does one force step. +-- It returns a (Try maybe) with a new force sate paired with the boundary change for debugging purposes. +-- It uses uGen to revise updates in the final ForceState. +-- It produces Left report for a stuck/incorrect graph. +-- A result of Right Nothing indicates forcing has finished and there are no more updates. +tryOneStepWith :: UpdateGenerator -> ForceState -> Try (Maybe (ForceState,BoundaryChange)) +tryOneStepWith uGen fs = + case findSafeUpdate (updateMap fs) of + Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u + fs' <- tryReviseFSWith uGen bdChange fs + return $ Just (fs',bdChange) + _ -> do maybeBdC <- tryUnsafes fs + case maybeBdC of + Just bdC -> do fs' <- tryReviseFSWith uGen bdC fs + return $ Just (fs',bdC) + Nothing -> return Nothing -- no more updates + +-- |tryOneStepF is a special case of tryOneStepWith only used for debugging +tryOneStepF :: ForceState -> Try (Maybe (ForceState,BoundaryChange)) +tryOneStepF = tryOneStepWith defaultAllUGen + + +{-| BoundaryChange records the new boundary state after completing an update (by either trySafeUpdate or tryUnsafeUpdate) + along with a list of directed edges which are no longer on the boundary, + plus a list of boundary edges revised (and requiring updates to be recalculated). + See affectedBoundary. +-} +data BoundaryChange = BoundaryChange + { newBoundaryState:: BoundaryState -- ^ resulting boundary state + , removedEdges:: [Dedge] -- ^ edges no longer on the boundary + , revisedEdges :: [Dedge] -- ^ boundary edges requiring new update calculations + , newFace :: TileFace -- ^ face added in the change + } deriving (Show) + +{-| Given a BoundaryState with a list of one new boundary edge or + two adjacent new boundary edges (or exceptionally no new boundary edges) to be added, + it extends the list with adjacent boundary edges (to produce 3 or 4 or none). + (Used to calculate revisedEdges in a BoundaryChange) + (When a face is fitted in to a hole with 3 sides there is no new boundary.) +-} +affectedBoundary :: BoundaryState -> [Dedge] -> [Dedge] +affectedBoundary bd [(a,b)] = [(x,a),(a,b),(b,y)] where + bdry = boundary bd + (x,_) = mustFind ((==a).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show a ++ "\n") + (_,y) = mustFind ((==b).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show b ++ "\n") +affectedBoundary bd [(a,b),(c,d)] | b==c = [(x,a),(a,b),(c,d),(d,y)] where + bdry = boundary bd + (x,_) = mustFind ((==a).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show a ++ "\n") + (_,y) = mustFind ((==d).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show d ++ "\n") +affectedBoundary bd [(a,b),(c,d)] | a==d = [(x,c),(c,d),(a,b),(b,y)] where + bdry = boundary bd + (x,_) = mustFind ((==c).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show c ++ "\n") + (_,y) = mustFind ((==b).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show b ++ "\n") +affectedBoundary _ [] = [] +affectedBoundary _ edges = error $ "affectedBoundary: unexpected new boundary edges " ++ show edges ++ "\n" + +{-| mustFind is an auxiliary function used to search with definite result. +mustFind p ls err returns the first item in ls satisfying predicate p and returns +err argument when none found (in finite cases). +-} +mustFind :: Foldable t => (p -> Bool) -> t p -> p -> p +mustFind p ls err + = maybe err id (find p ls) + +-- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange) +-- using uGen to calculate new updates. +tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap +tryReviseUpdates uGen bdChange umap = + do let umap' = foldr Map.delete umap (removedEdges bdChange) + umap'' <- uGen (newBoundaryState bdChange) (revisedEdges bdChange) + return (Map.union umap'' umap') + +-- |tryReviseFSWith ugen bdC fs tries to revise fs after a boundary change (bdC) by calculating +-- the revised updates with ugen (and using the new boundary state in bdC). +tryReviseFSWith :: UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState +tryReviseFSWith ugen bdC fs = + do umap <- tryReviseUpdates ugen bdC (updateMap fs) + return $ ForceState{ boundaryState = newBoundaryState bdC, updateMap = umap} + + +-- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering) +findSafeUpdate:: UpdateMap -> Maybe Update +findSafeUpdate umap = find isSafeUpdate (Map.elems umap) where + isSafeUpdate (SafeUpdate _ ) = True + isSafeUpdate (UnsafeUpdate _ ) = False + +{-| tryUnsafes: Should only be used when there are no Safe updates in the UpdateMap. + tryUnsafes works through the unsafe updates in (directed edge) key order and + completes the first unsafe update that is not blocked (by a touching vertex), returning Right (Just bdC) + where bdC is the resulting boundary change (if there is one). + It returns Right Nothing if there are no unsafe updates but + Left report if there are unsafes but all unsafes are blocked, where report describes the problem. +-} +tryUnsafes:: ForceState -> Try (Maybe BoundaryChange) +tryUnsafes fs = checkBlocked 0 $ Map.elems $ updateMap fs where + bd = boundaryState fs + -- the integer records how many blocked cases have been found so far + checkBlocked:: Int -> [Update] -> Try (Maybe BoundaryChange) + checkBlocked 0 [] = return Nothing + checkBlocked n [] = Left $ "tryUnsafes: There are " ++ show n++ " unsafe updates but ALL unsafe updates are blocked (by touching vertices)\n" + ++ "This should not happen! However it may arise when accuracy limits are reached on very large Tgraphs.\n" + ++ "Total number of faces is " ++ show (length $ allFaces bd) ++ "\n" + checkBlocked n (u: more) = case checkUnsafeUpdate bd u of + Nothing -> checkBlocked (n+1) more + other -> return other + +{-| checkUnsafeUpdate bd u, calculates the resulting boundary change for an unsafe update (u) with a new vertex + (raising an error if u is a safe update). + It performs a touching vertex check with the new vertex + returning Nothing if there is a touching vertex (blocked case). + Otherwise it returns Just bdc with bdc a boundary change. + [Note: Try is not used as a conflict cannot be found in the unsafe case, and blocking is only a problem + when all unsafe updates are blocked (and there is at least one) - see tryUnsafes] +-} +checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange +checkUnsafeUpdate _ (SafeUpdate _) = error "checkUnsafeUpdate: applied to safe update.\n" +checkUnsafeUpdate bd (UnsafeUpdate makeFace) = + let v = nextVertex bd + newface = makeFace v + oldVPoints = bvLocMap bd + newVPoints = addVPoint newface oldVPoints + vPosition = newVPoints VMap.! v -- Just vPosition = VMap.lookup v newVPoints + fDedges = faceDedges newface + matchedDedges = filter (\(x,y) -> x /= v && y /= v) fDedges -- singleton + newDedges = fmap reverseD (fDedges \\ matchedDedges) -- two edges + resultBd = BoundaryState + { boundary = newDedges ++ (boundary bd \\ matchedDedges) + , bvFacesMap = changeVFMap newface (bvFacesMap bd) + , bvLocMap = newVPoints + , allFaces = newface:allFaces bd + , nextVertex = v+1 + } + bdChange = BoundaryChange + { newBoundaryState = resultBd + , removedEdges = matchedDedges + , revisedEdges = affectedBoundary resultBd newDedges + , newFace = newface + } + in if touchCheck vPosition oldVPoints -- true if new vertex is blocked because it touches the boundary elsewhere + then Nothing -- don't proceed when v is a touching vertex + else Just bdChange + +{-| trySafeUpdate bd u adds a new face by completing a safe update u on BoundaryState bd + (raising an error if u is an unsafe update). + It returns a Right BoundaryChange (containing a new BoundaryState, removed boundary edges and + revised boundary edge list), unless a stuck/incorrect graph is found. + It checks that the new face is not in conflict with existing faces, + producing (Left report) if there is a conflict. + It should cater for the exceptional case where the update removes 3 boundary edges + in a triangle (and removes 3 boundary vertices), closing a hole. +-} +trySafeUpdate:: BoundaryState -> Update -> Try BoundaryChange +trySafeUpdate _ (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n" +trySafeUpdate bd (SafeUpdate newface) = + let fDedges = faceDedges newface + matchedDedges = fDedges `intersect` boundary bd -- list of 2 or 3 + removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3) + newDedges = fmap reverseD (fDedges \\ matchedDedges) -- one or none + nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs + resultBd = BoundaryState + { boundary = newDedges ++ (boundary bd \\ matchedDedges) + , bvFacesMap = foldr VMap.delete (changeVFMap newface $ bvFacesMap bd) removedBVs +-- , bvFacesMap = changeVFMap newface (bvFacesMap bd) + , allFaces = newface:allFaces bd + , bvLocMap = foldr VMap.delete (bvLocMap bd) removedBVs + --remove vertex/vertices no longer on boundary + , nextVertex = nextVertex bd + } + bdChange = BoundaryChange + { newBoundaryState = resultBd + , removedEdges = matchedDedges + , revisedEdges = affectedBoundary resultBd newDedges + , newFace = newface + } + in if noNewConflict newface nbrFaces + then Right bdChange + else Left $ "trySafeUpdate:(incorrect tiling)\nConflicting new face " + ++ show newface + ++ "\nwith neighbouring faces\n" + ++ show nbrFaces + ++ "\n" + + +-- | given 2 consecutive directed edges (not necessarily in the right order), +-- this returns the common vertex (as a singleton list). +-- Exceptionally it may be given 3 consecutive directed edges forming a triangle +-- and returns the 3 vertices of the triangle. +-- It raises an error if the argument is not one of these 2 cases. +commonVs :: [Dedge] -> [Vertex] +commonVs [(a,b),(c,d)] | b==c = [b] + | d==a = [a] + | otherwise = error $ "commonVs: 2 directed edges not consecutive: " ++ show [(a,b),(c,d)] ++ "\n" +commonVs [(a,b),(c,d),(e,f)] | length (nub [a,b,c,d,e,f]) == 3 = [a,c,e] +commonVs es = error $ "commonVs: unexpected argument edges (not 2 consecutive directed edges or 3 round triangle): " ++ show es ++ "\n" + +-- |tryUpdate: tries a single update (safe or unsafe), +-- producing Left report if the update creates a touching vertex in the unsafe case, +-- or if a stuck/incorrect Tgraph is discovered in the safe case. +tryUpdate:: BoundaryState -> Update -> Try BoundaryChange +tryUpdate bd u@(SafeUpdate _) = trySafeUpdate bd u +tryUpdate bd u@(UnsafeUpdate _) = + case checkUnsafeUpdate bd u of + Just bdC -> return bdC + Nothing -> Left "tryUpdate: crossing boundary (touching vertices).\n" + +-- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateVertices. +-- (Used at intervals in tryRecalibrateForce and recalibrateForce). +recalculateBVLocs :: BoundaryState -> BoundaryState +recalculateBVLocs bd = bd {bvLocMap = newlocs} where + newlocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ allFaces bd + bvs = fmap fst $ boundary bd + +-- |A version of tryForce that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch. +-- This is needed to limit accumulated inaccuracies when large numbers of faces are added in forcing. +tryRecalibratingForce :: Forcible c => c -> Try c +tryRecalibratingForce = tryFSOp recalibrating where + recalibrating fs = do + fs' <- tryStepForce 20000 fs + if null $ updateMap fs' + then return fs' + else recalibrating $ fs' {boundaryState = recalculateBVLocs $ boundaryState fs'} + +-- |A version of force that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch. +-- This is needed to limit accumulation of errors when large numbers of faces are added in forcing. +recalibratingForce :: Forcible c => c -> c +recalibratingForce = runTry . tryRecalibratingForce + + + +{- +Now unused: final stuck check +{- | +tryFinalStuckCheck was designed to check a final force state (in tryForceStateWith). +The final state is rejected as having a stuck Tgraph if any boundary vertex external angle is less than 4 (tenth turns). +This check was included in tryForceStateWith to catch examples like + + makeTgraph [LK(1,2,3),RK(4,3,2),RK(1,3,5),LK(4,6,3),RK(1,7,2),LK(4,2,8)] + +Previously forcing would not discover that the result was stuck without the check. +However a check for a false queen has been added to both allUGenerator and defaultAllUGenerator +to avoid the need for this check. +-} +tryFinalStuckCheck:: ForceState -> Try ForceState +tryFinalStuckCheck fs = + case find ((<4) . externalAngle bs) bvs of + Nothing -> Right fs + Just v -> Left $ "tryFinalStuckCheck: stuck/incorrect tiling: external angle problem found at vertex " ++ show v ++ + "\nwith local faces:" ++ show (facesAtBV bs v) ++ + "\nand boundary edges:" ++ show (boundary bs `intersect` (fmap reverseD $ facesDedges $ facesAtBV bs v)) ++ "\n" + where bs = boundaryState fs + bvs = fmap fst (boundary bs) +-} + + +{- $rules +Forcing rules, + +1. (wholeTileUpdates) When a join edge is on the boundary - add the missing half tile to make a whole tile. +2. (aceKiteUpdates) When a half dart has its short edge on the boundary + add the half kite that must be on the short edge + (this is at ace vertices but also helps with jack and deuce vertices). +3. (queenOrKingUpdates) When a vertex is both a dart origin and a kite wing it must be a queen or king vertex. + If there is a boundary short edge of a kite half at the vertex, + add another kite half sharing the short edge. + (This converts 1 kite to 2 and 3 kites to 4 in combination with the first rule). +4. (deuceDartUpdates) When two half kites share a short edge their oppV vertex must be a deuce vertex. + Add any missing half darts needed to complete the vertex. +5. (jackDartUpdates) When a single dart wing is at a vertex which is recognised as an incomplete jack vertex + and has a complete kite below the dart wing, + add a second dart half touching at the vertex (sharing the kite below). + This is also known as a *largeDartBase* vertex (= new dart base next level up - see later) +6. (sunStarUpdates) When a vertex has 3 or 4 whole kite origins (= 6 or 8 half kite origins) + it must be a sun centre. Also if a vertex has 4 whole dart origins (= 8 half dart origins) + it must be a star centre. + Add an appropriate half kite/dart on a boundary long edge at the vertex. + (This will complete suns (resp. stars) along with rule 1), +7. (jackKiteUpdates) When a dart half has its wing recognised as a jack (largeDartBase) vertex + add a missing kite half on its long edge. +8. (kingDartUpdates) When a vertex is a kite wing and also an origin for exactly 4 dart halves + it must be a king vertex. + Add a missing dart half (on any boundary long edge of a dart at the vertex). +9. (queenDartUpdates) If there are more than 2 kite wings at a vertex (necessarily a queen) + add any missing half dart on a boundary kite long edge +10.(queenKiteUpdates) If there are more than 2 kite wings at a vertex (necessarily a queen) + add any missing fourth half kite on a boundary kite short edge +-} + +{------------------- FORCING RULES and Generators -------------------------- +7 vertex types are: +sun, queen, jack (largeDartBase), ace (fool), deuce (largeKiteCentre), king, star +-} + +{-| allUGenerator combines all the 10 rule update generators. + They are combined in sequence (keeping the rule order) after applying each to the + supplied BoundaryState and a focus edge list. (See also defaultAllUGen). + This version returns a Left..(fail report) for the first generator that produces a Left..(fail report). + See $rules +-} +allUGenerator :: UpdateGenerator +allUGenerator bd focus = + do (_ , umap) <- foldl' addGen (Right (focus,Map.empty)) generators + return umap + where + addGen (Right (es,umap)) gen = do umap' <- gen bd es + let es' = es \\ Map.keys umap' + return (es',Map.union umap' umap) + addGen other _ = other -- fails with first failing generator + generators = [ wholeTileUpdates -- (rule 1) + , aceKiteUpdates -- (rule 2) + , queenOrKingUpdates -- (rule 3) + , deuceDartUpdates -- (rule 4) + , jackDartUpdates -- (rule 5) + , sunStarUpdates -- (rule 6) + , jackKiteUpdates -- (rule 7) + , kingDartUpdates -- (rule 8) + , queenDartUpdates -- (rule 9) + , queenKiteUpdates -- (rule 10) +-- , stuckFalseQueen -- (new: rule 11) + ] + +-- |UFinder (Update case finder functions). Given a BoundaryState and a list of (focus) boundary directed edges, +-- such a function returns each focus edge satisfying the particular update case paired with the tileface +-- matching that edge. For example, if the function is looking for dart short edges on the boundary, +-- it will return only those focus edges which are half-dart short edges, +-- each paired with its half-dart face. +type UFinder = BoundaryState -> [Dedge] -> [(Dedge,TileFace)] + +-- |UChecker (Update checker functions). Given a BoundaryState and a particular tileface (on the boundary), +-- such functions try to produce particular updates on the boundary edge of the given tileface. +-- [They are called update checkers because they may uncover an incorrect/stuck tiling (using tryFindThirdV) +-- when creating the update.] +-- As an example, addKiteShortE will try to produce an update to add a half-kite with short edge against the boundary. +-- Such a function can be used with a UFinder that either returns dart halves with short edge on the boundary +-- (nonKDarts in rule 2) or returns kite halves with short edge on the boundary +-- (kitesWingDartOrigin in rule 3). +type UChecker = BoundaryState -> TileFace -> Try Update + +{-|This is a general purpose filter used to create UFinder functions for each force rule. + It requires a face predicate. + The face predicate takes a BoundaryState bd, a boundary Dedge (a,b) and the TileFace with the edge (b,a) + and decides whether the face is wanted or not (True = wanted) + This will be used to filter all the faces at the focus edges + (when given a BoundaryState and list of focus edges). + For some predicates the BoundaryState argument is not used (eg boundaryJoin in incompleteHalves), + but for others it is used to look at other faces at b or at a besides the supplied face + (eg in kitesWingDartOrigin) +-} +boundaryFilter:: (BoundaryState -> Dedge -> TileFace -> Bool) -> UFinder +boundaryFilter predF bd focus = + [ (e,fc) | e <- focus + , fc <- facesAtBV bd (fst e) + , fc `elem` facesAtBV bd (snd e) + , predF bd e fc + ] + +-- |makeUpdate f x constructs a safe update if x is Just .. and an unsafe update if x is Nothing +makeUpdate:: (Vertex -> TileFace) -> Maybe Vertex -> Update +makeUpdate f (Just v) = SafeUpdate (f v) +makeUpdate f Nothing = UnsafeUpdate f + + + +-- |A vertex on the boundary must be a star if it has 7 or more dart origins +mustbeStar:: BoundaryState -> Vertex -> Bool +mustbeStar bd v = length (filter ((==v) . originV) $ filter isDart $ facesAtBV bd v) >= 7 + +-- |A vertex on the boundary must be a sun if it has 5 or more kite origins +mustbeSun:: BoundaryState -> Vertex -> Bool +mustbeSun bd v = length (filter ((==v) . originV) $ filter isKite $ facesAtBV bd v) >= 5 + +-- |A vertex on the boundary which is an oppV of a kite must be a deuce +-- if there is a shared kite short edge at the vertex. +mustbeDeuce:: BoundaryState -> Vertex -> Bool +mustbeDeuce bd v = isKiteOppV bd v && + hasAnyMatchingE (fmap shortE $ filter isKite $ facesAtBV bd v) + +-- |A boundary vertex which is a kite wing and has 4 dart origins must be a king vertex +mustbeKing:: BoundaryState -> Vertex -> Bool +mustbeKing bd v = isKiteWing bd v && length dartOrigins ==4 + where dartOrigins = filter ((==v) . originV) $ filter isDart $ facesAtBV bd v + +{- +-- |A boundary vertex which is a kite wing and dart origin must be either a king or queen +mustbeQorK:: BoundaryState -> Vertex -> Bool +mustbeQorK bd v = isDartOrigin bd v && isKiteWing bd v +-} + +-- |isKiteWing bd v - Vertex v is a kite wing in BoundaryState bd +isKiteWing:: BoundaryState -> Vertex -> Bool +isKiteWing bd v = v `elem` fmap wingV (filter isKite (facesAtBV bd v)) + +-- |isKiteOppV bd v - Vertex v is a kite oppV in BoundaryState bd +isKiteOppV:: BoundaryState -> Vertex -> Bool +isKiteOppV bd v = v `elem` fmap oppV (filter isKite (facesAtBV bd v)) + +-- |isDartOrigin bd v - Vertex v is a dart origin in BoundaryState bd +isDartOrigin:: BoundaryState -> Vertex -> Bool +isDartOrigin bd v = v `elem` fmap originV (filter isDart (facesAtBV bd v)) + +-- |A boundary vertex with >2 kite wings is a queen vertex +-- (needing a fourth kite on a kite short edge or dart on a kite long edge) +mustbeQueen:: BoundaryState -> Vertex -> Bool +mustbeQueen bd v = kiteWingCount bd v >2 + +-- |kiteWingCount bd v - the number of kite wings at v in BoundaryState bd +kiteWingCount:: BoundaryState -> Vertex -> Int +kiteWingCount bd v = length $ filter ((==v) . wingV) $ filter isKite (facesAtBV bd v) + +-- |mustbeJack (large dart base / jack) is true of a boundary vertex if +-- it is the wing of two darts not sharing a long edge or +-- it is a wing of a dart and also a kite origin +-- (false means it is either undetermined or is a large kite centre - deuce) +mustbeJack :: BoundaryState -> Vertex -> Bool +mustbeJack bd v = + (length dWings == 2 && not (hasAnyMatchingE (fmap longE dWings))) || -- 2 dart wings and dart long edges not shared. + (length dWings == 1 && isKiteOrigin) + where fcs = facesAtBV bd v + dWings = filter ((==v) . wingV) $ filter isDart fcs + isKiteOrigin = v `elem` fmap originV (filter isKite fcs) + +-- |hasMatching asks if a directed edge list has any two matching (=opposing) directed edges. +hasAnyMatchingE :: [Dedge] -> Bool +hasAnyMatchingE ((x,y):more) = (y,x) `elem` more || hasAnyMatchingE more +hasAnyMatchingE [] = False + +{-| makeGenerator combines an update case finder (UFinder) with its corresponding update checker (UChecker) + to produce an update generator function. + This is used to make each of the 10 update generators corresponding to 10 rules. + + When the generator is given a BoundaryState and list of focus edges, + the finder produces a list of pairs of dedge and face, + the checker is used to convert the face in each pair to an update (which can fail with a Left report), + and the new updates are returned as a map (with the dedges as key) in a Right result. +-} +makeGenerator :: UChecker -> UFinder -> UpdateGenerator +makeGenerator checker finder = gen where + gen bd edges = foldr addU (Right Map.empty) (finder bd edges) where + addU _ (Left x) = Left x + addU (e,fc) (Right ump) = do u <- checker bd fc + return (Map.insert e u ump) + + +-- * Ten Update Generators (with corresponding Finders) + + +-- |Update generator for rule (1) +wholeTileUpdates:: UpdateGenerator +wholeTileUpdates = makeGenerator completeHalf incompleteHalves + +-- |Find faces with missing opposite face (mirror face) +incompleteHalves :: UFinder +incompleteHalves = boundaryFilter boundaryJoin where + boundaryJoin _ (a,b) fc = joinE fc == (b,a) + + +-- |Update generator for rule (2) +aceKiteUpdates :: UpdateGenerator +aceKiteUpdates = makeGenerator addKiteShortE nonKDarts + +-- |Find half darts with boundary short edge +nonKDarts :: UFinder +nonKDarts = boundaryFilter bShortDarts where + bShortDarts _ (a,b) fc = isDart fc && shortE fc == (b,a) + + +-- |Update generator for rule (3) + -- queen and king vertices add a missing kite half (on a boundary kite short edge) +queenOrKingUpdates :: UpdateGenerator +queenOrKingUpdates = makeGenerator addKiteShortE kitesWingDartOrigin + +-- |Find kites with boundary short edge where the wing is also a dart origin +kitesWingDartOrigin :: UFinder +kitesWingDartOrigin = boundaryFilter kiteWDO where + kiteWDO bd (a,b) fc = shortE fc == (b,a) + && isKite fc && isDartOrigin bd (wingV fc) + + +{-| Update generator for rule (4) + (for deuce vertices = largeKiteCentres) + Kites whose short edge (b,a) matches a boundary edge (a,b) where their oppV + has 2 other kite halves sharing a shortE. + These need a dart adding on the short edge. +-} +deuceDartUpdates :: UpdateGenerator +deuceDartUpdates = makeGenerator addDartShortE kiteGaps + +-- |Find kite halves with a short edge on the boundary (a,b) +-- where there are 2 other kite halves sharing a short edge +-- at oppV of the kite half (a for left kite and b for right kite) +kiteGaps :: UFinder +kiteGaps = boundaryFilter kiteGap where + kiteGap bd (a,b) fc = shortE fc == (b,a) + && isKite fc && mustbeDeuce bd (oppV fc) + + +-- |Update generator for rule (5) +-- jackDartUpdates - jack vertex add a missing second dart +jackDartUpdates :: UpdateGenerator +jackDartUpdates = makeGenerator addDartShortE noTouchingDart + +-- |Find kite halves with a short edge on the boundary (a,b) where oppV is a largeDartBase vertex +-- (oppV is a for left kite and b for right kite). +-- The function mustbeJack determines if a vertex must be a a largeDartBase / jack +noTouchingDart :: UFinder +noTouchingDart = boundaryFilter farKOfDarts where + farKOfDarts bd (a,b) fc = shortE fc == (b,a) + && isKite fc && mustbeJack bd (oppV fc) + +{-| Update generator for rule (6) +sunStarUpdates is for vertices that must be either sun or star +almostSunStar finds half-kites/half-darts with a long edge on the boundary +where their origin vertex has 8 total half-kites/half-darts respectively +or their origin vertex has 6 total half-kites in the case of kites only +completeSunStar will add a new face of the same type (dart/kite) +sharing the long edge. +-} +sunStarUpdates :: UpdateGenerator +sunStarUpdates = makeGenerator completeSunStar almostSunStar + +-- |Find a boundary long edge of either +-- a dart where there are at least 7 dart origins, or +-- a kite where there are at least 5 kite origins +almostSunStar :: UFinder +almostSunStar = boundaryFilter multiples57 where + multiples57 bd (a,b) fc = longE fc == (b,a) && + ((isDart fc && mustbeStar bd (originV fc)) || + (isKite fc && mustbeSun bd (originV fc)) + ) + +-- |Update generator for rule (7) +-- jack vertices (largeDartBases) with dart long edge on boundary - add missing kite top +jackKiteUpdates :: UpdateGenerator +jackKiteUpdates = makeGenerator addKiteLongE jackMissingKite + +-- |Find jack vertices (largeDartBases) with dart long edge on the boundary +jackMissingKite :: UFinder +jackMissingKite = boundaryFilter dartsWingDB where + dartsWingDB bd (a,b) fc = longE fc == (b,a) && + isDart fc && mustbeJack bd (wingV fc) + +-- |Update generator for rule (8) +-- king vertices with 2 of the 3 darts - add another half dart on a boundary long edge of existing darts +kingDartUpdates :: UpdateGenerator +kingDartUpdates = makeGenerator addDartLongE kingMissingThirdDart + +-- |Find king vertices with a dart long edge on the boundary +-- and 2 of the 3 darts at its origin plus a kite wing at its origin +kingMissingThirdDart :: UFinder +kingMissingThirdDart = boundaryFilter predicate where + predicate bd (a,b) fc = longE fc == (b,a) && + isDart fc && mustbeKing bd (originV fc) + + +-- |Update generator for rule (9) +-- queen vertices (with 4 kite wings) -- add any missing half dart on a boundary kite long edge +queenDartUpdates :: UpdateGenerator +queenDartUpdates = makeGenerator addDartLongE queenMissingDarts + +-- |Find queen vertices (with 3 or 4 kite wings) and a boundary kite long edge +queenMissingDarts :: UFinder +queenMissingDarts = boundaryFilter predicate where + predicate bd (a,b) fc = + longE fc == (b,a) && isKite fc && length kiteWings >2 + where fcWing = wingV fc + kiteWings = filter ((==fcWing) . wingV) $ + filter isKite $ facesAtBV bd fcWing + +-- |Update generator for rule (10) +-- queen vertices with 3 kite wings -- add missing fourth half kite on a boundary kite short edge +queenKiteUpdates :: UpdateGenerator +queenKiteUpdates = makeGenerator addKiteShortE queenMissingKite + +-- |Find queen vertices with only 3 kite wings and a kite short edge on the boundary +queenMissingKite :: UFinder +queenMissingKite = boundaryFilter predicate where + predicate bd (a,b) fc = + shortE fc == (b,a) && isKite fc && length kiteWings >2 + where fcWing = wingV fc + kiteWings = filter ((==fcWing) . wingV) $ filter isKite (facesAtBV bd fcWing) + + +-- * Six Update Checkers + + +-- |completeHalf will check an update to +-- add a symmetric (mirror) face for a given face at a boundary join edge. +completeHalf :: UChecker +completeHalf bd (LD(a,b,_)) = makeUpdate makeFace <$> x where + makeFace v = RD(a,v,b) + x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD +completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where + makeFace v = LD(a,b,v) + x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD +completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where + makeFace v = RK(a,b,v) + x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK +completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where + makeFace v = LK(a,v,b) + x = tryFindThirdV bd (b,a) (2,1) --anglesForJoinLK + +-- |add a (missing) half kite on a (boundary) short edge of a dart or kite +addKiteShortE :: UChecker +addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where + makeFace v = LK(v,c,b) + x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK +addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where + makeFace v = RK(v,c,b) + x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK +addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where + makeFace v = RK(v,c,b) + x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK +addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where + makeFace v = LK(v,c,b) + x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK + +-- |add a half dart top to a boundary short edge of a half kite. +addDartShortE :: UChecker +addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where + makeFace v = LD(v,c,b) + x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD +addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where + makeFace v = RD(v,c,b) + x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD +addDartShortE _ _ = error "addDartShortE applied to non-kite face\n" + +-- |add a kite half to a kite long edge or dart half to a dart long edge +completeSunStar :: UChecker +completeSunStar bd fc = if isKite fc + then addKiteLongE bd fc + else addDartLongE bd fc + +-- |add a kite to a long edge of a dart or kite +addKiteLongE :: UChecker +addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where + makeFace v = RK(c,v,a) + x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK +addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where + makeFace v = LK(b,a,v) + x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK +addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where + makeFace v = LK(a,c,v) + x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK +addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where + makeFace v = RK(a,v,b) + x = tryFindThirdV bd (b,a) (2,1) -- anglesForLongRK + +-- |add a half dart on a boundary long edge of a dart or kite +addDartLongE :: UChecker +addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where + makeFace v = RD(a,c,v) + x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD +addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where + makeFace v = LD(a,v,b) + x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD +addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where + makeFace v = RD(b,a,v) + x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD +addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where + makeFace v = LD(c,v,a) + x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongLD + +{- +-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3) +anglesForJoinRD,anglesForJoinLD,anglesForJoinRK,anglesForJoinLK::(Int,Int) +anglesForJoinRD = (3,1) +anglesForJoinLD = (1,3) +anglesForJoinRK = (1,2) +anglesForJoinLK = (2,1) +-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3) +anglesForLongLD,anglesForLongRD,anglesForLongRK,anglesForLongLK::(Int,Int) +anglesForLongLD = (1,1) +anglesForLongRD = (1,1) +anglesForLongRK = (2,1) +anglesForLongLK = (1,2) +-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3) +anglesForShortLD,anglesForShortRD,anglesForShortLK,anglesForShortRK::(Int,Int) +anglesForShortLD = (3,1) +anglesForShortRD = (1,3) +anglesForShortLK = (2,2) +anglesForShortRK = (2,2) +-} + + +-- * The Default All Update Generator (defaultAllUGen) + + +-- |An alternative to allUGenerator, and used as the default. It uses the same rules and UCheckers, +-- but makes decisions based on the EdgeType of a boundary edge (instead of trying each UFinder in turn). +-- If there are any Left..(fail reports) for the given +-- boundary edges the result is a sigle Left.. concatenating all the failure reports (unlike allUGenerator). +defaultAllUGen :: UpdateGenerator +defaultAllUGen bd es = combine $ fmap decide es where -- Either String is a monoid as well as Map + decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e + + decider (e,f,Join) = mapItem e (completeHalf bd f) -- rule 1 + decider (e,f,Short) + | isDart f = mapItem e (addKiteShortE bd f) -- rule 2 + | otherwise = kiteShortDecider e f + decider (e,f,Long) + | isDart f = dartLongDecider e f + | otherwise = kiteLongDecider e f + + dartLongDecider e f + | mustbeStar bd (originV f) = mapItem e (completeSunStar bd f) + | mustbeKing bd (originV f) = mapItem e (addDartLongE bd f) + | mustbeJack bd (wingV f) = mapItem e (addKiteLongE bd f) + | otherwise = Right Map.empty + + kiteLongDecider e f + | mustbeSun bd (originV f) = mapItem e (completeSunStar bd f) + | mustbeQueen bd (wingV f) = mapItem e (addDartLongE bd f) + | otherwise = Right Map.empty + + kiteShortDecider e f + | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem e (addDartShortE bd f) + | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem e (addKiteShortE bd f) + | otherwise = Right Map.empty + + mapItem e = fmap (\u -> Map.insert e u Map.empty) + combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any + -- otherwise combines the update maps with mconcat + +-- |Given a BoundaryState and a directed boundary edge, this returns the same edge with +-- the unique face on that edge and the edge type for that face and edge (Short/Long/Join) +inspectBDedge:: BoundaryState -> Dedge -> (TileFace, EdgeType) +inspectBDedge bd e = (face,edgeType (reverseD e) face) where + face = case facesAtBV bd (fst e) `intersect` facesAtBV bd (snd e) of + [f] -> f + _ -> error $ "inspectBDedge: Not a boundary directed edge " ++ show e ++ "\n" + + + + +-- * Auxiliary Functions for adding faces: externalAngle and tryFindThirdV. $Additions + + +{- $Additions + +The difficulty of adding faces is determining if any edges of a new face already exist. +This goes beyond a simple graph operation and requires use of the internal angles of the faces. +We use a representation of angles which allows an equality test. +All angles are integer multiples of 1/10th turn (mod 10) so we use +these integers for comparing angles n where n is 0..9 + + +No crossing boundary property: +It is important that there are no crossing boundaries, otherwise external angle calculations could be wrong. + +Possible Touching Vertices. +When tryFindThirdV returns Nothing, this means a new vertex needs to be created. +This will need to have its position checked against other (boundary) vertices to avoid +creating a touching vertex/crossing boundary. (Taken care of in tryUnsafeUpdate) +---------------------------------} + +{-|tryFindThirdV finds a neighbouring third vertex on the boundary if there is one in the correct direction for a face added to + the right hand side of a directed boundary edge. + In tryFindThirdV bd (a,b) (n,m), the two integer arguments n and m are the INTERNAL angles + for the new face on the boundary directed edge (a,b) + (for a and b respectively) expressed as multiples of tt (tt being a tenth turn) + and must both be either 1,2, or 3. + tryFindThirdV compares these internal angles with the external angles of the boundary calculated at a and b. + If one of them matches, then an adjacent boundary edge will lead to the required vertex. + If either n or m is too large a Left report is returned indicating an incorrect graph (stuck tiling). + If n and m are smaller than the respective external angles, Right Nothing is returned. +-} +tryFindThirdV:: BoundaryState -> Dedge -> (Int,Int) -> Try (Maybe Vertex) +tryFindThirdV bd (a,b) (n,m) = maybeV where + aAngle = externalAngle bd a + bAngle = externalAngle bd b + maybeV | aAngle <1 || aAngle >9 + = Left $ "tryFindThirdV: vertex: " ++ show a ++ " has (tt) external angle " ++ show aAngle + ++ "\nwhen adding to boundary directed edge: " ++ show (a,b) + ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) + ++ "\nand faces at " ++ show b ++ ":\n" ++ show (bvFacesMap bd VMap.! b) + ++ "\nand a total of " ++ show (length $ allFaces bd) ++ " faces.\n" + | bAngle <1 || bAngle >9 + = Left $ "tryFindThirdV: vertex: " ++ show b ++ " has (tt) external angle " ++ show bAngle + ++ "\nwhen adding to boundary directed edge: " ++ show (a,b) + ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) + ++ "\nand faces at " ++ show b ++ ":\n" ++ show (bvFacesMap bd VMap.! b) + ++ "\nand a total of " ++ show (length $ allFaces bd) ++ " faces.\n" + | aAngle < n + = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " + ++ show (a,b) ++ "\n" + | bAngle < m + = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " + ++ show (a,b) ++ "\n" + | aAngle == n = case find ((==a) . snd) (boundary bd) of + Just pr -> Right $ Just (fst pr) + Nothing -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " + ++ show (a,b) ++ "\n" + | bAngle == m = case find ((==b) . fst) (boundary bd) of + Just pr -> Right $ Just (snd pr) + Nothing -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " + ++ show (a,b) ++ "\n" + | otherwise = Right Nothing + +-- |externalAngle bd v - calculates the external angle at boundary vertex v in BoundaryState bd as an +-- integer multiple of tt (tenth turn), so 1..9. It relies on there being no crossing boundaries, +-- so that there is a single external angle at each boundary vertex. +externalAngle:: BoundaryState -> Vertex -> Int +externalAngle bd v = 10 - sum (map (intAngleAt v) $ facesAtBV bd v) + +-- |intAngleAt v fc gives the internal angle of the face fc at vertex v (which must be a vertex of the face) +-- in terms of tenth turns, so returning an Int (1,2,or 3). +intAngleAt :: Vertex -> TileFace -> Int +intAngleAt v fc = faceIntAngles fc !! indexV v fc + +-- |faceIntAngles returns a list of the three internal angles of a face (clockwise from originV) +-- in terms of tenth turns - always 1 or 2 for kites and 1 or 3 for darts. +faceIntAngles :: TileFace -> [Int] +faceIntAngles (LD _) = [1,3,1] +faceIntAngles (RD _) = [1,1,3] +faceIntAngles _ = [1,2,2] -- LK and RK + + + diff --git a/src/Tgraph/Prelude.hs b/src/Tgraph/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Prelude.hs @@ -0,0 +1,1235 @@ +{-| +Module : Tgraph.Prelude +Description : Introducing types Tgraph, VPatch and drawing operations. +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +Introduces Tgraphs and includes operations on vertices, edges and faces as well as Tgraphs. +Plus VPatch (Vertex Patch) as intermediary between Tgraph and Diagram. +Conversion and drawing operations to produce Diagrams. +The module also includes functions to calculate (relative) locations of vertices (locateVertices, addVPoint), +touching vertex checks (touchingVertices, touchingVerticesGen), and edge drawing functions. + +This module re-exports module HalfTile and module Tgraph.Try. +-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} + +module Tgraph.Prelude + ( module HalfTile + , module Tgraph.Try + -- * Types for Tgraphs, Faces, Vertices, Directed Edges + , Tgraph -- not Data Constructor + , TileFace + , Vertex + , VertexSet + , VertexMap + -- $Edges + , Dedge + , EdgeType(..) + -- * Property Checking for Tgraphs + , makeUncheckedTgraph + , checkedTgraph + , tryTgraphProps + , tryConnectedNoCross +-- , findEdgeLoops + , hasEdgeLoops + , duplicates +-- , conflictingDedges + , edgeType +-- , sharedEdges +-- , newSharedEdges + , noNewConflict +-- unused , noNewConflictFull +-- , legal +-- , illegals + , illegalTiling +-- , crossingBVs + , crossingVertices + , crossingBoundaries + , connected +-- , connectedBy + -- * Basic Tgraph operations + , faces + , emptyTgraph + , nullGraph + , maxV + , ldarts + , rdarts + , lkites + , rkites + , kites + , darts + , selectFaces + , removeFaces + , removeVertices + , selectVertices + , vertexSet + , graphDedges + , graphEdges + , internalEdges + , graphBoundary + , phiEdges + , nonPhiEdges + , graphEFMap + , defaultAlignment + -- * Other Face/Vertex Operations + , faceVs + , faceVList + , faceVSet + , facesVSet + , facesMaxV + , firstV + , secondV + , thirdV + , originV + , wingV + , oppV + , indexV + , nextV + , prevV + , isAtV + , hasVIn + -- * Other Edge Operations + , faceDedges + , facesDedges + , reverseD + , joinE + , shortE + , longE + , joinOfTile + , facePhiEdges + , faceNonPhiEdges +-- , matchingE + , matchingLongE + , matchingShortE + , matchingJoinE + , hasDedge + , hasDedgeIn + , facesEdges +-- , bothDir +-- , bothDirOneWay + , facesBoundary +-- , missingRevs + -- * Other Face Operations + , edgeNb + , vertexFacesMap + , dedgesFacesMap + , buildEFMap + , faceForEdge + , edgeNbs +-- , extractLowestJoin + , lowestJoin + -- * VPatch and Conversions + , VPatch(..) + , VertexLocMap + , makeVP + , subVP + , relevantVP + , restrictVP + , graphFromVP + , removeFacesVP + , selectFacesVP + , findLoc + -- * Drawing Tgraphs and Vpatches with Labels + , DrawableLabelled(..) + , labelSize + , labelled + , rotateBefore + , dropLabels +-- * VPatch alignment with vertices + , centerOn + , alignXaxis + , alignments + , alignAll + , alignBefore + , makeAlignedVP + -- * Drawing Edges with a VPatch or a VertexLocationMap + , drawEdgesVP + , drawEdgeVP + , drawEdges + , drawEdge + -- * Vertex Location and Touching Vertices + , locateVertices + , addVPoint + , axisJoin +-- , find3Locs +-- , thirdVertexLoc + , touchingVertices + , touching + , touchingVerticesGen + , locateVerticesGen + ) where + +import Data.List ((\\), intersect, union, elemIndex,foldl',find) +-- import Data.Either(fromRight, lefts, rights, isLeft) +import qualified Data.IntMap.Strict as VMap (IntMap, alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet) +import qualified Data.IntSet as IntSet (IntSet,union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteMin,findMin,findMax,member,difference) +import qualified Data.Map.Strict as Map (Map, fromList, lookup, fromListWith) +import Data.Maybe (mapMaybe) -- edgeNbrs +import qualified Data.Set as Set (fromList,member,null,delete)-- used for locateVertices + +import Diagrams.Prelude hiding (union) +import Diagrams.TwoD.Text (Text) + +import TileLib +import HalfTile +import Tgraph.Try + + +{--------------------- +********************* +Tgraphs +********************* +-----------------------} + + + +-- $Types for Tgraphs, Vertices, Directed Edges, Faces + +-- |Tgraph vertices (must be positive) +type Vertex = Int +-- | directed edge +type Dedge = (Vertex,Vertex) +-- | Vertex Sets +type VertexSet = IntSet.IntSet + +-- |Tgraph faces (vertices clockwise starting with tile origin vertex) +-- a specialisation of HalfTile +type TileFace = HalfTile (Vertex,Vertex,Vertex) + +-- |A Tgraph is a list of faces. +-- All vertex labels should be positive, so 0 is not used as a vertex label. +-- Tgraphs should be constructed with makeTgraph or checkedTgraph to check required properties. +-- The data constructor Tgraph is not exported (but see also makeUncheckedTgraph). +newtype Tgraph = Tgraph [TileFace] + deriving (Show) + +-- | type used to classify edges of faces +data EdgeType = Short | Long | Join deriving (Show,Eq) + +-- |Abbreviation for Mapping from Vertex keys (also used for Boundaries) +type VertexMap a = VMap.IntMap a + +{------------------------------------------- +******************************************** +Basic Tgraph, vertex, edge, face operations +******************************************** +--------------------------------------------} + +{-* +Tgraphs and Property Checking +-} + + +-- |Creates a (possibly invalid) Tgraph from a list of faces. +-- It does not perform checks on the faces. Use makeTgraph (defined in Tgraphs module) or checkedTgraph to perform checks. +-- This is intended for use only when checks are known to be redundant (the data constructor Tgraph is hidden). +makeUncheckedTgraph:: [TileFace] -> Tgraph +makeUncheckedTgraph fcs = Tgraph fcs + +{-| Creates a Tgraph from a list of faces AND checks for edge loops, edge conflicts and +crossing boundaries and connectedness and legal tiling with tryTgraphProps. +(No crossing boundaries and connected implies tile-connected). +Produces an error if a check fails. + +Note: This does not check for touching vertices (distinct labels for the same vertex). +To perform this additional check use makeTgraph (defined in Tgraphs module) which also calls tryTgraphProps. +-} +checkedTgraph:: [TileFace] -> Tgraph +checkedTgraph = runTry . onFail report . tryTgraphProps + where report = "checkedTgraph: Failed\n" -- ++ " for faces: " ++ show fcs ++ "\n" + + +{- | Checks a list of faces to avoid: + edge loops, + edge conflicts (same directed edge on two or more faces), + illegal tilings (breaking legal rules for tiling), + vertices not all >0 , + crossing boundaries, and + non-connectedness. + +Returns Right g where g is a Tgraph on passing checks. +Returns Left lines if a test fails, where lines describes the problem found. +-} +tryTgraphProps:: [TileFace] -> Try Tgraph +tryTgraphProps [] = Right emptyTgraph +tryTgraphProps fcs + | hasEdgeLoops fcs = Left $ "tryTgraphProps: Non-valid tile-face(s)\n" ++ + "Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n" + | illegalTiling fcs = Left $ "tryTgraphProps: Non-legal tiling\n" ++ + "Conflicting face directed edges (non-planar tiling): " + ++ show (conflictingDedges fcs) ++ + "\nIllegal tile juxtapositions: " + ++ show (illegals fcs) ++ "\n" + | otherwise = let vs = facesVSet fcs + in if IntSet.findMin vs <1 -- any (<1) $ IntSet.toList vs + then Left $ "tryTgraphProps: Vertex numbers not all >0: " ++ show (IntSet.toList vs) ++ "\n" + else tryConnectedNoCross fcs + +-- |Checks a list of faces for no crossing boundaries and connectedness. +-- (No crossing boundaries and connected implies tile-connected). +-- Returns Right g where g is a Tgraph on passing checks. +-- Returns Left lines if a test fails, where lines describes the problem found. +-- This is used by tryTgraphProps after other checks have been made, +-- but can be used alone when other properties are known to hold (e.g. in tryPartCompose) +tryConnectedNoCross:: [TileFace] -> Try Tgraph +tryConnectedNoCross fcs + | not (connected fcs) = Left $ "tryConnectedNoCross: Non-valid Tgraph (Not connected)\n" ++ show fcs ++ "\n" + | crossingBoundaries fcs = Left $ "tryConnectedNoCross: Non-valid Tgraph\n" ++ + "Crossing boundaries found at " ++ show (crossingBVs fcs) + ++ "\nwith faces\n" ++ show fcs + | otherwise = Right (Tgraph fcs) + +-- |Returns any repeated vertices in a single tileface for a list of tilefaces. +findEdgeLoops:: [TileFace] -> [Vertex] +findEdgeLoops = concatMap (duplicates . faceVList) + +-- |Checks if there are repeated vertices within a tileface for a list of tilefaces. +-- Returns True if there are any. +hasEdgeLoops:: [TileFace] -> Bool +hasEdgeLoops = not . null . findEdgeLoops + + +-- |duplicates finds duplicated items in a list (reverses order but unique results) +duplicates :: Eq a => [a] -> [a] +duplicates = fst . foldl' check ([],[]) where + check (dups,seen) x | x `elem` dups = (dups,seen) + | x `elem` seen = (x:dups,seen) + | otherwise = (dups,x:seen) + +-- |conflictingDedges fcs returns a list of conflicting directed edges in fcs +-- i.e. different faces having the same edge in the same direction. +-- (which should be null for a Tgraph) +conflictingDedges :: [TileFace] -> [Dedge] +conflictingDedges = duplicates . facesDedges + + + +-- | edgeType d f - classifies the directed edge d +-- which must be one of the three directed edges of face f. +-- An error is raised if it is not a directed edge of the face +edgeType:: Dedge -> TileFace -> EdgeType +edgeType d f | d == longE f = Long + | d == shortE f = Short + | d == joinE f = Join + | otherwise = error $ "edgeType: directed edge " ++ show d ++ + " not found in face " ++ show f ++ "\n" + +-- |For a list of tile faces fcs this produces a list of tuples of the form (f1,etpe1,f2,etype2) +-- where f1 and f2 share a common edge and etype1 is the type of the shared edge in f1 and +-- etype2 is the type of the shared edge in f2. +-- This list can then be checked for inconsistencies / illegal pairings (using legal). +sharedEdges:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)] +sharedEdges fcs = [(f1, edgeType d1 f1, f2, edgeType d2 f2) + | f1 <- fcs + , d1 <- faceDedges f1 + , let d2 = reverseD d1 + , f2 <- filter (`hasDedge` d2) fcs + ] + +-- |A version of sharedEdges comparing a single face against a list of faces. +-- This does not look at shared edges within the list, but just the new face against the list. +newSharedEdges:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)] +newSharedEdges face fcs = + [(face, edgeType d1 face, fc', edgeType d2 fc') + | d1 <- faceDedges face + , let d2 = reverseD d1 + , fc' <- filter (`hasDedge` d2) fcs + ] + +-- | noNewConflict face fcs returns True if face has an illegal shared edge with fcs. +-- It does not check for illegal cases within the fcs. +noNewConflict :: TileFace -> [TileFace] -> Bool +noNewConflict face fcs = null $ filter (not . legal) shared where + shared = newSharedEdges face fcs + +{- +-- |noNewConflictFull face fcs where face is a new face and fcs are neighbouring faces. +-- Checks for illegal shared edges using noNewConflict but also checks that face does not have a directed edge +-- in the same direction as a directed edge in fcs. +noNewConflictFull :: TileFace -> [TileFace] -> Bool +noNewConflictFull face fcs = null (faceDedges face `intersect` facesDedges fcs) && noNewConflict face fcs +-} + +-- | legal (f1,etype1,f2,etype2) is True if and only if it is legal for f1 and f2 to share an edge +-- with edge type etype1 (and etype2 is equal to etype1). +legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool +legal (LK _, e1, RK _ , e2 ) = e1 == e2 +legal (RK _, e1, LK _ , e2 ) = e1 == e2 +legal (LK _, Short, RD _ , Short) = True +legal (RD _, Short, LK _ , Short) = True +legal (LK _, Long, RD _ , Long ) = True +legal (RD _, Long, LK _ , Long ) = True +legal (LD _, Join, RD _ , Join ) = True +legal (RD _, Join, LD _ , Join ) = True +legal (LD _, Long, RD _ , Long ) = True +legal (RD _, Long, LD _ , Long ) = True +legal (LD _, Short, RK _ , Short) = True +legal (RK _, Short, LD _ , Short) = True +legal (LD _, Long, RK _ , Long ) = True +legal (RK _, Long, LD _ , Long ) = True +legal _ = False + +-- | Returns a list of illegal face parings of the form (f1,e1,f2,e2) where f1 and f2 share an edge +-- and e1 is the type of this edge in f1, and e2 is the type of this edge in f2. +-- The list should be null for a legal Tgraph. +illegals:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)] +illegals = filter (not . legal) . sharedEdges + +-- | Returns True if there are conflicting directed edges or if there are illegal shared edges +-- in the list of tile faces +illegalTiling:: [TileFace] -> Bool +illegalTiling fcs = not (null (illegals fcs)) || not (null (conflictingDedges fcs)) + +-- |crossingBVs fcs returns a list of vertices with crossing boundaries +-- (which should be null). +crossingBVs :: [TileFace] -> [Vertex] +crossingBVs = crossingVertices . facesBoundary + +-- |Given a list of directed boundary edges, crossingVertices returns a list of vertices occurring +-- more than once at the start of the directed edges in the list. +-- Used for finding crossing boundary vertices when the boundary is already calculated. +crossingVertices:: [Dedge] -> [Vertex] +crossingVertices des = duplicates (fmap fst des) -- OR duplicates (fmap snd des) + +-- |There are crossing boundaries if vertices occur more than once +-- at the start of all boundary directed edges +-- (or more than once at the end of all boundary directed edges). +crossingBoundaries :: [TileFace] -> Bool +crossingBoundaries = not . null . crossingBVs + +-- |Predicate to check a Tgraph is a connected graph. +connected:: [TileFace] -> Bool +connected [] = True +connected fcs = null (snd $ connectedBy (facesEdges fcs) (IntSet.findMin vs) vs) + where vs = facesVSet fcs + +-- |Auxiliary function for calculating connectedness. +-- connectedBy edges v verts returns a pair of lists of vertices (conn,unconn) +-- where conn is a list of vertices from the set verts that are connected to v by a chain of edges, +-- and unconn is a list of vertices from set verts that are not connected to v. +-- This version creates an IntMap to represent edges (Vertex to [Vertex]) +-- and uses IntSets for the search algorithm arguments. +connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex],[Vertex]) +connectedBy edges v verts = search IntSet.empty (IntSet.singleton v) (IntSet.delete v verts) where + nextMap = VMap.fromListWith (++) $ map (\(a,b)->(a,[b])) edges +-- search arguments (sets): done (=processed), visited, unvisited. + search done visited unvisited + | IntSet.null unvisited = (IntSet.toList visited ++ IntSet.toList done,[]) + | IntSet.null visited = (IntSet.toList done, IntSet.toList unvisited) -- any unvisited are not connected + | otherwise = + search (IntSet.insert x done) (IntSet.union newVs visited') (unvisited IntSet.\\ newVs) + where x = IntSet.findMin visited + visited' = IntSet.deleteMin visited + newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x + + + +-- |Retrieve the faces of a Tgraph +faces :: Tgraph -> [TileFace] +faces (Tgraph fcs) = fcs + +-- |The empty Tgraph +emptyTgraph :: Tgraph +emptyTgraph = Tgraph [] + +-- |is the Tgraph empty? +nullGraph:: Tgraph -> Bool +nullGraph = null . faces + +-- |find the maximum vertex number in a Tgraph, returning 0 for an empty Tgraph. +maxV :: Tgraph -> Int +maxV = facesMaxV . faces + +ldarts,rdarts,lkites,rkites, kites, darts :: Tgraph -> [TileFace] +-- | selecting left darts from a Tgraph +ldarts = filter isLD . faces +-- | selecting right darts from a Tgraph +rdarts = filter isRD . faces +-- | selecting left kites from a Tgraph +lkites = filter isLK . faces +-- | selecting right kites from a Tgraph +rkites = filter isRK . faces +-- | selecting half kites from a Tgraph +kites = filter isKite . faces +-- | selecting half darts from a Tgraph +darts = filter isDart . faces + +-- |selects faces from a Tgraph (removing any not in the list), +-- but checks resulting Tgraph for connectedness and no crossing boundaries. +selectFaces :: [TileFace] -> Tgraph -> Tgraph +selectFaces fcs g = runTry $ tryConnectedNoCross $ faces g `intersect` fcs + +-- |removes faces from a Tgraph, +-- but checks resulting Tgraph for connectedness and no crossing boundaries. +removeFaces :: [TileFace] -> Tgraph -> Tgraph +removeFaces fcs g = runTry $ tryConnectedNoCross $ faces g \\ fcs + +-- |removeVertices vs g - removes any vertex in the list vs from g +-- by removing all faces at those vertices. Resulting Tgraph is checked +-- for required properties e.g. connectedness and no crossing boundaries. +removeVertices :: [Vertex] -> Tgraph -> Tgraph +removeVertices vs g = removeFaces (filter (hasVIn vs) (faces g)) g + +-- |selectVertices vs g - removes any face that does not have a vertex in the list vs from g. +-- Resulting Tgraph is checked +-- for required properties e.g. connectedness and no crossing boundaries. +selectVertices :: [Vertex] -> Tgraph -> Tgraph +selectVertices vs g = selectFaces (filter (hasVIn vs) (faces g)) g + +-- |the set of vertices of a Tgraph +vertexSet:: Tgraph -> VertexSet +vertexSet = facesVSet . faces + +-- |A list of all the directed edges of a Tgraph (going clockwise round faces) +graphDedges :: Tgraph -> [Dedge] +graphDedges = facesDedges . faces + +-- |graphEdges returns a list of all the edges of a Tgraph (both directions of each edge). +graphEdges :: Tgraph -> [Dedge] +graphEdges = facesEdges . faces + +-- |internal edges are shared by two faces = all edges except boundary edges +internalEdges :: Tgraph -> [Dedge] +internalEdges g = des \\ fmap reverseD (missingRevs des) where + des = graphDedges g + +-- |graphBoundary g are missing reverse directed edges in graphDedges g (the result contains single directions only) +-- Direction is such that a face is on LHS and exterior is on RHS of each boundary directed edge. +graphBoundary :: Tgraph -> [Dedge] +graphBoundary = facesBoundary . faces + +-- |phiEdges returns a list of the longer (phi-length) edges of a Tgraph (including kite joins). +-- This includes both directions of each edge. +phiEdges :: Tgraph -> [Dedge] +phiEdges = bothDir . concatMap facePhiEdges . faces + +-- |nonPhiEdges returns a list of the shorter edges of a Tgraph (including dart joins). +-- This includes both directions of each edge. +nonPhiEdges :: Tgraph -> [Dedge] +nonPhiEdges = bothDir . concatMap faceNonPhiEdges . faces + +-- | graphEFMap g - is a mapping associating with each directed edge of g, the unique TileFace with that directed edge. +-- This is more efficient than using dedgesFacesMap for the complete mapping. +graphEFMap :: Tgraph -> Map.Map Dedge TileFace +graphEFMap = buildEFMap . faces + +-- |the default alignment of a non-empty Tgraph is (v1,v2) where v1 is the lowest numbered face origin, +-- and v2 is the lowest numbered opp vertex of faces with origin at v1. This is the lowest join of g. +-- An error will be raised if the Tgraph is empty. +defaultAlignment :: Tgraph -> (Vertex,Vertex) +defaultAlignment g | nullGraph g = error "defaultAlignment: applied to empty Tgraph\n" + | otherwise = lowestJoin $ faces g + + +-- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace +faceVs::TileFace -> (Vertex,Vertex,Vertex) +faceVs = tileRep + +-- |list of (three) face vertices in order clockwise starting with origin +faceVList::TileFace -> [Vertex] +faceVList = (\(x,y,z) -> [x,y,z]) . faceVs + +-- |the set of vertices of a face +faceVSet :: TileFace -> VertexSet +faceVSet = IntSet.fromList . faceVList + +-- |the set of vertices of a list of faces +facesVSet:: [TileFace] -> VertexSet +facesVSet = mconcat . fmap faceVSet + +-- |find the maximum vertex for a list of faces (0 for an empty list). +facesMaxV :: [TileFace] -> Vertex +facesMaxV [] = 0 +facesMaxV fcs = IntSet.findMax $ facesVSet fcs + +-- Whilst first, second and third vertex of a face are obvious (clockwise), +-- it is often more convenient to refer to the originV (=firstV), +-- oppV (the vertex at the other end of the join edge), and +-- wingV (the remaining vertex not on the join edge) + +-- |firstV, secondV and thirdV vertices of a face are counted clockwise starting with the origin +firstV,secondV,thirdV:: TileFace -> Vertex +firstV face = a where (a,_,_) = faceVs face +secondV face = b where (_,b,_) = faceVs face +thirdV face = c where (_,_,c) = faceVs face + +originV,wingV,oppV:: TileFace -> Vertex +-- |the origin vertex of a face (firstV) +originV = firstV +-- |wingV returns the vertex not on the join edge of a face +wingV (LD(_,_,c)) = c +wingV (RD(_,b,_)) = b +wingV (LK(_,b,_)) = b +wingV (RK(_,_,c)) = c +-- |oppV returns the vertex at the opposite end of the join edge from the origin of a face +oppV (LD(_,b,_)) = b +oppV (RD(_,_,c)) = c +oppV (LK(_,_,c)) = c +oppV (RK(_,b,_)) = b + +-- |indexV finds the index of a vertex in a face (firstV -> 0, secondV -> 1, thirdV -> 2) +indexV :: Vertex -> TileFace -> Int +indexV v face = case elemIndex v (faceVList face) of + Just i -> i + _ -> error ("indexV: " ++ show v ++ " not found in " ++ show face) + +-- |nextV returns the next vertex in a face going clockwise from v +-- where v must be a vertex of the face +nextV :: Vertex -> TileFace -> Vertex +nextV v face = case indexV v face of + 0 -> secondV face + 1 -> thirdV face + 2 -> firstV face + _ -> error "nextV: index error" +-- |prevV returns the previous vertex in a face (i.e. next going anti-clockwise) from v +-- where v must be a vertex of the face +prevV :: Vertex -> TileFace -> Vertex +prevV v face = case indexV v face of + 0 -> thirdV face + 1 -> firstV face + 2 -> secondV face + _ -> error "prevV: index error" + +-- |isAtV v f asks if a face f has v as a vertex +isAtV:: Vertex -> TileFace -> Bool +isAtV v (LD(a,b,c)) = v==a || v==b || v==c +isAtV v (RD(a,b,c)) = v==a || v==b || v==c +isAtV v (LK(a,b,c)) = v==a || v==b || v==c +isAtV v (RK(a,b,c)) = v==a || v==b || v==c + +-- |hasVIn vs f - asks if face f has an element of vs as a vertex +hasVIn:: [Vertex] -> TileFace -> Bool +hasVIn vs face = not $ null $ faceVList face `intersect` vs + + +{- $Edges +Edges: (a,b) is regarded as a directed edge from a to b. +A list of such pairs will usually be regarded as a list of directed edges. +In the special case that the list is symmetrically closed [(b,a) is in the list whenever (a,b) is in the list] +we will refer to this as an edge list rather than a directed edge list. +-} + + +-- |directed edges (clockwise) round a face. +faceDedges::TileFace -> [Dedge] +faceDedges (LD(a,b,c)) = [(a,b),(b,c),(c,a)] +faceDedges (RD(a,b,c)) = [(a,b),(b,c),(c,a)] +faceDedges (LK(a,b,c)) = [(a,b),(b,c),(c,a)] +faceDedges (RK(a,b,c)) = [(a,b),(b,c),(c,a)] + +-- |Returns the list of all directed edges (clockwise round each) of a list of tile faces. +facesDedges :: [TileFace] -> [Dedge] +facesDedges = concatMap faceDedges + +-- |opposite directed edge. +reverseD:: Dedge -> Dedge +reverseD (a,b) = (b,a) + +{- +-- |firstE, secondE and thirdE are the directed edges of a face counted clockwise from the origin, +firstE,secondE,thirdE:: TileFace -> Dedge +firstE = head . faceDedges +secondE = head . tail . faceDedges +thirdE = head . tail . tail . faceDedges +-} + +joinE, shortE, longE, joinOfTile:: TileFace -> Dedge +-- |the join directed edge of a face in the clockwise direction going round the face (see also joinOfTile). +joinE (LD(a,b,_)) = (a,b) +joinE (RD(a,_,c)) = (c,a) +joinE (LK(a,_,c)) = (c,a) +joinE (RK(a,b,_)) = (a,b) +-- |The short directed edge of a face in the clockwise direction going round the face. +-- This is the non-join short edge for darts. +shortE (LD(_,b,c)) = (b,c) +shortE (RD(_,b,c)) = (b,c) +shortE (LK(_,b,c)) = (b,c) +shortE (RK(_,b,c)) = (b,c) + +-- |The long directed edge of a face in the clockwise direction going round the face. +-- This is the non-join long edge for kites. +longE (LD(a,_,c)) = (c,a) +longE (RD(a,b,_)) = (a,b) +longE (LK(a,b,_)) = (a,b) +longE (RK(a,_,c)) = (c,a) + +-- |The join edge of a face directed from the origin (not clockwise for RD and LK) +joinOfTile face = (originV face, oppV face) + +facePhiEdges, faceNonPhiEdges:: TileFace -> [Dedge] +-- |The phi edges of a face (both directions) +-- which is long edges for darts, and join and long edges for kites +facePhiEdges face@(RD _) = [e, reverseD e] where e = longE face +facePhiEdges face@(LD _) = [e, reverseD e] where e = longE face +facePhiEdges face = [e, reverseD e, j, reverseD j] + where e = longE face + j = joinE face + +-- |The non-phi edges of a face (both directions) +-- which is short edges for kites, and join and short edges for darts. +faceNonPhiEdges face = bothDirOneWay (faceDedges face) \\ facePhiEdges face + +-- |matchingE eselect face is a predicate on tile faces +-- where eselect selects a particular edge type of a face +-- (eselect could be joinE or longE or shortE for example). +-- This is True for face' if face' has an eselect edge matching the (reversed) eselect edge of face. +matchingE :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool +matchingE eselect face = (== reverseD (eselect face)) . eselect + +matchingLongE,matchingShortE,matchingJoinE :: TileFace -> TileFace -> Bool + -- Used in Compose (getDartWingInfo and composedFaceGroups). +-- |check if two TileFaces have opposite directions for their long edge. +matchingLongE = matchingE longE +-- |check if two TileFaces have opposite directions for their short edge. +matchingShortE = matchingE shortE +-- |check if two TileFaces have opposite directions for their join edge. +matchingJoinE = matchingE joinE + +-- |hasDedge f e returns True if directed edge e is one of the directed edges of face f +hasDedge :: TileFace -> Dedge -> Bool +hasDedge f e = e `elem` faceDedges f + +-- |hasDedgeIn f es - is True if face f has a directed edge in the list of directed edges es. +hasDedgeIn :: TileFace -> [Dedge] -> Bool +hasDedgeIn face es = not $ null $ es `intersect` faceDedges face + +-- |facesEdges returns a list of all the edges of a list of TileFaces (both directions of each edge). +facesEdges :: [TileFace] -> [Dedge] +facesEdges = bothDir . facesDedges + +-- |bothDir adds missing reverse directed edges to a list of directed edges +-- to complete edges (Result is a complete edge list) +-- It assumes no duplicates in argument. +bothDir:: [Dedge] -> [Dedge] +bothDir es = missingRevs es ++ es + +-- |bothDirOneWay adds all the reverse directed edges to a list of directed edges +-- without checking for duplicates. +-- Should be used on lists with single directions only. +-- If the argument may contain reverse directions, use bothDir to avoid duplicates. +bothDirOneWay:: [Dedge] -> [Dedge] +bothDirOneWay [] = [] +bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es + +-- |facesBoundary fcs are missing reverse directed edges in facesDedges fcs (the result contains single directions only) +-- Direction is such that a face is on LHS and exterior is on RHS of each boundary directed edge. +facesBoundary :: [TileFace] -> [Dedge] +facesBoundary fcs = missingRevs $ facesDedges fcs + + +-- | efficiently finds missing reverse directions from a list of directed edges (using IntMap) +missingRevs:: [Dedge] -> [Dedge] +missingRevs es = revUnmatched es where + vmap = VMap.fromListWith (++) $ map singleton es + singleton (a,b) = (a,[b]) + seekR (a,b) = case VMap.lookup b vmap of + Nothing -> False + Just vs -> a `elem` vs + + revUnmatched [] = [] + revUnmatched (e@(a,b):more) | seekR e = revUnmatched more + | otherwise = (b,a):revUnmatched more + + +-- |two tile faces are edge neighbours +edgeNb::TileFace -> TileFace -> Bool +edgeNb face = any (`elem` edges) . faceDedges where + edges = fmap reverseD (faceDedges face) + + + +{-|vertexFacesMap vs fcs - +For list of vertices vs and list of faces fcs, +create an IntMap from each vertex in vs to a list of those faces in fcs that are at that vertex. +-} +vertexFacesMap:: [Vertex] -> [TileFace] -> VertexMap [TileFace] +vertexFacesMap vs = foldl' insertf startVF where + startVF = VMap.fromList $ fmap (,[]) vs + insertf vfmap f = foldr (VMap.alter addf) vfmap (faceVList f) + where addf Nothing = Nothing + addf (Just fs) = Just (f:fs) + +-- | dedgesFacesMap des fcs - Produces an edge-face map. Each directed edge in des is associated with +-- a unique TileFace in fcs that has that directed edge (if there is one). +-- It will report an error if more than one TileFace in fcs has the same directed edge in des. +-- If the directed edges and faces are all those from a Tgraph, graphEFMap will be more efficient. +-- dedgesFacesMap is intended for a relatively small subset of directed edges in a Tgraph. +dedgesFacesMap:: [Dedge] -> [TileFace] -> Map.Map Dedge TileFace +dedgesFacesMap des fcs = Map.fromList (assocFaces des) where + vs = fmap fst des `union` fmap snd des + vfMap = vertexFacesMap vs fcs + assocFaces [] = [] + assocFaces (d@(a,b):more) = case (VMap.lookup a vfMap, VMap.lookup b vfMap) of + (Just fcs1, Just fcs2) -> case filter (`hasDedge` d) $ fcs1 `intersect` fcs2 of + [face] -> (d,face):assocFaces more + [] -> assocFaces more + _ -> error $ "dedgesFacesMap: more than one Tileface has the same directed edge: " + ++ show d ++ "\n" + _ -> assocFaces more + + +-- |Build a Map from directed edges to faces (the unique face containing the directed edge) +buildEFMap:: [TileFace] -> Map.Map Dedge TileFace +buildEFMap = Map.fromList . concatMap assignFace where + assignFace f = fmap (,f) (faceDedges f) +{- +buildEFMap = mconcat . fmap processFace where + processFace face = Map.fromList $ (,face) <$> faceDedges face +-} + +-- | look up a face for an edge in an edge-face map +faceForEdge :: Dedge -> Map.Map Dedge TileFace -> Maybe TileFace +faceForEdge = Map.lookup + +-- |Given a tileface (face) and a map from each directed edge to the tileface containing it (efMap) +-- return the list of edge neighbours of face. +edgeNbs:: TileFace -> Map.Map Dedge TileFace -> [TileFace] +edgeNbs face efMap = mapMaybe getNbr edges where + getNbr e = Map.lookup e efMap + edges = fmap reverseD $ faceDedges face + +-- |For a non-empty list of tile faces +-- find the face with lowest originV (and then lowest oppV). +-- Move this face to the front of the returned list of faces. +-- Used by locateVertices to determine the starting point for location calculation +extractLowestJoin:: [TileFace] -> (TileFace,[TileFace]) +extractLowestJoin fcs + | null fcs = error "extractLowestJoin: applied to empty list of faces" + | otherwise = (face, fcs\\[face]) + where a = minimum (fmap originV fcs) + aFaces = filter ((a==) . originV) fcs + b = minimum (fmap oppV aFaces) + face = case find (((a,b)==) . joinOfTile) aFaces of + Just f -> f + Nothing -> error $ "extractLowestJoin: no face fond at " + ++ show a ++ " with opp vertex at " ++ show b ++ "\n" +-- (face: _) = filter (((a,b)==) . joinOfTile) aFaces + +-- |Return the join edge with lowest origin vertex (and lowest oppV vertex if there is more than one). +-- The resulting edge is always directed from the origin to the opp vertex, i.e (orig,opp). +lowestJoin:: [TileFace] -> Dedge +lowestJoin fcs | null fcs = error "lowestJoin: applied to empty list of faces" +lowestJoin fcs = (a,b) where + a = minimum (fmap originV fcs) + aFaces = filter ((a==) . originV) fcs + b = minimum (fmap oppV aFaces) + +{--------------------- +********************* +VPatch and Conversions +********************* +-----------------------} + +-- |Abbreviation for finite mappings from Vertex to Location (i.e Point) +type VertexLocMap = VMap.IntMap (Point V2 Double) + + +-- |A VPatch has a map from vertices to points along with a list of tile faces. +-- It is an intermediate form between Tgraphs and Diagrams +data VPatch = VPatch {vLocs :: VertexLocMap, vpFaces::[TileFace]} deriving Show + +-- |needed for making VPatch transformable +type instance V VPatch = V2 +-- |needed for making VPatch transformable +type instance N VPatch = Double + + +-- |Make VPatch Transformable. +instance Transformable VPatch where + transform t vp = vp {vLocs = VMap.map (transform t) (vLocs vp)} + + +{-|Convert a Tgraph to a VPatch. +This uses locateVertices to form an intermediate VertexLocMap (mapping of vertices to positions). +This makes the join of the face with lowest origin and lowest oppV align on the positive x axis. +-} +makeVP::Tgraph -> VPatch +makeVP g = VPatch {vLocs = locateVertices fcs, vpFaces = fcs} where fcs = faces g + +-- |Creates a VPatch from a list of tile faces, using the vertex location map from the given VPatch. +-- The vertices in the tile faces should have locations assigned in the given VPatch vertex locations. +-- However THIS IS NOT CHECKED so missing locations for vertices will raise an error when drawing. +-- subVP vp fcs can be used for both subsets of tile faces of vp, +-- and also for larger scale faces which use the same vertex to point assignment (e.g in compositions). +-- The vertex location map is not changed (see also relevantVP and restrictVP). +subVP:: VPatch -> [TileFace] -> VPatch +subVP vp fcs = vp {vpFaces = fcs} + +-- | removes locations for vertices not used in the faces of a VPatch. +-- (Useful when restricting which labels get drawn). +-- relevantVP vp will raise an error if any vertex in the faces of vp is not a key in the location map of vp. +relevantVP :: VPatch -> VPatch +relevantVP vp + | null diffList = vp{vLocs = locVs} + | otherwise = error $ "relevantVP: missing locations for: " ++ + show diffList ++ "\n" + where + vs = facesVSet (vpFaces vp) + source = VMap.keysSet locVs + diffList = IntSet.toList $ IntSet.difference vs source + locVs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) $ vLocs vp + +-- | A combination of subVP and relevantVP. Restricts a vp to a list of faces, removing locations for vertices not in the faces. +-- (Useful when restricting which labels get drawn) +-- restrictVP vp fcs will raise an error if any vertex in fcs is not a key in the location map of vp. +restrictVP:: VPatch -> [TileFace] -> VPatch +restrictVP vp fcs = relevantVP (subVP vp fcs) + +-- |Recover a Tgraph from a VPatch by dropping the vertex positions and checking Tgraph properties. +graphFromVP:: VPatch -> Tgraph +graphFromVP = checkedTgraph . vpFaces + +-- |remove a list of faces from a VPatch +removeFacesVP :: VPatch -> [TileFace] -> VPatch +removeFacesVP vp fcs = restrictVP vp (vpFaces vp \\ fcs) + +-- |make a new VPatch with a list of selected faces from a VPatch. +-- This will ignore any faces that are not in the given VPatch. +selectFacesVP:: VPatch -> [TileFace] -> VPatch +selectFacesVP vp fcs = restrictVP vp (fcs `intersect` vpFaces vp) + +-- |find the location of a single vertex in a VPatch +findLoc :: Vertex -> VPatch -> Maybe (Point V2 Double) +findLoc v = VMap.lookup v . vLocs + + + + +-- |VPatches are drawable +instance Drawable VPatch where + drawWith pd vp = drawWith pd (dropLabels vp) + +-- |converts a VPatch to a Patch, removing vertex information and converting faces to Located Pieces. +-- (Usage can be confined to Drawable VPatch instance and DrawableLabelled VPatch instance.) +dropLabels :: VPatch -> Patch +dropLabels vp = fmap convert (vpFaces vp) where + locations = vLocs vp + convert face = case (VMap.lookup (originV face) locations , VMap.lookup (oppV face) locations) of + (Just p, Just p') -> fmap (const (p' .-. p)) face `at` p -- using HalfTile functor fmap + _ -> error $ "dropLabels: Vertex location not found for some vertices:\n " + ++ show (faceVList face \\ VMap.keys locations) ++ "\n" + +-- |Tgraphs are Drawable +instance Drawable Tgraph where + drawWith pd = drawWith pd . makeVP + +-- | A class for things that can be drawn with labels when given a colour and a measure (size) for the label and a +-- a draw function (for Patches). +-- So labelColourSize c m modifies a Patch drawing function to add labels (of colour c and size measure m). +-- Measures are defined in Diagrams. In particular: tiny, verySmall, small, normal, large, veryLarge, huge. +class DrawableLabelled a where +-- | When a specific Backend B is in scope, +-- +-- labelColourSize :: DrawableLabelled a => Colour Double -> Measure Double -> (Patch -> Diagram B) -> a -> Diagram B + labelColourSize :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => + Colour Double -> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b +-- The argument type of the draw function is Patch rather than VPatch, which prevents labelling twice. + + +-- | VPatches can be drawn with labels +instance DrawableLabelled VPatch where + labelColourSize c m d vp = drawLabels (vLocs vp) <> d (dropLabels vp) where + drawLabels vpMap = position $ drawlabel <$> VMap.toList vpMap + drawlabel(v,p) = (p, baselineText (show v) # fontSize m # fc c) + +-- | Tgraphs can be drawn with labels +instance DrawableLabelled Tgraph where + labelColourSize c r d = labelColourSize c r d . makeVP + +-- | Default Version of labelColourSize with colour red. Example usage: labelSize tiny draw a , labelSize normal drawj a +-- +-- When a specific Backend B is in scope, labelSize :: DrawableLabelled a => Measure Double -> (Patch -> Diagram B) -> a -> Diagram B +labelSize :: (Renderable (Path V2 Double) b, Renderable (Text Double) b, DrawableLabelled a) => + Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b +labelSize = labelColourSize red + +-- | Default Version of labelColourSize using red and small (rather than normal label size). Example usage: labelled draw a , labelled drawj a +-- +-- When a specific Backend B is in scope, labelled :: DrawableLabelled a => (Patch -> Diagram B) -> a -> Diagram B +labelled :: (Renderable (Path V2 Double) b, Renderable (Text Double) b, DrawableLabelled a) => + (Patch -> Diagram2D b) -> a -> Diagram2D b +labelled = labelColourSize red small --(normalized 0.023) + +-- |rotateBefore vfun a g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun. +-- Tgraphs need to be rotated after a VPatch is calculated but before any labelled drawing. +-- E.g. rotateBefore (labelled draw) angle graph. +rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a +rotateBefore vfun angle = vfun . rotate angle . makeVP + +-- |center a VPatch on a particular vertex. (Raises an error if the vertex is not in the VPatch vertices) +centerOn :: Vertex -> VPatch -> VPatch +centerOn a vp = + case findLoc a vp of + Just loca -> translate (origin .-. loca) vp + _ -> error $ "centerOn: vertex not found (Vertex " ++ show a ++ ")\n" + +-- |alignXaxis takes a vertex pair (a,b) and a VPatch vp +-- for centering vp on a and rotating the result so that b is on the positive X axis. +-- (Raises an error if either a or b are not in the VPatch vertices) +alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch +alignXaxis (a,b) vp = rotate angle newvp + where newvp = centerOn a vp + angle = signedAngleBetweenDirs (direction unitX) (direction (locb .-. origin)) + locb = case findLoc b newvp of + Just l -> l + Nothing -> error $ "alignXaxis: second alignment vertex not found (Vertex " ++ show b ++ ")\n" + +-- |alignments takes a list of vertex pairs for respective alignmants of VPatches in the second list. +-- For a pair (a,b) the corresponding VPatch is centered on a then b is aligned along the positive x axis. +-- The vertex pair list can be shorter than the list of VPatch - the remaining VPatch are left as they are. +-- (Raises an error if either vertex in a pair is not in the corresponding VPatch vertices) +alignments :: [(Vertex, Vertex)] -> [VPatch] -> [VPatch] +alignments [] vps = vps +alignments _ [] = error "alignments: Too many alignment pairs.\n" -- non-null list of pairs +alignments ((a,b):more) (vp:vps) = alignXaxis (a,b) vp : alignments more vps + +-- |alignAll (a,b) vpList +-- provided both vertices a and b exist in each VPatch in vpList, the VPatch are all aligned +-- centred on a, with b on the positive x axis. +-- An error is raised if any VPatch does not contain both a and b vertices. +alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch] +alignAll (a,b) = fmap (alignXaxis (a,b)) + +-- |alignBefore vfun (a,b) g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis +-- before applying the VPatch function vfun +-- Will raise an error if either a or b is not a vertex in g. +-- Tgraphs need to be aligned after a VPatch is calculated but before any labelled drawing. +-- E.g. alignBefore (labelled draw) (a,b) g +alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a +alignBefore vfun vs = vfun . alignXaxis vs . makeVP + +-- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligned on the x-axis. +-- Will raise an error if either a or b is not a vertex in g. +makeAlignedVP:: (Vertex,Vertex) -> Tgraph -> VPatch +makeAlignedVP = alignBefore id + + +-- |produce a diagram of a list of edges (given a VPatch) +-- Will raise an error if any vertex of the edges is not a key in the vertex to location mapping of the VPatch. +-- +-- When a specific Backend B is in scope, drawEdgesVP :: VPatch -> [Dedge] -> Diagram B +drawEdgesVP :: Renderable (Path V2 Double) b => + VPatch -> [Dedge] -> Diagram2D b +drawEdgesVP = drawEdges . vLocs --foldMap (drawEdgeVP vp) + +-- |produce a diagram of a single edge (given a VPatch) +-- Will raise an error if either vertex of the edge is not a key in the vertex to location mapping of the VPatch. +-- +-- When a specific Backend B is in scope, drawEdgeVP :: VPatch -> Dedge -> Diagram B +drawEdgeVP:: Renderable (Path V2 Double) b => + VPatch -> Dedge -> Diagram2D b +drawEdgeVP = drawEdge . vLocs + +-- |produce a diagram of a list of edges (given a mapping of vertices to locations) +-- Will raise an error if any vertex of the edges is not a key in the mapping. +-- +-- When a specific Backend B is in scope, drawEdges :: VertexLocMap -> [Dedge] -> Diagram B +drawEdges :: Renderable (Path V2 Double) b => + VertexLocMap -> [Dedge] -> Diagram2D b +drawEdges = foldMap . drawEdge + +-- |produce a diagram of a single edge (given a mapping of vertices to locations). +-- Will raise an error if either vertex of the edge is not a key in the mapping. +-- +-- When a specific Backend B is in scope, drawEdge :: VertexLocMap -> Dedge -> Diagram B +drawEdge :: Renderable (Path V2 Double) b => + VertexLocMap -> Dedge -> Diagram2D b +drawEdge vpMap (a,b) = case (VMap.lookup a vpMap, VMap.lookup b vpMap) of + (Just pa, Just pb) -> pa ~~ pb + _ -> error $ "drawEdge: location not found for one or both vertices "++ show(a,b) ++ "\n" + + + +{-| locateVertices: processes a list of faces to associate points for each vertex. +It aligns the lowest numbered join of the faces on the x-axis, and returns a vertex-to-point Map. +It will raise an error if faces are not connected. +If faces have crossing boundaries (i.e not locally tile-connected), this could raise an error +or a result with touching vertices (i.e. more than one vertex with the same location). +-} +locateVertices:: [TileFace] -> VertexLocMap +-- This version is made more efficient by calculating an edge to face map +-- and also using Sets for 2nd arg of fastAddVPoints. +locateVertices [] = VMap.empty +locateVertices fcs = fastAddVPoints [joinFace] (Set.fromList more) (axisJoin joinFace) where + (joinFace,more) = extractLowestJoin fcs + efMap = buildEFMap fcs -- map from Dedge to TileFace + +{- fastAddVPoints readyfaces fcOther vpMap. +The first argument list of faces (readyfaces) contains the ones being processed next in order where +each will have at least two known vertex locations in vpMap. +The second argument Set of faces (fcOther) are faces that have not yet been added +and may not yet have known vertex locations. +The third argument is the mapping of vertices to points. +-} + fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap + fastAddVPoints [] fcOther _ = error $ "locateVertices (fastAddVPoints): Faces not tile-connected: " + ++ show fcOther ++ "/n" + fastAddVPoints (face:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where + nbs = filter (`Set.member` fcOther) (edgeNbs face efMap) + fcOther' = foldl' (flip Set.delete) fcOther nbs +-- fcOther' = foldr Set.delete fcOther nbs + vpMap' = addVPoint face vpMap + +-- |Given a tileface and a vertex to location map which gives locations for at least 2 of the tileface vertices +-- this returns a new map by adding a location for the third vertex (when missing) or the same map when not missing. +-- It will raise an error if there are fewer than 2 tileface vertices with a location in the map +-- (indicating a non tile-connected face). +-- It is possible that a newly added location is already in the range of the map (creating a touching vertices), +-- so this needs to be checked for. +addVPoint:: TileFace -> VertexLocMap -> VertexLocMap +addVPoint face vpMap = + case thirdVertexLoc face vpMap of + Just (v,p) -> VMap.insert v p vpMap + Nothing -> vpMap + +-- |axisJoin face +-- initialises a vertex to point mapping with locations for the join edge vertices of face +-- with originV face at the origin and aligned along the x axis with unit length for a half dart +-- and length phi for a half kite. (Used to initialise locateVertices) +axisJoin::TileFace -> VertexLocMap +axisJoin face = + VMap.insert (originV face) origin $ VMap.insert (oppV face) (p2(x,0)) VMap.empty where + x = if isDart face then 1 else phi + +-- |lookup 3 vertex locations in a vertex to point map. +find3Locs::(Vertex,Vertex,Vertex) -> VertexLocMap + -> (Maybe (Point V2 Double),Maybe (Point V2 Double),Maybe (Point V2 Double)) +find3Locs (v1,v2,v3) vpMap = (VMap.lookup v1 vpMap, VMap.lookup v2 vpMap, VMap.lookup v3 vpMap) + +{-| thirdVertexLoc face vpMap, where face is a tileface and vpMap associates points with vertices (positions). +It looks up all 3 vertices of face in vpMap hoping to find at least 2 of them, it then returns Just pr +where pr associates a new location with the third vertex. +If all 3 are found, returns Nothing. +If none or one found this is an error (a non tile-connected face). + +New Version: This assumes all edge lengths are 1 or phi. +It now uses signorm to produce vectors of length 1 rather than rely on relative lengths. +(Requires ttangle and phi from TileLib). +-} +thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double) +thirdVertexLoc face@(LD _) vpMap = case find3Locs (faceVs face) vpMap of + (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1)) + (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = signorm (rotate (ttangle 7) (loc3 .-. loc2)) + (Just loc1, Nothing, Just loc3) -> Just (oppV face, loc1 .+^ v) where v = signorm (rotate (ttangle 1) (loc3 .-. loc1)) + (Just _ , Just _ , Just _) -> Nothing + _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n" + +thirdVertexLoc face@(RD _) vpMap = case find3Locs (faceVs face) vpMap of + (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v) where v = signorm (rotate (ttangle 9) (loc2 .-. loc1)) + (Nothing, Just loc2, Just loc3) -> Just (originV face, loc3 .+^ v) where v = signorm (rotate (ttangle 3) (loc2 .-. loc3)) + (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1)) + (Just _ , Just _ , Just _) -> Nothing + _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n" + +thirdVertexLoc face@(LK _) vpMap = case find3Locs (faceVs face) vpMap of + (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1)) + (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2)) + (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1)) + (Just _ , Just _ , Just _) -> Nothing + _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n" + +thirdVertexLoc face@(RK _) vpMap = case find3Locs (faceVs face) vpMap of + (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1)) + (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2)) + (Just loc1, Nothing, Just loc3) -> Just (oppV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1)) + (Just _ , Just _ , Just _) -> Nothing + _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n" + + + +-- * Touching Vertices + + +{-| +touchingVertices checks that no vertices are too close to each other using locateVertices. +If vertices are too close that indicates we may have different vertex numbers at the same location +(the touching vertex problem). +It returns pairs of vertices that are too close (higher number first in each pair) +An empty list is returned if there are no touching vertices. +Complexity has order of the square of the number of vertices. + +This is used in makeTgraph and fullUnion (via correctTouchingVertices). +-} +touchingVertices:: [TileFace] -> [(Vertex,Vertex)] +touchingVertices fcs = check vpAssoc where + vpAssoc = VMap.assocs $ locateVertices fcs -- assocs puts in key order so that check returns (higher,lower) pairs + check [] = [] + check ((v,p):more) = [(v1,v) | v1 <- nearv ] ++ check (filter ((`notElem` nearv).fst) more) + where nearv = [v1 | (v1,p1) <- more, touching p p1 ] +-- check ((v,p):more) = [(v1,v) | (v1,p1) <- more, touching p p1 ] ++ check more +-- does not correctly deal with 3 or more vertices touching at the same point + +{-|touching checks if two points are considered close. +Close means the square of the distance between them is less than a certain number (currently 0.1) so they cannot be +vertex locations for 2 different vertices in a VPatch using unit scale for short edges. +It is used in touchingVertices and touchingVerticesGen). +-} +touching :: Point V2 Double -> Point V2 Double -> Bool +touching p p1 = quadrance (p .-. p1) < 0.1 -- quadrance is square of length of a vector +-- 0.1 represents a distance of about 0.316 units (= sqrt 0.1) + + +{-* Generalised Touching Vertices +-} + +{-| +touchingVerticesGen generalises touchingVertices to allow for multiple faces sharing a directed edge. +This can arise when applied to the union of faces from 2 Tgraphs which might clash in places. +It is used in the calculation of commonFaces. +-} +touchingVerticesGen:: [TileFace] -> [(Vertex,Vertex)] +touchingVerticesGen fcs = check vpAssoc where + vpAssoc = VMap.assocs $ locateVerticesGen fcs -- assocs puts in key order so that check returns (higher,lower) pairs + check [] = [] + check ((v,p):more) = [(v1,v) | v1 <- nearv ] ++ check (filter ((`notElem` nearv).fst) more) + where nearv = [v1 | (v1,p1) <- more, touching p p1 ] + +{-| locateVerticesGen generalises locateVertices to allow for multiple faces sharing an edge. +This can arise when applied to the union of faces from 2 Tgraphs (e.g. in commonFaces) +-} +locateVerticesGen:: [TileFace] -> VertexLocMap +locateVerticesGen [] = VMap.empty +locateVerticesGen fcs = fastAddVPointsGen [face] (Set.fromList more) (axisJoin face) where + (face,more) = extractLowestJoin fcs + efMapGen = buildEFMapGen fcs -- map from Dedge to [TileFace] + +{- fastAddVPointsGen readyfaces fcOther vpMap. +The first argument list of faces (readyfaces) contains the ones being processed next in order where +each will have at least two known vertex locations in vpMap. +The second argument Set of faces (fcOther) are faces that have not yet been added +and may not yet have known vertex locations. +The third argument is the mapping of vertices to points. +-} + fastAddVPointsGen [] fcOther vpMap | Set.null fcOther = vpMap + fastAddVPointsGen [] fcOther _ = error $ "fastAddVPointsGen: Faces not tile-connected " ++ show fcOther ++ "\n" + fastAddVPointsGen (f:fs) fcOther vpMap = fastAddVPointsGen (fs++nbs) fcOther' vpMap' where + nbs = filter (`Set.member` fcOther) (edgeNbsGen f) +-- nbs = filter (`Set.member` fcOther) (edgeNbsGen efMapGen fc) + fcOther' = foldr Set.delete fcOther nbs + vpMap' = addVPoint f vpMap +-- Generalises buildEFMap by allowing for multiple faces on a directed edge. +-- buildEFMapGen:: [TileFace] -> Map.Map Dedge [TileFace] + buildEFMapGen = Map.fromListWith (++) . concatMap processFace + processFace f = (,[f]) <$> faceDedges f + +-- Generalised edgeNbs allowing for multiple faces on a directed edge. +-- edgeNbsGen:: Map.Map Dedge [TileFace] -> TileFace -> [TileFace] + edgeNbsGen f = concat $ mapMaybe getNbrs edges where + getNbrs e = Map.lookup e efMapGen + edges = fmap reverseD (faceDedges f) +{- + edgeNbsGen efMapGen f = concat $ mapMaybe getNbrs edges where + getNbrs e = Map.lookup e efMapGen + edges = fmap reverseD (faceDedges f) +-} + + + + + diff --git a/src/Tgraph/Relabelling.hs b/src/Tgraph/Relabelling.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Relabelling.hs @@ -0,0 +1,406 @@ +{-| +Module : Tgraph.Relabelling +Description : Guided union and commonFaces using relabelling operations +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This module includes relabelling functions for Tgraphs whose main purpose is +to implement a guided union of Tgraphs (fullUnion and tryFullUnion) +and also a commonFaces operation (a kind of intersection which need not be a Tgraph) +and a guided equality check (sameGraph). +-} +module Tgraph.Relabelling + ( -- * Assisted Union (and matching) operations + fullUnion + , tryFullUnion + -- * commonFaces (Assisted Intersection) and sameGraph (Assisted Equivalence) + , commonFaces + , sameGraph + -- * Creating Relabellings + , Relabelling(..) + , newRelabelling +-- , relabellingFrom +-- , relabellingTo +-- , relabelUnion + -- * Relabellings and matching + , relabelToMatch + , tryRelabelToMatch +-- , tryRelabelFromFaces +-- , tryGrowRelabel + , relabelToMatchIgnore +-- , relabelFromFacesIgnore +-- , growRelabelIgnore + -- * Using Relabellings + , relabelGraph + , checkRelabelGraph + , relabelFace + , relabelV +-- , relabelAvoid + , prepareFixAvoid + , relabelContig + -- * Renumbering (not necessarily 1-1) + , renumberFaces +-- , tryMatchFace +-- , twoVMatch +-- , matchFaceIgnore +-- , differing + ) where + + +import Data.List (intersect, (\\), union,find,partition,nub) +import qualified Data.IntMap.Strict as VMap (IntMap, findWithDefault, fromList, fromAscList, union) +import qualified Data.IntSet as IntSet (fromList,intersection,findMax,elems,(\\),null,member) + +import Tgraph.Prelude +-- import Tgraph.Convert (touchingVertices, touchingVerticesGen) -- used for fullUnion and commonFaces + + +{-| fullUnion (g1,e1) (g2,e2) will try to create the union of g1 and g2. That is, it will try to combine the faces of g1 + and (possibly relabelled) faces of g2 as a Tgraph. It does this + by first matching the respective edges e1 and e2 and relabelling g2 to match g1 on a tile-connected region containing e1. + It will raise an error if there is a mismatch. + If succesfull it then uses geometry of tiles (vertex locations) to correct for multiple overlapping regions + of tiles in g1 and relabelled g2 by a further relabelling of any touching vertices. + The resulting union of faces requires an expensive tryTgraphProps if touching vertices were found. + However the check is not needed when there are no touching vertices (i.e. a single tile-connected overlap). +-} +fullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph +fullUnion (g1,e1) (g2,e2) = runTry $ tryFullUnion (g1,e1) (g2,e2) + +{-| tryFullUnion (g1,e1) (g2,e2) will try to create the union of g1 and g2. That is, it will try to combine the faces of g1 + and (possibly relabelled) faces of g2 as a Tgraph. It does this + by first matching the respective edges e1 and e2 and relabelling g2 to match g1 on a tile-connected region containing e1. + It returns Left lines if there is a mismatch (where lines explains the problem). + If succesfull it then uses geometry of tiles (vertex locations) to correct for multiple overlapping regions + of tiles in g1 and relabelled g2 by a further relabelling of any touching vertices. + The resulting union of faces requires an expensive tryTgraphProps if any touching vertices were found, + and will return Left ... if this fails and Right t otherwise, where t is a Tgraph + containing the union of faces. + The check is not used when there are no touching vertices (i.e. a single tile-connected overlap). +-} +tryFullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph +tryFullUnion (g1,e1) (g2,e2) = onFail "tryFullUnion:\n" $ + do g3 <- tryRelabelToMatch (g1,e1) (g2,e2) + let fcs = faces g1 `union` faces g3 + touchVs = touchingVertices fcs + if null touchVs + then return $ makeUncheckedTgraph fcs -- no properties check needed! + else let vertg1 = vertexSet g1 + correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e + newrel = newRelabelling $ fmap correct touchVs + in tryTgraphProps $ nub $ fmap (relabelFace newrel) fcs + + +-- | commonFaces (g1,e1) (g2,e2) relabels g2 to match with g1 (where they match) +-- and returns the common faces as a subset of faces of g1. +-- i.e. with g1 vertex labelling. +-- It requires a face in g1 with directed edge e1 to match a face in g2 with directed edge e2, +-- (apart from the third vertex label) otherwise an error is raised. +-- This uses vertex locations to correct touching vertices in multiply overlapping regions. +-- >>>> touching vertices being 1-1 is sensitive to nearness check of touchingVerticesGen <<<<<<<<< +commonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> [TileFace] +commonFaces (g1,e1) (g2,e2) = faces g1 `intersect` relFaces where + g3 = relabelToMatchIgnore (g1,e1) (g2,e2) + fcs = faces g1 `union` faces g3 + touchVs = touchingVerticesGen fcs -- requires generalised version of touchingVertices + relFaces = fmap (relabelFace $ newRelabelling $ fmap correct touchVs) (faces g3) + vertg1 = vertexSet g1 + correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e + + +-- | sameGraph (g1,e1) (g2,e2) checks to see if g1 and g2 are the same Tgraph after relabelling g2. +-- The relabelling is based on directed edge e2 in g2 matching e1 in g1 (where the direction is clockwise round a face) +-- and uses tryRelabelToMatch. +sameGraph :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Bool +sameGraph (g1,e1) (g2,e2) = length (faces g1) == length (faces g2) && + ifFail False tryResult where + tryResult = do g <- tryRelabelToMatch (g1,e1) (g2,e2) + return (vertexSet g == vertexSet g1) + + +-- |Relabelling is a special case of mappings from vertices to vertices that are not the +-- identity on a finite number of vertices. +-- They are represented by keeping the non identity cases in a finite map. +-- When applied, we assume the identity map for vertices not found in the representation domain +-- (see relabelV). Relabellings must be 1-1 on their representation domain, +-- and redundant identity mappings are removed in the representation. +-- Vertices in the range of a relabelling must be >0. +newtype Relabelling = Relabelling (VMap.IntMap Vertex) + +-- | newRelabelling prs - make a relabelling from a finite list of vertex pairs. +-- The first item in each pair relabels to the second in the pair. +-- The resulting relabelling excludes any identity mappings of vertices. +-- An error is raised if second items of the pairs contain duplicated numbers or a number<1 +newRelabelling :: [(Vertex,Vertex)] -> Relabelling +newRelabelling prs + | wrong (map snd prs) = error $ "newRelabelling: Not 1-1 or Non-positive label in range " ++ show prs + | otherwise = Relabelling $ VMap.fromList $ differing prs + where wrong vs = any (<1) vs || not (null (duplicates vs)) + +-- | relabellingFrom n vs - make a relabelling from finite set of vertices vs. +-- Elements of vs are ordered and relabelled from n upwards (an error is raised if n<1). +-- The resulting relabelling excludes any identity mappings of vertices. +relabellingFrom :: Int -> VertexSet -> Relabelling +relabellingFrom n vs + | n<1 = error $ "relabellingFrom: Label not positive " ++ show n + | otherwise = Relabelling $ VMap.fromAscList $ differing $ zip (IntSet.elems vs) [n..] + +-- | f1 \`relabellingTo\` f2 - creates a relabelling so that +-- if applied to face f1, the vertices will match with face f2 exactly. +-- It does not check that the tile faces have the same form (LK,RK,LD,RD). +relabellingTo :: TileFace -> TileFace -> Relabelling +f1 `relabellingTo` f2 = newRelabelling $ zip (faceVList f1) (faceVList f2) -- f1 relabels to f2 + +-- | Combine relabellings (assumes disjoint representation domains and disjoint representation ranges but +-- no check is made for these). +relabelUnion:: Relabelling -> Relabelling -> Relabelling +relabelUnion (Relabelling r1) (Relabelling r2) = Relabelling $ VMap.union r1 r2 + + +{-|relabelToMatch (g1,e1) (g2,e2) produces a relabelled version of g2 that is +consistent with g1 on a single tile-connected region of overlap. +The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2 +will be identified with e1 by the relabelling of g2. +This produces an error if a mismatch is found anywhere in the overlap. + +CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1. +If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1 +will be tile-connected but may have touching vertices. +This limitation is addressed by fullUnion. +-} +relabelToMatch:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph +relabelToMatch ge1 ge2 = runTry $ tryRelabelToMatch ge1 ge2 + +{-|tryRelabelToMatch (g1,e1) (g2,e2) produces either Right g where g is a relabelled version of g2 that is +consistent with g1 on an overlapping tile-connected region or Left lines if there is a mismatch (lines explaining the problem). +The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2 +will be identified with e1 by the relabelling of g2. + +CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1. +If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1 +will be tile-connected but may have touching vertices. +This limitation is addressed by tryFullUnion. +-} +tryRelabelToMatch :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph +tryRelabelToMatch (g1,(x1,y1)) (g2,(x2,y2)) = onFail "tryRelabelToMatch:\n" $ + do let g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2 + fc2 <- find (`hasDedge` (x2,y2)) (faces g2prepared) + `nothingFail` ("No face found for edge " ++ show (x2,y2)) + maybef <- tryMatchFace (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 + fc1 <- maybef `nothingFail` + ("No matching face found at edge "++show (x1,y1)++ + "\nfor relabelled face " ++ show fc2) + -- assert g2prepared has no labels in common with g1 except possibly those in fc2 + tryRelabelFromFaces (g1,fc1) (g2prepared,fc2) + +{-|tryRelabelFromFaces is an auxiliary function for tryRelabelToMatch. +tryRelabelFromFaces (g1,fc1) (g2,fc2) - fc1 and fc2 should have the same form (RK,LK,RD,LD), +with fc1 a face in g1 and fc2 a face in g2. +g2 must have no vertices in common with g1 except for (possibly) vertices in fc2. +The result is either Right g3 where +g3 is a relabelling of g2 which is consistent with g1 in a single region of overlap containing fc1 if this is possible, or +Left lines if there is a mismatch (lines explaining the problem). +In the successful case fc2 will be relabelled to fc1. + +CAVEAT: Only the single tile-connected region of common overlap (containing fc2) of g2 gets relabelled +to match with g1. +-} +tryRelabelFromFaces :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Try Tgraph +tryRelabelFromFaces (g1,fc1) (g2,fc2) = onFail "tryRelabelFromFaces:\n" $ + do rlab <- tryGrowRelabel g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1) + return $ relabelGraph rlab g2 + +{-|tryGrowRelabel is used by tryRelabelFromFaces to build a relabelling map which can fail, producing Left lines. +In the successful case it produces a Right rlab +where rlab is the required relabelling. +The arguments are: g processing awaiting rlab where +g is the Tgraph being matched against; +processing is a list of faces to be matched next +(each has an edge in common with at least one previously matched face or it is the starting face); +awaiting is a list of faces that have not yet been tried for a match and are not +tile-connected to any faces already matched. +rlab is the relabelling so far. + +The idea is that from a single matched starting face we process faces that share an edge with a +previously matched face. Each face processed should have a match in g (with 2 matching vertices). +If a face is tried but has no such match, it is ignored (it may share some boundary with g, but +for the overlap to be a single tile-connected region, only boundaries with matched tiles are possible +and therefore relabelling will already be done for the boundary). +If a processed face has an edge in common with a face in g it has to match exactly +apart from (possibly) the third vertex label, +otherwise the faces do not match and this +indicates a mismatch on the overlap and Left ... is returned. +-} +tryGrowRelabel:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling +tryGrowRelabel _ [] _ rlab = Right rlab -- awaiting are not tile-connected to overlap region +tryGrowRelabel g (fc:fcs) awaiting rlab = + do maybef <- tryMatchFace (relabelFace rlab fc) g + case maybef of + Nothing -> tryGrowRelabel g fcs awaiting rlab + Just orig -> tryGrowRelabel g (fcs++fcs') awaiting' rlab' + where (fcs', awaiting') = partition (edgeNb fc) awaiting + rlab' = relabelUnion (fc `relabellingTo` orig) rlab + + + +-- |same as relabelToMatch but ignores non-matching faces (except for the initial 2) +-- The initial 2 faces are those on the given edges, and an error is raised if they do not match. +-- This is used by commonFaces +relabelToMatchIgnore :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph +relabelToMatchIgnore (g1,(x1,y1)) (g2,(x2,y2)) = relabelFromFacesIgnore (g1,fc1) (g2prepared,fc2) where + g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2 + fc2 = case find (`hasDedge` (x2,y2)) (faces g2prepared) of + Nothing -> error $ "No face found for edge " ++ show (x2,y2) + Just f -> f + fc1 = case matchFaceIgnore (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 of + Nothing -> error $ "No matching face found at edge "++show (x1,y1)++ + "\nfor relabelled face " ++ show fc2 + Just f -> f + + +{-| relabelFromFacesIgnore is an auxiliary function for relabelToMatchIgnore. +It is similar to tryRelabelFromFaces except that it uses growRelabelIgnore and matchFaceIgnore +which ignores non-matching faces rather than failing. It thus returns a definite relabelled Tgraph. +tryRelabelFromFaces (g1,fc1) (g2,fc2) - fc1 and fc2 should have the same form (RK,LK,RD,LD), +with fc1 a face in g1 and fc2 a face in g2. +g2 must have no vertices in common with g1 except for (possibly) vertices in fc2. +The result is g3 where +g3 is a relabelling of g2 which is consistent with g1 in a common single region of overlap containing fc1. + +CAVEAT: Only the single tile-connected region of common overlap (containing fc2) of g2 gets relabelled +to match with g1. +-} +relabelFromFacesIgnore :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Tgraph +relabelFromFacesIgnore (g1,fc1) (g2,fc2) = relabelGraph rlab g2 where + rlab = growRelabelIgnore g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1) + +-- |growRelabelIgnore is similar to tryGrowRelabel except that it uses matchFaceIgnore (instead of tryMatchFace) +-- which ignores non-matching faces rather than failing. It thus returns a definite Relabelling. +growRelabelIgnore:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling +growRelabelIgnore _ [] _ rlab = rlab -- awaiting are not tile-connected to overlap region +growRelabelIgnore g (fc:fcs) awaiting rlab = + case matchFaceIgnore (relabelFace rlab fc) g of + Nothing -> growRelabelIgnore g fcs awaiting rlab + Just orig -> growRelabelIgnore g (fcs++fcs') awaiting' rlab' + where (fcs', awaiting') = partition (edgeNb fc) awaiting + rlab' = relabelUnion (fc `relabellingTo` orig) rlab + + +-- |relabelGraph rlab g - uses a Relabelling rlab to change vertices in a Tgraph g. +-- Caveat: This should only be used when it is known that: +-- rlab is 1-1 on its (representation) domain, and +-- the vertices of g are disjoint from those vertices that are in the representation range +-- but which are not in the representation domain of rlab. +-- This ensures rlab (extended with the identity) remains 1-1 on vertices in g, +-- so that the resulting Tgraph does not need an expensive check for Tgraph properties. +-- (See also checkRelabelGraph) +relabelGraph:: Relabelling -> Tgraph -> Tgraph +relabelGraph rlab g = makeUncheckedTgraph newFaces where + newFaces = fmap (relabelFace rlab) (faces g) + +-- |checkRelabelGraph uses a relabelling map to change vertices in a Tgraph, +-- then checks that the result is a valid Tgraph. (see also relabelGraph) +checkRelabelGraph:: Relabelling -> Tgraph -> Tgraph +checkRelabelGraph rlab g = checkedTgraph newFaces where + newFaces = fmap (relabelFace rlab) (faces g) + +-- |Uses a relabelling to relabel the three vertices of a face. +-- Any vertex not in the domain of the mapping is left unchanged. +-- The mapping should be 1-1 on the 3 vertices to avoid creating a self loop edge. +relabelFace:: Relabelling -> TileFace -> TileFace +relabelFace rlab = fmap (all3 (relabelV rlab)) where -- fmap of HalfTile Functor + all3 f (a,b,c) = (f a,f b,f c) + +-- |relabelV rlab v - uses relabelling rlab to find a replacement for v (leaves as v if none found). +-- I.e relabelV turns a Relabelling into a total function using identity +-- for undefined cases in the Relabelling representation. +relabelV:: Relabelling -> Vertex -> Vertex +relabelV (Relabelling r) v = VMap.findWithDefault v v r + +-- |relabelAvoid avoid g - produces a new Tgraph from g by relabelling. +-- Any vertex in g that is in the set avoid will be changed to a new vertex that is +-- neither in g nor in the set avoid. Vertices in g that are not in avoid will remain the same. +relabelAvoid :: VertexSet -> Tgraph -> Tgraph +relabelAvoid avoid g = relabelGraph rlab g where + gverts = vertexSet g + avoidMax = if IntSet.null avoid then 0 else IntSet.findMax avoid + vertsToChange = gverts `IntSet.intersection` avoid + rlab = relabellingFrom (1+ max (maxV g) avoidMax) vertsToChange + -- assert: rlab is 1-1 on the vertices of g + -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does) + -- assert: the relabelled Tgraph does not have vertices in the set avoid + + +{-|prepareFixAvoid fix avoid g - produces a new Tgraph from g by relabelling. + Any vertex in g that is in the set avoid but not in the list fix will be changed to a new vertex that is + neither in g nor in the set (avoid with fix removed). + All other vertices of g (including those in fix) will remain the same. + Usage: This is used to prepare a graph by avoiding accidental label clashes with the avoid set + (usually vertices of another graph). + However we fix a list of vertices which we intend to control in a subsequent relabelling. + (this is usually a pair of vertices from a directed edge that will get a specific subsequent relabelling). +Note: If any element of the list fix is not a vertex in g, it could end up in the relabelled Tgraph. +-} +prepareFixAvoid :: [Vertex] -> VertexSet -> Tgraph -> Tgraph +prepareFixAvoid fix avoid = relabelAvoid (avoid IntSet.\\ IntSet.fromList fix) + -- assert: the relabelled Tgraph satisfies Tgraph properties (if the argument Tgraph does) + -- assert: the relabelled Tgraph does not have vertices in the set (avoid\\fix) + +-- |Relabel all vertices in a Tgraph using new labels 1..n (where n is the number of vertices). +relabelContig :: Tgraph -> Tgraph +relabelContig g = relabelGraph rlab g where + rlab = relabellingFrom 1 (vertexSet g) + -- assert: rlab is 1-1 on the vertices of g + -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does) + + +-- |renumberFaces allows for a non 1-1 relabelling represented by a list of pairs. +-- It is used only for tryCorrectTouchingVs in Tgraphs which then checks the result +renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace] +renumberFaces prs = fmap renumberFace where + mapping = VMap.fromList $ differing prs + renumberFace = fmap (all3 renumber) + all3 f (a,b,c) = (f a,f b,f c) + renumber v = VMap.findWithDefault v v mapping + + +{-| +tryMatchFace f g - looks for a face in g that corresponds to f (sharing a directed edge), +If the corresponding face does not match properly (with twoVMatch) this stops the +matching process returning Left ... to indicate a failed match. +Otherwise it returns either Right (Just f) where f is the matched face or +Right Nothing if there is no corresponding face. +-} +tryMatchFace:: TileFace -> Tgraph -> Try (Maybe TileFace) +tryMatchFace face g = onFail "tryMatchFace:\n" $ + case find (`hasDedgeIn` faceDedges face) (faces g) of + Nothing -> Right Nothing + Just corresp -> if twoVMatch corresp face + then Right $ Just corresp + else Left $ "Found non matching faces " ++ show (corresp, face) ++ "\n" + +-- |twoVMatch f1 f2 is True if the two tilefaces are the same except +-- for a single vertex label possibly not matching. +twoVMatch:: TileFace -> TileFace -> Bool +twoVMatch f1 f2 = isMatched f1 f2 && + if firstV f1 == firstV f2 + then secondV f1 == secondV f2 || thirdV f1 == thirdV f2 + else secondV f1 == secondV f2 && thirdV f1 == thirdV f2 + +{-|A version of tryMatchFace that just ignores mismatches. +matchFaceIgnore f g - looks for a face in g that corresponds to f (sharing a directed edge), +If there is a corresponding face f' which matches label and corresponding directed edge then Just f' is returned +Otherwise Nothing is returned. (Thus ignoring a clash) +-} +matchFaceIgnore:: TileFace -> Tgraph -> Maybe TileFace +matchFaceIgnore face g = case tryMatchFace face g of + Right mf -> mf + Left _ -> Nothing + + +-- |selects only non-matching pairs from a list +differing :: Eq a => [(a,a)] -> [(a,a)] +differing = filter (\(a,b) -> a/=b) + diff --git a/src/Tgraph/Try.hs b/src/Tgraph/Try.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Try.hs @@ -0,0 +1,88 @@ +{-| +Module : Tgraph.Try +Description : Result types for partial functions +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +Try is a synonym for Either String, which is used for results of partial operations +which return either Right something when defined or Left string when there is a problem +(where string is a failure report). +This is to allow computation to continue in failure cases without necessarily raising an error. +This module contains functions associated with Try results. +-} + +module Tgraph.Try + ( -- * Try - result types with failure reporting (for partial operations). + Try + , onFail + , nothingFail + , runTry + , ifFail + , isFail + , concatFails + , ignoreFails + , atLeastOne + , noFails + ) where + +import Data.Either(fromRight, lefts, rights, isLeft) + + +-- | Try is a synonym for Either String. Used for results of partial functions +-- which return either Right something when defined or Left string when there is a problem +-- where string is a failure report. +-- Note: Either String (and hence Try) is a monad, and this is used frequently for combining partial operations. +type Try a = Either String a + +-- | onFail s exp - inserts s at the front of failure report if exp fails with Left report +onFail:: String -> Try a -> Try a +onFail s = either (Left . (s++)) Right + +-- | Converts a Maybe Result into a Try result by treating Nothing as a failure +-- (the string s is the failure report on failure). +-- Usually used as infix (exp `nothingFail` s) +nothingFail :: Maybe b -> String -> Try b +nothingFail a s = maybe (Left s) Right a + +-- |Extract the (Right) result from a Try, producing an error if the Try is Left s. +-- The failure report is passed to error for an error report. +runTry:: Try a -> a +runTry = either error id + +-- |ifFail a tr - extracts the (Right) result from tr but returning a if tr is Left s. +ifFail :: a -> Try a -> a +ifFail = fromRight + +-- |a try result is a failure if it is a Left +isFail:: Try a -> Bool +isFail = isLeft + +-- |Combines a list of Trys into a single Try with failure overriding success. +-- It concatenates all failure reports if there are any and returns a single Left r. +-- Otherwise it produces Right rs where rs is the list of all (successful) results. +-- In particular, concatFails [] = Right [] +concatFails:: [Try a] -> Try [a] +concatFails ls = case lefts ls of + [] -> Right $ rights ls + other -> Left $ mconcat other -- concatenates strings for single report + +-- |Combines a list of Trys into a list of the successes, ignoring any failures. +-- In particular, ignoreFails [] = [] +ignoreFails:: [Try a] -> [a] +ignoreFails = rights + +-- | atLeastOne rs - returns the list of successful results if there are any, but fails with an error otherwise. +-- The error report will include the concatenated reports from the failures. +atLeastOne:: [Try a] -> [a] +atLeastOne [] = error "atLeastOne: applied to empty list.\n" +atLeastOne results = case ignoreFails results of + [] -> runTry $ onFail "atLeastOne: no successful results.\n" $ concatFails results + other -> other + +-- | noFails rs - returns the list of successes when all cases succeed, but fails with +-- an error and a concatenated failure report of all failures if there is at least one failure. +-- In particular, noFails [] = [] +noFails:: [Try a] -> [a] +noFails = runTry . concatFails diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs new file mode 100644 --- /dev/null +++ b/src/TgraphExamples.hs @@ -0,0 +1,459 @@ + +{-| +Module : TgraphExamples +Description : Examples of tilings represented with Tgraphs and their diagrams +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} + +module TgraphExamples + (-- * Some Layout tools + padBorder + , chunks + , arrangeRowsGap + , arrangeRows + , labelAt + -- * Tgraphs for 7 vertex types + , sunGraph + , jackGraph + , kingGraph + , queenGraph + , aceGraph + , deuceGraph + , starGraph + -- * Further Basic Tgraphs + , kiteGraph + , dartGraph + , fool + , foolD + , foolDminus + , foolDs + , sunDs + , kiteDs + , dartDs + , dartD4 + , sun3Dart + -- * Some Simple Figures + , foolFig + , foolAndFoolD + , figSunD3D2 + -- * Figures for 7 vertex types + , vertexTypesFig + , forceVFigures + -- * Partial Composition figures + , pCompFig1 + , pCompFig2 + , pCompFig + -- * Forced Tgraph figures + , forceFoolDminus + , forceDartD5Fig + , forceKiteD5Fig + , forceSunD5Fig + , forceFig + -- * Removed faces (forcing and composing) + , brokenDart + , badlyBrokenDart + , brokenDartFig + , badlyBrokenDartFig + , removeIncompletesFig + -- * Incorrect Tgraphs + , mistake + , mistake1 + -- * superForce Figure + , superForceFig + , superForceRocketsFig + -- * Tgraphs with Boundary faces + , boundaryFDart4 + , boundaryFDart5 + , boundaryFDart4Fig + , boundaryFDart5Fig + , boundaryGapFDart4 + , boundaryGapFDart5 + , boundaryGap4Fig + , boundaryGap5Fig + -- * Boundary coverings and empires + , boundaryVCoveringFigs + , boundaryECoveringFigs + , kingECoveringFig + , kingVCoveringFig + , kingEmpiresFig + , kingEmpire1Fig + , kingEmpire2Fig + + ) where + +import Diagrams.Prelude +import Diagrams.TwoD.Text (Text) +-- import ChosenBackend (B) +import TileLib +import Tgraphs + + + +-- |used for most diagrams to give border padding +-- +-- When a specific Backend B is in scope, padBorder:: Diagram B -> Diagram B +padBorder :: Diagram2D b -> Diagram2D b +padBorder = pad 1.2 . centerXY + +-- |chunks n l - split a list l into chunks of length n (n>0) +chunks::Int -> [a] -> [[a]] +chunks n + | n < 1 = error "chunks: argument <1\n" + | otherwise = ch where + ch [] = [] + ch as = take n as : ch (drop n as) + +-- |arrangeRowsGap s n diags - arranges diags into n per row, centering each row horizontally, +-- with a seperation gap (horizontally and vertically) of s. +-- The result is a single diagram. +-- +-- When a specific Backend B is in scope, arrangeRowsGap :: Double -> Int -> [Diagram B] -> Diagram B +arrangeRowsGap :: Double -> Int -> [Diagram2D b] -> Diagram2D b +arrangeRowsGap s n = centerY . vsep s . fmap (centerX . hsep s) . chunks n + +-- |arrangeRows n diags - arranges diags into n per row, centering each row horizontally. +-- The result is a single diagram (seperation is 1 unit vertically and horizontally). +-- +-- When a specific Backend B is in scope, arrangeRows :: Int -> [Diagram B] -> Diagram B +arrangeRows :: Int -> [Diagram2D b] -> Diagram2D b +arrangeRows = arrangeRowsGap 1.0 + +-- |add a given label at a given point offset from the centre of the given diagram. +-- +-- When a specific Backend B is in scope, labelAt :: Point V2 Double -> String -> Diagram B -> Diagram B +labelAt :: Renderable (Text Double) b => + Point V2 Double -> String -> Diagram2D b -> Diagram2D b +labelAt p l d = baselineText l # fontSize (output 15) # moveTo p <> d +--labelAt p l d = baselineText l # fontSize (normalized 0.02) # moveTo p <> d + + +fool, foolD, foolDminus:: Tgraph +-- |fool: fool's kite - also called an ace. +fool = makeTgraph [RK (5,2,7),LK (5,6,4),RK (5,4,3),LK (5,3,2),RD (1,2,3),LD (1,3,4)] +-- fool = makeTgraph [ RD (1,2,3), LD (1,3,4), RK (6,2,5), LK (6,3,2), RK (6,4,3), LK (6,7,4)] + +-- |a once decomposed fool (= foolDs!!1) +foolD = decompose fool + +-- |foolDminus: 3 faces removed from foolD - still a valid Tgraph +foolDminus = removeFaces [RD (5,15,13), LD (5,16,15), RK (7,11,2)] foolD +-- foolDminus = removeFaces [RD (6,15,13), LD (6,17,15), RK (5,11,2)] foolD + +-- | an infinite list of decompositions of fool +foolDs :: [Tgraph] +foolDs = decompositions fool + +-- | diagram of just fool. +-- +-- When a specific Backend B is in scope, foolFig :: Diagram B +foolFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +foolFig = padBorder $ labelSize normal drawj fool + +-- |diagram of fool with foolD. +-- +-- When a specific Backend B is in scope, foolAndFoolD :: Diagram B +foolAndFoolD :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +foolAndFoolD = padBorder $ hsep 1 [scale phi $ labelled drawj fool, labelled drawj foolD] + +-- |Tgraph for a sun (sun vertex type) +sunGraph :: Tgraph +sunGraph = makeTgraph + [ RK (1,2,11), LK (1,3,2) + , RK (1,4,3) , LK (1,5,4) + , RK (1,6,5) , LK (1,7,6) + , RK (1,8,7) , LK (1,9,8) + , RK (1,10,9), LK (1,11,10) + ] +-- | an infinite list of decompositions of sunGraph +sunDs :: [Tgraph] +sunDs = decompositions sunGraph + +-- |Figure for a 3 times decomposed sun with a 2 times decomposed sun. +-- +-- When a specific Backend B is in scope, figSunD3D2 :: Diagram B +figSunD3D2 :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +figSunD3D2 = padBorder $ hsep 1 [labelled drawj $ sunDs !! 3, scale phi $ labelled drawj $ sunDs !! 2] + +-- |Tgraph for kite +kiteGraph :: Tgraph +kiteGraph = makeTgraph [ RK (1,2,4), LK (1,3,2)] + +-- | an infinite list of decompositions of a kite +kiteDs :: [Tgraph] +kiteDs = decompositions kiteGraph + +-- |Tgraph for a dart +dartGraph :: Tgraph +dartGraph = makeTgraph [ RD (1,2,3), LD (1,3,4)] + +-- | an infinite list of decompositions of a dart +dartDs :: [Tgraph] +dartDs = decompositions dartGraph + +-- |Tgraph of 4 times decomposed dartGraph (used in several examples) +dartD4 :: Tgraph +dartD4 = dartDs!!4 + + + + +pCompFig1,pCompFig2,pCompFig :: Renderable (Path V2 Double) b => Diagram2D b +-- |diagram showing partial composition of a forced 3 times decomposed dart (with remainder faces in pale green). +-- +-- When a specific Backend B is in scope, pCompFig1 :: Diagram B +pCompFig1 = lw veryThin $ hsep 5 $ rotations [1,1] [draw fd3, drawPCompose fd3] + where fd3 = force $ dartDs!!3 +-- |diagram showing partial composition of a forced 3 times decomposed kite (with remainder faces in pale green). +-- +-- When a specific Backend B is in scope, pCompFig2 :: Diagram B +pCompFig2 = lw veryThin $ hsep 5 [draw fk3, drawPCompose fk3] + where fk3 = force $ kiteDs!!3 +-- |diagram showing two partial compositions (with remainder faces in pale green). +-- +-- When a specific Backend B is in scope, pCompFig :: Diagram B +pCompFig = padBorder $ vsep 3 [center pCompFig1, center pCompFig2] + + +-- |diagram of foolDminus and the result of forcing. +-- +-- When a specific Backend B is in scope, forceFoolDminus :: Diagram B +forceFoolDminus :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +forceFoolDminus = padBorder $ hsep 1 $ fmap (labelled drawj) [foolDminus, force foolDminus] + + +forceDartD5Fig,forceKiteD5Fig,forceSunD5Fig,forceFig :: Renderable (Path V2 Double) b => Diagram2D b +-- |diagram of forced 5 times decomposed dart. +-- +-- When a specific Backend B is in scope, forceDartD5Fig :: Diagram B +forceDartD5Fig = padBorder $ lw ultraThin $ drawForce $ dartDs !! 5 +-- |diagram of forced 5 times decomposed kite. +-- +-- When a specific Backend B is in scope, forceKiteD5Fig :: Diagram B +forceKiteD5Fig = padBorder $ lw ultraThin $ rotate (ttangle 1) $ drawForce $ kiteDs!!5 +-- |diagram of forced 5 times decomposed sun. +-- +-- When a specific Backend B is in scope, forceSunD5Fig :: Diagram B +forceSunD5Fig = padBorder $ lw ultraThin $ drawForce $ sunDs !! 5 +-- |diagram of forced 5 times decomposed dart (left) and kite (right). +-- +-- When a specific Backend B is in scope, forceFig :: Diagram B +forceFig = hsep 1 [forceDartD5Fig,forceKiteD5Fig] + +-- |brokenDart is a 4 times decomposed dart (dartD4) with 5 halftile faces removed. +-- Forcing will repair to produce the same Tgraph as force dartD4. +-- This graph can also be repeatedly composed (without forcing) to get a maximal Tgraph. +brokenDart :: Tgraph +brokenDart = removeFaces deleted dartD4 where + deleted = [RK (2,16,33),LD (15,33,16),RK (16,66,15),LK (16,67,66),LK (5,15,66)] + +{-| badlyBrokenDart has more faces removed from brokenDart. +This will also get repaired by forcing (to produce the same as force dartD4). +However it will fail to produce a valid Tgraph if composed twice without forcing. +-} +badlyBrokenDart :: Tgraph +badlyBrokenDart = removeFaces deleted bbd where + deleted = [RK (6,28,54)] + bbd = removeVertices [63,37] brokenDart +-- deleted = RK(6,28,54):filter (isAtV 63) (faces brokenDart) + +-- |brokenDartFig shows the faces removed from dartD4 to make brokenDart and badlyBrokenDart. +-- +-- When a specific Backend B is in scope, brokenDartFig :: Diagram B +brokenDartFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +brokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [dartD4, brokenDart, badlyBrokenDart] + +-- |badlyBrokenDartFig shows badlyBrokenDart, followed by its composition, followed by the faces +-- that would result from an unchecked second composition which are not tile-connected. +-- (Simply applying compose twice to badlyBrokenDart will raise an error). +-- +-- When a specific Backend B is in scope, badlyBrokenDartFig :: Diagram B +badlyBrokenDartFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +badlyBrokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [vp, vpComp, vpFailed] where + vp = makeVP badlyBrokenDart + comp = compose badlyBrokenDart + vpComp = restrictVP vp $ faces $ comp + vpFailed = restrictVP vp $ composedFaces comp + +-- |figure showing the result of removing incomplete tiles (those that do not have their matching halftile) +-- to a 3 times decomposed sun. +-- +-- When a specific Backend B is in scope, removeIncompletesFig :: Diagram B +removeIncompletesFig :: Renderable (Path V2 Double) b => Diagram2D b +removeIncompletesFig = padBorder $ drawj $ removeFaces (boundaryJoinFaces g) g where + g = sunDs !! 3 + + +-- |mistake is a legal but incorrect Tgraph - a kite with 2 darts on its long edges +mistake:: Tgraph +mistake = makeTgraph [RK (1,2,4), LK (1,3,2), RD (3,1,5), LD (4,6,1), LD (3,5,7), RD (4,8,6)] + +-- |mistake1 is a kite bordered by 2 half darts (subgraph of mistake and still incorrect) +mistake1:: Tgraph +mistake1 = makeTgraph [RK (1,2,4), LK (1,3,2), RD (3,1,5), LD (4,6,1)] + +-- * Figures for 7 vertex types + +-- | vertexTypesFig is 7 vertex types in a single diagram as a row. +-- +-- When a specific Backend B is in scope, vertexTypesFig :: Diagram B +vertexTypesFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +vertexTypesFig = padBorder $ hsep 1 lTypeFigs + where + lTypeFigs = zipWith (labelAt (p2 (0,-2.2))) ["sun","star","jack","queen","king","ace","deuce"] vTypeFigs + vTypeFigs = zipWith drawVertex + [sunGraph, starGraph, jackGraph, queenGraph, kingGraph, aceGraph, deuceGraph] + [(1,2), (1,2), (1,2), (1,2), (1,2), (3,6), (2,6)] -- alignments + drawVertex g alm = alignBefore (lw thin . showOrigin . drawj) alm g + +jackGraph,kingGraph,queenGraph,aceGraph,deuceGraph,starGraph::Tgraph +-- |Tgraph for vertex type jack. +jackGraph = makeTgraph + [LK (1,9,11),RK (1,11,2),LK (7,8,1),RD (9,1,8),RK (1,3,4) + ,LK (1,2,3),RK (7,1,5),LD (4,5,1),LD (9,8,10),RD (4,6,5) + ] -- centre 1 +-- |Tgraph for vertex type king. +kingGraph = makeTgraph + [LD (1,2,3),RD (1,11,2),LD (1,4,5),RD (1,3,4),LD (1,10,11) + ,RD (1,9,10),LK (9,1,7),RK (9,7,8),RK (5,7,1),LK (5,6,7) + ] -- centre 1 +-- |Tgraph for vertex type queen. +queenGraph = makeTgraph + [LK (7,1,5),RK (3,5,1),LD (1,2,3),RK (7,9,1),LK (11,1,9) + ,RD (1,11,2),RK (7,5,6),LK (7,8,9),LK (3,4,5),RK (11,9,10) + ] -- centre 1 +-- |Tgraph for vertex type ace (same as fool). +aceGraph = fool -- centre 3 +-- |Tgraph for vertextype deuce. +deuceGraph = makeTgraph + [LK (7,8,2),RK (7,2,6),RK (5,2,4),LK (5,6,2),LD (1,4,2) + ,RD (1,2,8),RD (1,3,4),LD (1,8,9) + ] -- centre 2 +-- |Tgraph for vertex type star. +starGraph = makeTgraph + [LD (1,2,3),RD (1,11,2),LD (1,10,11),RD (1,9,10),LD (1,8,9) + ,RD (1,7,8),LD (1,6,7),RD (1,5,6),LD (1,4,5),RD (1,3,4) + ] -- centre 1 + +-- |forceVFigures is a list of 7 diagrams - force of 7 vertex types. +-- +-- When a specific Backend B is in scope, forceVFigures :: [Diagram B] +forceVFigures :: Renderable (Path V2 Double) b => [Diagram2D b] +forceVFigures = rotations [0,0,9,5,0,0,1] $ + fmap (center . drawForce) [sunGraph,starGraph,jackGraph,queenGraph,kingGraph,aceGraph,deuceGraph] + + +sun3Dart :: Tgraph +-- |A sun with 3 darts on the boundary NOT all adjacent +-- (Used in superForceRocketsFig). +sun3Dart = addHalfDart (9,10) $ addHalfDart (8,9) $ addHalfDart (5,6) $ addHalfDart (4,5) $ addHalfDart (3,4) $ addHalfDart (2,3) sunGraph +-- sun3Dart = addHalfDart (9,10) $ addHalfDart (8,9) sun2AdjDart + + +-- |Diagram showing superForce with initial Tgraph g (red), force g (red and black), +-- and superForce g (red and black and blue). +-- +-- When a specific Backend B is in scope, superForceFig :: Diagram B +superForceFig :: Renderable (Path V2 Double) b => Diagram2D b +superForceFig = padBorder $ lw thin $ rotate (ttangle 1) $ drawSuperForce g where + g = addHalfDart (220,221) $ force $ decompositions fool !!3 + +-- |Diagram showing 4 rockets formed by applying superForce to successive decompositions +-- of sun3Dart. The decompositions are in red with normal force additions in black and superforce additions in blue. +-- +-- When a specific Backend B is in scope, superForceRocketsFig :: Diagram B +superForceRocketsFig :: Renderable (Path V2 Double) b => Diagram2D b +superForceRocketsFig = padBorder $ lw veryThin $ vsep 1 $ rotations [8,9,9,8] $ + fmap drawSuperForce decomps where + decomps = take 4 $ decompositions sun3Dart + + +boundaryFDart4, boundaryFDart5 :: Tgraph +-- |graph of the boundary faces only of a forced graph (dartDs!!4) +boundaryFDart4 = checkedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 +-- |graph of the boundary faces only of a forced graph (dartDs!!5) +boundaryFDart5 = checkedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) + +boundaryFDart4Fig,boundaryFDart5Fig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +-- |figure of the boundary faces only of a forced graph (dartDs!!4). +-- +-- When a specific Backend B is in scope, boundaryFDart4Fig :: Diagram B +boundaryFDart4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryFDart4 +-- |figure of the boundary faces only of a forced graph (dartDs!!5). +-- +-- When a specific Backend B is in scope, boundaryFDart5Fig :: Diagram B +boundaryFDart5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryFDart5 + +boundaryGapFDart4, boundaryGapFDart5 :: Tgraph +-- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap +boundaryGapFDart4 = removeVertices [354] boundaryFDart4 + -- checkedTgraph $ filter ((/=354).originV) (faces boundaryFDart4) +-- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap +boundaryGapFDart5 = removeVertices [1467] boundaryFDart5 + -- checkedTgraph $ filter ((/=1467).originV) (faces boundaryFDart5) + +boundaryGap4Fig, boundaryGap5Fig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b +-- |figure for the boundary gap graph boundaryGapFDart4. +-- +-- When a specific Backend B is in scope, boundaryGap4Fig :: Diagram B +boundaryGap4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryGapFDart4 +-- |figure for the boundary gap graph boundaryGapFDart5. +-- +-- When a specific Backend B is in scope, boundaryGap5Fig :: Diagram B +boundaryGap5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryGapFDart5 + + +-- | boundaryVCoveringFigs bd - produces a list of diagrams for the boundaryVCovering of bd +-- (with the Tgraph represented by bd shown in red in each case). +-- +-- When a specific Backend B is in scope, boundaryVCoveringFigs :: BoundaryState -> [Diagram B] +boundaryVCoveringFigs :: Renderable (Path V2 Double) b => + BoundaryState -> [Diagram2D b] +boundaryVCoveringFigs bd = + fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryVCovering bd + where redg = lc red $ draw g --alignBefore draw alig g + alig = defaultAlignment g + g = recoverGraph bd + +-- | boundaryECoveringFigs bd - produces a list of diagrams for the boundaryECovering of bd +-- (with the Tgraph represented by bd shown in red in each case). +-- +-- When a specific Backend B is in scope, boundaryECoveringFigs :: BoundaryState -> [Diagram B] +boundaryECoveringFigs :: Renderable (Path V2 Double) b => + BoundaryState -> [Diagram2D b] +boundaryECoveringFigs bd = + fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryECovering bd + where redg = lc red $ draw g + alig = defaultAlignment g + g = recoverGraph bd + +kingECoveringFig,kingVCoveringFig :: Renderable (Path V2 Double) b => Diagram2D b +-- | diagram showing the boundaryECovering of a forced kingGraph. +-- +-- When a specific Backend B is in scope, kingECoveringFig :: Diagram B +kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ force $ makeBoundaryState kingGraph +-- | diagram showing the boundaryVCovering of a forced kingGraph. +-- +-- When a specific Backend B is in scope, kingVCoveringFig :: Diagram B +kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ force $ makeBoundaryState kingGraph + +kingEmpiresFig, kingEmpire1Fig, kingEmpire2Fig :: Renderable (Path V2 Double) b => Diagram2D b +-- | figure showing King's empires (1 and 2). +-- +-- When a specific Backend B is in scope, kingEmpiresFig :: Diagram B +kingEmpiresFig = padBorder $ hsep 10 [kingEmpire1Fig, kingEmpire2Fig] +-- | figure showing King's empires 1. +-- +-- When a specific Backend B is in scope, kingEmpire1Fig :: Diagram B +kingEmpire1Fig = showEmpire1 kingGraph +-- | figure showing King's empire 2. +-- +-- When a specific Backend B is in scope, kingEmpire2Fig :: Diagram B +kingEmpire2Fig = showEmpire2 kingGraph diff --git a/src/Tgraphs.hs b/src/Tgraphs.hs new file mode 100644 --- /dev/null +++ b/src/Tgraphs.hs @@ -0,0 +1,810 @@ +{-| +Module : Tgraphs +Description : Collects and exports the various Tgraph modules plus extra operations, including makeTgraph +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This is the main module for Tgraph operations which collects and exports the other Tgraph modules. +It exports makeTgraph for constructing checked Tgraphs and excludes data constructor Tgraph. +The module also defines several functions for producing overlaid diagrams for Tgraphs (including smart drawing) and +experimental combinations such as boundaryECovering, boundaryVCovering, empire1, empire2, superForce, boundaryLoopsG. +It also defines experimental TrackedTgraphs (used for tracking subsets of faces of a Tgraph). +-} +-- {-# OPTIONS_HADDOCK ignore-exports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch +-- {-# LANGUAGE TypeOperators #-} -- needed for type equality constraints ~ + +module Tgraphs + ( module Tgraph.Prelude + , module Tgraph.Decompose + , module Tgraph.Compose + , module Tgraph.Force + , module Tgraph.Relabelling + -- * Making valid Tgraphs (with a check for no touching vertices). + , makeTgraph + , tryMakeTgraph + , tryCorrectTouchingVs + -- * Smart drawing of Tgraphs + , smart + , boundaryJoinFaces + , drawJoinsFor + , smartdraw + , restrictSmart + , smartRotateBefore + , smartAlignBefore + -- * Overlaid drawing tools for Tgraphs + , drawPCompose + , drawForce + , drawSuperForce + , drawWithMax + , addBoundaryAfter + , drawCommonFaces + , emphasizeFaces + -- * Combining force, compose, decompose + , composeK + , compForce + , allCompForce + , maxCompForce + , forceDecomp + , allForceDecomps + -- * Emplace Choices + , emplaceChoices +-- , emplaceChoices' + -- * Boundary Covering and Empires + , forcedBoundaryECovering + , forcedBoundaryVCovering + , boundaryECovering + , boundaryEdgeSet + , commonBdry + , boundaryVCovering + , boundaryVertexSet + , internalVertexSet + , tryDartAndKiteForced + , tryDartAndKite + , drawFBCovering + , empire1 + , empire2 + , empire2Plus + , drawEmpire + , showEmpire1 + , showEmpire2 + -- * Super Force with boundary edge covers + , superForce + , trySuperForce + , singleChoiceEdges + -- * Boundary loops + , boundaryLoopsG + , boundaryLoops + , findLoops + , pathFromBoundaryLoops + -- * TrackedTgraphs + , TrackedTgraph(..) + , newTrackedTgraph + , makeTrackedTgraph + , trackFaces + , unionTwoTracked + -- * Forcing and Decomposing TrackedTgraphs + , addHalfDartTracked + , addHalfKiteTracked + , decomposeTracked + -- * Drawing TrackedTgraphs + , drawTrackedTgraph + , drawTrackedTgraphRotated + , drawTrackedTgraphAligned + ) where + +-- import Tgraph.Prelude hiding (Tgraph(Tgraph)) -- hides Tgraph as type and data constructor +-- import Tgraph.Prelude (Tgraph) -- re-includes Tgraph as type constructor only +import Tgraph.Prelude +import Tgraph.Decompose +import Tgraph.Compose +import Tgraph.Force +import Tgraph.Relabelling +import Diagrams.Prelude hiding (union) +import TileLib + +import Data.List (intersect, union, (\\), find, foldl',nub, transpose) +import qualified Data.Set as Set (Set,fromList,null,intersection,deleteFindMin)-- used for boundary covers +import qualified Data.IntSet as IntSet (fromList,member,(\\)) -- for boundary vertex set +import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops + +-- * Making valid Tgraphs (with a check for no touching vertices). + +{-| +makeTgraph performs a no touching vertex check as well as using tryTgraphProps for other required properties. +It produces an error if either check fails. +Note that the other Tgraph properties are checked first, to ensure that calculation of +vertex locations can be done for a touching vertex check. +-} +makeTgraph :: [TileFace] -> Tgraph +makeTgraph fcs = runTry $ onFail "makeTgraph: (failed):\n" $ tryMakeTgraph fcs + +{-| +tryMakeTgraph performs the same checks for Tgraph properties as tryTgraphProps but in addition +it also checks that there are no touching vertices (distinct labels for the same vertex) +using Tgraph.Convert.touchingVertices (which calculates vertex locations). +It produces Left ... if either check fails and Right g otherwise where g is the Tgraph. +Note that the other Tgraph properties are checked first, to ensure that calculation of +vertex locations can be done. +-} +tryMakeTgraph :: [TileFace] -> Try Tgraph +tryMakeTgraph fcs = + do g <- tryTgraphProps fcs -- must be checked first + let touchVs = touchingVertices (faces g) + if null touchVs + then Right g + else Left ("Found touching vertices: " + ++ show touchVs + ++ "\nwith faces:\n" + ++ show fcs + ++ "\n\n(To fix, use: tryCorrectTouchingVs)\n\n" + ) + +{-| tryCorrectTouchingVs fcs finds touching vertices by calculating locations for vertices in the faces fcs, + then renumbers to remove touching vertices (renumbers higher to lower numbers), + then checks for Tgraph properties of the resulting faces to produce a Tgraph. + NB fcs needs to be tile-connected before the renumbering and + the renumbering need not be 1-1 (hence Relabelling is not used) +-} +tryCorrectTouchingVs :: [TileFace] -> Try Tgraph +tryCorrectTouchingVs fcs = + onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $ + tryTgraphProps $ nub $ renumberFaces touchVs fcs + -- renumberFaces allows for a non 1-1 relabelling represented by a list + where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices + + + +-- |smart dr g - uses VPatch drawing function dr after converting g to a VPatch +-- It will add boundary joins regardless of the drawing function. +-- Examples: +-- +-- smart draw g +-- +-- smart (labelled draw) g +-- +-- smart (labelSize normal draw) g +-- +-- When a specific Backend B is in scope, smart :: (VPatch -> Diagram B) -> Tgraph -> Diagram B +smart :: Renderable (Path V2 Double) b => + (VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b +smart dr g = drawJoinsFor (boundaryJoinFaces g) vp <> dr vp + where vp = makeVP g + +-- |select the halftile faces of a Tgraph with a join edge on the boundary. +-- Useful for drawing join edges only on the boundary. +boundaryJoinFaces :: Tgraph -> [TileFace] +boundaryJoinFaces g = fmap snd $ incompleteHalves bdry $ boundary bdry where + bdry = makeBoundaryState g + +-- |given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces. +-- +-- When a specific Backend B is in scope, drawJoinsFor:: [TileFace] -> VPatch -> Diagram B +drawJoinsFor:: Renderable (Path V2 Double) b => + [TileFace] -> VPatch -> Diagram2D b +drawJoinsFor fcs vp = drawWith dashjOnly (subVP vp fcs) + +-- |same as draw except adding dashed lines on boundary join edges. +-- +-- When a specific Backend B is in scope, smartdraw :: Tgraph -> Diagram B +smartdraw :: Renderable (Path V2 Double) b => Tgraph -> Diagram2D b +smartdraw = smart draw + +-- |restrictSmart g dr vp - assumes vp has locations for vertices in g. +-- It uses the VPatch drawing function dr to draw g and adds dashed boundary joins. +-- This can be used instead of smart when an appropriate vp is already available. +-- +-- When a specific Backend B is in scope, restrictSmart:: Tgraph -> (VPatch -> Diagram B) -> VPatch -> Diagram B +restrictSmart :: Renderable (Path V2 Double) b => + Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b +restrictSmart g dr vp = drawJoinsFor (boundaryJoinFaces g) rvp <> dr rvp + where rvp = restrictVP vp $ faces g + +-- |smartRotateBefore vfun a g - a tricky combination of smart with rotateBefore. +-- Uses vfun to produce a Diagram after converting g to a rotated VPatch but also adds the dashed boundary join edges of g. +-- +-- Example: smartRotateBefore (labelled draw) angle g +-- +-- When a specific Backend B is in scope, smartRotateBefore:: (VPatch -> Diagram B) -> Angle Double -> Tgraph -> Diagram B +smartRotateBefore :: Renderable (Path V2 Double) b => + (VPatch -> Diagram2D b) -> Angle Double -> Tgraph -> Diagram2D b +smartRotateBefore vfun angle g = rotateBefore (restrictSmart g vfun) angle g + +-- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore. +-- Uses vfun to produce a Diagram after converting g to n aligned VPatch but also adds the dashed boundary join edges of g. +-- +-- Example: smartAlignBefore (labelled draw) (a,b) g +-- +-- When a specific Backend B is in scope, smartAlignBefore:: (VPatch -> Diagram B) -> (Vertex,Vertex) -> Tgraph -> Diagram B +smartAlignBefore :: Renderable (Path V2 Double) b => + (VPatch -> Diagram2D b) -> (Vertex,Vertex) -> Tgraph -> Diagram2D b +smartAlignBefore vfun (a,b) g = alignBefore (restrictSmart g vfun) (a,b) g + + + +-- |applies partCompose to a Tgraph g, then draws the composed graph with the remainder faces (in lime). +-- (Relies on the vertices of the composition and remainder being subsets of the vertices of g.) +-- +-- When a specific Backend B is in scope, drawPCompose :: Tgraph -> Diagram B +drawPCompose :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +drawPCompose g = + restrictSmart g' draw vp + <> drawj (subVP vp remainder) # lw medium # lc lime + where (remainder,g') = partCompose g + vp = makeVP g + +-- |drawForce g is a diagram showing the argument g in red overlayed on force g +-- It adds dashed join edges on the boundary of g +-- +-- When a specific Backend B is in scope, drawForce:: Tgraph -> Diagram B +drawForce :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +drawForce g = + restrictSmart g draw vp # lc red # lw medium + <> draw vp + where vp = makeVP $ force g + +-- |drawSuperForce g is a diagram showing the argument g in red overlayed on force g in black +-- overlaid on superForce g in blue. +-- It adds dashed join edges on the boundary of g. +-- +-- When a specific Backend B is in scope, drawSuperForce:: Tgraph -> Diagram B +drawSuperForce :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +drawSuperForce g = (dg # lc red) <> dfg <> (dsfg # lc blue) where + sfg = superForce g + fg = force g + vp = makeVP $ superForce g + dfg = draw $ selectFacesVP vp (faces fg \\ faces g) -- restrictSmart (force g) draw vp + dg = restrictSmart g draw vp + dsfg = draw $ selectFacesVP vp (faces sfg \\ faces fg) + +-- | drawWithMax g - draws g and overlays the maximal composition of force g in red. +-- This relies on g and all compositions of force g having vertices in force g. +-- +-- When a specific Backend B is in scope, drawWithMax :: Tgraph -> Diagram B +drawWithMax :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +drawWithMax g = (dmax # lc red # lw medium) <> dg where + vp = makeVP $ force g -- duplicates force to get the locations of vertices in the forced Tgraph + dg = restrictSmart g draw vp + maxg = maxCompForce g + dmax = draw $ subVP vp (faces maxg) + +-- |displaying the boundary of a Tgraph in lime (overlaid on the Tgraph drawn with f). +-- +-- When a specific Backend B is in scope, addBoundaryAfter :: (VPatch -> Diagram B) -> Tgraph -> Diagram B +addBoundaryAfter :: Renderable (Path V2 Double) b => + (VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b +addBoundaryAfter f g = (drawEdgesVP vp edges # lc lime) <> f vp where + vp = makeVP g + edges = graphBoundary g + +-- |drawCommonFaces (g1,e1) (g2,e2) uses commonFaces (g1,e1) (g2,e2) to find the common faces +-- and emphasizes them on the background g1. +-- +-- When a specific Backend B is in scope, drawCommonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram B +drawCommonFaces :: Renderable (Path V2 Double) b => + (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram2D b +drawCommonFaces (g1,e1) (g2,e2) = emphasizeFaces (commonFaces (g1,e1) (g2,e2)) g1 + +-- |emphasizeFaces fcs g emphasizes the given faces (that are in g) overlaid on the background g. +-- +-- When a specific Backend B is in scope, emphasizeFaces:: [TileFace] -> Tgraph -> Diagram B +emphasizeFaces :: Renderable (Path V2 Double) b => + [TileFace] -> Tgraph -> Diagram2D b +emphasizeFaces fcs g = (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where + vp = makeVP g + emphvp = subVP vp (fcs `intersect` faces g) + + + + +-- | An unsound version of composition which defaults to kites when there are choices (unknowns). +-- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph. +composeK :: Tgraph -> Tgraph +composeK g = runTry $ tryConnectedNoCross newfaces where + dwInfo = getDartWingInfo g + changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo + , unknowns = [] + } + compositions = composedFaceGroups changedInfo + newfaces = map fst compositions + +-- |compForce does a force then compose. +-- It omits the check for connected, and no crossing boundaries because the argument is forced first. +-- This relies on a proof that composition does not need to be checked for a forced Tgraph. +-- It may raise an error if the initial force fails with an incorrect Tgraph. +compForce:: Tgraph -> Tgraph +compForce = uncheckedCompose . force + +-- |allCompForce g produces a list of the non-null iterated forced compositions of g. +-- It will raise an error if the initial force fails with an incorrect Tgraph. +-- The list will be [] if g is the emptyTgraph. +-- The list will be [force g] if the first composition of force g is the emptyTgraph but g is not the emptyTgraph. +-- The definition relies on (1) a proof that the composition of a forced Tgraph is forced and +-- (2) a proof that composition does not need to be checked for a forced Tgraph. +allCompForce:: Tgraph -> [Tgraph] +allCompForce = takeWhile (not . nullGraph) . iterate uncheckedCompose . force + +-- |maxCompForce g produces the maximally composed (non-null) Tgraph starting from force g, provided g is not the emptyTgraph +-- and just the emptyTgraph otherwise. +-- It will raise an error if the initial force fails with an incorrect Tgraph. +maxCompForce:: Tgraph -> Tgraph +maxCompForce g | nullGraph g = g + | otherwise = last $ allCompForce g + + +-- |force after a decomposition +forceDecomp:: Tgraph -> Tgraph +forceDecomp = force . decompose + +-- | allForceDecomps g - produces an infinite list of forced decompositions of g +allForceDecomps:: Tgraph -> [Tgraph] +allForceDecomps = iterate forceDecomp + + +-- |emplaceChoices forces then maximally composes. At this top level it +-- produces a list of forced choices for the unknowns. +-- It then repeatedly forceDecomps back to the starting level to return a list of Tgraphs. +-- This version relies on compForce theorem and related theorems +emplaceChoices:: Tgraph -> [Tgraph] +emplaceChoices g = emplaceChoices' $ force $ makeBoundaryState g + +-- |emplaceChoices' bd - assumes bd is forced. It maximally composes. At this top level it +-- produces a list of forced choices for the unknowns. +-- It then repeatedly forceDecomps back to the starting level to return a list of Tgraphs. +-- This version relies on compForce theorem and related theorems +emplaceChoices':: BoundaryState -> [Tgraph] +emplaceChoices' startbd | nullGraph g' = recoverGraph <$> choices [startbd] + | otherwise = forceDecomp <$> emplaceChoices' (makeBoundaryState g') + where + g' = compose $ recoverGraph startbd + startunknowns = unknowns $ getDartWingInfo $ recoverGraph startbd + choices [] = [] + choices (bd:bds) + = case startunknowns `intersect` unknowns (getDartWingInfo $ recoverGraph bd) of + [] -> bd:choices bds + (u:_) -> choices (atLeastOne (tryDartAndKiteForced (findDartLongForWing u bd) bd)++bds) + findDartLongForWing v bd + = case find isDart (facesAtBV bd v) of + Just d -> longE d + Nothing -> error $ "emplaceChoices': dart not found for dart wing vertex " ++ show v + + + +{-| forcedBoundaryECovering g - produces a list of all boundary covers of force g, each of which +extends force g to cover the entire boundary directed edges in (force g). +(So the boundary of force g is entirely internal edges in each cover). +The covers include all possible ways faces can be added on the boundary that are correct. +The common faces of the covers constitute the empire (level 1) of g. +This will raise an error if the initial force fails with a stuck graph. +-} +forcedBoundaryECovering:: Tgraph -> [Tgraph] +forcedBoundaryECovering g = recoverGraph <$> boundaryECovering gforcedBdry where + gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" $ + tryForce $ makeBoundaryState g + +{-| forcedBoundaryVCovering g - produces a list of all boundary covers of force g as with +forcedBoundaryECovering g but covering all boundary vertices rather than just boundary edges. +-} +forcedBoundaryVCovering:: Tgraph -> [Tgraph] +forcedBoundaryVCovering g = recoverGraph <$> boundaryVCovering gforcedBdry where + gforcedBdry = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" $ + tryForce $ makeBoundaryState g + +{-| boundaryECovering bd - produces a list of all possible covers of the boundary directed edges in bd. +[bd should be a boundary state resulting from forcing]. +A cover is a forced extension (of bd) such that the original boundary directed edges of bd are all internal edges. +Extensions are made by repeatedly adding a face to any edge on the original boundary that is still on the boundary +and forcing, repeating this until the orignal boundary is all internal edges. +The resulting covers account for all possible ways the boundary can be extended. +This can raise an error if bd is a boundary state of an unforced Tgraph. +It will raise an error if both choices on a boundary edge fail when forced (using atLeastOne). +-} +boundaryECovering:: BoundaryState -> [BoundaryState] +boundaryECovering bstate = covers [(bstate, boundaryEdgeSet bstate)] where + covers:: [(BoundaryState, Set.Set Dedge)] -> [BoundaryState] + covers [] = [] + covers ((bs,es):opens) + | Set.null es = bs:covers opens -- bs is a completed cover + | otherwise = covers (newcases ++ opens) + where (de,des) = Set.deleteFindMin es + newcases = fmap (\b -> (b, commonBdry des b)) + (atLeastOne $ tryDartAndKiteForced de bs) + +-- |Make a set of the directed boundary edges of a BoundaryState +boundaryEdgeSet:: BoundaryState -> Set.Set Dedge +boundaryEdgeSet = Set.fromList . boundary + +-- | commonBdry des b - returns those directed edges in des that are boundary directed edges of bd +commonBdry:: Set.Set Dedge -> BoundaryState -> Set.Set Dedge +commonBdry des b = des `Set.intersection` boundaryEdgeSet b + +{-| boundaryVCovering bd - similar to boundaryECovering, but produces a list of all possible covers of + the boundary vertices in bd (rather than just boundary edges). + [bd should be a boundary state resulting from forcing]. + This can raise an error if bd is a boundary state of an unforced Tgraph. +-} +boundaryVCovering:: BoundaryState -> [BoundaryState] +boundaryVCovering bd = covers [(bd, startbds)] where + startbds = boundaryEdgeSet bd + startbvs = boundaryVertexSet bd +--covers:: [(BoundaryState,Set.Set Dedge)] -> [BoundaryState] + covers [] = [] + covers ((open,es):opens) + | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary open) of + Nothing -> open:covers opens + Just dedge -> covers $ fmap (\b -> (b, es)) (atLeastOne $ tryDartAndKiteForced dedge open) ++opens + | otherwise = covers $ fmap (\b -> (b, commonBdry des b)) (atLeastOne $ tryDartAndKiteForced de open) ++opens + where (de,des) = Set.deleteFindMin es + +-- | returns the set of boundary vertices of a BoundaryState +boundaryVertexSet :: BoundaryState -> VertexSet +boundaryVertexSet bd = IntSet.fromList $ fmap fst (boundary bd) + +-- | returns the set of internal vertices of a BoundaryState +internalVertexSet :: BoundaryState -> VertexSet +internalVertexSet bd = vertexSet (recoverGraph bd) IntSet.\\ boundaryVertexSet bd + + +-- | tryDartAndKiteForced de b - returns the list of (2) results after adding a dart (respectively kite) +-- to edge de a forcible b and then tries forcing. Each of the result is a Try. +tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a] +tryDartAndKiteForced de b = + [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ + tryAddHalfDart de b >>= tryForce + , onFail ("tryDartAndKiteForced: Kite on edge: " ++ show de ++ "\n") $ + tryAddHalfKite de b >>= tryForce + ] + +-- | tryDartAndKite de b - returns the list of (2) results after adding a dart (respectively kite) +-- to edge de of a Forcible b. Each of the result is a Try. +tryDartAndKite:: Forcible a => Dedge -> a -> [Try a] +tryDartAndKite de b = + [ onFail ("tryDartAndKite: Dart on edge: " ++ show de ++ "\n") $ + tryAddHalfDart de b + , onFail ("tryDartAndKite: Kite on edge: " ++ show de ++ "\n") $ + tryAddHalfKite de b + ] + + +-- | test function to draw a column of the list of graphs resulting from forcedBoundaryVCovering g. +-- +-- When a specific Backend B is in scope, drawFBCovering:: Tgraph -> Diagram B +drawFBCovering :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +drawFBCovering g = lw ultraThin $ vsep 1 (draw <$> forcedBoundaryVCovering g) + +-- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g. +-- The tgraph of the result is the first boundary vertex cover of force g, +-- and the tracked list of the result has the common faces of all the boundary vertex covers (of force g) +-- at the head, followed by the original faces of g. +empire1:: Tgraph -> TrackedTgraph +empire1 g = makeTrackedTgraph g0 [fcs,faces g] where + covers = forcedBoundaryVCovering g + g0 = head covers + others = tail covers + fcs = foldl' intersect (faces g0) $ fmap g0Intersect others + de = defaultAlignment g + g0Intersect g1 = commonFaces (g0,de) (g1,de) + +-- | empire2 g - produces a TrackedTgraph representing the level 2 empire of g. +-- NB since very large graphs can be generated with boundary vertex covers, we use boundary edge covers only. +-- That is, after finding all boundary edge covers of force g, +-- boundary edge covers are then found for each boundary edge cover to form a list of doubly-extended +-- boundary edge covers. +-- The tgraph of the result is the first (doubly-extended) boundary edge cover (of force g), +-- and the tracked list of the result has the common faces of all the (doubly-extended) boundary edge covers +-- at the head, followed by the original faces of g. +empire2:: Tgraph -> TrackedTgraph +empire2 g = makeTrackedTgraph g0 [fcs, faces g] where + covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" + $ tryForce $ makeBoundaryState g + covers2 = concatMap boundaryECovering covers1 +-- (g0:others) = fmap recoverGraph covers2 + gcovers = fmap recoverGraph covers2 + g0 = head gcovers + others = tail gcovers + fcs = foldl' intersect (faces g0) $ fmap g0Intersect others + de = defaultAlignment g + g0Intersect g1 = commonFaces (g0,de) (g1,de) + +-- | empire2Plus g - produces a TrackedTgraph representing an extended level 2 empire of g +-- similar to empire2, but using boundaryVCovering insrtead of boundaryECovering. +empire2Plus:: Tgraph -> TrackedTgraph +empire2Plus g = makeTrackedTgraph g0 [fcs, faces g] where + covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" + $ tryForce $ makeBoundaryState g + covers2 = concatMap boundaryVCovering covers1 +-- (g0:others) = fmap recoverGraph covers2 + gcovers = fmap recoverGraph covers2 + g0 = head gcovers + others = tail gcovers + fcs = foldl' intersect (faces g0) $ fmap g0Intersect others + de = defaultAlignment g + g0Intersect g1 = commonFaces (g0,de) (g1,de) + +-- | drawEmpire e - produces a diagram for an empire e represented as a TrackedTgraph +-- as calcultaed by e.g. empire1 or empire2 or empire2Plus. +-- The diagram draws the underlying Tgraph, with the first tracked faces - the starting Tgraph shown red, and emphasising the second tracked faces +-- - the common faces. +-- +-- When a specific Backend B is in scope, drawEmpire:: TrackedTgraph -> Diagram B +drawEmpire :: Renderable (Path V2 Double) b => + TrackedTgraph -> Diagram2D b +drawEmpire = + drawTrackedTgraph [ lw ultraThin . draw + , lw thin . fillDK lightgrey lightgrey + , lw thin . lc red . draw + ] + +-- | showEmpire1 g - produces a diagram emphasising the common faces of all boundary covers of force g. +-- This is drawn over one of the possible boundary covers and the faces of g are shown in red. +-- +-- When a specific Backend B is in scope, showEmpire1:: Tgraph -> Diagram B +showEmpire1 :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +showEmpire1 = drawEmpire . empire1 + +-- | showEmpire2 g - produces a diagram emphasising the common faces of a doubly-extended boundary cover of force g. +-- This is drawn over one of the possible doubly-extended boundary covers and the faces of g are shown in red. +-- +-- When a specific Backend B is in scope, showEmpire2:: Tgraph -> Diagram B +showEmpire2 :: Renderable (Path V2 Double) b => + Tgraph -> Diagram2D b +showEmpire2 = drawEmpire . empire2 + +-- |superForce g - after forcing g this looks for single choice boundary edges. +-- That is a boundary edge for which only a dart or only a kite addition occurs in all boundary edge covers. +-- If there is at least one such edge, it makes the choice for the first such edge and recurses, +-- otherwise it returns the forced result. +-- This will raise an error if force encounters a stuck (incorrect) tiling or if +-- both forced extensions fail for some boundary edge. +-- Otherwise, the result has exactly two correct possible extensions for each boundary edge. +superForce:: Forcible a => a -> a +superForce g = runTry $ trySuperForce g + +-- |trySuperForce g - this looks for single choice edges after trying to force g. +-- If there is at least one, it makes that choice and recurses. +-- It returns a Left s if force fails or if both choices fail for some edge (where s is a failure report). +-- Otherwise Right g' is returned where g' is the super forced g. +trySuperForce:: Forcible a => a -> Try a +trySuperForce = tryFSOp trySuperForceFS where + -- |trySuperForceFS - implementation of trySuperForce for force states only + trySuperForceFS :: ForceState -> Try ForceState + trySuperForceFS fs = + do forcedFS <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $ + tryForce fs + case singleChoiceEdges $ boundaryState forcedFS of + [] -> return forcedFS + (elpr:_) -> do extended <- addSingle elpr forcedFS + trySuperForceFS extended + addSingle (e,l) fs = if isDart l then tryAddHalfDart e fs else tryAddHalfKite e fs + +-- |singleChoiceEdges bd - if bd is a boundary state of a forced Tgraph this finds those boundary edges of bd +-- which have a single choice (i.e. the other choice is incorrect), by inspecting boundary edge covers of bd. +-- The result is a list of pairs of (edge,label) where edge is a boundary edge with a single choice +-- and label indicates the choice as the common face label. +singleChoiceEdges :: BoundaryState -> [(Dedge,HalfTileLabel)] +singleChoiceEdges bstate = commonToCovering (boundaryECovering bstate) (boundary bstate) + where +-- |commonToCovering bds edgeList - when bds are all the boundary edge covers of some forced Tgraph +-- whose boundary edges were edgeList, this looks for edges in edgeList that have the same tile label added in all covers. +-- This indicates there is a single choice for such an edge (the other choice is incorrect). +-- The result is a list of pairs: edge and a common tile label. +-- commonToCovering :: [BoundaryState] -> [Dedge] -> [(Dedge,HalfTileLabel)] + commonToCovering bds edgeList = common edgeList (transpose labellists) where + labellists = fmap (`reportCover` edgeList) bds + common [] [] = [] + common [] (_:_) = error "singleChoiceEdges:commonToCovering: label list is longer than edge list" + common (_:_) [] = error "singleChoiceEdges:commonToCovering: label list is shorter than edge list" + common (e:more) (ls:lls) = if matchingLabels ls + then (e,head ls):common more lls + else common more lls + matchingLabels [] = error "singleChoiceEdges:commonToCovering: empty list of labels" + matchingLabels (l:ls) = all (==l) ls + +-- |reportCover bd edgelist - when bd is a boundary edge cover of some forced Tgraph whose boundary edges are edgelist, +-- this returns the tile label for the face covering each edge in edgelist (in corresponding order). +-- reportCover :: BoundaryState -> [Dedge] -> [HalfTileLabel] + reportCover bd des = fmap (tileLabel . getf) des where + efmap = dedgesFacesMap des (allFaces bd) -- more efficient than using graphEFMap? +-- efmap = graphEFMap (recoverGraph bd) + getf e = maybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e) + id + (faceForEdge e efmap) + + + +-- | Returns a list of (looping) vertex trails for the boundary of a Tgraph. +-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes. +-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex. +-- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs. +boundaryLoopsG:: Tgraph -> [[Vertex]] +boundaryLoopsG = findLoops . graphBoundary + +-- | Returns a list of (looping) vertex trails for a BoundaryState. +-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes. +-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex. +-- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs (and hence BoundaryStates). +boundaryLoops:: BoundaryState -> [[Vertex]] +boundaryLoops = findLoops . boundary + +-- | When applied to a boundary edge list this returns a list of (looping) vertex trails. +-- I.e. if we follow the boundary edges of a Tgraph recording vertices visited as a list returning to the starting vertex +-- we get a looping trail. +-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes. +-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex. +findLoops:: [Dedge] -> [[Vertex]] +findLoops = collectLoops . VMap.fromList where + + -- Make a vertex to vertex map from the directed edges then delete items from the map as a trail is followed + -- from the lowest numbered vertex. + -- Vertices are collected in reverse order, then the list is reversed when a loop is complete. + -- This is repeated until the map is empty, to collect all boundary trials. + collectLoops vmap -- + | VMap.null vmap = [] + | otherwise = chase startV vmap [startV] + where + (startV,_) = VMap.findMin vmap + chase a vm sofar -- sofar is the collected trail in reverse order. + = case VMap.lookup a vm of + Just b -> chase b (VMap.delete a vm) (b:sofar) + Nothing -> if a == startV + then reverse sofar: collectLoops vm -- look for more loops + else error $ "findLoops (collectLoops): non looping boundary component, starting at " + ++show startV++ + " and finishing at " + ++ show a ++ + "\nwith loop vertices "++ show (reverse sofar) ++"\n" + + +-- | Given a suitable vertex to location map and boundary loops (represented as a list of lists of vertices), +-- this will return a (Diagrams) Path for the boundary. It will raise an error if any vertex listed is not a map key. +-- (The resulting path can be filled when converted to a diagram.) +pathFromBoundaryLoops:: VertexLocMap -> [[Vertex]] -> Path V2 Double +pathFromBoundaryLoops vlocs loops = toPath $ map (locateLoop . map (vlocs VMap.!)) loops where + locateLoop pts = (`at` head pts) $ glueTrail $ trailFromVertices pts + + + +-- * TrackedTgraphs + +{-| + TrackedTgraph - introduced to allow tracking of subsets of faces + in both force and decompose operations. + Mainly used for drawing purposes but also for empires. + A TrackedTgraph has a main Tgraph (tgraph) and a list of subsets (sublists) of faces (tracked). + The list allows for tracking different subsets of faces at the same time. +-} +data TrackedTgraph = TrackedTgraph{ tgraph:: Tgraph, tracked::[[TileFace]]} deriving Show + +-- |newTrackedTgraph g creates a TrackedTgraph from a Tgraph g with an empty tracked list +newTrackedTgraph :: Tgraph -> TrackedTgraph +newTrackedTgraph g = makeTrackedTgraph g [] + +-- |makeTrackedTgraph g trackedlist creates a TrackedTgraph from a Tgraph g +-- from trackedlist where each list in trackedlist is a subset of the faces of g. +-- Any faces not in g are ignored. +makeTrackedTgraph :: Tgraph -> [[TileFace]] -> TrackedTgraph +makeTrackedTgraph g trackedlist = TrackedTgraph{ tgraph = g, tracked = fmap (`intersect` faces g) trackedlist} + +-- |trackFaces ttg - pushes the maingraph tilefaces onto the stack of tracked subsets of ttg +trackFaces:: TrackedTgraph -> TrackedTgraph +trackFaces ttg = ttg{ tracked = faces (tgraph ttg):tracked ttg } + +-- |unionTwoTracked ttg - combines the top two lists of tracked tilefaces replacing them with the list union. +unionTwoTracked:: TrackedTgraph -> TrackedTgraph +unionTwoTracked ttg = ttg{ tracked = newTracked } where + newTracked = case tracked ttg of + (a:b:more) -> a `union` b:more + _ -> error $ "unionTwoTracked: Two tracked lists of faces not found: " ++ show ttg ++"\n" + +{-* +Forcing and Decomposing TrackedTgraphs +-} + +-- | TrackedTgraphs are Forcible +instance Forcible TrackedTgraph where + tryFSOpWith ugen f ttg = do + g' <- tryFSOpWith ugen f $ tgraph ttg + return ttg{ tgraph = g' } + tryInitFSWith ugen ttg = tryInitFSWith ugen (tgraph ttg) + tryChangeBoundaryWith ugen f ttg = do + g' <- tryChangeBoundaryWith ugen f $ tgraph ttg + return ttg{ tgraph = g' } +-- getBoundaryState = getBoundaryState . tgraph + +-- |addHalfDartTracked ttg e - add a half dart to the tgraph of ttg on the given edge e, +-- and push the new singleton face list onto the tracked list. +addHalfDartTracked:: Dedge -> TrackedTgraph -> TrackedTgraph +addHalfDartTracked e ttg = + TrackedTgraph{ tgraph = g' , tracked = fcs:tracked ttg} + where + g = tgraph ttg + g' = addHalfDart e g + fcs = faces g' \\ faces g + +-- |addHalfKiteTracked ttg e - add a half kite to the tgraph of ttg on the given edge e, +-- and push the new singleton face list onto the tracked list. +addHalfKiteTracked:: Dedge -> TrackedTgraph -> TrackedTgraph +addHalfKiteTracked e ttg = + TrackedTgraph{ tgraph = g' , tracked = fcs:tracked ttg} + where + g = tgraph ttg + g' = addHalfKite e g + fcs = faces g' \\ faces g + +-- |decompose a TrackedTgraph - applies decomposition to all tracked subsets as well as the full Tgraph. +-- Tracked subsets get the same numbering of new vertices as the main Tgraph. +decomposeTracked :: TrackedTgraph -> TrackedTgraph +decomposeTracked ttg = + TrackedTgraph{ tgraph = g' , tracked = tlist} + where +-- makeTrackedTgraph g' tlist where + g = tgraph ttg + g' = makeUncheckedTgraph newFaces + newVFor = phiVMap g + newFaces = concatMap (decompFace newVFor) (faces g) + tlist = fmap (concatMap (decompFace newVFor)) (tracked ttg) + +{-* Drawing TrackedTgraphs +-} + +{-| + To draw a TrackedTgraph, we use a list of functions each turning a VPatch into a diagram. + The first function is applied to a VPatch for untracked faces. + Subsequent functions are applied to VPatches for the respective tracked subsets. + Each diagram is beneath later ones in the list, with the diagram for the untracked VPatch at the bottom. + The VPatches are all restrictions of a single VPatch for the Tgraph, so consistent. + (Any extra draw functions are applied to the VPatch for the main tgraph and the results placed atop.) + + When a specific Backend B is in scope, drawTrackedTgraph:: [VPatch -> Diagram B] -> TrackedTgraph -> Diagram B +-} +drawTrackedTgraph :: [VPatch -> Diagram2D b] -> TrackedTgraph -> Diagram2D b +drawTrackedTgraph drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where + vp = makeVP (tgraph ttg) + untracked = vpFaces vp \\ concat (tracked ttg) + vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp + +{-| + To draw a TrackedTgraph rotated. + Same as drawTrackedTgraph but with additional angle argument for the rotation. + This is useful when labels are being drawn. + The angle argument is used to rotate the common vertex location map before drawing + (to ensure labels are not rotated). + + When a specific Backend B is in scope, drawTrackedTgraphRotated:: [VPatch -> Diagram B] -> Angle Double -> TrackedTgraph -> Diagram B +-} +drawTrackedTgraphRotated :: [VPatch -> Diagram2D b] -> Angle Double -> TrackedTgraph -> Diagram2D b +drawTrackedTgraphRotated drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where + vp = rotate a $ makeVP (tgraph ttg) + untracked = vpFaces vp \\ concat (tracked ttg) + vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp + +{-| + To draw a TrackedTgraph aligned. + Same as drawTrackedTgraph but with additional vertex pair argument for the (x-axis) aligment. + This is useful for when labels are being drawn. + The vertex pair argument is used to align the common vertex location map before drawing + (to ensure labels are not rotated). + This will raise an error if either of the pair of vertices is not a vertex of (the tgraph of) the TrackedTgraph + + When a specific Backend B is in scope, drawTrackedTgraphAligned:: [VPatch -> Diagram B] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram B +-} +drawTrackedTgraphAligned :: [VPatch -> Diagram2D b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram2D b +drawTrackedTgraphAligned drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where + vp = makeAlignedVP (a,b) (tgraph ttg) + untracked = vpFaces vp \\ concat (tracked ttg) + vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp + + + + diff --git a/src/TileLib.hs b/src/TileLib.hs new file mode 100644 --- /dev/null +++ b/src/TileLib.hs @@ -0,0 +1,481 @@ +{-| +Module : TileLib +Description : Introducing Pieces and Patches and Drawable class +Copyright : (c) Chris Reade, 2021 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This module introduces Pieces and Patches for drawing finite tilings using Penrose's Dart and Kite tiles. +It includes several primitives for drawing half tiles (Pieces), a class Drawable with instance Patch +and commonly used operations for the Drawable class (draw, drawj, fillDK,..). +There is also a decompose operation for Patches (decompPatch) and sun and star example Patches. +-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch +{-# LANGUAGE TypeOperators #-} -- needed for type equality constraints ~ + +module TileLib + ( -- * Pieces + Piece + , joinVector + , ldart + , rdart + , lkite + , rkite + -- * Drawing Pieces + , Diagram2D + , phi + , ttangle + , pieceEdges + , wholeTileEdges + , drawPiece + , dashjPiece + , dashjOnly + , drawRoundPiece + , drawJoin + , fillOnlyPiece + , fillPieceDK + , fillMaybePieceDK + , leftFillPieceDK + , experiment + -- * Patches and Drawable Class + , Drawable(..) + , Patch + , draw + , drawj + , fillDK + , fillKD + , fillMaybeDK + , colourDKG + , colourMaybeDKG + -- * Patch Decomposition and Compose choices + , decompPatch + , decompositionsP + , compChoices + , compNChoices + -- * Example Patches + , penta + , sun + , TileLib.star + , suns + , sun5 + , sun6 + -- * Diagrams of Patches + , sun6Fig + , leftFilledSun6 + , filledSun6 + -- * Rotation and Scaling operations + , rotations + , scales + , phiScales + , phiScaling + ) where + +import Diagrams.Prelude + +import HalfTile + +{-| Piece type for tile halves: Left Dart, Right Dart, Left Kite, Right Kite +with a vector from their origin along the join edge where +origin for a dart is the tip, origin for a kite is the vertex with smallest internal angle. +Using Imported polymorphic HalfTile. + +Pieces are Transformable +-} +type Piece = HalfTile (V2 Double) + +-- | get the vector representing the join edge in the direction away from the origin of a piece +joinVector:: Piece -> V2 Double +joinVector = tileRep + +-- |ldart,rdart,lkite,rkite are the 4 pieces (with join edge oriented along the x axis, unit length for darts, length phi for kites). +ldart,rdart,lkite,rkite:: Piece +ldart = LD unitX +rdart = RD unitX +lkite = LK (phi*^unitX) +rkite = RK (phi*^unitX) + +-- |All edge lengths are powers of the golden ratio (phi). +-- We also have the interesting property of the golden ratio that phi^2 == phi + 1 and so 1/phi = phi-1 +-- (also phi^3 = 2phi +1 and 1/phi^2 = 2-phi) +phi::Double +phi = (1.0 + sqrt 5.0) / 2.0 + +-- |All angles used are multiples of tt where tt is a tenth of a turn +-- (so 36 degrees). +-- ttangle n is n multiples of tt. +ttangle:: Int -> Angle Double +ttangle n = fromIntegral (n `mod` 10) *^tt + where tt = 1/10 @@ turn + +{-| produces a list of the two adjacent non-join tile directed edges of a piece starting from the origin. + +Perhaps confusingly we regard left and right of a dart differently from left and right of a kite. +This is in line with common sense view but darts are reversed from origin point of view. + +So for right dart and left kite the edges are directed and ordered clockwise from the piece origin, and for left dart and right kite these are +directed and ordered anti-clockwise from the piece origin. +-} +pieceEdges:: Piece -> [V2 Double] +pieceEdges (LD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 9) v +pieceEdges (RD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 1) v +pieceEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v +pieceEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v + +-- |the 4 tile edges of a completed half-tile piece (used for colour fill). +-- These are directed and ordered clockwise from the origin of the tile. +wholeTileEdges:: Piece -> [V2 Double] +wholeTileEdges (LD v) = wholeTileEdges (RD v) +wholeTileEdges (RD v) = pieceEdges (RD v) ++ map negated (reverse $ pieceEdges (LD v)) +wholeTileEdges (LK v) = pieceEdges (LK v) ++ map negated (reverse $ pieceEdges (RK v)) +wholeTileEdges (RK v) = wholeTileEdges (LK v) + + +-- | Abbreviation for 2D diagrams for any Backend b. +type Diagram2D b = QDiagram b V2 Double Any + + + + + +-- |drawing lines for the 2 non-join edges of a piece. +-- +-- When a specific Backend B is in scope, drawPiece:: Piece -> Diagram B +drawPiece :: Renderable (Path V2 Double) b => + Piece -> Diagram2D b +drawPiece = strokeLine . fromOffsets . pieceEdges + +-- |same as drawPiece but with join edge added as dashed-line. +-- +-- When a specific Backend B is in scope, dashjPiece:: Piece -> Diagram B +dashjPiece :: Renderable (Path V2 Double) b => + Piece -> Diagram2D b +dashjPiece piece = drawPiece piece <> dashjOnly piece + + +-- |draw join edge only (as dashed line). +-- +-- When a specific Backend B is in scope, dashjOnly:: Piece -> Diagram B +dashjOnly :: Renderable (Path V2 Double) b => + Piece -> Diagram2D b +dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey + +-- |same as drawPiece but with added join edge (also fillable as a loop). +-- +-- When a specific Backend B is in scope, drawRoundPiece:: Piece -> Diagram B +drawRoundPiece :: Renderable (Path V2 Double) b => + Piece -> Diagram2D b +drawRoundPiece = strokeLoop . closeLine . fromOffsets . pieceEdges + +-- |draw join edge only. +-- +-- When a specific Backend B is in scope, drawJoin:: Piece -> Diagram B +drawJoin :: Renderable (Path V2 Double) b => + Piece -> Diagram2D b +drawJoin piece = strokeLine $ fromOffsets [joinVector piece] + +-- |fillOnlyPiece col piece - fills piece with colour col without drawing any lines. +-- +-- When a specific Backend B is in scope, fillOnlyPiece:: Colour Double -> Piece -> Diagram B +fillOnlyPiece :: Renderable (Path V2 Double) b => + Colour Double -> Piece -> Diagram2D b +fillOnlyPiece col piece = drawRoundPiece piece # fc col # lw none + +-- |fillPieceDK dcol kcol piece - draws and fills the half-tile piece +-- with colour dcol for darts and kcol for kites. +-- Note the order D K. +-- +-- When a specific Backend B is in scope, fillPieceDK:: Colour Double -> Colour Double -> Piece -> Diagram B +fillPieceDK :: Renderable (Path V2 Double) b => + Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram2D b +fillPieceDK dcol kcol piece = drawPiece piece <> fillOnlyPiece col piece where + col = case piece of (LD _) -> dcol + (RD _) -> dcol + (LK _) -> kcol + (RK _) -> kcol + +-- |fillMaybePieceDK d k piece - draws the half-tile piece and possibly fills as well: +-- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol +-- Nothing indicates no fill for either darts or kites or both. +-- +-- When a specific Backend B is in scope, fillMaybePieceDK:: Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram B +fillMaybePieceDK :: Renderable (Path V2 Double) b => + Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram2D b +fillMaybePieceDK d k piece = drawPiece piece <> filler where + maybeFill (Just c) = fillOnlyPiece c piece + maybeFill Nothing = mempty + filler = case piece of (LD _) -> maybeFill d + (RD _) -> maybeFill d + (LK _) -> maybeFill k + (RK _) -> maybeFill k + + +-- |leftFillPieceDK dcol kcol pc fills the whole tile when pc is a left half-tile, +-- darts are filled with colour dcol and kites with colour kcol. +-- (Right half-tiles produce nothing, so whole tiles are not drawn twice). +-- +-- When a specific Backend B is in scope, leftFillPieceDK:: Colour Double -> Colour Double -> Piece -> Diagram B +leftFillPieceDK :: Renderable (Path V2 Double) b => + Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram2D b +leftFillPieceDK dcol kcol pc = + case pc of (LD _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fc dcol + (LK _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fc kcol + _ -> mempty + +-- |experiment uses a different rule for drawing half tiles. +-- This clearly displays the larger kites and darts. +-- Half tiles are first drawn with dashed lines, then certain edges are overlayed to emphasise them. +-- Half darts have the join edge emphasised in red, while +-- Half kites have the long edge emphasised in black. +-- +-- When a specific Backend B is in scope, experiment:: Piece -> Diagram B +experiment:: Renderable (Path V2 Double) b => + Piece -> Diagram2D b +experiment piece = emph piece <> (drawRoundPiece piece # dashingN [0.003,0.003] 0 # lw ultraThin) + --emph pc <> (drawRoundPiece pc # dashingO [1,2] 0 # lw ultraThin) + where emph pc = case pc of + (LD v) -> (strokeLine . fromOffsets) [v] # lc red -- emphasise join edge of darts in red + (RD v) -> (strokeLine . fromOffsets) [v] # lc red + (LK v) -> (strokeLine . fromOffsets) [rotate (ttangle 1) v] -- emphasise long edge for kites + (RK v) -> (strokeLine . fromOffsets) [rotate (ttangle 9) v] + + + +-- |A patch is a list of Located pieces (the point associated with each piece locates its originV) +-- Patches are Transformable +type Patch = [Located Piece] + +-- | A class for things that can be turned to diagrams when given a function to draw pieces. +class Drawable a where +-- When a specific Backend B is in scope, drawWith :: Drawable a => (Piece -> Diagram B) -> a -> Diagram B + drawWith :: Renderable (Path V2 Double) b => + (Piece -> Diagram2D b) -> a -> Diagram2D b + +-- | Patches are drawable +instance Drawable Patch where + drawWith = drawPatchWith where + -- turn a patch into a diagram using the first argument for drawing pieces. + -- drawPatchWith:: (Piece -> Diagram B) -> Patch -> Diagram B + drawPatchWith pd = position . fmap (viewLoc . mapLoc pd) + +-- | the main default case for drawing using drawPiece. +-- +-- When a specific Backend B is in scope, draw :: Drawable a => a -> Diagram B +draw :: (Drawable a, Renderable (Path V2 Double) b) => + a -> Diagram2D b +draw = drawWith drawPiece + +-- | alternative default case for drawing adding dashed lines for join edges. +-- +-- When a specific Backend B is in scope, drawj :: Drawable a => a -> Diagram B +drawj :: (Drawable a, Renderable (Path V2 Double) b) => + a -> Diagram2D b +drawj = drawWith dashjPiece + +fillDK, fillKD :: (Drawable a, Renderable (Path V2 Double) b) => + Colour Double -> Colour Double -> a -> Diagram2D b +-- |fillDK dcol kcol a - draws and fills a with colour dcol for darts and kcol for kites. +-- Note the order D K. +-- +-- When a specific Backend B is in scope, fillDK:: Drawable a => Colour Double -> Colour Double -> a -> Diagram B +fillDK c1 c2 = drawWith (fillPieceDK c1 c2) + +-- |fillKD kcol dcol a - draws and fills a with colour kcol for kites and dcol for darts. +-- Note the order K D. +-- +-- When a specific Backend B is in scope, fillKD:: Drawable a => Colour Double -> Colour Double -> a -> Diagram B +fillKD c1 c2 = fillDK c2 c1 + +-- |fillMaybeDK c1 c2 a - draws a and maybe fills as well: +-- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol +-- Nothing indicates no fill for either darts or kites or both +-- Note the order D K. +-- +-- When a specific Backend B is in scope, fillMaybeDK:: Drawable a => Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram B +fillMaybeDK :: (Drawable a, Renderable (Path V2 Double) b) => + Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram2D b +fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2) + +-- |colourDKG (c1,c2,c3) p - fill in a drawable with colour c1 for darts, colour c2 for kites and +-- colour c3 for grout (that is, the non-join edges). +-- Note the order D K G. +-- +-- When a specific Backend B is in scope, colourDKG:: Drawable a => (Colour Double,Colour Double,Colour Double) -> a -> Diagram B +colourDKG :: (Drawable a, Renderable (Path V2 Double) b) => + (Colour Double,Colour Double,Colour Double) -> a -> Diagram2D b +colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lc c3 + +-- |colourMaybeDKG (d,k,g) a - draws a and possibly fills as well: +-- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol +-- Nothing indicates no fill for either darts or kites or both +-- The g argument is for grout - i.e the non-join edges round tiles. +-- Edges are drawn with gcol if g = Just gcol and not drawn if g = Nothing. +-- +-- When a specific Backend B is in scope, colourMaybeDKG:: Drawable a => (Maybe (Colour Double), Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram B +colourMaybeDKG:: (Drawable a, Renderable (Path V2 Double) b) => + (Maybe (Colour Double), Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram2D b +colourMaybeDKG (d,k,g) a = fillMaybeDK d k a # maybeGrout g where + maybeGrout (Just c) = lc c + maybeGrout Nothing = lw none + + + +{-| +Decomposing splits each located piece in a patch into a list of smaller located pieces to create a refined patch. +(See also decompose in Tgraph.Decompose.hs for a more abstract version of this operation). +-} +decompPatch :: Patch -> Patch +decompPatch = concatMap decompPiece + +-- |Decomposing a located piece to a list of (2 or 3) located pieces at smaller scale. +decompPiece :: Located Piece -> [Located Piece] +decompPiece lp = case viewLoc lp of + (p, RD vd)-> [ LK vd `at` p + , RD vd' `at` (p .+^ v') + ] where v' = phi*^rotate (ttangle 1) vd + vd' = (2-phi) *^ negated v' -- (2-phi) = 1/phi^2 + (p, LD vd)-> [ RK vd `at` p + , LD vd' `at` (p .+^ v') + ] where v' = phi*^rotate (ttangle 9) vd + vd' = (2-phi) *^ negated v' -- (2-phi) = 1/phi^2 + (p, RK vk)-> [ RD vd' `at` p + , LK vk' `at` (p .+^ v') + , RK vk' `at` (p .+^ v') + ] where v' = rotate (ttangle 9) vk + vd' = (2-phi) *^ v' -- (2-phi) = 1/phi^2 + vk' = ((phi-1) *^ vk) ^-^ v' -- (phi-1) = 1/phi + (p, LK vk)-> [ LD vd' `at` p + , RK vk' `at` (p .+^ v') + , LK vk' `at` (p .+^ v') + ] where v' = rotate (ttangle 1) vk + vd' = (2-phi) *^ v' -- (2-phi) = 1/phi^2 + vk' = ((phi-1) *^ vk) ^-^ v' -- (phi-1) = 1/phi + +-- |Create an infinite list of increasing decompositions of a patch +decompositionsP:: Patch -> [Patch] +decompositionsP = iterate decompPatch + +{-| +compChoices applied to a single located piece produces a list of alternative located pieces NOT a Patch. +Each of these is a larger scale single piece with a location such that when decomposed +the original piece in its original position is part of the decomposition) +-} +compChoices :: Located Piece -> [Located Piece] +compChoices lp = case viewLoc lp of + (p, RD vd)-> [ RD vd' `at` (p .+^ v') + , RK vk `at` p + ] where v' = (phi+1) *^ vd -- vd*phi^2 + vd' = rotate (ttangle 9) (vd ^-^ v') + vk = rotate (ttangle 1) v' + (p, LD vd)-> [ LD vd' `at` (p .+^ v') + , LK vk `at` p + ] where v' = (phi+1) *^ vd -- vd*phi^2 + vd' = rotate (ttangle 1) (vd ^-^ v') + vk = rotate (ttangle 9) v' + (p, RK vk)-> [ LD vk `at` p + , LK lvk' `at` (p .+^ lv') + , RK rvk' `at` (p .+^ rv') + ] where lv' = phi*^rotate (ttangle 9) vk + rv' = phi*^rotate (ttangle 1) vk + rvk' = phi*^rotate (ttangle 7) vk + lvk' = phi*^rotate (ttangle 3) vk + (p, LK vk)-> [ RD vk `at` p + , RK rvk' `at` (p .+^ rv') + , LK lvk' `at` (p .+^ lv') + ] where lv' = phi*^rotate (ttangle 9) vk + rv' = phi*^rotate (ttangle 1) vk + rvk' = phi*^rotate (ttangle 7) vk + lvk' = phi*^rotate (ttangle 3) vk + +-- |compNChoices n lp - gives a list of all the alternatives after n compChoices starting with lp +-- Note that the result is not a Patch as the list represents alternatives. +compNChoices :: Int -> Located Piece -> [Located Piece] +compNChoices 0 lp = [lp] +compNChoices n lp = do + lp' <- compChoices lp + compNChoices (n-1) lp' + + + +-- |combine 5 copies of a patch (each rotated by ttangle 2 successively) +-- (ttAngle 2 is 72 degrees) +-- Must be used with care to avoid creating a nonsense patch +penta:: Patch -> Patch +penta p = concatMap copy [0..4] + where copy n = rotate (ttangle (2*n)) p + +sun,star::Patch +-- |sun is a patch with five kites sharing common origin (base of kite) +sun = penta [rkite `at` origin, lkite `at` origin] +-- |star is a patch with five darts sharing common origin (tip of dart) +star = penta [rdart `at` origin, ldart `at` origin] + + +-- |An infinite list of patches of increasingly decomposed sun +suns::[Patch] +suns = decompositionsP sun +sun5,sun6:: Patch +-- |a patch of a 6 times decomposed sun +sun6 = suns!!6 +-- |a patch of a 5 times decomposed sun +sun5 = suns!!5 + + + -- * Diagrams of Patches + +-- |diagram for sun6. +-- +-- When a specific Backend B is in scope, sun6Fig::Diagram B +sun6Fig :: Renderable (Path V2 Double) b => Diagram2D b +sun6Fig = draw sun6 # lw thin + + +-- |Colour filled using leftFillPieceDK. +-- +-- When a specific Backend B is in scope, leftFilledSun6::Diagram B +leftFilledSun6 :: Renderable (Path V2 Double) b => Diagram2D b +leftFilledSun6 = drawWith (leftFillPieceDK red blue) sun6 # lw thin + +-- |Colour filled using fillDK. +-- +-- When a specific Backend B is in scope, filledSun6::Diagram B +filledSun6 :: Renderable (Path V2 Double) b => Diagram2D b +filledSun6 = fillDK darkmagenta indigo sun6 # lw thin # lc gold + + + + +-- |rotations takes a list of integers (representing ttangles) for respective rotations of items in the second list (things to be rotated). +-- This includes Diagrams, Patches, VPatches. +-- The integer list can be shorter than the list of items - the remaining items are left unrotated. +-- It will raise an error if the integer list is longer than the list of items to be rotated. +-- (Rotations by an angle are anti-clockwise) + +rotations :: (Transformable a, V a ~ V2, N a ~ Double) => [Int] -> [a] -> [a] +rotations (n:ns) (d:ds) = rotate (ttangle n) d: rotations ns ds +rotations [] ds = ds +rotations _ [] = error "rotations: too many rotation integers" + +-- |scales takes a list of doubles for respective scalings of items in the second list (things to be scaled). +-- This includes Diagrams, Pieces, Patches, VPatches. +-- The list of doubles can be shorter than the list of items - the remaining items are left unscaled. +-- It will raise an error if the integer list is longer than the list of items to be scaled. +scales :: (Transformable a, V a ~ V2, N a ~ Double) => [Double] -> [a] -> [a] +scales (s:ss) (d:ds) = scale s d: scales ss ds +scales [] ds = ds +scales _ [] = error "scales: too many scalars" + +-- |increasing scales by a factor of phi along a list starting with 1. +phiScales:: (Transformable a, V a ~ V2, N a ~ Double) => [a] -> [a] +phiScales = phiScaling 1 + +-- |increasing scales by a factor of phi along a list starting with given first argument +phiScaling:: (Transformable a, V a ~ V2, N a ~ Double) => Double -> [a] -> [a] +phiScaling _ [] = [] +phiScaling s (d:more) = scale s d: phiScaling (phi*s) more + + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,135 @@ +import Test.Hspec +import Control.Exception (evaluate) + +import Tgraphs +import TgraphExamples +-- import TestIllustrate (touchErrorFaces,testCrossingBoundary) +main :: IO () +main = hspec spec + +spec :: Spec +spec = do graphPropSpec + graphOpSpec + graphLabelCheck +-- Example lists of tile-faces + +x0,x1,x2,x3,x4,x5 :: [TileFace] +-- x0 has a face with a repeated vertex +x0 = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13) + ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,14,14),RK (7,14,12) + ] + +-- x1 has crossing boundaries +x1 = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13) + ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,4,14),RK (7,14,12) + ] + +-- x2 is not connected +x2 = x1 ++ [LK (15,16,17),RK (15,17,18)] + +-- x3 has edge conflicts +x3 = [LK (3,8,1),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13) + ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,4,14),RK (7,14,12) + ] + +-- x4 has edge conflicts +x4 = [LD(1,2,3),RD(1,4,2),RD(4,1,5),LD(4,5,6)] + +-- x5 has enon-positive vertex number +x5 = [LD(0,1,2)] + +-- dD6 is a 6 times decomposed dartGraph +dD6 :: Tgraph +dD6 = dartDs !!6 + +{-|touchErrorFaces is an addition of 2 faces to those of foolD which contains touching vertices. +These will be caught by makeTgraph which raises an error. +The error is not picked up by checkedTgraph. It can be fixed using tryCorrectTouchingVs. + +*** Exception: makeTgraph: touching vertices [(19,7)] + +> checkedTgraph touchErrorFaces +Tgraph {maxV = 19, faces = ...} + +> tryCorrectTouchingVs touchErrorFaces +Right (Tgraph {maxV = 18, faces = [..., LK (7,17,18)]}) + +test with: +padBorder $ drawjLabelled $ runTry $ tryCorrectTouchingVs touchErrorFaces +-} +touchErrorFaces::[TileFace] +touchErrorFaces = faces foolD ++ [RD (6,18,17),LK (19,17,18)] + +-- |Example for testing crossing boundary detection e.g. using +-- checkedTgraph testCrossingBoundary, or by using +-- force (makeUncheckedTgraph testCrossingBoundary) +-- produces an error for a non-valid Tgraph. +testCrossingBoundary :: [TileFace] +testCrossingBoundary = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13),RD (6,13,10) + ,LK (3,2,13),RK (3,13,11),RK (3,14,4),LK (3,11,14),LK (7,4,14),RK (7,14,12) + ] + + +graphPropSpec :: Spec +graphPropSpec = describe "Test Properties of Tgraphs" $ do + context "When fcs (a list of tile-faces) has any face with a repeated vertex" $ + it "hasEdgeLoops fcs should return True" $ + hasEdgeLoops x0 `shouldBe` True + context "When fcs has no face with a repeated vertex" $ + it "hasEdgeLoops fcs should return False" $ + hasEdgeLoops x1 `shouldBe` False + context "When fcs has crossing boundaries" $ + it "crossingBoundaries fcs should return True" $ + crossingBoundaries x1 `shouldBe` True + context "When fcs has no crossing boundaries" $ + it "crossingBoundaries fcs should return False" $ + crossingBoundaries (faces foolD) `shouldBe` False + context "When fcs are connected" $ + it "connected fcs should return True" $ + connected x1 `shouldBe` True + context "When fcs are not connected" $ + it "connected fcs should return False" $ + connected x2 `shouldBe` False + context "When fcs has illegal edge conflicts" $ + it "illegalTiling fcs should return True" $ + illegalTiling x3 `shouldBe` True + context "When fcs has illegal edge conflicts" $ + it "illegalTiling fcs should return True" $ + illegalTiling x4 `shouldBe` True + context "When fcs has no illegal edge conflicts" $ + it "illegalTiling fcs should return False" $ + illegalTiling x1 `shouldBe` False + context "When fcs contains a non-positive vertex number" $ + it "makeTgraph fcs should throw an exception" $ do + evaluate (makeTgraph x5) `shouldThrow` anyException + context "When fcs have a touching vertex" $ + it "makeTgraph fcs should throw an exception" $ do + evaluate (makeTgraph touchErrorFaces) `shouldThrow` anyException + context "When fcs do not form a valid Tgraph" $ + it "makeTgraph fcs should throw an exception" $ do + evaluate (makeTgraph testCrossingBoundary) `shouldThrow` anyException + +graphOpSpec :: Spec +graphOpSpec = describe "Main Tgraph Operations Test" $ do + context "Decomposition of Tgraphs" $ + it "Number of faces of dartDs !!6 should be 466" $ + length(faces dD6) `shouldBe` 466 + context "Composing Tgraphs" $ + it "Number of faces of maxCompForce (dartDs !!6) should be 6" $ + length(faces(maxCompForce dD6)) `shouldBe` 6 + context "Forcing Tgraphs" $ + it "Number of faces of force (dartDs !!6) should be 7546" $ + length(faces(force dD6)) `shouldBe` 7546 + +graphLabelCheck :: Spec +graphLabelCheck = describe "Label critical examples check" $ do + context "boundaryGapFDart4" $ + it "Number of faces of boundaryGapFDart4 should be 180" $ + length(faces boundaryGapFDart4) `shouldBe` 180 + context "boundaryGapFDart5" $ + it "Number of faces of boundaryGapFDart5 should be 316" $ + length(faces boundaryGapFDart5) `shouldBe` 316 + context "superForceFig" $ + it "Number of faces of superForceFig should be 349" $ + length (faces(addHalfDart (220,221) $ force $ decompositions fool !!3)) `shouldBe` 349 +