diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,109 @@ # Revision history for PenroseKiteDart +## version 1.4 -- 2025-6-12 + +Changed module Tgraphs to module Tgraph.Extras + +### New HasFaces class + +Introduced to define common functions for +[TileList], Tgraph, VPatch, BoundaryState, Forced + +Breaking Name Changes for + nullGraph -> nullFaces + graphBoundary -> boundary + facesBoundary -> boundary + graphDedges -> dedges + facesDedges -> dedges + facesVSet -> vertexSet + facesMaxV -> maxV + graphBoundaryVs -> boundaryVs + boundaryVertexSet -> vertexSet + facesEdges -> completeEdges + graphEdges -> completeEdges + boundaryLoopsG -> boundaryLoops + graphEFMap -> buildEFMap + + Also changed selector in BoundaryState to boundaryDedges (but note boundary generalised) + +Generalised (to use HasFaces) + boundary + faces + maxV + vertexSet + boundaryVs + internalEdges + phiEdges + nonPhiEdges + vertexFacesMap + dedgesFacesMap + buildEFMap + extractLowestJoin + lowestJoin + locateVertices + locateVerticesGen + touchingVertices + boundaryEdgeSet + commonBdry + boundaryVertexSet + internalVertexSet + boundaryLoops + evalFaces + ldarts,rdarts,lkites,rkites, kites, darts + crossingBVs + crossingBoundaries + connected + defaultAlignment + findEdgeLoops + hasEdgeLoops + conflictingDedges + +Breaking: No longer exported: +findLoops, axisJoin, drawEdge (use drawLocatedEdge), drawEdges (use drawLocatedEdges), +crossingVertices, tryFindThirdV, makeGenerator (use newUpdateGenerator) + +### Try changed +Changed the type for Try to use ShowS instead of String +(ShowS = String -> String) + +New: failReport, failReports, tryAtLeastOne + +Breaking: + Occurrences of + Left s :: Try a + need to be replaced by + failReport s + or + Left (s<>) + +An instance of Show(ShowS) is provided in order to show Try results + +### Changes to Forced + +Forced is no longer a Functor. + +Instead, 4 specific safe cases for changing a Forced Forcible +(New) +recoverGraphF,boundaryStateF,makeBoundaryStateF,initFSF + +Data constructor Forced is no longer exported but +(New) +labelAsForced :: a -> Forced a (for use only when the argument is known to be forced) + +(New) +tryDartAndKiteF - version of tryDartAndKiteForced with explicitly forced results. +tryCheckCasesDKF, checkCasesDKF - special case to report any counter example found +when trying to add a dart and kite to a boundary edge of an explicitly Forced forcible. + +Removed warning pragma for makeUncheckedTgraph + ## version 1.3 -- 2025-5-19 +(New) +Introduced newtype operator Forced +to enable restricting functions which require a forced argument. +Forced a is an explicitly forced version of a. + Breaking changes: Removed: @@ -28,10 +130,6 @@ Other changes: (New) -Introduced newtype operator Forced -to enable restricting functions which require a forced argument. -Forced a is an explicitly forced version of a. - forgetF :: Forced a -> a (to unwrap explicitly Forced) tryForceF (to create explicitly Forced) forceF (to create explicitly Forced) diff --git a/PenroseKiteDart.cabal b/PenroseKiteDart.cabal --- a/PenroseKiteDart.cabal +++ b/PenroseKiteDart.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: PenroseKiteDart -version: 1.3 +version: 1.4 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 @@ -32,12 +32,12 @@ HalfTile TileLib Try - Tgraphs Tgraph.Prelude Tgraph.Decompose Tgraph.Compose Tgraph.Force Tgraph.Relabelling + Tgraph.Extras TgraphExamples other-modules: Paths_PenroseKiteDart @@ -48,7 +48,7 @@ base >=4.7 && <5 , containers >=0.6.7 && <0.7 , diagrams-lib >=1.4.6 && <1.5 - default-language: Haskell2010 + default-language: GHC2021 test-suite PenroseKiteDart-test type: exitcode-stdio-1.0 @@ -64,7 +64,7 @@ , containers >=0.6.7 && <0.7 , diagrams-lib >=1.4.6 && <1.5 , hspec >=2.10.10 && <2.12 - default-language: Haskell2010 + default-language: GHC2021 benchmark PenroseKiteDart-bench type: exitcode-stdio-1.0 @@ -79,4 +79,4 @@ , base >=4.7 && <5 , containers >=0.6.7 && <0.7 , diagrams-lib >=1.4.6 && <1.5 - default-language: Haskell2010 + default-language: GHC2021 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Author: Chris Reade -March 2021 - 2024 +March 2021 - 2025 See LICENSE file @@ -10,7 +10,7 @@ Penrose\'s kite and dart tiles have the property that they can tile the entire plane aperiodicly. There are rules to ensure legal tilings with the kites and darts. -Legal tilings can still get stuck (so cannot be continued to cover the entire plane) - these are called incorrect. +Legal tilings can still get stuck (so cannot be continued to cover the entire plane) - these are called incorrect tilings. This package is a Haskell library of tools to build, draw and explore finite tilings with kites and darts, making use of the Haskell Diagrams package. @@ -74,14 +74,17 @@ ## Modules -Module `PKD` is the main module which imports and re-exports `Tgraphs` and `TileLib`. -`Tgraphs` imports and re-exports the contents of the other Tgraph modules, namely -`Tgraph.Compose`, `Tgraph.Decompose`, `Tgraph.Force`, `Tgraph.Relabelling`, `Tgraph.Prelude`. -`TileLib` contains underlying drawing tools for tiles. -`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`). +Module `PKD` is the main module which imports and re-exports everything. +That is, module `TileLib` and the Tgraph modules +`Tgraph.Compose`, `Tgraph.Decompose`, `Tgraph.Force`, `Tgraph.Relabelling`, `Tgraph.Prelude`, `Tgraph.Extras`. + +`Try` is imported and re-exported by `Tgraph.Prelude` (used for results of partial functions). + +`HalfTile` is imported and re-exported by `Tgraph.Prelude` (with the constructors `LD`,`RD`,`LK`,`RK`). + `CheckBackend` is imported by `TileLib` which rexports class `OKBackend`. (The constraint `OKBackend b =>` is used extensively in the library to abstract types from any particular Backend). + `TgraphExamples` contains example Tgraphs and Diagrams. ## Further Information diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -1,4 +1,4 @@ -import Tgraphs +import PKD import TgraphExamples import Debug.Trace (traceMarkerIO) import Control.Concurrent (threadDelay) @@ -18,16 +18,15 @@ _ <- traceMarkerIO "finished decomposing" wait _ <- traceMarkerIO "starting force" - let fkD = {-# SCC "forcingKD" #-} force kD + let fkD = {-# SCC "forcingKD" #-} forceF kD putStrLn $ "Number of faces of force (" ++ sn ++ " times decomposed King) is " - ++ show (length (faces fkD)) + ++ show (length $ faces $ forgetF fkD) putStrLn $ "Max vertex of force (" ++ sn ++ " times decomposed King) is " - ++ show (maxV fkD) + ++ show (maxV $ forgetF fkD) _ <- traceMarkerIO "finished force" wait _ <- traceMarkerIO "starting (unchecked) composing" - let cfkD = {-# SCC "composing" #-} forgetF $ last $ takeWhile (not . nullGraph . forgetF) $ iterate composeF $ Forced fkD - -- let cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate uncheckedCompose fkD + let cfkD = {-# SCC "composing" #-} forgetF $ last $ takeWhile (not . nullFaces . forgetF) $ iterate composeF fkD putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is " ++ show (length (faces cfkD)) putStrLn $ "Max vertex of recomposed force (" ++ sn ++ " times decomposed King) is " diff --git a/src/CheckBackend.hs b/src/CheckBackend.hs --- a/src/CheckBackend.hs +++ b/src/CheckBackend.hs @@ -25,7 +25,9 @@ import Diagrams.TwoD.Text (Text) --- |Class OKBackend is a class synonym for suitable constraints on Backends for drawing tilings. +{-|Class OKBackend is a class synonym for a collection of constraints on a Backend b suitable for +drawing tiles. That is 2 dimensional with Real numbers (Double) able to render paths and text. +-} class (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) => OKBackend b where {} diff --git a/src/PKD.hs b/src/PKD.hs --- a/src/PKD.hs +++ b/src/PKD.hs @@ -1,28 +1,48 @@ {-| Module : PKD -Description : A wrapper module including Tgraphs and TileLib +Description : The main module which re-exports everything except TgraphExamples Copyright : (c) Chris Reade, 2024 License : BSD-style Maintainer : chrisreade@mac.com Stability : experimental -This is the main module to re-export both Tgraphs and TileLib (which includes Halftile) modules. -However it does not export the data constructor Forced (only the newtype operator). -There is a warning about using makeUncheckedTgraph. +This is the main module (PKD for PenroseKiteDart) which re-exports + TileLib +and all the Tgraph modules + Tgraph.Prelude, + Tgraph.Decompose, + Tgraph.Compose, + Tgraph.Force, + Tgraph.Relabelling + Tgraph.Extras + +(Everything except TgraphExamples) -} - -module PKD ( module Tgraphs - , module TileLib - , makeUncheckedTgraph - ) where +module PKD + ( -- * Pieces, Patches and Drawable Class + module TileLib + -- * Tgraphs, TileFaces, VPatches ... plus HalfTile and Try Modules + , module Tgraph.Prelude + -- * Decomposing Tgraphs + , module Tgraph.Decompose + -- * Composing Tgraphs + , module Tgraph.Compose + -- * Forcing Tgraphs + , module Tgraph.Force + -- * Relabelling Tgraphs plus guided equality, union, common faces + , module Tgraph.Relabelling + -- * Smart drawing of Tgraphs and other extras + , module Tgraph.Extras + + ) where + import TileLib -import Tgraphs hiding (makeUncheckedTgraph, Forced(..)) -- hides data constructor -import Tgraphs (Forced) -- import Type only -import qualified Tgraphs as Unchecked (makeUncheckedTgraph) +import Tgraph.Prelude +import Tgraph.Decompose +import Tgraph.Compose +import Tgraph.Relabelling +import Tgraph.Force +import Tgraph.Extras -{-# WARNING makeUncheckedTgraph "Bypasses checks for required Tgraph properties. Use makeTgraph instead" #-} --- |Now has a warning. -makeUncheckedTgraph :: [TileFace] -> Tgraph -makeUncheckedTgraph = Unchecked.makeUncheckedTgraph diff --git a/src/Tgraph/Compose.hs b/src/Tgraph/Compose.hs --- a/src/Tgraph/Compose.hs +++ b/src/Tgraph/Compose.hs @@ -14,10 +14,11 @@ module Tgraph.Compose ( compose + , composeF , partCompose , partComposeF - , composeF , tryPartCompose + -- * Exported auxiliary functions (and type) , partComposeFaces -- , partComposeFacesF , DartWingInfo(..) @@ -32,7 +33,7 @@ import qualified Data.IntSet as IntSet (empty,insert,toList,member) import Tgraph.Prelude -import Tgraph.Force ( Forced(..), forgetF ) +import Tgraph.Force ( Forced(), forgetF, labelAsForced ) {------------------------------------------------------------------------- *************************************************************************** COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose @@ -60,7 +61,7 @@ tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = do let (remainder,newFaces) = partComposeFaces g - checked <- onFail "tryPartCompose:/n" $ tryConnectedNoCross newFaces + checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces return (remainder,checked) -- |partComposeFaces g - produces a pair of the remainder faces (faces from g which will not compose) @@ -86,7 +87,7 @@ -- Since fg is a forced Tgraph it does not need a check for validity of the composed Tgraph. -- The fact that the result is also Forced relies on a theorem. partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph) -partComposeF fg = (remainder, Forced $ makeUncheckedTgraph $! evalFaces newfaces) where +partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph $! evalFaces newfaces) where (remainder,newfaces) = partComposeFacesF fg -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph. diff --git a/src/Tgraph/Decompose.hs b/src/Tgraph/Decompose.hs --- a/src/Tgraph/Decompose.hs +++ b/src/Tgraph/Decompose.hs @@ -14,6 +14,7 @@ module Tgraph.Decompose ( decompose , decompositions + -- * Exported auxiliary functions , phiVMap , decompFace ) where diff --git a/src/Tgraph/Extras.hs b/src/Tgraph/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Tgraph/Extras.hs @@ -0,0 +1,769 @@ +{-| +Module : Tgraph.Extras +Description : Additional Tgraph functions +Copyright : (c) Chris Reade, 2024 +License : BSD-style +Maintainer : chrisreade@mac.com +Stability : experimental + +This module defines several functions for producing overlaid diagrams for Tgraphs +(including smart drawing) and combinations such as compForce, +experimental combinations such as +boundaryECovering, boundaryVCovering, empire1, empire2, superForce, boundaryLoopsG. + +It also defines experimental TrackedTgraphs (used for tracking subsets of faces of a Tgraph). + +-} + +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch +{-# LANGUAGE TupleSections #-} + +module Tgraph.Extras + ( smart + , boundaryJoinFaces + , drawBoundaryJoins + , 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 + -- * Boundary Covering and Empires + , forcedBoundaryECovering + , forcedBoundaryVCovering + , boundaryECovering + , boundaryVCovering + , tryDartAndKite + , tryDartAndKiteForced + , tryDartAndKiteF + , tryCheckCasesDKF + , checkCasesDKF + , boundaryEdgeSet + , commonBdry + , boundaryVertexSet + , internalVertexSet + , drawFBCovering + , empire1 + , empire2 + , empire2Plus + , drawEmpire + , showEmpire1 + , showEmpire2 + -- * Super Force with boundary edge covers + , superForce + , trySuperForce + , singleChoiceEdges + -- * Boundary face graph + , tryBoundaryFaceGraph + -- * Boundary loops + , boundaryLoops + -- , findLoops + , pathFromBoundaryLoops + -- * TrackedTgraphs + , TrackedTgraph(..) + , newTrackedTgraph + , makeTrackedTgraph + , trackFaces + , unionTwoTracked + -- * Forcing and Decomposing TrackedTgraphs + , addHalfDartTracked + , addHalfKiteTracked + , decomposeTracked + -- * Drawing TrackedTgraphs + , drawTrackedTgraph + , drawTrackedTgraphRotated + , drawTrackedTgraphAligned + ) where + +import TileLib +import Tgraph.Prelude +import Tgraph.Decompose +import Tgraph.Compose +import Tgraph.Relabelling +import Tgraph.Force + +import Diagrams.Prelude hiding (union) +import Data.List (intersect, union, (\\), find, foldl', transpose) +import qualified Data.Set as Set (Set,fromList,null,intersection,deleteFindMin)-- used for boundary covers +import qualified Data.IntSet as IntSet (fromList,member,(\\)) -- for boundary vertex set +import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops +import qualified Data.Maybe (fromMaybe) + +-- |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 +smart :: OKBackend b => + (VPatch -> Diagram b) -> Tgraph -> Diagram b +smart dr g = drawBoundaryJoins 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 + +-- |draw boundary join edges of a Tgraph using a given VPatch +drawBoundaryJoins :: OKBackend b => Tgraph -> VPatch -> Diagram b +drawBoundaryJoins g vp = drawEdgesVP vp (map joinE $ boundaryJoinFaces g) # joinDashing + +-- |Given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces. +-- Will raise an error if any vertex in the faces does not have a location in the VPatch. +drawJoinsFor:: OKBackend b => + [TileFace] -> VPatch -> Diagram b +drawJoinsFor fcs vp = drawWith dashjOnly (restrictVP vp fcs) + +-- |same as draw except adding dashed lines on boundary join edges. +smartdraw :: OKBackend b => Tgraph -> Diagram b +smartdraw = smart draw + +-- |restrictSmart g dr vp - assumes vp has locations for vertices in g. +-- It uses the VPatch drawing function dr to draw g and adds dashed boundary joins. +-- This can be used instead of smart when an appropriate vp is already available. +restrictSmart :: OKBackend b => + Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b +restrictSmart g dr vp = drawBoundaryJoins 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 +smartRotateBefore :: OKBackend b => + (VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b +smartRotateBefore vfun angle g = rotateBefore (restrictSmart g vfun) angle g + +-- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore. +-- Uses vfun to produce a Diagram after converting g to an aligned VPatch but also adds the dashed boundary join edges of g. +-- +-- Example: smartAlignBefore (labelled draw) (a,b) g +smartAlignBefore :: OKBackend b => + (VPatch -> Diagram b) -> (Vertex,Vertex) -> Tgraph -> Diagram b +smartAlignBefore vfun (a,b) g = alignBefore (restrictSmart g vfun) (a,b) g + +-- |applies partCompose to a Tgraph g, then draws the composed graph along with the remainder faces (in lime). +-- (Relies on the vertices of the composition and remainder being subsets of the vertices of g.) +-- This will raise an error if the composed faces have a crossing boundary or are disconnected. +drawPCompose :: OKBackend b => + Tgraph -> Diagram 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. +-- It will raise an error if the force fails with an incorrect/stuck Tgraph +drawForce :: OKBackend b => + Tgraph -> Diagram 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. +-- It will raise an error if the initial force fails with an incorrect/stuck Tgraph +drawSuperForce :: OKBackend b => + Tgraph -> Diagram b +drawSuperForce g = (dg # lc red) <> dfg <> (dsfg # lc blue) where + fg = force g + sfg = superForce fg + vp = makeVP sfg + dfg = draw $ selectFacesVP vp (faces fg \\ faces g) -- restrictSmart (force g) draw vp + dg = restrictSmart g draw vp + dsfg = draw $ selectFacesVP vp (faces sfg \\ faces fg) + +-- | drawWithMax g - draws g and overlays the maximal composition of force g in red. +-- This relies on g and all compositions of force g having vertices in force g. +-- It will raise an error if forcing fails (g is an incorrect Tgraph). +drawWithMax :: OKBackend b => + Tgraph -> Diagram b +drawWithMax g = (dmax # lc red # lw medium) <> dg where + vp = makeVP $ force g -- duplicates force to get the locations of vertices in the forced Tgraph + dg = restrictSmart g draw vp + maxg = maxCompForce g + dmax = draw $ subVP vp $ faces $ forgetF maxg + +-- |addBoundaryAfter f g - displaying the boundary of a Tgraph g in lime (overlaid on g drawn with f). +addBoundaryAfter :: OKBackend b => + (VPatch -> Diagram b) -> Tgraph -> Diagram b +addBoundaryAfter f g = (drawEdgesVP vp edges # lc lime) <> f vp where + vp = makeVP g + edges = boundary g + +-- |drawCommonFaces (g1,e1) (g2,e2) uses commonFaces (g1,e1) (g2,e2) to find the common faces +-- and emphasizes them on the background g1. +drawCommonFaces :: OKBackend b => + (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram b +drawCommonFaces (g1,e1) (g2,e2) = emphasizeFaces (commonFaces (g1,e1) (g2,e2)) g1 + +-- |emphasizeFaces fcs g emphasizes the given faces (that are in g) overlaid on the background draw g. +emphasizeFaces :: OKBackend b => + [TileFace] -> Tgraph -> Diagram b +emphasizeFaces fcs g = (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where + vp = makeVP g + emphvp = subVP vp (fcs `intersect` faces g) + + +-- | For illustrating an unsound version of composition which defaults to kites when there are unknown +-- dart wings on the boundary. +-- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph. +-- E.g. when applied to force queenGraph. +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 is a partial function similar to (compose . force), +-- i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph). +-- However it produces an explicitly Forced Tgraph, +-- and is more efficient because it omits the check for connected, and no crossing boundaries +-- (and uses getDartWingInfoForced instead of getDartWingInfo) +-- This relies on a proof that composition does not need to be checked for a forced Tgraph. +-- (We also have a proof that the result must be a forced Tgraph when the initial force succeeds.) +-- This will raise an error if the initial force fails with an incorrect Tgraph. +compForce:: Tgraph -> Forced Tgraph +compForce = composeF . forceF + + +-- |allCompForce g produces a list of the non-null iterated (forced) compositions of force g. +-- It will raise an error if the initial force fails with an incorrect Tgraph. +-- The list will be [] if g is the emptyTgraph, otherwise the list begins with force g (when the force succeeds). +-- The definition relies on (1) a proof that the composition of a forced Tgraph is forced and +-- (2) a proof that composition does not need to be checked for a forced Tgraph. +allCompForce:: Tgraph -> [Forced Tgraph] +allCompForce = takeWhile (not . nullFaces . forgetF) . iterate composeF . forceF + + +-- |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 -> Forced Tgraph +maxCompForce g | nullFaces g = labelAsForced g + | otherwise = last $ allCompForce g + + +-- | allForceDecomps g - produces an infinite list (starting with g) +-- of forced decompositions of g (raising an error if a force fails with an incorrect Tgraph). +allForceDecomps:: Tgraph -> [Tgraph] +allForceDecomps = iterate (force . decompose) + +{-| forcedBoundaryECovering g - produces a list of all boundary covers of force g. +Each boundary cover is a forced Tgraph that extends force g and covers the entire boundary directed edges of force g. +(So the boundary of force g is entirely internal edges in each boundary cover). +The covers include all possible ways faces can be added on the boundary of force g +except combinations which are found to be incorrect. +The common faces of the covers constitute an empire (level 1) of g. +This will raise an error if the initial force fails with an incorrect/stuck Tgraph. +-} +forcedBoundaryECovering:: Tgraph -> [Forced Tgraph] +forcedBoundaryECovering g = recoverGraphF <$> boundaryECovering gforcedBdry where + gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" $ + tryForceF $ 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. +This will raise an error if the initial force fails with an incorrect/stuck Tgraph. +-} +forcedBoundaryVCovering:: Tgraph -> [Forced Tgraph] +forcedBoundaryVCovering g = recoverGraphF <$> boundaryVCovering gforcedBdry where + gforcedBdry = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" $ + tryForceF $ makeBoundaryState g + +{-| boundaryECovering - for an explicitly Forced BoundaryState fbd, +produces a list of all possible covers of the boundary directed edges in fbd. +A cover is an explicitly Forced extension (of fbd) such that the original boundary directed edges of fbd 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 both choices on a boundary edge fail when forced (using atLeastOne). + +In which case, fbd represents an important counter example to the hypothesis that +successfully forced forcibles are correct. +-} +boundaryECovering:: Forced BoundaryState -> [Forced BoundaryState] +boundaryECovering forcedbs = covers [(forcedbs, boundaryEdgeSet (forgetF forcedbs))] where + covers:: [(Forced BoundaryState, Set.Set Dedge)] -> [Forced BoundaryState] + covers [] = [] + covers ((fbs,es):opens) + | Set.null es = fbs:covers opens -- bs is a completed cover + | otherwise = covers (newcases ++ opens) + where (de,des) = Set.deleteFindMin es + newcases = fmap (\b -> (b, commonBdry des (forgetF b))) + (runTry $ tryCheckCasesDKF de fbs) + + +-- |Make a set of the directed boundary edges from tilefaces +boundaryEdgeSet:: HasFaces a => a -> Set.Set Dedge +boundaryEdgeSet = Set.fromList . boundary + +-- | commonBdry des a - returns those directed edges in des that are boundary directed edges of a +commonBdry:: HasFaces a => Set.Set Dedge -> a -> Set.Set Dedge +commonBdry des a = des `Set.intersection` boundaryEdgeSet a + +{-| boundaryVCovering fbd - similar to boundaryECovering, but produces a list of all possible covers of + the boundary vertices in fbd (rather than just boundary edges). + This can raise an error if both choices on a boundary edge fail when forced (using atLeastOne). + -} +boundaryVCovering:: Forced BoundaryState -> [Forced BoundaryState] +boundaryVCovering fbd = covers [(fbd, startbds)] where + startbds = boundaryEdgeSet $ forgetF fbd + startbvs = boundaryVertexSet $ forgetF fbd +--covers:: [(Forced BoundaryState,Set.Set Dedge)] -> [Forced BoundaryState] + covers [] = [] + covers ((open,es):opens) + | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary $ forgetF open) of + Nothing -> open:covers opens + Just dedge -> covers $ fmap (,es) (runTry $ tryCheckCasesDKF dedge open) ++opens + | otherwise = covers $ fmap (\b -> (b, commonBdry des (forgetF b))) (atLeastOne $ tryDartAndKiteF de (forgetF open)) ++opens + where (de,des) = Set.deleteFindMin es + + +-- | returns the set of boundary vertices of a tilefaces +boundaryVertexSet :: HasFaces a => a -> VertexSet +boundaryVertexSet = IntSet.fromList . boundaryVs + +-- | returns the set of internal vertices of a tilefaces +internalVertexSet :: HasFaces a => a -> VertexSet +internalVertexSet a = vertexSet a IntSet.\\ boundaryVertexSet a + + +-- | 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 results 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 + ] + +-- | tryDartAndKiteF de b - returns the list of (2) results after adding a dart (respectively kite) +-- to edge de of a Forcible b and then tries forcing. +-- Each of the results is a Try of an explicitly Forced type. +tryDartAndKiteF:: Forcible a => Dedge -> a -> [Try (Forced a)] +tryDartAndKiteF de b = + [ onFail ("tryDartAndKiteF: Dart on edge: " ++ show de ++ "\n") $ + tryAddHalfDart de b >>= tryForceF + , onFail ("tryDartAndKiteF: Kite on edge: " ++ show de ++ "\n") $ + tryAddHalfKite de b >>= tryForceF + ] + +-- | tryDartAndKiteForced de b - returns the list of (2) results after adding a dart (respectively kite) +-- to edge de of a Forcible b and then tries forcing. +-- Each of the results is a Try. +tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a] +tryDartAndKiteForced de b = + [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ + tryAddHalfDart de b >>= tryForce + , onFail ("tryDartAndKiteForced: Kite on edge: " ++ show de ++ "\n") $ + tryAddHalfKite de b >>= tryForce + ] + +-- | tryCheckCasesDKF dedge fb (where fb is an explicitly forced Forcible +-- and dedge is a directed boundary edge of fb) tries to add both a half kite and a half dart to the edge +-- then tries forcing each result. +-- It returns the list of only the successful Try results provided there is AT LEAST ONE. +-- If there are no successes, this may be an important counter example +-- and it will return Left with a failure report describing the counter example +-- to the following: +-- +-- Hypothesis: A successfully forced Tgraph is correct (a correct tiling). +-- +-- (If both legal additions to a boundary edge are incorrect, +-- then the (Forced) Forcible must be incorrect). +tryCheckCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> Try [Forced a] +tryCheckCasesDKF dedge fb = + onFail ("tryCheckCasesDKF: <<< Counter Example Found!! >>>\n" + ++ "\nBoth legal extensions to directed edge " ++ show dedge + ++ " \nare incorrrect for a successfully forced Forcible.\n" + ++ "This shows a successfully forced forcible can still be incorrect\n" + ++ "which is a counter example to the hypothesis that successful forcing\n" + ++ "returns correct tilings.\n\n" + ++ "The incorrect but forced forcible is:\n" + ++ show fb + ) + $ tryAtLeastOne $ tryDartAndKiteF dedge (forgetF fb) + +-- | checkCasesDKF dedge fb (where fb is an explicitly forced Forcible +-- and dedge is a directed boundary edge of fb) tries to add both a half kite and a half dart to the edge +-- then tries forcing each result. +-- It returns the list of only the successful results provided there is AT LEAST ONE. +-- If there are no successes, this may be an important counter example +-- and it will raise an error describing the counter example +-- to the following: +-- +-- Hypothesis: A successfully forced Tgraph is correct (a correct tiling). +-- +-- (If both legal additions to a boundary edge are incorrect, +-- then the (Forced) Forcible must be incorrect). +checkCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> [Forced a] +checkCasesDKF dedge = runTry . tryCheckCasesDKF dedge + +-- |A test function to draw (as a column) the list of covers resulting from forcedBoundaryVCovering +-- for a given Tgraph. +drawFBCovering :: OKBackend b => + Tgraph -> Diagram b +drawFBCovering g = lw ultraThin $ vsep 1 (draw . forgetF <$> forcedBoundaryVCovering g) + + +-- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g. +-- Raises an error if force g fails with a stuck/incorrect Tgraph. +-- The tgraph of the result is the first boundary vertex cover of force g +-- which is arbitrarily chosen amongst the covers as the background setting, +-- 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 = + case forcedBoundaryVCovering g of + [] -> error "empire1 : no forced boundary covers found\n" + (fg0:others) -> makeTrackedTgraph g0 [fcs,faces g] where + g0 = forgetF fg0 + fcs = foldl' intersect (faces g0) $ fmap g0Intersect others + de = defaultAlignment g + g0Intersect fg1 = commonFaces (g0,de) (forgetF fg1,de) + +-- | empire2 g - produces a TrackedTgraph representing a level 2 empire of g. +-- Raises an error if force g fails with a stuck/incorrect Tgraph. +-- 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) +-- which is arbitrarily chosen amongst the (doubly-extended) covers as the background setting, +-- 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 = + case fmap (recoverGraph . forgetF) covers2 of + [] -> error "empire2: empty list of secondary boundary covers found" + (g0:others) -> makeTrackedTgraph g0 [fcs, faces g] + where fcs = foldl' intersect (faces g0) $ fmap g0Intersect others + g0Intersect g1 = commonFaces (g0,de) (g1,de) + where + covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" + $ tryForceF $ makeBoundaryState g + covers2 = concatMap boundaryECovering covers1 + de = defaultAlignment g + + +-- | empire2Plus g - produces a TrackedTgraph representing an extended level 2 empire of g +-- similar to empire2, but using boundaryVCovering instead of boundaryECovering. +-- Raises an error if force g fails with a stuck/incorrect Tgraph. +empire2Plus:: Tgraph -> TrackedTgraph +empire2Plus g = + case fmap (recoverGraph . forgetF) covers2 of + [] -> error "empire2: empty list of secondary boundary covers found" + (g0:others) -> makeTrackedTgraph g0 [fcs, faces g] + where fcs = foldl' intersect (faces g0) $ fmap g0Intersect others + g0Intersect g1 = commonFaces (g0,de) (g1,de) + where + covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" + $ tryForceF $ makeBoundaryState g + covers2 = concatMap boundaryVCovering covers1 + de = defaultAlignment g + + +-- | 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 (the background setting), with the first tracked faces +-- (the starting Tgraph) shown red, and emphasising the second tracked faces +-- (the common faces). +drawEmpire :: OKBackend b => + TrackedTgraph -> Diagram 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. +showEmpire1 :: OKBackend b => + Tgraph -> Diagram b +showEmpire1 = drawEmpire . empire1 + +-- | showEmpire2 g - produces a diagram emphasising the common faces of a doubly-extended boundary cover of force g. +-- This is drawn over one of the possible doubly-extended boundary covers and the faces of g are shown in red. +showEmpire2 :: OKBackend b => + Tgraph -> Diagram 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" $ + tryForceF fs + case singleChoiceEdges $ boundaryStateF forcedFS of + [] -> return $ forgetF forcedFS + (elpr:_) -> do extended <- addSingle elpr $ forgetF forcedFS + trySuperForceFS extended + addSingle (e,l) fs = if isDart l then tryAddHalfDart e fs else tryAddHalfKite e fs + +-- |singleChoiceEdges bd - if bd is an explicitly Forced 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 :: Forced BoundaryState -> [(Dedge,HalfTileLabel)] +singleChoiceEdges bstate = commonToCovering (forgetF <$> boundaryECovering bstate) (boundary $ forgetF 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 (_:_) ([]:_) = error "singleChoiceEdges:commonToCovering: empty list of labels" + common (e:more) ((l:ls):lls) = if all (==l) ls + then (e,l):common more lls + else common more lls + +-- |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 = Data.Maybe.fromMaybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e) + (faceForEdge e efmap) + +-- |Tries to create a new Tgraph from all faces with a boundary vertex in a Tgraph. +-- The resulting faces could have a crossing boundary and also could be disconnected if there is a hole in the starting Tgraph +-- so these conditions are checked for, producing a Try result. +tryBoundaryFaceGraph :: Tgraph -> Try Tgraph +tryBoundaryFaceGraph = tryConnectedNoCross . boundaryFaces . makeBoundaryState + + +{- -- | Returns a list of (looping) vertex trails for the boundary of a Tgraph. +-- 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 . boundary + -} +-- | 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:: HasFaces a => a -> [[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 [] = error "pathFromBoundaryLoops: empty loop found\n" + locateLoop (p:pts) = (`at` p) $ glueTrail $ trailFromVertices (p: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 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' } +-- boundaryState = boundaryState . tgraph + +-- |TrackedTgraph is in class HasFaces +instance HasFaces TrackedTgraph where + faces = faces . tgraph + boundary = boundary . faces . tgraph + maxV = maxV . faces . 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 = newfcs:tracked ttg} + where + g = tgraph ttg + g' = addHalfDart e g + newfcs = 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 = newfcs:tracked ttg} + where + g = tgraph ttg + g' = addHalfKite e g + newfcs = 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.) +-} +drawTrackedTgraph :: OKBackend b => [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b +drawTrackedTgraph drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where + vp = makeVP (tgraph ttg) + untracked = faces 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 (anticlockwise) before drawing + to ensure labels are not rotated. +-} +drawTrackedTgraphRotated :: OKBackend b => [VPatch -> Diagram b] -> Angle Double -> TrackedTgraph -> Diagram b +drawTrackedTgraphRotated drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where + vp = rotate a $ makeVP (tgraph ttg) + untracked = faces 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) alignment. + This is useful when labels are being drawn. + The vertex pair argument is used to align the common vertex location map before drawing + (to ensure labels are not rotated). + This will raise an error if either of the pair of vertices is not a vertex of (the tgraph of) the TrackedTgraph +-} +drawTrackedTgraphAligned :: OKBackend b => [VPatch -> Diagram b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram b +drawTrackedTgraphAligned drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where + vp = makeAlignedVP (a,b) (tgraph ttg) + untracked = faces vp \\ concat (tracked ttg) + vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp + + + diff --git a/src/Tgraph/Force.hs b/src/Tgraph/Force.hs --- a/src/Tgraph/Force.hs +++ b/src/Tgraph/Force.hs @@ -22,7 +22,6 @@ , forceWith , tryForce , tryForceWith - , wholeTiles , stepForce , tryStepForce , tryStepForceWith @@ -30,22 +29,28 @@ , initFS , tryInitFS , tryChangeBoundary - -- * Forced - , Forced(..) + , wholeTiles + -- * Explicitly Forced + , Forced() , forgetF , tryForceF , forceF - -- * Force Related + , recoverGraphF + , boundaryStateF + , makeBoundaryStateF + , initFSF + , labelAsForced + -- * Force Related , addHalfKite , tryAddHalfKite , addHalfDart , tryAddHalfDart - -- * One Step (for debugging) + -- * Debug Step Forcing , tryOneStepWith , tryOneStepForce -- * Types for Forcing - , ForceState(..) , BoundaryState(..) + , ForceState(..) , BoundaryChange(..) , Update(..) , UpdateMap @@ -54,6 +59,7 @@ , UChecker -- * BoundaryState operations , makeBoundaryState + -- , boundary (part of HasFaces class) , recoverGraph -- , changeVFMap -- Now HIDDEN , facesAtBV @@ -121,34 +127,16 @@ , mustbeJack -- * Other tools for making new update generators , newUpdateGenerator - , makeGenerator + -- , makeGenerator , boundaryFilter , makeUpdate -- , hasAnyMatchingE -{- - , anglesForJoinRD - , anglesForJoinLD - , anglesForJoinRK - , anglesForJoinLK - , anglesForLongLD - , anglesForLongRD - , anglesForLongRK - , anglesForLongLK - , anglesForShortLD - , anglesForShortRD - , anglesForShortLK - , anglesForShortRK --} --- , inspectBDedge +-- , inspectBDedge -- * Auxiliary Functions for adding faces -- $Additions - , tryFindThirdV + -- , tryFindThirdV , externalAngle -{- - , intAngleAt - , faceIntAngles --} , touchCheck ) where @@ -185,31 +173,39 @@ -} data BoundaryState = BoundaryState - { boundary:: [Dedge] -- ^ boundary directed edges (face on LHS, exterior on RHS) + { boundaryDedges:: [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) +-- |BoundaryState is in class HasFaces +instance HasFaces BoundaryState where + faces = allFaces + boundary = boundaryDedges + maxV bd = nextVertex bd - 1 + -- |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 + let bdes = boundary 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 + in BoundaryState - { boundary = bdes + { boundaryDedges = bdes , bvFacesMap = vertexFacesMap bvs (faces g) , bvLocMap = bvLocs , allFaces = faces g , nextVertex = 1+ maxV g } - +{- -- |TEMP +boundary :: BoundaryState -> [Dedge] +boundary = boundaryDedges + -} -- |Converts a BoundaryState back to a Tgraph recoverGraph:: BoundaryState -> Tgraph recoverGraph = makeUncheckedTgraph . allFaces @@ -236,7 +232,7 @@ -- |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 = fst <$> boundary bd + bvs = boundaryVs bd -- boundaryFaces = nub . concat . VMap.elems . bvFacesMap -- relies on the map containing no extra info for non boundary vertices @@ -271,19 +267,24 @@ newtype UpdateGenerator = UpdateGenerator {applyUG :: 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 +-- | Forcing a Tgraph requires conversion to a BoundaryState (which records extra data) +-- and then to a ForceState (which keeps track of possible updates during forcing). +-- Thus we introduce a Forcible class which will have Tgraph, BoundaryState, ForceState as instances. +-- +-- Forcible class has operations to (indirectly) implement forcing and single step forcing +-- 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. +-- For example 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. +-- Note that these operations are parameterised on an UpdateGenerator, which encapsulates +-- the forcing rules to be used. 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) + -- 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. 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. @@ -299,7 +300,7 @@ tryChangeBoundaryWith ugen f fs = do bdC <- f (boundaryState fs) tryReviseFSWith ugen bdC fs --- getBoundaryState = boundaryState +-- boundaryState = boundaryState -- | BoundaryStates are Forcible instance Forcible BoundaryState where @@ -313,7 +314,6 @@ tryChangeBoundaryWith _ f bd = do -- update generator not used bdC <- f bd return $ newBoundaryState bdC --- getBoundaryState = id -- | Tgraphs are Forcible instance Forcible Tgraph where @@ -321,7 +321,7 @@ tryInitFSWith ugen g = tryInitFSWith ugen (makeBoundaryState g) tryChangeBoundaryWith ugen f g = -- update generator not used recoverGraph <$> tryChangeBoundaryWith ugen f (makeBoundaryState g) --- getBoundaryState = makeBoundaryState +-- boundaryState = makeBoundaryState -- | try forcing using a given UpdateGenerator. @@ -403,23 +403,30 @@ tryChangeBoundary:: Forcible a => (BoundaryState -> Try BoundaryChange) -> a -> Try a tryChangeBoundary = tryChangeBoundaryWith defaultAllUGen --- |Forced a explicitly indicates that a is Forced. --- This is to enable restricting some functions which are only total on a Forced forcible. --- (Similar to the way Data.List.NonEmpty is used to explicitly indicate a non-empty list) +-- |Forced a is a newtype (for a) to explicitly indicate that a is fully forced. +-- This enables restriction of some functions that should only be applied to a fully forced Forcible. -- --- To access the forcible use: forgetF :: Forced a -> a +-- To access the Forcible use: forgetF :: Forced a -> a -- --- Create using forceF or tryForceF -newtype Forced a = Forced a +-- Create an explicitly Forced Forcible using forceF or tryForceF +newtype Forced a = Forced { -- | forget the explicit Forced labelling + forgetF :: a + } deriving (Show) -instance Functor Forced where - fmap f (Forced a) = Forced (f a) - --- |unwraps a Forced -forgetF :: Forced a -> a -forgetF (Forced a) = a +-- |Extend HasFaces ops from a to Forced a +instance HasFaces a => HasFaces (Forced a) where + faces = faces . forgetF + boundary = boundary . forgetF + maxV = maxV . faces +-- | Constructs an explicitly Forced type. +-- +-- WARNING: this should only be used when the argument is known to be a fully forced Forcible. +-- Consider using forceF or tryForceF instead for safety reasons. +labelAsForced :: a -> Forced a +labelAsForced = Forced + -- |tryForceF is the same as tryForce except that -- the successful result is explitly indicated as Forced. tryForceF :: Forcible a => a -> Try (Forced a) @@ -430,7 +437,22 @@ forceF:: Forcible a => a -> Forced a forceF = runTry . tryForceF +-- | recoverGraphF is an explicitly forced version of recoverGraph +recoverGraphF :: Forced BoundaryState -> Forced Tgraph +recoverGraphF (Forced bs) = labelAsForced (recoverGraph bs) +-- | boundaryStateF is an explicitly forced version of boundaryState +boundaryStateF :: Forced ForceState -> Forced BoundaryState +boundaryStateF (Forced fs) = labelAsForced (boundaryState fs) + +-- | makeBoundaryStateF is an explicitly forced version of makeBoundaryState +makeBoundaryStateF :: Forced Tgraph -> Forced BoundaryState +makeBoundaryStateF (Forced g) = labelAsForced (makeBoundaryState g) + +-- | initFSF is an explicitly forced version of initFS +initFSF :: Forcible a => Forced a -> Forced ForceState +initFSF (Forced a) = labelAsForced (initFS a) + -- |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. @@ -450,12 +472,16 @@ tryAddHalfKiteBoundary e bd = do de <- case [e, reverseD e] `intersect` boundary bd of [de] -> Right de - _ -> Left $ "tryAddHalfKite: on non-boundary edge " ++ show e ++ "\n" + _ -> failReports + ["tryAddHalfKite: on non-boundary edge " + ,show e + ,"\n" + ] let (fc,etype) = inspectBDedge bd de let tryU | etype == Long = addKiteLongE bd fc | etype == Short = addKiteShortE bd fc | etype == Join && isKite fc = completeHalf bd fc - | otherwise = Left "tryAddHalfKite: applied to dart join (not possible).\n" + | otherwise = failReport "tryAddHalfKite: applied to dart join (not possible).\n" u <- tryU tryUpdate bd u @@ -479,12 +505,16 @@ tryAddHalfDartBoundary e bd = do de <- case [e, reverseD e] `intersect` boundary bd of [de] -> Right de - _ -> Left $ "tryAddHalfDart: on non-boundary edge " ++ show e ++ "\n" + _ -> failReports + ["tryAddHalfDart: on non-boundary edge " + ,show e + ,"\n" + ] let (fc,etype) = inspectBDedge bd de let tryU | etype == Long = addDartLongE bd fc | etype == Short && isKite fc = addDartShortE bd fc | etype == Join && isDart fc = completeHalf bd fc - | otherwise = Left "tryAddHalfDart: applied to short edge of dart or to kite join (not possible).\n" + | otherwise = failReport "tryAddHalfDart: applied to short edge of dart or to kite join (not possible).\n" u <- tryU tryUpdate bd u @@ -591,9 +621,15 @@ -- 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 [] = failReports + ["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 @@ -618,7 +654,7 @@ matchedDedges = filter (\(x,y) -> x /= v && y /= v) fDedges -- singleton newDedges = fmap reverseD (fDedges \\ matchedDedges) -- two edges resultBd = BoundaryState - { boundary = newDedges ++ (boundary bd \\ matchedDedges) + { boundaryDedges = newDedges ++ (boundary bd \\ matchedDedges) , bvFacesMap = changeVFMap newface (bvFacesMap bd) , bvLocMap = newVPoints , allFaces = newface:allFaces bd @@ -654,7 +690,7 @@ newDedges = fmap reverseD (fDedges \\ matchedDedges) -- one or none nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs resultBd = BoundaryState - { boundary = newDedges ++ (boundary bd \\ matchedDedges) + { boundaryDedges = newDedges ++ (boundaryDedges bd \\ matchedDedges) , bvFacesMap = foldr VMap.delete (changeVFMap newface $ bvFacesMap bd) removedBVs -- , bvFacesMap = changeVFMap newface (bvFacesMap bd) , allFaces = newface:allFaces bd @@ -670,11 +706,13 @@ } 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" + else failReports + ["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), @@ -697,7 +735,7 @@ tryUpdate bd u@(UnsafeUpdate _) = case checkUnsafeUpdate bd u of Just bdC -> return bdC - Nothing -> Left "tryUpdate: crossing boundary (touching vertices).\n" + Nothing -> failReport "tryUpdate: crossing boundary (touching vertices).\n" -- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateVertices. -- (Used at intervals in tryRecalibratingForce and recalibratingForce). @@ -924,10 +962,10 @@ addU (e,fc) (Right ump) = do u <- checker bd fc return (Map.insert e u ump) -{-| makeGenerator (deprecated) this is renamed as newUpdateGenerator. -} +{- {-| makeGenerator (deprecated) this is renamed as newUpdateGenerator. -} makeGenerator :: UChecker -> UFinder -> UpdateGenerator makeGenerator = newUpdateGenerator - + -} -- Ten Update Generators (with corresponding Finders) @@ -1263,31 +1301,71 @@ 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" + = failReports + ["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" + = failReports + ["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" + = failReports + ["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" + = failReports + ["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" + Nothing -> failReports + ["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" + Nothing -> failReports + ["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 diff --git a/src/Tgraph/Prelude.hs b/src/Tgraph/Prelude.hs --- a/src/Tgraph/Prelude.hs +++ b/src/Tgraph/Prelude.hs @@ -24,7 +24,6 @@ ( module HalfTile , module Try -- * Types for Tgraphs, Faces, Vertices, Directed Edges - , Tgraph -- not Data Constructor , TileFace , Vertex , VertexSet @@ -32,23 +31,28 @@ -- $Edges , Dedge , EdgeType(..) - -- * Property Checking for Tgraphs + , Tgraph() -- not Data Constructor Tgraph , makeTgraph , tryMakeTgraph - , tryCorrectTouchingVs + , checkedTgraph + , makeUncheckedTgraph + , HasFaces(..) -- faces, boundary, maxV + , dedges + , vertexSet + , vertices + , boundaryVs + -- * Property Checking for Tgraphs -- , renumberFaces -- , differing - , makeUncheckedTgraph - , evalFaces - -- , evalFace - , checkedTgraph , tryTgraphProps , tryConnectedNoCross + , tryCorrectTouchingVs -- , findEdgeLoops , hasEdgeLoops , duplicates -- , conflictingDedges , edgeType + --, findEdgeLoop -- , sharedEdges -- , newSharedEdges , noNewConflict @@ -56,36 +60,31 @@ -- , legal -- , illegals , illegalTiling --- , crossingBVs - , crossingVertices + , crossingBVs + -- , crossingVertices , crossingBoundaries , connected -- , connectedBy - -- * Basic Tgraph operations - , faces + -- * Basic Tgraph and HasFaces operations +-- , faces , emptyTgraph - , nullGraph - , maxV + , nullFaces + , evalFaces , ldarts , rdarts , lkites , rkites , kites , darts - , selectFaces - , removeFaces - , removeVertices - , selectVertices - , vertexSet - , graphBoundaryVs - , graphDedges - , graphEdges , internalEdges - , graphBoundary , phiEdges , nonPhiEdges - , graphEFMap , defaultAlignment + , selectFaces + , removeFaces + , removeVertices + , selectVertices + , vertexFacesMap -- * Other Face/Vertex Operations , makeRD , makeLD @@ -94,8 +93,6 @@ , faceVs , faceVList , faceVSet - , facesVSet - , facesMaxV , firstV , secondV , thirdV @@ -109,7 +106,6 @@ , hasVIn -- * Other Edge Operations , faceDedges - , facesDedges , reverseD , joinE , shortE @@ -123,14 +119,12 @@ , matchingJoinE , hasDedge , hasDedgeIn - , facesEdges + , completeEdges -- , bothDir -- , bothDirOneWay - , facesBoundary -- , missingRevs -- * Other Face Operations , edgeNb - , vertexFacesMap , dedgesFacesMap , buildEFMap , faceForEdge @@ -169,24 +163,24 @@ -- * Vertex Location and Touching Vertices , locateVertices , addVPoint - , axisJoin +-- , axisJoin -- , find3Locs -- , thirdVertexLoc , touchingVertices , touching , touchingVerticesGen , locateVerticesGen - , drawEdges - , drawEdge + --, drawEdges + --, drawEdge ) where import Data.List ((\\), intersect, union, elemIndex,foldl',find,nub) -- import Data.Either(fromRight, lefts, rights, isLeft) import qualified Data.IntMap.Strict as VMap (IntMap, alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet, findWithDefault) -import qualified Data.IntSet as IntSet (IntSet,union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteMin,findMin,findMax,member,difference) +import qualified Data.IntSet as IntSet (IntSet,union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteMin,findMin,findMax,member,difference,elems) 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 qualified Data.Set as Set (fromList,member,null,delete,)-- used for locateVertices import Diagrams.Prelude hiding (union,mapping) -- import Diagrams.TwoD.Text (Text) @@ -207,7 +201,7 @@ -- Types for Tgraphs, Vertices, Directed Edges, Faces --- |Tgraph vertex labels (must be positive) +-- |Vertex labels are integers. They must be positive for a Tgraph (Checked by makeTgraph). type Vertex = Int -- | directed edge type Dedge = (Vertex,Vertex) @@ -215,17 +209,25 @@ type VertexSet = IntSet.IntSet -- |A TileFace is a HalfTile with 3 vertex labels (clockwise starting with the origin vertex). --- Usually referred to as a face. +-- Usually referred to simply as a face. +-- +-- For example a right dart: RD(1,2,3) or a left kite: LK(1,5,6) type TileFace = HalfTile (Vertex,Vertex,Vertex) --- |A Tgraph is a list of faces (TileFaces). --- All vertex labels should be positive, so 0 is not used as a vertex label. --- Tgraphs should be constructed with makeTgraph or checkedTgraph to check required properties. --- The data constructor Tgraph is not exported (but see also makeUncheckedTgraph). -newtype Tgraph = Tgraph [TileFace] +{- | A Tgraph is a newtype for a list of faces (that is [TileFace]). + 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). + + Use faces to retrieve the list of faces of a Tgraph. +-} +newtype Tgraph = Tgraph { -- | getFaces is not exported (use faces) + getFaces ::[TileFace] -- ^ Retrieve the faces of a Tgraph + } deriving (Show) --- | type used to classify edges of faces +-- |A type used to classify edges of faces. +-- Each (halftile) face has a long edge, a short edge and a join edge. data EdgeType = Short | Long | Join deriving (Show,Eq) -- |Abbreviation for Mapping from Vertex keys (also used for Boundaries) @@ -259,7 +261,7 @@ let touchVs = touchingVertices (faces g) if null touchVs then Right g - else Left ("Found touching vertices: " + else failReport ("Found touching vertices: " ++ show touchVs ++ "\nwith faces:\n" ++ show fcs @@ -290,14 +292,17 @@ differing = filter $ uncurry (/=) -- |Creates a (possibly invalid) Tgraph from a list of faces. --- It does not perform checks on the faces. Use makeTgraph or checkedTgraph to perform checks. --- This is intended for use only when checks are known to be redundant. +-- It does not perform checks on the faces. +-- +-- WARNING: This is intended for use only when checks are known to be redundant. +-- Consider using makeTgraph, tryMakeTgraph or checkedTgraph instead to perform checks. makeUncheckedTgraph:: [TileFace] -> Tgraph -makeUncheckedTgraph = Tgraph -- . evalFaces +makeUncheckedTgraph = Tgraph -- |force evaluation of a list of faces. -evalFaces :: [TileFace] -> [TileFace] -evalFaces fcs = find (has0 . tileRep) fcs `seq` fcs where +evalFaces :: HasFaces a => a -> [TileFace] +evalFaces = eval . faces where + eval fcs = find (has0 . tileRep) fcs `seq` fcs has0 (x,y,z) = x==0 || y==0 || z==0 {-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties @@ -325,16 +330,24 @@ 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 + | hasEdgeLoops fcs = + failReport $ "tryTgraphProps: Non-valid tile-face(s)\n" ++ + "Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n" + | illegalTiling fcs = failReports + ["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 = vertexSet 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" + then failReports + ["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. @@ -345,25 +358,37 @@ -- 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 + | not (connected fcs) = failReports + ["tryConnectedNoCross: Non-valid Tgraph (Not connected)\n" + ,show fcs + ,"\n" + ] + | crossingBoundaries fcs = failReports + ["tryConnectedNoCross: Non-valid Tgraph\n" + ,"Crossing boundaries found at " + ,show (crossingBVs fcs) + ,"\nwith faces\n" + ,show fcs + ,"\n" + ] | otherwise = Right (Tgraph fcs) -- |Returns any repeated vertices within each TileFace for a list of TileFaces. -findEdgeLoops:: [TileFace] -> [Vertex] -findEdgeLoops = concatMap (duplicates . faceVList) +findEdgeLoops:: HasFaces a => a -> [Vertex] +findEdgeLoops = concatMap findEdgeLoop . faces +-- |Returns a repeated vertex for TileFace +findEdgeLoop :: TileFace -> [Vertex] +findEdgeLoop = duplicates . faceVList + -- |Checks if there are repeated vertices within any TileFace for a list of TileFaces. -- Returns True if there are any. -hasEdgeLoops:: [TileFace] -> Bool +hasEdgeLoops:: HasFaces a => a -> Bool hasEdgeLoops = not . null . findEdgeLoops - --- |duplicates finds duplicated items in a list (reverses order but unique results) +-- |duplicates finds any duplicated items in a list (unique results). duplicates :: Eq a => [a] -> [a] -duplicates = fst . foldl' check ([],[]) where +duplicates = reverse . fst . foldl' check ([],[]) where check (dups,seen) x | x `elem` dups = (dups,seen) | x `elem` seen = (x:dups,seen) | otherwise = (dups,x:seen) @@ -371,8 +396,8 @@ -- |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 +conflictingDedges :: HasFaces a => a -> [Dedge] +conflictingDedges = duplicates . dedges @@ -414,14 +439,6 @@ noNewConflict face fcs = all 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 @@ -452,28 +469,22 @@ 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) +-- |crossingBVs fcs returns a list of vertices where there are crossing boundaries +-- (which should be null for Tgraphs, VPatches, BoundaryStates, Forced, TrackedTgraph). +crossingBVs :: HasFaces a => a -> [Vertex] +crossingBVs = duplicates . boundaryVs -- |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 +-- in the boundary vertices. +crossingBoundaries :: HasFaces a => a -> 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 +-- |Predicate to check if the faces are connected (in graph theory sense). +connected:: HasFaces a => a -> Bool +connected = conn . faces where + conn [] = True + conn fcs = null (snd $ connectedBy (completeEdges fcs) (IntSet.findMin vs) vs) + where vs = vertexSet fcs -- |Auxiliary function for calculating connectedness. -- connectedBy edges v verts returns a pair of lists of vertices (conn,unconn) @@ -496,34 +507,70 @@ --- |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 +-- |are there no faces? +nullFaces:: HasFaces a => a -> Bool +nullFaces = null . faces --- |find the maximum vertex number in a Tgraph, returning 0 for an empty Tgraph. -maxV :: Tgraph -> Int -maxV = facesMaxV . faces +-- |Class HasFaces for operations using (a list of) TileFaces. +-- +-- Used to define common functions on [TileFace], Tgraph, VPatch, BoundaryState, Forced, TrackedTgraph +class HasFaces a where + -- |get the tileface list + faces :: a -> [TileFace] + -- |get the directed edges of the boundary + -- (direction with a tileface on the left and exterior on right). + boundary :: a -> [Dedge] + -- |get the maximum vertex in all faces (0 if there are no faces) + maxV :: a -> Int -ldarts,rdarts,lkites,rkites, kites, darts :: Tgraph -> [TileFace] --- | selecting left darts from a Tgraph +-- |An ascending list of the vertices occuring in faces (without duplicates) +vertices :: HasFaces a => a -> [Vertex] +vertices = IntSet.elems . vertexSet + +-- |List of boundary vertices +-- May have duplicates when applied to an arbitrary list of TileFace. +-- but no duplicates for Tgraph, VPatch, BoundaryState, Forced, TrackedTgraph. +boundaryVs :: HasFaces a => a -> [Vertex] +boundaryVs = fmap fst . boundary + +-- |get all the directed edges (directed clockwise round each face) +dedges :: HasFaces a => a -> [Dedge] +dedges = concatMap faceDedges . faces + +-- |get the set of vertices in the faces +vertexSet :: HasFaces a => a -> VertexSet +vertexSet = mconcat . fmap faceVSet . faces + +-- |A list of tilefaces is in class HasFaces +instance HasFaces [TileFace] where + faces = id + boundary = missingRevs . dedges + maxV [] = 0 + maxV fcs = IntSet.findMax $ vertexSet fcs + +-- |Tgraph is in class HasFaces +instance HasFaces Tgraph where + faces = getFaces + boundary = boundary . faces + maxV = maxV . faces + +ldarts,rdarts,lkites,rkites, kites, darts :: HasFaces a => a -> [TileFace] +-- | selecting left darts from ldarts = filter isLD . faces --- | selecting right darts from a Tgraph +-- | selecting right darts from the faces rdarts = filter isRD . faces --- | selecting left kites from a Tgraph +-- | selecting left kites from the faces lkites = filter isLK . faces --- | selecting right kites from a Tgraph +-- | selecting right kites from the faces rkites = filter isRK . faces --- | selecting half kites from a Tgraph +-- | selecting half kites from the faces kites = filter isKite . faces --- | selecting half darts from a Tgraph +-- | selecting half darts from the faces darts = filter isDart . faces -- |selects faces from a Tgraph (removing any not in the list), @@ -537,63 +584,40 @@ 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. +-- by removing all faces at those vertices. The resulting Tgraph is checked +-- for required properties e.g. connectedness and no crossing boundaries +-- and will raise an error if these fail. removeVertices :: [Vertex] -> Tgraph -> Tgraph removeVertices vs g = removeFaces (filter (hasVIn vs) (faces g)) g -- |selectVertices vs g - removes any face that does not have at least one vertex in the list vs from g. -- Resulting Tgraph is checked --- for required properties e.g. connectedness and no crossing boundaries. +-- for required properties e.g. connectedness and no crossing boundaries +-- and will raise an error if these fail. selectVertices :: [Vertex] -> Tgraph -> Tgraph selectVertices vs g = selectFaces (filter (hasVIn vs) (faces g)) g --- |the set of vertices of a Tgraph -vertexSet:: Tgraph -> VertexSet -vertexSet = facesVSet . faces - --- |list of vertices that are on the boundary of a Tgraph -graphBoundaryVs :: Tgraph -> [Vertex] -graphBoundaryVs = map fst . graphBoundary - --- |A list of all the directed edges of a Tgraph (going clockwise round faces) -graphDedges :: Tgraph -> [Dedge] -graphDedges = facesDedges . faces - --- |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 +-- |internal edges are shared by two faces. That is, all edges except those at the boundary. +-- Both directions of each internal directed edge will appear in the result. +internalEdges :: HasFaces a => a -> [Dedge] +internalEdges a = des \\ fmap reverseD (missingRevs des) where + des = dedges a --- |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 returns a list of the longer (phi-length) edges in the faces (including kite joins). +-- The result includes both directions of each edge. +phiEdges :: HasFaces a => a -> [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 returns a list of the shorter edges in the faces (including dart joins). +-- The result includes both directions of each edge. +nonPhiEdges :: HasFaces a => a -> [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. +-- |the default alignment of non-empty faces 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 edge. -- 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" +defaultAlignment :: HasFaces a => a -> (Vertex,Vertex) +defaultAlignment g | nullFaces g = error "defaultAlignment: applied to null list of faces\n" | otherwise = lowestJoin $ faces g makeRD,makeLD,makeRK,makeLK :: Vertex -> Vertex -> Vertex -> TileFace @@ -622,15 +646,11 @@ 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). +{- -- |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 - +facesMaxV fcs = IntSet.findMax $ vertexSet 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 @@ -692,6 +712,7 @@ {- $Edges + Representing Edges: For vertices a and b, (a,b) is regarded as a directed edge from a to b (a Dedge). @@ -709,10 +730,10 @@ 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. +{- -- |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) @@ -785,9 +806,9 @@ 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 +-- |completeEdges returns a list of all the edges of the faces (both directions of each edge). +completeEdges :: HasFaces a => a -> [Dedge] +completeEdges = bothDir . dedges -- |bothDir adds missing reverse directed edges to a list of directed edges -- to complete edges (Result is a complete edge list) @@ -803,12 +824,6 @@ 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 @@ -830,30 +845,23 @@ -{-|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 vs a - +For list of vertices vs and faces from a, +create an IntMap from each vertex in vs to a list of those faces in a that are at that vertex. -} -vertexFacesMap:: [Vertex] -> [TileFace] -> VertexMap [TileFace] -vertexFacesMap vs = foldl' insertf startVF where +vertexFacesMap:: HasFaces a => [Vertex] -> a-> VertexMap [TileFace] +vertexFacesMap vs = foldl' insertf startVF . faces 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) -{- - insertf vfmap f = h x1 (h x2 (h x3 vfmap)) where - (x1,x2,x3) = faceVs f - h = VMap.alter addf - 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 des a - Produces an edge-face map. Each directed edge in des is associated with +-- a unique face in a that has that directed edge (if there is one). +-- It will report an error if more than one face in a has the same directed edge in des. +-- If the directed edges are all the ones in a, buildEFMap 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:: HasFaces a => [Dedge] -> a -> Map.Map Dedge TileFace dedgesFacesMap des fcs = Map.fromList (assocFaces des) where vs = fmap fst des `union` fmap snd des vfMap = vertexFacesMap vs fcs @@ -867,14 +875,10 @@ _ -> 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 +-- |Build a Map from all directed edges to faces (the unique face containing the directed edge) +buildEFMap:: HasFaces a => a -> Map.Map Dedge TileFace +buildEFMap = Map.fromList . concatMap assignFace . faces 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 @@ -887,31 +891,34 @@ getNbr e = Map.lookup e efMap edges = reverseD <$> faceDedges face --- |For a non-empty list of tile faces +-- |For an argument with a non-empty list of faces, -- find the face with lowest originV (and then lowest oppV). -- Move this face to the front of the returned list of faces. +-- This will raise an error if there are no 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 +extractLowestJoin:: HasFaces a => a -> (TileFace,[TileFace]) +extractLowestJoin = getLJ . faces where + getLJ 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 found at " + ++ show a ++ " with opp vertex at " ++ show b ++ "\n" + -- |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) +lowestJoin:: HasFaces a => a -> Dedge +lowestJoin = lowest . faces where + lowest fcs | null fcs = error "lowestJoin: applied to empty list of faces" + lowest fcs = (a,b) where + a = minimum (fmap originV fcs) + aFaces = filter ((a==) . originV) fcs + b = minimum (fmap oppV aFaces) {--------------------- ********************* @@ -937,7 +944,13 @@ instance Transformable VPatch where transform t vp = vp {vLocs = VMap.map (transform t) (vLocs vp)} +-- |VPatch is in class HasFace +instance HasFaces VPatch where + faces = vpFaces + boundary = boundary . faces + maxV = maxV . faces + {-|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. @@ -963,7 +976,7 @@ | otherwise = error $ "relevantVP: missing locations for: " ++ show diffList ++ "\n" where - vs = facesVSet (vpFaces vp) + vs = vertexSet (faces vp) source = VMap.keysSet locVs diffList = IntSet.toList $ IntSet.difference vs source locVs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) $ vLocs vp @@ -976,16 +989,16 @@ -- |Recover a Tgraph from a VPatch by dropping the vertex positions and checking Tgraph properties. graphFromVP:: VPatch -> Tgraph -graphFromVP = checkedTgraph . vpFaces +graphFromVP = checkedTgraph . faces -- |remove a list of faces from a VPatch removeFacesVP :: VPatch -> [TileFace] -> VPatch -removeFacesVP vp fcs = restrictVP vp (vpFaces vp \\ fcs) +removeFacesVP vp fcs = restrictVP vp (faces 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) +selectFacesVP vp fcs = restrictVP vp (fcs `intersect` faces vp) -- |find the location of a single vertex in a VPatch findLoc :: Vertex -> VPatch -> Maybe (Point V2 Double) @@ -1001,7 +1014,7 @@ -- |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 +dropLabels vp = fmap convert (faces 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 @@ -1124,7 +1137,7 @@ (Just pa, Just pb) -> pa ~~ pb _ -> error $ "drawEdge: location not found for one or both vertices "++ show (a,b) ++ "\n" -{-# DEPRECATED drawEdge, drawEdges "Use drawLocatedEdge, drawLocatedEdges instead" #-} +{- {-# DEPRECATED drawEdge, drawEdges "Use drawLocatedEdge, drawLocatedEdges instead" #-} -- |deprecated (use drawLocatedEdges) drawEdges :: OKBackend b => VertexLocMap -> [Dedge] -> Diagram b @@ -1134,7 +1147,7 @@ drawEdge :: OKBackend b => VertexLocMap -> Dedge -> Diagram b drawEdge = drawLocatedEdge - + -} {-| locateVertices: processes a list of faces to associate points for each vertex using a default scale and orientation. The default scale is 1 unit for short edges (phi units for long edges). @@ -1143,14 +1156,14 @@ 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 label with the same location). -} -locateVertices:: [TileFace] -> VertexLocMap +locateVertices:: HasFaces a => a -> 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 +locateVertices = locVs . faces where + locVs [] = VMap.empty + locVs 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. @@ -1160,7 +1173,7 @@ -} fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap fastAddVPoints [] fcOther _ = error $ "locateVertices (fastAddVPoints): Faces not tile-connected: " - ++ show fcOther ++ "/n" + ++ 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 @@ -1247,7 +1260,7 @@ This is used in makeTgraph and fullUnion (via correctTouchingVertices). -} -touchingVertices:: [TileFace] -> [(Vertex,Vertex)] +touchingVertices:: HasFaces a => a -> [(Vertex,Vertex)] touchingVertices fcs = check vpAssoc where vpAssoc = VMap.assocs $ locateVertices fcs -- assocs puts in increasing key order so that check returns (higher,lower) pairs check [] = [] @@ -1282,12 +1295,12 @@ {-| 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 +locateVerticesGen:: HasFaces a => a -> VertexLocMap +locateVerticesGen = locVs . faces where + locVs [] = VMap.empty + locVs 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. diff --git a/src/Tgraph/Relabelling.hs b/src/Tgraph/Relabelling.hs --- a/src/Tgraph/Relabelling.hs +++ b/src/Tgraph/Relabelling.hs @@ -366,7 +366,11 @@ Nothing -> Right Nothing Just corresp -> if twoVMatch corresp face then Right $ Just corresp - else Left $ "Found non matching faces " ++ show (corresp, face) ++ "\n" + else failReports + ["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. diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs --- a/src/TgraphExamples.hs +++ b/src/TgraphExamples.hs @@ -93,9 +93,8 @@ ) where import Diagrams.Prelude -import TileLib -import Tgraphs - +import PKD +import Tgraph.Prelude as NoWarn (makeUncheckedTgraph) import Data.List (intersect,find) -- for emplaceChoices @@ -357,9 +356,9 @@ boundaryFDart4, boundaryFDart5 :: Tgraph -- |graph of the boundary faces only of a forced graph (dartDs!!4) -boundaryFDart4 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 +boundaryFDart4 = NoWarn.makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 -- |graph of the boundary faces only of a forced graph (dartDs!!5) -boundaryFDart5 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) +boundaryFDart5 = NoWarn.makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) boundaryFDart4Fig,boundaryFDart5Fig :: OKBackend b => Diagram b -- |figure of the boundary faces only of a forced graph (dartDs!!4). @@ -421,21 +420,23 @@ -- It then repeatedly applies (force . decompose) back to the starting level to return a list of Tgraphs. -- This version relies on compForce theorem and related theorems emplaceChoices:: Tgraph -> [Tgraph] -emplaceChoices g = emplaceChoicesForced $ recoverGraph $ force $ makeBoundaryState g where +emplaceChoices = emplaceChoicesForced . forceF where - emplaceChoicesForced:: Tgraph -> [Tgraph] - emplaceChoicesForced g0 | nullGraph g' = chooseUnknowns [(unknowns $ getDartWingInfo g0, g0)] - | otherwise = force . decompose <$> emplaceChoicesForced g' - where g' = compose g0 + emplaceChoicesForced:: Forced Tgraph -> [Tgraph] + emplaceChoicesForced fg | nullFaces g' = chooseUnknowns [(unknowns $ getDartWingInfo g0, g0)] + | otherwise = force . decompose <$> emplaceChoicesForced fg' + where g0 = forgetF fg + fg' = composeF fg + g' = forgetF fg' chooseUnknowns :: [([Vertex],Tgraph)] -> [Tgraph] chooseUnknowns [] = [] chooseUnknowns (([],g0):more) = g0:chooseUnknowns more chooseUnknowns ((u:unks,g0): more) = chooseUnknowns (map (remainingunks unks) newgs ++ more) - where newgs = map recoverGraph $ atLeastOne $ tryDartAndKiteForced (findDartLongForWing u bd) bd + where newgs = map recoverGraph $ atLeastOne $ fmap forgetF <$> tryDartAndKiteF (findDartLongForWing u bd) bd bd = makeBoundaryState g0 - remainingunks startunks g' = (startunks `intersect` graphBoundaryVs g', g') + remainingunks startunks g' = (startunks `intersect` boundaryVs g', g') findDartLongForWing :: Vertex -> BoundaryState -> Dedge findDartLongForWing v bd diff --git a/src/Tgraphs.hs b/src/Tgraphs.hs deleted file mode 100644 --- a/src/Tgraphs.hs +++ /dev/null @@ -1,713 +0,0 @@ -{-| -Module : Tgraphs -Description : Collects and exports the various Tgraph modules plus extra operations. -Copyright : (c) Chris Reade, 2021 -License : BSD-style -Maintainer : chrisreade@mac.com -Stability : experimental - -This is the main module for Tgraph operations which collects and exports the other Tgraph modules. -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 TupleSections #-} - -module Tgraphs - ( module Tgraph.Prelude - , module Tgraph.Decompose - , module Tgraph.Compose - , module Tgraph.Force - , module Tgraph.Relabelling - -- * Smart drawing of Tgraphs - , smart - , boundaryJoinFaces - , drawBoundaryJoins - , 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 - -- * 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 face graph - , tryBoundaryFaceGraph - -- * 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 -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', 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 -import qualified Data.Maybe (fromMaybe) - - - --- |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 -smart :: OKBackend b => - (VPatch -> Diagram b) -> Tgraph -> Diagram b -smart dr g = drawBoundaryJoins 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 - --- |draw boundary join edges of a Tgraph using a given VPatch -drawBoundaryJoins :: OKBackend b => Tgraph -> VPatch -> Diagram b -drawBoundaryJoins g vp = drawEdgesVP vp (map joinE $ boundaryJoinFaces g) # joinDashing - --- |Given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces. --- Will raise an error if any vertex in the faces does not have a location in the VPatch. -drawJoinsFor:: OKBackend b => - [TileFace] -> VPatch -> Diagram b -drawJoinsFor fcs vp = drawWith dashjOnly (restrictVP vp fcs) - --- |same as draw except adding dashed lines on boundary join edges. -smartdraw :: OKBackend b => Tgraph -> Diagram b -smartdraw = smart draw - --- |restrictSmart g dr vp - assumes vp has locations for vertices in g. --- It uses the VPatch drawing function dr to draw g and adds dashed boundary joins. --- This can be used instead of smart when an appropriate vp is already available. -restrictSmart :: OKBackend b => - Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b -restrictSmart g dr vp = drawBoundaryJoins 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 -smartRotateBefore :: OKBackend b => - (VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b -smartRotateBefore vfun angle g = rotateBefore (restrictSmart g vfun) angle g - --- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore. --- Uses vfun to produce a Diagram after converting g to an aligned VPatch but also adds the dashed boundary join edges of g. --- --- Example: smartAlignBefore (labelled draw) (a,b) g -smartAlignBefore :: OKBackend b => - (VPatch -> Diagram b) -> (Vertex,Vertex) -> Tgraph -> Diagram b -smartAlignBefore vfun (a,b) g = alignBefore (restrictSmart g vfun) (a,b) g - - - --- |applies partCompose to a Tgraph g, then draws the composed graph with the remainder faces (in lime). --- (Relies on the vertices of the composition and remainder being subsets of the vertices of g.) -drawPCompose :: OKBackend b => - Tgraph -> Diagram 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 -drawForce :: OKBackend b => - Tgraph -> Diagram 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. -drawSuperForce :: OKBackend b => - Tgraph -> Diagram b -drawSuperForce g = (dg # lc red) <> dfg <> (dsfg # lc blue) where - fg = force g - sfg = superForce fg - vp = makeVP sfg - dfg = draw $ selectFacesVP vp (faces fg \\ faces g) -- restrictSmart (force g) draw vp - dg = restrictSmart g draw vp - dsfg = draw $ selectFacesVP vp (faces sfg \\ faces fg) - --- | drawWithMax g - draws g and overlays the maximal composition of force g in red. --- This relies on g and all compositions of force g having vertices in force g. -drawWithMax :: OKBackend b => - Tgraph -> Diagram b -drawWithMax g = (dmax # lc red # lw medium) <> dg where - vp = makeVP $ force g -- duplicates force to get the locations of vertices in the forced Tgraph - dg = restrictSmart g draw vp - maxg = maxCompForce g - dmax = draw $ subVP vp $ faces $ forgetF maxg - --- |addBoundaryAfter f g - displaying the boundary of a Tgraph g in lime (overlaid on g drawn with f). -addBoundaryAfter :: OKBackend b => - (VPatch -> Diagram b) -> Tgraph -> Diagram b -addBoundaryAfter f g = (drawEdgesVP vp edges # lc lime) <> f vp where - vp = makeVP g - edges = graphBoundary g - --- |drawCommonFaces (g1,e1) (g2,e2) uses commonFaces (g1,e1) (g2,e2) to find the common faces --- and emphasizes them on the background g1. -drawCommonFaces :: OKBackend b => - (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram b -drawCommonFaces (g1,e1) (g2,e2) = emphasizeFaces (commonFaces (g1,e1) (g2,e2)) g1 - --- |emphasizeFaces fcs g emphasizes the given faces (that are in g) overlaid on the background draw g. -emphasizeFaces :: OKBackend b => - [TileFace] -> Tgraph -> Diagram b -emphasizeFaces fcs g = (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where - vp = makeVP g - emphvp = subVP vp (fcs `intersect` faces g) - - --- | 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 is a partial function similar to (compose . force), --- i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph). --- However it produces an explicitly Forced Tgraph, --- and is more efficient because it omits the check for connected, and no crossing boundaries --- (and uses getDartWingInfoForced instead of getDartWingInfo) --- This relies on a proof that composition does not need to be checked for a forced Tgraph. --- (We also have a proof that the result must be a forced Tgraph when the initial force succeeds.) -compForce:: Tgraph -> Forced Tgraph -compForce = composeF . forceF - -{- compForce:: Tgraph -> Tgraph -compForce = uncheckedCompose . force - -} --- |allCompForce g produces a list of the non-null iterated (forced) compositions of force g. --- It will raise an error if the initial force fails with an incorrect Tgraph. --- The list will be [] if g is the emptyTgraph, otherwise the list begins with force g (when the force succeeds). --- The definition relies on (1) a proof that the composition of a forced Tgraph is forced and --- (2) a proof that composition does not need to be checked for a forced Tgraph. -allCompForce:: Tgraph -> [Forced Tgraph] -allCompForce = takeWhile (not . nullGraph . forgetF) . iterate composeF . forceF - -{- 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 -> Forced Tgraph -maxCompForce g | nullGraph g = Forced g - | otherwise = last $ allCompForce g - -{- --- |force after a decomposition (raising an error if the force fails with an incorrect Tgraph) -forceDecomp:: Tgraph -> Tgraph -forceDecomp = force . decompose --} - --- | allForceDecomps g - produces an infinite list (starting with g) --- of forced decompositions of g (raising an error if a force fails with an incorrect Tgraph). -allForceDecomps:: Tgraph -> [Tgraph] -allForceDecomps = iterate (force . decompose) - -{-| forcedBoundaryECovering g - produces a list of all boundary covers of force g, each of which -extends force g to cover the entire boundary directed edges in (force g). -(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 -> [Forced Tgraph] -forcedBoundaryECovering g = fmap recoverGraph <$> boundaryECovering gforcedBdry where - gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" $ - tryForceF $ 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. -This will raise an error if the initial force fails with a stuck graph. --} -forcedBoundaryVCovering:: Tgraph -> [Forced Tgraph] -forcedBoundaryVCovering g = fmap recoverGraph <$> boundaryVCovering gforcedBdry where - gforcedBdry = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" $ - tryForceF $ makeBoundaryState g - -{-| boundaryECovering - for an explicitly Forced BoundaryState fbd, -produces a list of all possible covers of the boundary directed edges in fbd. -A cover is an explicitly Forced extension (of fbd) such that the original boundary directed edges of fbd 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 both choices on a boundary edge fail when forced (using atLeastOne). --} -boundaryECovering:: Forced BoundaryState -> [Forced BoundaryState] -boundaryECovering (Forced bstate) = covers [(bstate, boundaryEdgeSet bstate)] where - covers:: [(BoundaryState, Set.Set Dedge)] -> [Forced BoundaryState] - covers [] = [] - covers ((bs,es):opens) - | Set.null es = Forced 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 fbd - similar to boundaryECovering, but produces a list of all possible covers of - the boundary vertices in fbd (rather than just boundary edges). - This can raise an error if both choices on a boundary edge fail when forced (using atLeastOne). - -} -boundaryVCovering:: Forced BoundaryState -> [Forced BoundaryState] -boundaryVCovering (Forced 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 -> Forced open:covers opens - Just dedge -> covers $ fmap (,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 of a Forcible b and then tries forcing. Each of the results is a Try. -tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a] -tryDartAndKiteForced de b = - [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ - 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 results 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. -drawFBCovering :: OKBackend b => - Tgraph -> Diagram b -drawFBCovering g = lw ultraThin $ vsep 1 (draw . forgetF <$> forcedBoundaryVCovering g) - - --- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g. --- Raises an error if force g fails with a stuck/incorrect Tgraph. --- 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 = - case forcedBoundaryVCovering g of - [] -> error "empire1 : no forced boundary covers found\n" - (fg0:others) -> makeTrackedTgraph g0 [fcs,faces g] where - g0 = forgetF fg0 - fcs = foldl' intersect (faces g0) $ fmap g0Intersect others - de = defaultAlignment g - g0Intersect fg1 = commonFaces (g0,de) (forgetF fg1,de) - --- | empire2 g - produces a TrackedTgraph representing the level 2 empire of g. --- Raises an error if force g fails with a stuck/incorrect Tgraph. --- 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 = - case fmap (recoverGraph . forgetF) covers2 of - [] -> error "empire2: empty list of secondary boundary covers found" - (g0:others) -> makeTrackedTgraph g0 [fcs, faces g] - where fcs = foldl' intersect (faces g0) $ fmap g0Intersect others - g0Intersect g1 = commonFaces (g0,de) (g1,de) - where - covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" - $ tryForceF $ makeBoundaryState g - covers2 = concatMap boundaryECovering covers1 - de = defaultAlignment g - - --- | empire2Plus g - produces a TrackedTgraph representing an extended level 2 empire of g --- similar to empire2, but using boundaryVCovering instead of boundaryECovering. --- Raises an error if force g fails with a stuck/incorrect Tgraph. -empire2Plus:: Tgraph -> TrackedTgraph -empire2Plus g = - case fmap (recoverGraph . forgetF) covers2 of - [] -> error "empire2: empty list of secondary boundary covers found" - (g0:others) -> makeTrackedTgraph g0 [fcs, faces g] - where fcs = foldl' intersect (faces g0) $ fmap g0Intersect others - g0Intersect g1 = commonFaces (g0,de) (g1,de) - where - covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" - $ tryForceF $ makeBoundaryState g - covers2 = concatMap boundaryVCovering covers1 - de = defaultAlignment g - - --- | 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. -drawEmpire :: OKBackend b => - TrackedTgraph -> Diagram 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. -showEmpire1 :: OKBackend b => - Tgraph -> Diagram b -showEmpire1 = drawEmpire . empire1 - --- | showEmpire2 g - produces a diagram emphasising the common faces of a doubly-extended boundary cover of force g. --- This is drawn over one of the possible doubly-extended boundary covers and the faces of g are shown in red. -showEmpire2 :: OKBackend b => - Tgraph -> Diagram 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" $ - tryForceF fs - case singleChoiceEdges $ fmap boundaryState forcedFS of - [] -> return $ forgetF forcedFS - (elpr:_) -> do extended <- addSingle elpr $ forgetF forcedFS - trySuperForceFS extended - addSingle (e,l) fs = if isDart l then tryAddHalfDart e fs else tryAddHalfKite e fs - --- |singleChoiceEdges bd - if bd is an explicitly Forced 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 :: Forced BoundaryState -> [(Dedge,HalfTileLabel)] -singleChoiceEdges bstate = commonToCovering (forgetF <$> boundaryECovering bstate) (boundary $ forgetF 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 (_:_) ([]:_) = error "singleChoiceEdges:commonToCovering: empty list of labels" - common (e:more) ((l:ls):lls) = if all (==l) ls - then (e,l):common more lls - else common more lls - --- |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 = Data.Maybe.fromMaybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e) - (faceForEdge e efmap) - --- |Tries to create a new Tgraph from all faces with a boundary vertex in a Tgraph. --- The resulting faces could have a crossing boundary and also could be disconnected if there is a hole in the starting Tgraph --- so these conditions are checked for, producing a Try result. -tryBoundaryFaceGraph :: Tgraph -> Try Tgraph -tryBoundaryFaceGraph = tryConnectedNoCross . boundaryFaces . makeBoundaryState - - --- | Returns a list of (looping) vertex trails for the boundary of a Tgraph. --- 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 [] = error "pathFromBoundaryLoops: empty loop found\n" - locateLoop (p:pts) = (`at` p) $ glueTrail $ trailFromVertices (p: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.) --} -drawTrackedTgraph :: OKBackend b => [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b -drawTrackedTgraph drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where - vp = makeVP (tgraph ttg) - untracked = vpFaces vp \\ concat (tracked ttg) - 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 (anticlockwise) before drawing - to ensure labels are not rotated. --} -drawTrackedTgraphRotated :: OKBackend b => [VPatch -> Diagram b] -> Angle Double -> TrackedTgraph -> Diagram b -drawTrackedTgraphRotated drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where - vp = rotate a $ makeVP (tgraph ttg) - untracked = vpFaces vp \\ concat (tracked ttg) - 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) alignment. - This is useful when labels are being drawn. - The vertex pair argument is used to align the common vertex location map before drawing - (to ensure labels are not rotated). - This will raise an error if either of the pair of vertices is not a vertex of (the tgraph of) the TrackedTgraph --} -drawTrackedTgraphAligned :: OKBackend b => [VPatch -> Diagram b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram b -drawTrackedTgraphAligned drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where - vp = makeAlignedVP (a,b) (tgraph ttg) - untracked = vpFaces vp \\ concat (tracked ttg) - vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp - - - diff --git a/src/TileLib.hs b/src/TileLib.hs --- a/src/TileLib.hs +++ b/src/TileLib.hs @@ -32,8 +32,10 @@ , ttangle , pieceEdges , wholeTileEdges + -- $OKBackend , drawPiece , dashjPiece + , joinDashing , dashjOnly , drawRoundPiece , drawJoin @@ -43,8 +45,8 @@ , leftFillPieceDK , experiment -- * Patches and Drawable Class - , Drawable(..) , Patch + , Drawable(..) , draw , drawj , fillDK @@ -64,7 +66,7 @@ , suns , sun5 , sun6 - -- * Diagrams of Patches + -- * Example Diagrams of Patches , sun6Fig , leftFilledSun6 , filledSun6 @@ -73,7 +75,6 @@ , scales , phiScales , phiScaling - , joinDashing ) where import Diagrams.Prelude @@ -82,12 +83,14 @@ import CheckBackend 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. +{-| Piece is a type for (scaled and oriented) tile halves: Left Dart, Right Dart, Left Kite, Right Kite +represented by a vector from their origin along the join edge where +origin for a dart is the tip, origin for a kite is the vertex opposite the vertex with +largest internal angle. -Pieces are Transformable +(This specialises polymorphic HalfTiles with 2D vectors). + +Pieces are Transformable (but not translatable until they are located). -} type Piece = HalfTile (V2 Double) @@ -95,16 +98,22 @@ 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 is a left dart at the origin with join edge oriented along the x axis, unit length. ldart = LD unitX +-- |rdart is a right dartat the origin with join edge oriented along the x axis, unit length. rdart = RD unitX +-- |lkite is a left kite at the origin with join edge oriented along the x axis, length phi. lkite = LK (phi*^unitX) +-- |rkite is a right kite at the origin with join edge oriented along the x axis, length phi. 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) +-- We have the following roperties of the golden ratio +-- +-- phi^2 == phi + 1 and 1/phi = phi-1 +-- +-- phi^3 = 2phi + 1 and 1/phi^2 = 2-phi phi::Double phi = (1.0 + sqrt 5.0) / 2.0 @@ -115,10 +124,11 @@ 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. +{-|This 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. +We consider left and right as viewed from the origin. +This means that darts are reversed with respect to a view from the tail, but kites are +in keeping with a common view (the kite tail being the origin). 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. @@ -137,22 +147,10 @@ wholeTileEdges (LK v) = pieceEdges (LK v) ++ map negated (reverse $ pieceEdges (RK v)) wholeTileEdges (RK v) = wholeTileEdges (LK v) -{- --- |Class OKBackend is a synonym for suitable constraints on a Backend -class (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) - => OKBackend b where {} --} - -{- --- | Abbreviation for 2D diagrams for any Backend b. --- No longer used now class OKBackend is available -type Diagram2D b = QDiagram b V2 Double Any +{- $OKBackend +Note: Most functions for drawing will have constraint OKBackend b and result type Diagram b -} - - - - - + -- |drawing lines for the 2 non-join edges of a piece. drawPiece :: OKBackend b => Piece -> Diagram b @@ -204,20 +202,6 @@ (LK _) -> fillOnlyPiece kcol piece (RK _) -> fillOnlyPiece kcol piece -{- {-# DEPRECATED fillMaybePieceDK "Use fillPieceDK which now works with AlphaColours such as transparent" #-} --- |fillMaybePieceDK *Deprecated* --- (use fillPieceDK which works with AlphaColours such as transparent as well as Colours) -fillMaybePieceDK :: OKBackend b => - Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram b -fillMaybePieceDK d k piece = drawPiece piece <> filler where - maybeFill (Just c) = fillOnlyPiece c piece - maybeFill Nothing = mempty - 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). @@ -247,7 +231,7 @@ -- |A patch is a list of Located pieces (the point associated with each piece locates its originV) --- Patches are Transformable +-- Patches are Transformable (including translatable) type Patch = [Located Piece] -- | A class for things that can be turned to diagrams when given a function to draw pieces. diff --git a/src/Try.hs b/src/Try.hs --- a/src/Try.hs +++ b/src/Try.hs @@ -6,23 +6,29 @@ 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). +Try is a synonym for Either ShowS, and is used for results of partial operations +which return either Right something when defined or Left report when there is a problem +(where report 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. -} +{-# LANGUAGE FlexibleInstances #-} -- needed for instance Show (ShowS) +{-# OPTIONS_GHC -Wno-orphans #-} -- needed for instance Show (ShowS) + module Try ( -- * Try - result types with failure reporting (for partial operations). Try , onFail , nothingFail + , failReport + , failReports , runTry , ifFail , isFail , concatFails , ignoreFails + , tryAtLeastOne , atLeastOne -- , noFails ) where @@ -30,36 +36,47 @@ 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 +-- | Try is a synonym for Either ShowS. Used for results of partial functions +-- which return either Right something when defined or Left r when there is a problem +-- where r is a (prepending) failure report. +-- Note: ShowS = String -> String makes prepending Strings efficient as composition +-- Note: Either ShowS (and hence Try) is a monad, and this is used frequently for combining partial operations. +type Try a = Either ShowS a --- | onFail s exp - inserts s at the front of failure report if exp fails with Left report +-- | onFail s exp - prepends s at the front of a failure report if exp fails with Left report -- but does nothing otherwise. onFail:: String -> Try a -> Try a -onFail s = either (Left . (s++)) Right +onFail s = either (Left . (pure s <>)) Right --either (Left . (pure s .)) Right +-- |failReport s - creates a failure (Left), prepending s for the failure report +failReport :: String -> Try a +failReport = Left . (<>) + +-- |failReports ss - creates a failure (Left), concatenating ss for the failure report +failReports :: [String] -> Try a +failReports = Left . mconcat . fmap (<>) --failReport . mconcat + -- Note: failReport . mconcat concatenates strings + -- but Left . mconcat . fmap (<>) composes functions + -- | nothingFail a s - Converts a Maybe Result (a) into a Try result by treating Nothing as a failure --- (the string s is the failure report on failure). +-- (the String s is used for 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 +nothingFail a s = maybe (failReport s) Right a --- |Extract the (Right) result from a Try, producing an error if the Try is Left s. --- The failure report (s) is passed to error for an error report. +-- |Extract the (Right) result from a Try, raising an error if the Try is Left r. +-- The failure report (from Left r) is converted to a Stirng and passed to error. runTry:: Try a -> a -runTry = either error id +runTry = either (error . ($ "")) id --- |ifFail a tr - extracts the (Right) result from tr but returning a if tr is Left s. +-- |ifFail a tr - extracts the (Right) result from tr but returning a if tr is Left _ . ifFail :: a -> Try a -> a -ifFail = fromRight +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. @@ -67,25 +84,27 @@ concatFails:: [Try a] -> Try [a] concatFails ls = case lefts ls of [] -> Right $ rights ls - other -> Left $ mconcat other -- concatenates strings for single report + other -> Left $ mconcat other -- concatenates reports 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 +-- | tryAtLeastOne rs - returns Right with the list of successful results if there are any, +-- but Left with a fail report otherwise. +-- The error report will include the concatenated reports from multiple failures. +tryAtLeastOne:: [Try a] -> Try [a] +tryAtLeastOne [] = failReport "atLeastOne: applied to empty list.\n" +tryAtLeastOne results = case ignoreFails results of + [] -> onFail "atLeastOne: no successful results.\n" $ concatFails results + other -> Right other + -- | 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. +-- The error report will include the concatenated reports from multiple 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.\nCounter Example Found?\n" $ concatFails results - other -> other +atLeastOne = runTry . tryAtLeastOne -{- {-# DEPRECATED noFails "Use (runTry . concatFails) instead" #-} --- | 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 - -} +-- |Cheating - a ShowS function is "shown" by applying it to a String +instance Show ShowS where + show r = show " = (" ++ r "" ++ show " ++)" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,9 @@ import Test.Hspec import Control.Exception (evaluate) -import Tgraphs +import PKD import TgraphExamples --- import TestIllustrate (touchErrorFaces,testCrossingBoundary) + main :: IO () main = hspec spec @@ -116,7 +116,7 @@ length(faces dD6) `shouldBe` 466 context "Composing Tgraphs" $ it "Number of faces of maxCompForce (dartDs !!6) should be 6" $ - (length $ faces $ forgetF $ maxCompForce dD6) `shouldBe` 6 + length (faces $ forgetF $ maxCompForce dD6) `shouldBe` 6 context "Forcing Tgraphs" $ it "Number of faces of force (dartDs !!6) should be 7546" $ length(faces(force dD6)) `shouldBe` 7546