{-|
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 #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Tgraph.Extras
( smart
, smartdraw
, smartOn
, smartRotating
, smartAligning
, smartRotateBefore
, smartAlignBefore
, drawBoundaryJoins
, drawJoinsFor
-- * Overlaid drawing tools for Tgraphs
, drawPCompose
, drawForce
, drawPCompose'
, drawForce'
, drawSuperForce
, drawWithMax
, 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
, commonBdry
, 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
, drawTrackedTgraphRotating
, drawTrackedTgraphAligning
, 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, transpose)
import Prelude hiding (Foldable(..))
import Data.Foldable (Foldable(..))
import Data.Set(Set)
import qualified Data.Set as Set (null,intersection,deleteFindMin)-- used for boundary covers
import qualified Data.IntSet as IntSet (member,(\\)) -- for boundary vertex set
import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops
-- |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, HasGraph a) =>
(VPatch -> Diagram b) -> a -> Diagram b
smart dr a = (drawBoundaryJoins g <> dr) (makeVP g) where g = recoverGraph a
-- |drawBoundaryJoins a vp - draw boundary join edges of faces in a, using a given suitable VPatch
-- Will raise an error if any vertex in the faces does not have a location in the VPatch.
drawBoundaryJoins :: (HasFaces a, OKBackend b) => a -> VPatch -> Diagram b
drawBoundaryJoins = drawJoinsFor . boundaryJoinFaces
--drawWith dashJOnly $ restrictTo (boundaryJoinFaces a) vp
{- Old version used drawEdgesVP
drawBoundaryJoins :: OKBackend b => Tgraph -> VPatch -> Diagram b
drawBoundaryJoins g vp = drawEdgesVP vp (map joinE $ boundaryJoinFaces g) # joinDashing
-}
-- |drawJoinsFor a vp - If vp is a VPatch with suitable locations, draw dashed joins for the faces in a.
-- Will raise an error if any vertex in the faces does not have a location in the VPatch.
drawJoinsFor:: (HasFaces a, OKBackend b) =>
a -> VPatch -> Diagram b
drawJoinsFor a = drawWith dashJOnly . restrictTo a
-- |same as draw except adding dashed lines on boundary join edges.
smartdraw :: (OKBackend b, HasGraph a) => a -> Diagram b
smartdraw = smart draw
-- |smartOn a dr vp - assumes the VPatch vp has locations for vertices in faces of a.
-- It uses the VPatch drawing function dr to draw faces in a and adds dashed boundary joins.
-- This can be used instead of smart when an appropriate vp is already available.
smartOn :: (HasFaces a, OKBackend b) =>
a -> (VPatch -> Diagram b) -> VPatch -> Diagram b
smartOn a dr = (drawBoundaryJoins a <> dr) . restrictTo a
-- |smartRotating angle vfun g - a tricky combination of smart with rotating.
-- Uses vfun to produce a Diagram after converting g to a rotated VPatch (rotated by angle)
-- then adds the dashed boundary join edges of g.
--
-- Example: smartRotating angle (labelled draw) g
smartRotating :: (OKBackend b, HasGraph a) =>
Angle Double -> (VPatch -> Diagram b) -> a -> Diagram b
smartRotating angle vfun a = rotating angle (smartOn g vfun) g where g = recoverGraph a
{-# DEPRECATED smartRotateBefore "Use (flip smartRotating)" #-}
-- |smartRotateBefore vfun angle g - a tricky combination of smart with rotateBefore.
-- Uses vfun to produce a Diagram after converting g to a rotated VPatch (rotated by angle)
-- then adds the dashed boundary join edges of g.
smartRotateBefore :: OKBackend b =>
(VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b
smartRotateBefore = flip smartRotating
-- |smartAligning (a,b) vfun g - a tricky combination of smart with aligning.
-- Uses vfun to produce a Diagram after converting g to an aligned VPatch
-- then adds the dashed boundary join edges of g.
-- Vertex a is centered and vertex b aligned on the positive x-axis.
-- Will raise an error if either a or b is not a vertex in g.
--
-- Example: smartAligning (a,b) (labelled draw) g
smartAligning :: (OKBackend b, HasGraph a) =>
(Vertex,Vertex) -> (VPatch -> Diagram b) -> a -> Diagram b
smartAligning (a,b) vfun c = aligning (a,b) (smartOn g vfun) g where g = recoverGraph c
{-# DEPRECATED smartAlignBefore "Use (flip smartAligning)" #-}
-- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with aligning.
-- Uses vfun to produce a Diagram after converting g to an aligned VPatch
-- then adds the dashed boundary join edges of g.
smartAlignBefore :: OKBackend b =>
(VPatch -> Diagram b) -> (Vertex,Vertex) -> Tgraph -> Diagram b
smartAlignBefore = flip smartAligning
-- |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.
-- (See also drawForce')
drawForce :: OKBackend b =>
Tgraph -> Diagram b
drawForce = drawForce' red
-- |a generalisation of drawForce which takes an additional colour argument
-- for drawing the edges of the original Tgraph (default colour is red in drawForce).
drawForce' :: OKBackend b =>
Colour Double -> Tgraph -> Diagram b
drawForce' c g =
smartOn g draw vp # lc c <> draw vp
where vp = makeVP $ forceF g
-- |applies partCompose to a Tgraph g, then draws the composed Tgraph
-- along with the remainder faces (drawn in lime).
-- This will raise an error if the composed faces have a crossing boundary or are disconnected.
-- (See also drawPCompose')
drawPCompose :: OKBackend b =>
Tgraph -> Diagram b
drawPCompose = drawPCompose' lime
-- |a generalisation of drawPCompose which takes an additional colour argument
-- for drawing the edges of remainder faces (default colour is lime in drawPCompose).
drawPCompose' :: OKBackend b =>
Colour Double -> Tgraph -> Diagram b
drawPCompose' c g =
smartOn g' draw vp
<> drawJ (subFaces remainder vp) # lc c
where (remainder,g') = partCompose g
vp = makeVP 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 $ restrictTo (faces fg \\ faces g) vp
--selectFacesVP vp (faces fg \\ faces g) -- smartOn (force g) draw vp
dg = smartOn g draw vp
dsfg = draw $ restrictTo (faces sfg \\ faces fg) vp
--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 = drawWithMax' red
-- | generalisation of drawWithMax, taking an extra colour argument for drawing
-- the edges of the maximal composition (default is red in drawWithMax)
drawWithMax' :: OKBackend b =>
Colour Double -> Tgraph -> Diagram b
drawWithMax' c g = (dmax # lc c) <> dg where
vp = makeVP $ force g -- duplicates force to get the locations of vertices in the forced Tgraph
dg = smartOn g draw vp
maxg = maxCompForce g
dmax = draw $ subFaces maxg vp
-- |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 a g - emphasizes the faces that are in a and g, overlaid on the background draw g.
emphasizeFaces :: (OKBackend b, HasFaces a) =>
a -> Tgraph -> Diagram b
emphasizeFaces a g = (smartOn a draw vp # lw thin) <>
(smartOn g draw vp # lw ultraThin)
where vp = makeVP g
-- | For illustrating an unsound version of composition.
-- This composition defaults to
-- forming a large half kite when there is an unknown
-- dart wing on the boundary with a complete kite at the short edge of the half dart.
-- 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 $
do dwInfo <- tryGetDartWingInfo g
let changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo
, unknowns = []
}
( _ , newfaces) = partComposeDWI changedInfo
tryConnectedNoCross newfaces
-- |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 a faster composition method for forced Tgraphs.
-- 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:: (Forcible a, HasGraph a) => a -> Forced Tgraph
compForce = composeF . withForced recoverGraph . 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:: (Forcible a, HasGraph a) => a -> [Forced Tgraph]
allCompForce = takeWhile (not . nullGraph) . iterate composeF . withForced recoverGraph . 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:: (Forcible a, HasGraph a) => a -> Forced Tgraph
maxCompForce g | nullGraph g = labelAsForced emptyTgraph -- forceF 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:: HasGraph a => a -> [Tgraph]
allForceDecomps = iterate (force . decompose) . recoverGraph
{-| 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 = withForced recoverGraph <$> boundaryECovering gforcedBdry where
gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n"
$ tryInitFS g >>= tryForceF
{-| 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 = withForced recoverGraph <$> boundaryVCovering ffs where
ffs = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n"
$ tryInitFS g >>= tryForceF
{-| boundaryECovering - for an explicitly Forced ForceState ffs,
produces a list of all possible covers of the boundary directed edges in ffs.
A cover is an explicitly Forced extension (of ffs) such that the original boundary directed edges of ffs are all internal edges.
Extensions are made by choosing any edge on the original boundary that is still on the boundary,
adding both possible legal faces, and forcing each result (keeping only successes - using
tryCheckCasesDKF) then
repeating this process 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 tryCheckCasesDKF).
In which case, ffs represents an important counter example to the hypothesis that
successfully forced forcibles are correct.
-}
boundaryECovering:: Forced ForceState -> [Forced ForceState]
boundaryECovering forcedfs = covers [(forcedfs, boundaryESet forcedfs)] where
covers:: [(Forced ForceState, Set Dedge)] -> [Forced ForceState]
covers [] = []
covers ((ffs,es):opens)
| Set.null es = ffs:covers opens -- fs is a completed cover
| otherwise = covers (newcases ++ opens)
where (de,des) = Set.deleteFindMin es
newcases = map (\x -> (x, commonBdry des x))
(runTry $ tryCheckCasesDKF de ffs)
-- | commonBdry des a - returns those directed edges in des that are boundary directed edges of a
commonBdry:: HasFaces a => Set Dedge -> a -> Set Dedge
commonBdry des a = des `Set.intersection` boundaryESet a
{-| boundaryVCovering ffs - similar to boundaryECovering, but produces a list of all possible covers of
the boundary vertices in ffs (rather than just boundary edges).
This can raise an error if both choices on a boundary edge fail when forced (using tryCheckCasesDKF).
-}
boundaryVCovering:: Forced ForceState -> [Forced ForceState]
boundaryVCovering ffs = covers [(ffs, startbdes)] where
startbdes = boundaryESet ffs
startbvs = boundaryVSet ffs
covers:: [(Forced ForceState, Set Dedge)] -> [Forced ForceState]
covers [] = []
covers ((open,es):opens)
| Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary open) of
Nothing -> open:covers opens
Just dedge -> covers $ map (,es) (runTry $ tryCheckCasesDKF dedge open) ++opens
| otherwise = covers $ map (\b -> (b, commonBdry des b)) (runTry $ tryCheckCasesDKF de open) ++opens
where (de,des) = Set.deleteFindMin es
-- | returns the set of internal vertices of all tilefaces
internalVertexSet :: HasFaces a => a -> VertexSet
internalVertexSet a = vertexSet a IntSet.\\ boundaryVSet 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
]
-- | 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 de fa =
onFail ("tryCheckCasesDKF: <<< Counter Example Found!! >>>\n"
++ "\nBoth legal extensions to directed edge "
++ show de
++ " \nare incorrrect for a Forced ForceState.\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 Forced ForceState has Tgraph:\n"
++ show (forgetF fa)
) $
fmap (map labelAsForced) $ tryAtLeastOne
[ onFail ("tryCheckCasesDKF: Dart on edge: " ++ show de ++ "\n") $
tryFSOp (\fs -> tryAddHalfDart de fs >>= tryForce) a
, onFail ("tryCheckCasesDKF: Kite on edge: " ++ show de ++ "\n") $
tryFSOp (\fs -> tryAddHalfKite de fs >>= tryForce) a
] where a = forgetF fa
{- 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 . recoverGraph <$> 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 = recoverGraph fg0
fcs = foldl' intersect (faces g0) $ map g0Intersect others
de = defaultAlignment g
g0Intersect fg1 = commonFaces (g0,de) (recoverGraph 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 map recoverGraph covers2 of
[] -> error "empire2: empty list of secondary boundary covers found"
(g0:others) -> makeTrackedTgraph g0 [fcs, faces g]
where fcs = foldl' intersect (faces g0) $ map g0Intersect others
g0Intersect g1 = commonFaces (g0,de) (g1,de)
where
covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n"
$ tryInitFS g >>= tryForceF
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 map recoverGraph covers2 of
[] -> error "empire2: empty list of secondary boundary covers found"
(g0:others) -> makeTrackedTgraph g0 [fcs, faces g]
where fcs = foldl' intersect (faces g0) $ map g0Intersect others
g0Intersect g1 = commonFaces (g0,de) (g1,de)
where
covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n"
$ tryInitFS g >>= tryForceF
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 -> Forced 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 (Forced a)
trySuperForce = fmap labelAsForced . tryFSOp trySuperForceFS where
-- |trySuperForceFS - implementation of trySuperForce for force states only
trySuperForceFS :: ForceState -> Try ForceState
trySuperForceFS fs =
do ffs <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $
tryForceF fs
case singleChoiceEdges $ ffs of
[] -> return $ forgetF ffs
(elpr:_) -> do extended <- addSingle elpr $ forgetF ffs
trySuperForceFS extended
addSingle (e,l) fs = if isDart l then tryAddHalfDart e fs else tryAddHalfKite e fs
-- |singleChoiceEdges ffs - if ffs is an explicitly Forced ForceState (of a forced Tgraph) this finds those boundary edges of ffs
-- which have a single choice (i.e. the other choice is incorrect), by inspecting boundary edge covers of ffs.
-- 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 ForceState -> [(Dedge,HalfTileLabel)]
singleChoiceEdges bstate = commonToCovering (forgetF <$> boundaryECovering bstate) (boundary bstate)
where
-- commonToCovering bds edgeList - when bds are all the boundary edge covers of some forced Tgraph
-- whose boundary edges were edgeList, this looks for edges in edgeList that have the same tile label added in all covers.
-- This indicates there is a single choice for such an edge (the other choice is incorrect).
-- The result is a list of pairs: edge and a common tile label.
commonToCovering :: [ForceState] -> [Dedge] -> [(Dedge,HalfTileLabel)]
commonToCovering ffs edgeList = common edgeList (transpose labellists) where
labellists = map (`reportCover` edgeList) ffs
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 fs edgelist - when fs 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 :: ForceState -> [Dedge] -> [HalfTileLabel]
reportCover fs des = map getLabel des where
efmap = dedgeFMap des fs -- more efficient than using graphEFMap?
getLabel e = case faceForEdge e efmap of
Nothing -> error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e
Just f -> tileLabel f
-- |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 :: HasFaces a => a -> Try Tgraph
tryBoundaryFaceGraph = tryConnectedNoCross . boundaryVFaces
{- -- | 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 :: HasGraph a => a -> TrackedTgraph
newTrackedTgraph g = makeTrackedTgraph (recoverGraph 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 :: HasGraph a => a -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph a trackedlist = TrackedTgraph{ tgraph = g, tracked = map (`intersect` faces g) trackedlist}
where g = recoverGraph a
-- |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
tryFSOp f ttg = do
g' <- tryFSOp f $ recoverGraph ttg
return ttg{ tgraph = g' }
tryInitFS = tryInitFS . recoverGraph
tryChangeBoundary f ttg = do
g' <- tryChangeBoundary f $ recoverGraph ttg
return ttg{ tgraph = g' }
-- |TrackedTgraph is in class HasFaces
instance HasFaces TrackedTgraph where
faces = faces . recoverGraph
{- boundary = boundary . tgraph
maxV = maxV . tgraph
boundaryVFMap = boundaryVFMap . tgraph -- note need for nub
-}
-- | TrackedTgraph is in class HasGraph
instance HasGraph TrackedTgraph where
recoverGraph = 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 = recoverGraph 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 = recoverGraph 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 = recoverGraph ttg
g' = makeUncheckedTgraph newFaces
newVFor = phiVMap g
newFaces = concatMap (decompFace newVFor) (faces g)
tlist = map (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 ttg
untracked = faces vp \\ concat (tracked ttg)
vpList = map (`restrictTo` 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.
-}
drawTrackedTgraphRotating :: OKBackend b => Angle Double -> [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b
drawTrackedTgraphRotating a drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where
vp = rotate a $ makeVP ttg
untracked = faces vp \\ concat (tracked ttg)
vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp
{-# DEPRECATED drawTrackedTgraphRotated "Use (flip drawTrackedTgraphRotating)" #-}
{-|
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 = flip drawTrackedTgraphRotating
{-|
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
-}
drawTrackedTgraphAligning :: OKBackend b => (Vertex,Vertex) -> [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b
drawTrackedTgraphAligning (a,b) drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where
vp = makeAlignedVP (a,b) ttg
untracked = faces vp \\ concat (tracked ttg)
vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp
{-# DEPRECATED drawTrackedTgraphAligned "Use (flip drawTrackedTgraphAligning)" #-}
{-|
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 = flip drawTrackedTgraphAligning