diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,46 @@ # Revision history for PenroseKiteDart +## version 1.3 -- 2025-5-19 + +Breaking changes: + +Removed: +uncheckedCompose (use new composeF with explicitly Forced Tgraph) +uncheckedPartCompose (use new partComposeF with explicitly Forced Tgraph) + +Changed types (to make use of Forced) for: +compForce +allCompForce +maxCompForce +boundaryVCovering +boundaryECovering +singleChoiceEdges + +Removed deprecated: +noFails (use runTry . concatFails) +colourMaybeDKG (use colourDKG with transparent) +fillMaybeDK (use fillDK with transparent) +fillMaybePieceDK (use fillPieceDK with transparent) + +Renamed: +tryOneStepF is now tryOneStepForce + +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) +composeF :: Forced Tgraph -> Forced Tgraph +partComposeF :: Forced Tgraph -> ([TileFace], Forced Tgraph) + +Added warning in PKD for makeUncheckedTgraph + + ## version 1.2.1 -- 2025-4-2 Added: drawBoundaryJoins, joinDashing 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.2.1 +version: 1.3 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 @@ -46,7 +46,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 - , containers >=0.6.7 && <0.8 + , containers >=0.6.7 && <0.7 , diagrams-lib >=1.4.6 && <1.5 default-language: Haskell2010 @@ -61,7 +61,7 @@ build-depends: PenroseKiteDart , base >=4.7 && <5 - , containers >=0.6.7 && <0.8 + , containers >=0.6.7 && <0.7 , diagrams-lib >=1.4.6 && <1.5 , hspec >=2.10.10 && <2.12 default-language: Haskell2010 @@ -77,6 +77,6 @@ build-depends: PenroseKiteDart , base >=4.7 && <5 - , containers >=0.6.7 && <0.8 + , containers >=0.6.7 && <0.7 , diagrams-lib >=1.4.6 && <1.5 default-language: Haskell2010 diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -26,7 +26,8 @@ _ <- traceMarkerIO "finished force" wait _ <- traceMarkerIO "starting (unchecked) composing" - let cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate uncheckedCompose fkD + 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 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/PKD.hs b/src/PKD.hs --- a/src/PKD.hs +++ b/src/PKD.hs @@ -6,18 +6,23 @@ Maintainer : chrisreade@mac.com Stability : experimental -This is the main module to import Tgraphs and TileLib (which includes Halftile) modules. +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. -} --- {-# LANGUAGE NoMonomorphismRestriction #-} --- {-# LANGUAGE FlexibleContexts #-} --- {-# LANGUAGE TypeFamilies #-} --- {-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch --- {-# LANGUAGE TypeOperators #-} -- needed for type equality constraints ~ + module PKD ( module Tgraphs , module TileLib + , makeUncheckedTgraph ) where -import Tgraphs import TileLib +import Tgraphs hiding (makeUncheckedTgraph, Forced(..)) -- hides data constructor +import Tgraphs (Forced) -- import Type only +import qualified Tgraphs as Unchecked (makeUncheckedTgraph) +{-# 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 @@ -6,7 +6,8 @@ Maintainer : chrisreade@mac.com Stability : experimental -This module includes the main composition operations compose, partCompose, tryPartCompose but also exposes +This module includes the main composition operations compose, partCompose, +tryPartCompose, composeF, and partComposeF but also exposes getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and composedFaceGroups for debugging and experimenting. -} -- {-# LANGUAGE StrictData #-} @@ -14,12 +15,11 @@ module Tgraph.Compose ( compose , partCompose + , partComposeF + , composeF , tryPartCompose - , uncheckedCompose - , uncheckedPartCompose , partComposeFaces - -- , partComposeFacesWith - -- , composedFaces + -- , partComposeFacesF , DartWingInfo(..) , getDartWingInfo , getDartWingInfoForced @@ -32,29 +32,22 @@ import qualified Data.IntSet as IntSet (empty,insert,toList,member) import Tgraph.Prelude - +import Tgraph.Force ( Forced(..), forgetF ) {------------------------------------------------------------------------- *************************************************************************** COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose *************************************************************************** ---------------------------------------------------------------------------} --- |The main compose function which simply drops the remainder faces from partCompose to return just +-- |The main compose (partial) function which simply drops the remainder faces from partCompose to return just -- the composed Tgraph. It will raise an error if the result is not a valid Tgraph --- (i.e. if it fails the connectedness, no crossing boundary check) --- It does not assume the given Tgraph is forced and is inefficient on large Tgraphs +-- (i.e. if it fails the connectedness, no crossing boundary check). +-- It does not assume the given Tgraph is forced. compose:: Tgraph -> Tgraph compose = snd . partCompose --- |This does the same as compose but more efficiently because it assumes the given Tgraph is forced. --- It uses getDartWingInfoForced and it does not perform checks for connectedness and no crossing boundaries in the result. --- This relies on a proof that the checks are not needed for forced Tgraphs. --- (The result is a forced Tgraph.) -uncheckedCompose:: Tgraph -> Tgraph -uncheckedCompose = snd . uncheckedPartCompose - --- |partCompose g produces a pair consisting of remainder faces (faces from g which will not compose) --- and a composed Tgraph. It does not assume the given Tgraph is forced and can be inefficient on large Tgraphs. +-- |partCompose g is a partial function producing a pair consisting of remainder faces (faces from g which will not compose) +-- and a composed Tgraph. It does not assume the given Tgraph is forced. -- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails. partCompose:: Tgraph -> ([TileFace],Tgraph) partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g @@ -63,43 +56,47 @@ -- It checks the resulting new faces for connectedness and no crossing boundaries. -- If the check is OK it produces Right (remainder, g') where g' is the composed Tgraph and remainder is a list -- of faces from g which will not compose. If the check fails it produces Left s where s is a failure report. --- It does not assume the given Tgraph is forced and is inefficient on large Tgraphs. +-- It does not assume the given Tgraph is forced. tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = do let (remainder,newFaces) = partComposeFaces g checked <- onFail "tryPartCompose:/n" $ tryConnectedNoCross newFaces return (remainder,checked) --- |uncheckedPartCompose g - assumes g is forced. It produces a pair of the remainder faces (faces from g which will not compose) --- and a Tgraph made from the composed faces without checking for connectedness and no crossing boundaries. --- This relies on a proof that the result of composing a forced Tgraph does not require these checks. -uncheckedPartCompose:: Tgraph -> ([TileFace],Tgraph) -uncheckedPartCompose g = (remainder, makeUncheckedTgraph $! evalFaces newfaces) where - (remainder,newfaces) = partComposeFacesWith getDartWingInfoForced g - -- |partComposeFaces g - produces a pair of the remainder faces (faces from g which will not compose) -- and the composed faces (which may or may not constitute faces of a valid Tgraph). -- It does not assume that g is forced. partComposeFaces:: Tgraph -> ([TileFace],[TileFace]) -partComposeFaces = partComposeFacesWith getDartWingInfo - --- |partComposeFacesWith gtdwi g, --- (where gtdwi gets dart wing info from g - either getDartWingInfo or getDartWingInfoForced) --- produces a pair of the remainder faces (faces from the original which will not compose) --- and the composed faces (which may or may not constitute faces of a valid Tgraph). -partComposeFacesWith:: (Tgraph -> DartWingInfo) -> Tgraph -> ([TileFace],[TileFace]) -partComposeFacesWith getdwi g = (remainder,newfaces) where - compositions = composedFaceGroups $ getdwi g +partComposeFaces g = (remainder,newfaces) where + compositions = composedFaceGroups $ getDartWingInfo g newfaces = map fst compositions remainder = faces g \\ concatMap snd compositions +-- |partComposeFacesF (does the same as partComposeFaces for a Forced Tgraph). +-- It produces a pair of the remainder faces (faces which will not compose) +-- and the composed faces. +partComposeFacesF :: Forced Tgraph -> ([TileFace],[TileFace]) +partComposeFacesF fg = (remainder,newfaces) where + compositions = composedFaceGroups $ getDartWingInfoForced fg + newfaces = map fst compositions + remainder = faces (forgetF fg) \\ concatMap snd compositions -{- --- |composedFaces g produces the composed faces of g (which may or may not constitute faces of a valid Tgraph). -composedFaces:: Tgraph -> [TileFace] -composedFaces = snd . partComposeFaces - -} +-- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose) +-- and a composed (Forced) Tgraph. +-- 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 + (remainder,newfaces) = partComposeFacesF fg +-- |composeF - produces a composed Forced Tgraph from a Forced Tgraph. +-- Since the argument is a forced Tgraph it does not need a check for validity of the composed Tgraph. +-- The fact that the function is total and the result is also Forced relies on theorems +-- established for composing. +composeF:: Forced Tgraph -> Forced Tgraph +composeF = snd . partComposeF + + -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. -- It includes a faceMap from dart wings to faces at that vertex. data DartWingInfo = DartWingInfo @@ -114,11 +111,12 @@ getDartWingInfo:: Tgraph -> DartWingInfo getDartWingInfo = getDWIassumeF False --- | getDartWingInfoForced g, classifies the dart wings in g and calculates a faceMap for each dart wing, --- returning as DartWingInfo. It assume g is forced. -getDartWingInfoForced :: Tgraph -> DartWingInfo -getDartWingInfoForced = getDWIassumeF True +-- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg and calculates a faceMap for each dart wing, +-- returning as DartWingInfo. +getDartWingInfoForced :: Forced Tgraph -> DartWingInfo +getDartWingInfoForced fg = getDWIassumeF True ( forgetF fg) + -- | getDWIassumeF isForced g, classifies the dart wings in g and calculates a faceMap for each dart wing, -- returning as DartWingInfo. The boolean isForced is used to decide if g can be assumed to be forced. getDWIassumeF:: Bool -> Tgraph -> DartWingInfo @@ -216,9 +214,10 @@ find (matchingJoinE rk) (filter isLK fcs) findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" --- | Auxiliary function for partComposeFacesWith. --- Creates a list of new composed faces, each paired with a list of old faces (components of the new face) + +-- |Creates a list of new composed faces, each paired with a list of old faces (components of the new face) -- using dart wing information. +-- Auxiliary function but exported for experimenting. composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where diff --git a/src/Tgraph/Force.hs b/src/Tgraph/Force.hs --- a/src/Tgraph/Force.hs +++ b/src/Tgraph/Force.hs @@ -30,6 +30,11 @@ , initFS , tryInitFS , tryChangeBoundary + -- * Forced + , Forced(..) + , forgetF + , tryForceF + , forceF -- * Force Related , addHalfKite , tryAddHalfKite @@ -37,7 +42,7 @@ , tryAddHalfDart -- * One Step (for debugging) , tryOneStepWith - , tryOneStepF + , tryOneStepForce -- * Types for Forcing , ForceState(..) , BoundaryState(..) @@ -286,10 +291,6 @@ -- | tryChangeBoundaryWith when given an update generator, converts a (try) BoundaryState changing operation to a (try) Forcible operation. -- The update generator is only used when the instance is a ForceState (to revise the update map in the result). tryChangeBoundaryWith :: UpdateGenerator -> (BoundaryState -> Try BoundaryChange) -> a -> Try a -{- - -- | construct or recover the BoundaryState from a Forcible - getBoundaryState :: a -> BoundaryState --} -- |ForceStates are Forcible instance Forcible ForceState where @@ -362,7 +363,7 @@ tryForce:: Forcible a => a -> Try a tryForce = tryForceWith defaultAllUGen --- |The main force function using defaultAllUGen representing all 10 rules for updates. +-- |The main force (partial) function using defaultAllUGen representing all 10 rules for updates. -- This raises an error on discovering a stuck/incorrect Forcible. force:: Forcible a => a -> a force = runTry . tryForce @@ -372,6 +373,7 @@ wholeTiles = forceWith wholeTileUpdates -- | forceWith ugen: force using the given UpdateGenerator +-- This raises an error on discovering a stuck/incorrect Forcible. forceWith:: Forcible a => UpdateGenerator -> a -> a forceWith ugen = runTry . tryForceWith ugen @@ -401,8 +403,34 @@ 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) +-- +-- To access the forcible use: forgetF :: Forced a -> a +-- +-- Create using forceF or tryForceF +newtype Forced a = Forced 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 +-- |tryForceF is the same as tryForce except that +-- the successful result is explitly indicated as Forced. +tryForceF :: Forcible a => a -> Try (Forced a) +tryForceF = fmap Forced . tryForce + +-- |forceF is the same partial function as force except that +-- the (successful) result is explitly indicated as Forced. +forceF:: Forcible a => a -> Forced a +forceF = runTry . tryForceF + + -- |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. @@ -478,9 +506,9 @@ return $ Just (fs',bdC) Nothing -> return Nothing -- no more updates --- |tryOneStepF is a special case of tryOneStepWith using defaultAllUGen (used for debugging). -tryOneStepF :: ForceState -> Try (Maybe (ForceState,BoundaryChange)) -tryOneStepF = tryOneStepWith defaultAllUGen +-- |tryOneStepForce is a special case of tryOneStepWith using defaultAllUGen (used for debugging). +tryOneStepForce :: ForceState -> Try (Maybe (ForceState,BoundaryChange)) +tryOneStepForce = tryOneStepWith defaultAllUGen {-| After a face addition to a BoundaryState (by either trySafeUpdate or tryUnsafeUpdate), a BoundaryChange records @@ -690,6 +718,7 @@ -- |A version of force that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch. -- This is needed to limit accumulation of errors when large numbers of faces are added in forcing. +-- This raises an error on discovering a stuck/incorrect Forcible. recalibratingForce :: Forcible c => c -> c recalibratingForce = runTry . tryRecalibratingForce @@ -1148,9 +1177,9 @@ -- |The default all update generator (see also allUGenerator). It uses the 10 rules (and the same UCheckers as allUGenerator), -- but makes decisions based on the EdgeType of a boundary edge (instead of trying each UFinder in turn). -- If there are any Left..(fail reports) for the given --- boundary edges the result is a sigle Left.. concatenating all the failure reports (unlike allUGenerator). +-- boundary edges the result is a single Left, concatenating all the failure reports (unlike allUGenerator). defaultAllUGen :: UpdateGenerator -defaultAllUGen = UpdateGenerator gen where +defaultAllUGen = UpdateGenerator { applyUG = gen } where gen bd es = combine $ fmap decide es where -- Either String is a monoid as well as Map decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e diff --git a/src/Tgraph/Prelude.hs b/src/Tgraph/Prelude.hs --- a/src/Tgraph/Prelude.hs +++ b/src/Tgraph/Prelude.hs @@ -1124,6 +1124,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 (use drawLocatedEdges) drawEdges :: OKBackend b => VertexLocMap -> [Dedge] -> Diagram b diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs --- a/src/TgraphExamples.hs +++ b/src/TgraphExamples.hs @@ -355,7 +355,6 @@ fmap drawSuperForce decomps where decomps = take 4 $ decompositions sun3Dart - boundaryFDart4, boundaryFDart5 :: Tgraph -- |graph of the boundary faces only of a forced graph (dartDs!!4) boundaryFDart4 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 @@ -382,32 +381,31 @@ -- |figure for the boundary gap graph boundaryGapFDart5. boundaryGap5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryGapFDart5 - -- | boundaryVCoveringFigs bd - produces a list of diagrams for the boundaryVCovering of bd -- (with the Tgraph represented by bd shown in red in each case). boundaryVCoveringFigs :: OKBackend b => - BoundaryState -> [Diagram b] + Forced BoundaryState -> [Diagram b] boundaryVCoveringFigs bd = - lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph <$> boundaryVCovering bd + lw ultraThin . (redg <>) . alignBefore draw alig . (recoverGraph . forgetF) <$> boundaryVCovering bd where redg = lc red $ draw g --alignBefore draw alig g alig = defaultAlignment g - g = recoverGraph bd + g = recoverGraph $ forgetF bd -- | boundaryECoveringFigs bd - produces a list of diagrams for the boundaryECovering of bd -- (with the Tgraph represented by bd shown in red in each case). boundaryECoveringFigs :: OKBackend b => - BoundaryState -> [Diagram b] + Forced BoundaryState -> [Diagram b] boundaryECoveringFigs bd = - lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph <$> boundaryECovering bd + lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph . forgetF <$> boundaryECovering bd where redg = lc red $ draw g alig = defaultAlignment g - g = recoverGraph bd + g = recoverGraph $ forgetF bd kingECoveringFig,kingVCoveringFig :: OKBackend b => Diagram b -- | diagram showing the boundaryECovering of a forced kingGraph. -kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ force $ makeBoundaryState kingGraph +kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ forceF $ makeBoundaryState kingGraph -- | diagram showing the boundaryVCovering of a forced kingGraph. -kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ force $ makeBoundaryState kingGraph +kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ forceF $ makeBoundaryState kingGraph kingEmpiresFig, kingEmpire1Fig, kingEmpire2Fig :: OKBackend b => Diagram b -- | figure showing King's empires (1 and 2). diff --git a/src/Tgraphs.hs b/src/Tgraphs.hs --- a/src/Tgraphs.hs +++ b/src/Tgraphs.hs @@ -129,7 +129,7 @@ boundaryJoinFaces g = fmap snd $ incompleteHalves bdry $ boundary bdry where bdry = makeBoundaryState g --- draw boundary join edges of a Tgraph using a given VPatch +-- |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 @@ -160,7 +160,7 @@ smartRotateBefore vfun angle g = rotateBefore (restrictSmart g vfun) angle g -- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore. --- Uses vfun to produce a Diagram after converting g to n aligned VPatch but also adds the dashed boundary join edges of g. +-- 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 => @@ -204,14 +204,14 @@ -- | 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 + 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 maxg) + dmax = draw $ subVP vp $ faces $ forgetF maxg --- |displaying the boundary of a Tgraph in lime (overlaid on the Tgraph drawn with f). +-- |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 @@ -224,7 +224,7 @@ (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 g. +-- |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 @@ -243,27 +243,37 @@ compositions = composedFaceGroups changedInfo newfaces = map fst compositions --- |compForce is semantically equivalent to (compose . force), i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph). --- However it is more efficient because it omits the check for connected, and no crossing boundaries + +-- |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 -> Tgraph -compForce = uncheckedCompose . force +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 -> [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 -> Tgraph -maxCompForce g | nullGraph g = g +maxCompForce:: Tgraph -> Forced Tgraph +maxCompForce g | nullGraph g = Forced g | otherwise = last $ allCompForce g {- @@ -284,39 +294,40 @@ The common faces of the covers constitute the empire (level 1) of g. This will raise an error if the initial force fails with a stuck graph. -} -forcedBoundaryECovering:: Tgraph -> [Tgraph] -forcedBoundaryECovering g = recoverGraph <$> boundaryECovering gforcedBdry where +forcedBoundaryECovering:: Tgraph -> [Forced Tgraph] +forcedBoundaryECovering g = fmap recoverGraph <$> boundaryECovering gforcedBdry where gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" $ - tryForce $ makeBoundaryState g + 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. +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 -> [Tgraph] -forcedBoundaryVCovering g = recoverGraph <$> boundaryVCovering gforcedBdry where +forcedBoundaryVCovering:: Tgraph -> [Forced Tgraph] +forcedBoundaryVCovering g = fmap recoverGraph <$> boundaryVCovering gforcedBdry where gforcedBdry = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" $ - tryForce $ makeBoundaryState g + tryForceF $ makeBoundaryState g -{-| boundaryECovering bd - produces a list of all possible covers of the boundary directed edges in bd. -[bd should be a boundary state resulting from forcing]. -A cover is a forced extension (of bd) such that the original boundary directed edges of bd are all internal edges. +{-| 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 bd is a boundary state of an unforced Tgraph. -It will raise an error if both choices on a boundary edge fail when forced (using atLeastOne). +This can raise an error if both choices on a boundary edge fail when forced (using atLeastOne). -} -boundaryECovering:: BoundaryState -> [BoundaryState] -boundaryECovering bstate = covers [(bstate, boundaryEdgeSet bstate)] where - covers:: [(BoundaryState, Set.Set Dedge)] -> [BoundaryState] +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 = bs:covers opens -- bs is a completed cover + | 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 @@ -325,20 +336,19 @@ commonBdry:: Set.Set Dedge -> BoundaryState -> Set.Set Dedge commonBdry des b = des `Set.intersection` boundaryEdgeSet b -{-| boundaryVCovering bd - similar to boundaryECovering, but produces a list of all possible covers of - the boundary vertices in bd (rather than just boundary edges). - [bd should be a boundary state resulting from forcing]. - This can raise an error if bd is a boundary state of an unforced Tgraph. --} -boundaryVCovering:: BoundaryState -> [BoundaryState] -boundaryVCovering bd = covers [(bd, startbds)] where +{-| 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 -> open:covers opens + 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 @@ -376,22 +386,26 @@ -- | 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 <$> forcedBoundaryVCovering g) +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 = makeTrackedTgraph g0 [fcs,faces g] where - covers = forcedBoundaryVCovering g - g0 = head covers - others = tail covers - fcs = foldl' intersect (faces g0) $ fmap g0Intersect others - de = defaultAlignment g - g0Intersect g1 = commonFaces (g0,de) (g1,de) +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 @@ -400,32 +414,35 @@ -- and the tracked list of the result has the common faces of all the (doubly-extended) boundary edge covers -- at the head, followed by the original faces of g. empire2:: Tgraph -> TrackedTgraph -empire2 g = makeTrackedTgraph g0 [fcs, faces g] where - covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" - $ tryForce $ makeBoundaryState g - covers2 = concatMap boundaryECovering covers1 --- (g0:others) = fmap recoverGraph covers2 - gcovers = fmap recoverGraph covers2 - g0 = head gcovers - others = tail gcovers - fcs = foldl' intersect (faces g0) $ fmap g0Intersect others - de = defaultAlignment g - g0Intersect g1 = commonFaces (g0,de) (g1,de) +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 insrtead of boundaryECovering. +-- 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 = makeTrackedTgraph g0 [fcs, faces g] where - covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" - $ tryForce $ makeBoundaryState g - covers2 = concatMap boundaryVCovering covers1 --- (g0:others) = fmap recoverGraph covers2 - gcovers = fmap recoverGraph covers2 - g0 = head gcovers - others = tail gcovers - fcs = foldl' intersect (faces g0) $ fmap g0Intersect others - de = defaultAlignment g - g0Intersect g1 = commonFaces (g0,de) (g1,de) +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. @@ -471,21 +488,21 @@ trySuperForceFS :: ForceState -> Try ForceState trySuperForceFS fs = do forcedFS <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $ - tryForce fs - case singleChoiceEdges $ boundaryState forcedFS of - [] -> return forcedFS - (elpr:_) -> do extended <- addSingle elpr forcedFS + 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 a boundary state of a forced Tgraph this finds those boundary edges of bd +-- |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 :: BoundaryState -> [(Dedge,HalfTileLabel)] -singleChoiceEdges bstate = commonToCovering (boundaryECovering bstate) (boundary bstate) +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 +-- 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. @@ -495,12 +512,11 @@ common [] [] = [] common [] (_:_) = error "singleChoiceEdges:commonToCovering: label list is longer than edge list" common (_:_) [] = error "singleChoiceEdges:commonToCovering: label list is shorter than edge list" - common (e:more) (ls:lls) = if matchingLabels ls - then (e,head ls):common more lls - else common more lls - matchingLabels [] = error "singleChoiceEdges:commonToCovering: empty list of labels" - matchingLabels (l:ls) = all (==l) ls - + 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] @@ -565,7 +581,8 @@ -- (The resulting path can be filled when converted to a diagram.) pathFromBoundaryLoops:: VertexLocMap -> [[Vertex]] -> Path V2 Double pathFromBoundaryLoops vlocs loops = toPath $ map (locateLoop . map (vlocs VMap.!)) loops where - locateLoop pts = (`at` head pts) $ glueTrail $ trailFromVertices pts + locateLoop [] = error "pathFromBoundaryLoops: empty loop found\n" + locateLoop (p:pts) = (`at` p) $ glueTrail $ trailFromVertices (p:pts) -- * TrackedTgraphs diff --git a/src/TileLib.hs b/src/TileLib.hs --- a/src/TileLib.hs +++ b/src/TileLib.hs @@ -39,7 +39,7 @@ , drawJoin , fillOnlyPiece , fillPieceDK - , fillMaybePieceDK + -- , fillMaybePieceDK , leftFillPieceDK , experiment -- * Patches and Drawable Class @@ -49,9 +49,9 @@ , drawj , fillDK , fillKD - , fillMaybeDK + -- , fillMaybeDK , colourDKG - , colourMaybeDKG + -- , colourMaybeDKG -- * Patch Decomposition and Compose choices , decompPatch , decompositionsP @@ -170,7 +170,7 @@ -- dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey dashjOnly piece = drawJoin piece # joinDashing --- changes line style to ultraThin dashed lines (for drawing join edges) +-- |changes line style to ultraThin dashed lines (for drawing join edges) joinDashing :: (HasStyle c, N c ~ Double) => c -> c joinDashing = dashing [dashmeasure,dashmeasure] 0 . lw ultraThin where dashmeasure = normalized 0.003 `atLeast` output 0.5 @@ -204,6 +204,7 @@ (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 => @@ -215,7 +216,7 @@ (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. @@ -282,13 +283,14 @@ -- Note the order K D. -- Works with AlphaColours as well as Colours. fillKD c1 c2 = fillDK c2 c1 - + +{- {-# DEPRECATED fillMaybeDK "Use fillDK which now works with AlphaColours such as transparent" #-} -- |fillMaybeDK *Deprecated* -- (Use fillDK which works with AlphaColours such as transparent as well as Colours). fillMaybeDK :: (Drawable a, OKBackend b) => Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram b fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2) - + -} -- |colourDKG (c1,c2,c3) p - fill in a drawable with colour c1 for darts, colour c2 for kites and -- colour c3 for grout (that is, the non-join edges). -- Note the order D K G. @@ -297,6 +299,7 @@ (c1,c2,c3) -> a -> Diagram b colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lineColor c3 +{- {-# DEPRECATED colourMaybeDKG "Use colourDKG which now works with AlphaColours such as transparent" #-} -- |colourMaybeDKG *Deprecated* -- (Use colourDKG which works with AlphaColours such as transparent as well as Colours) colourMaybeDKG:: (Drawable a, OKBackend b) => @@ -304,6 +307,7 @@ colourMaybeDKG (d,k,g) a = fillMaybeDK d k a # maybeGrout g where maybeGrout (Just c) = lc c maybeGrout Nothing = lw none + -} {-| Decomposing splits each located piece in a patch into a list of smaller located pieces to create a refined patch. diff --git a/src/Try.hs b/src/Try.hs --- a/src/Try.hs +++ b/src/Try.hs @@ -1,5 +1,5 @@ {-| -Module : Tgraph.Try +Module : Try Description : Result types for partial functions Copyright : (c) Chris Reade, 2021 License : BSD-style @@ -24,7 +24,7 @@ , concatFails , ignoreFails , atLeastOne - , noFails + -- , noFails ) where import Data.Either(fromRight, lefts, rights, isLeft) @@ -37,17 +37,18 @@ type Try a = Either String a -- | onFail s exp - inserts s at the front of failure report if exp fails with Left report +-- but does nothing otherwise. onFail:: String -> Try a -> Try a onFail s = either (Left . (s++)) Right --- | Converts a Maybe Result into a Try result by treating Nothing as a failure +-- | 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). -- Usually used as infix (exp `nothingFail` s) nothingFail :: Maybe b -> String -> Try b nothingFail a s = maybe (Left s) Right a -- |Extract the (Right) result from a Try, producing an error if the Try is Left s. --- The failure report is passed to error for an error report. +-- The failure report (s) is passed to error for an error report. runTry:: Try a -> a runTry = either error id @@ -62,7 +63,7 @@ -- |Combines a list of Trys into a single Try with failure overriding success. -- It concatenates all failure reports if there are any and returns a single Left r. -- Otherwise it produces Right rs where rs is the list of all (successful) results. --- In particular, concatFails [] = Right [] +-- In particular, concatFails [] = Right [] (so is NOT a fail) concatFails:: [Try a] -> Try [a] concatFails ls = case lefts ls of [] -> Right $ rights ls @@ -78,11 +79,13 @@ atLeastOne:: [Try a] -> [a] atLeastOne [] = error "atLeastOne: applied to empty list.\n" atLeastOne results = case ignoreFails results of - [] -> runTry $ onFail "atLeastOne: no successful results.\n" $ concatFails results + [] -> runTry $ onFail "atLeastOne: no successful results.\nCounter Example Found?\n" $ concatFails results other -> other +{- {-# 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 + -} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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(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