diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,36 @@ # Revision history for PenroseKiteDart +## version v1.5 2025-8-9 + +Changes to composing. + +(When a Tgraph is not known to be forced, +composing now involves calculating the forced version to get accurate information +about boundary dart wings. Previously only local information was used to classify +which could result in a dart wing being classified as unknown when non-local +information suggests otherwise). + +This affects: + compose, + partCompose, + tryPartCompose (new), + tryPartComposeFaces (new), + tryGetDartWingInfo (new) + +This does not affect: + composeF, + partComposeF, + getDartWingInfoForced, + partComposeFacesFrom (new) + +removed: + partComposeFaces, + partComposeFacesF, + composedFaceGroups, + getDartWingInfo (renamed as oldGetDartWingInfo) + +The previous version of partCompose is renamed as oldPartCompose (for comparisons) + ## version 1.4.5 -- 2025-8-3 added: class P3_DrawableLabelled (instances VPatch, Tgraph) @@ -11,7 +42,6 @@ drawnEdges (renamed from pieceEdges) decomposeFaces - fillOnlyPieceDK exposed: P3_Patch, bothDir, missingRevs, extractLowestJoin 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.4.5 +version: 1.5 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 diff --git a/src/Tgraph/Compose.hs b/src/Tgraph/Compose.hs --- a/src/Tgraph/Compose.hs +++ b/src/Tgraph/Compose.hs @@ -8,35 +8,44 @@ This module includes the main composition operations compose, partCompose, tryPartCompose, composeF, and partComposeF but also exposes -getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) -and partCompFacesFrom for debugging and composedFaceGroups for experimenting. +auxiliary functions +tryGetDartWingInfo, getDartWingInfoForced (and type DartWingInfo) +and partCompFacesFrom for debugging. -} {-# LANGUAGE Strict #-} module Tgraph.Compose - ( compose - , composeF - , partCompose + ( -- * Composing forced Tgraphs + composeF , partComposeF + -- * General compose operations + , compose + , partCompose , tryPartCompose + , tryPartComposeFaces -- * Exported auxiliary functions (and type) -- , partCompFacesAssumeF - , partComposeFaces - , partComposeFacesF + -- , partComposeFaces + -- , partComposeFacesF + , partComposeFacesFrom --new , DartWingInfo(..) -- , getDWIassumeF - , getDartWingInfo + -- , getDartWingInfo + , tryGetDartWingInfo , getDartWingInfoForced - , composedFaceGroups + -- , composedFaceGroups + -- * Older versions (for debugging/comparison) + , oldGetDartWingInfo + , oldPartCompose ) where -import Data.List (find, foldl', (\\),partition) -import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!),alter,empty) +import Data.List (find, foldl', (\\),partition, nub) +import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!),alter,empty,elems) import Data.Maybe (mapMaybe) import qualified Data.IntSet as IntSet (empty,insert,toList,member) import Tgraph.Prelude -import Tgraph.Force ( Forced(), forgetF, labelAsForced ) +import Tgraph.Force ( Forced(), forgetF, labelAsForced, tryForceF ) {------------------------------------------------------------------------- *************************************************************************** COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose @@ -47,26 +56,47 @@ -- 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. +-- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info). compose:: Tgraph -> Tgraph compose = snd . partCompose -- |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. +-- and a composed Tgraph. +-- It checks the composed Tgraph for connectedness and no crossing boundaries +-- raising an error if this check fails. +-- It does not assume the given Tgraph is forced. +-- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info). partCompose:: Tgraph -> ([TileFace],Tgraph) partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g -- |tryPartCompose g tries to produce a Tgraph by composing faces which uniquely compose in g, +-- It uses tryGetDartWingInfo g which can fail if g is found to be incorrect when forced. -- 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. +-- If both the above succeed, the result is Right (remainder, g') +-- where g' is the composed Tgraph and remainder is a list +-- of faces from g which will not compose. tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = - do let (~remainder,newFaces) = partComposeFaces g + do dwInfo <- tryGetDartWingInfo g + let (~remainder,newFaces) = partComposeFacesFrom dwInfo checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces return (remainder,checked) +-- |Get the remainder and composed faces (without checking the composed faces make a valid Tgraph) +-- It uses tryGetDartWingInfo g which can fail if g is found to be incorrect when forced. +tryPartComposeFaces:: Tgraph -> Try ([TileFace],[TileFace]) +tryPartComposeFaces g = + do dwInfo <- tryGetDartWingInfo g + return $ partComposeFacesFrom dwInfo +-- tryPartComposeFaces is used in an example showing failure of the connected, no crossing boundary check. + + +-- |Uses supplied dartwing info to get remainder faces and composed faces. +-- Does not assume forced and does not check the composed faces for connected/no crossing boundaries +partComposeFacesFrom :: DartWingInfo -> ([TileFace], [TileFace]) +partComposeFacesFrom = partCompFacesAssumeF False + +{- -- |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 which makes it less efficient than partComposeFacesF. @@ -79,6 +109,7 @@ partComposeFacesF :: Forced Tgraph -> ([TileFace],[TileFace]) partComposeFacesF = partCompFacesAssumeF True . forgetF + -} -- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose) -- and a composed (Forced) Tgraph. @@ -86,7 +117,7 @@ -- The fact that the result is also Forced relies on a theorem. partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph) partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where - (~remainder,newfaces) = partComposeFacesF fg + (~remainder,newfaces) = partCompFacesAssumeF True $ getDartWingInfoForced 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. @@ -96,6 +127,7 @@ composeF = snd . partComposeF + -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. -- Faces at a largeKiteCentre vertex will form kite faces when composed. -- Faces at a largeDartBase vertex will form dart faces when composed. @@ -110,22 +142,46 @@ , unMapped :: [TileFace] -- ^ any faces not at a dart wing vertex (necessarily kites) } deriving Show --- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, +-- |Recover a list of faces (no repetitions) contained in the dart wing info. +-- (These should be all faces of the Tgraph used to make the dart wing info.) +recoverFaces :: DartWingInfo -> [TileFace] +recoverFaces dwInfo = nub $ concat (unMapped dwInfo : VMap.elems (faceMap dwInfo)) + + +{- -- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, -- returning as DartWingInfo. It does not assume g is forced and is more expensive than getDartWingInfoForced getDartWingInfo:: Tgraph -> DartWingInfo getDartWingInfo = getDWIassumeF False + -} --- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg and calculates a faceMap for each dart wing, --- returning as DartWingInfo. (It can classify quicker knowing the Tgraph is forced.) -getDartWingInfoForced :: Forced Tgraph -> DartWingInfo -getDartWingInfoForced fg = getDWIassumeF True (forgetF fg) +-- |The given Tgraph is not assumed to be forced. +-- Getting the dart wing information makes use of the forced version +-- as well as the Tgraph so this uses tryForce first which can fail if +-- the Tgraph is found to be incorrect. +tryGetDartWingInfo :: Tgraph -> Try DartWingInfo +tryGetDartWingInfo g = + do fg <- onFail "tryGetDartWingInfo: incorrect Tgraph found.\n" $ tryForceF g + return $ getDWIassumeF False g fg +-- | oldGetDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, +-- returning as DartWingInfo. If only uses local information to classify each dart wing and can +-- therefore sometimes classify a dart wing as unknown unnecessarily. +-- In contrast tryGetDartWingInfo is accurate using information from forcing (so is not local) +oldGetDartWingInfo:: Tgraph -> DartWingInfo +oldGetDartWingInfo = oldGetDWIassumeF False --- | getDWIassumeF (not exported but used to define 2 cases getDartWingInfoForced and getDartWingInfo). --- getDWIassumeF isForced g, classifies the dart wings in g and calculates a faceMap for each dart wing, +-- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg +-- and calculates a faceMap for each dart wing, returning as DartWingInfo. +-- The classification is much simplified knowing that the Tgraph is forced. +getDartWingInfoForced :: Forced Tgraph -> DartWingInfo +getDartWingInfoForced fg = getDWIassumeF True (forgetF fg) fg + +-- | getDWIassumeF (not exported but used to define 2 cases getDartWingInfoForced and tryGetDartWingInfo). +-- getDWIassumeF isForced g fg (where fg is forceF 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 -getDWIassumeF isForced g = +-- When this is True, the classification is simpler and does not use fg. +getDWIassumeF:: Bool -> Tgraph -> Forced Tgraph -> DartWingInfo +getDWIassumeF isForced g fg = DartWingInfo { largeKiteCentres = IntSet.toList allKcs , largeDartBases = IntSet.toList allDbs , unknowns = IntSet.toList allUnks @@ -137,19 +193,154 @@ -- using only relevant vertices where there is a dart wing. -- i.e only wings for darts and only oppVs and originVs for kites. -- The map is built first from darts, then kites are added. - (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts -- all kites added to relevant dart wings - where - dartWMap = foldl' insertD VMap.empty drts -- all dartwings with 1 or 2 darts each + (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts + -- all kite halves added to relevant dart wings of the dart wing map. + where -- the unused list records half kites not added to any dart wing. + dartWMap = foldl' insertD VMap.empty drts + -- maps all dart wing vertices to 1 or 2 half darts. insertD vmap f = VMap.alter (addD f) (wingV f) vmap addD f Nothing = Just [f] addD f (Just fs) = Just (f:fs) insertK (vmap,unsd) f = - let op = oppV f + let opp = oppV f org = originV f - in case (VMap.lookup op vmap, VMap.lookup org vmap) of - (Just _ ,Just _) -> (VMap.alter (addK f) (oppV f) $ VMap.alter (addK f) (originV f) vmap, unsd) - (Just _ , Nothing) -> (VMap.alter (addK f) (oppV f) vmap, unsd) - (Nothing, Just _ ) -> (VMap.alter (addK f) (originV f) vmap, unsd) + in case (VMap.lookup opp vmap, VMap.lookup org vmap) of + (Just _ ,Just _) -> (VMap.alter (addK f) opp $ VMap.alter (addK f) org vmap, unsd) + (Just _ , Nothing) -> (VMap.alter (addK f) opp vmap, unsd) + (Nothing, Just _ ) -> (VMap.alter (addK f) org vmap, unsd) + (Nothing, Nothing) -> (vmap, f:unsd) -- kite face not at any dart wing + + addK _ Nothing = Nothing -- not added to map if it is not a dart wing vertex + addK f (Just fs) = Just (f:fs) + + (allKcs,allDbs,allUnks) = foldl' processD (IntSet.empty, IntSet.empty, IntSet.empty) drts +-- kcs = kite centres of larger kites, +-- dbs = dart bases of larger darts, +-- unks = unclassified dart wing vertices +-- Uses a triple of IntSets rather than lists + processD (kcs, dbs, unks) drt = + let w = wingV drt + revLongE = reverseD (longE drt) + in + if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else-- already classified + let + fcs = dwFMap VMap.! w -- list of faces at w + in + if w `elem` map originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else + -- wing is a half kite origin => largeDartBase + if revLongE `elem` map longE (filter isDart fcs) then (IntSet.insert w kcs,dbs,unks) else + -- long edge drt shared with another dart => largeKiteCentre + if isForced then (kcs, dbs, IntSet.insert w unks) else + let -- (when not already forced) do same checks but with forced faces + ffcs = filter (isAtV w) (faces fg) + in + if w `elem` map originV (filter isKite ffcs) then (kcs,IntSet.insert w dbs,unks) else + -- wing is a half kite origin => largeDartBase + if revLongE `elem` map longE (filter isDart ffcs) then (IntSet.insert w kcs,dbs,unks) else + -- long edge drt shared with another dart => largeKiteCentre + (kcs,dbs,IntSet.insert w unks) + + + +-- |partCompFacesAssumeF +-- (not exported but used to build 2 cases: partComposeFacesFrom, partComposeF) +-- If the boolean is True then assumptions are made that the DartWingIno +-- has come from a forced Tgraph, +-- making the remainder faces calculation more efficient. +partCompFacesAssumeF :: Bool -> DartWingInfo -> ([TileFace],[TileFace]) +partCompFacesAssumeF isForced dwInfo = (remainder, newFaces) where + ~remainder = + if isForced + then -- unMapped faces plus all faces at unknowns. + unMapped dwInfo ++ concatMap (faceMap dwInfo VMap.!) (unknowns dwInfo) + else -- all faces except those successfully used in making composed faces. + recoverFaces dwInfo \\ concatMap concat [groupRDs, groupLDs, groupRKs, groupLKs] + + newFaces = newRDs ++ newLDs ++ newRKs ++ newLKs + + newRDs = map makenewRD groupRDs + groupRDs = mapMaybe groupRD (largeDartBases dwInfo) + makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) + makenewRD _ = error "composedFaceGroups: RD case" + groupRD v = do fcs <- VMap.lookup v (faceMap dwInfo) + rd <- find isRD fcs + lk <- find (matchingShortE rd) fcs + return [rd,lk] + + newLDs = map makenewLD groupLDs + groupLDs = mapMaybe groupLD (largeDartBases dwInfo) + makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld) + makenewLD _ = error "composedFaceGroups: LD case" + groupLD v = do fcs <- VMap.lookup v (faceMap dwInfo) + ld <- find isLD fcs + rk <- find (matchingShortE ld) fcs + return [ld,rk] + + newRKs = map makenewRK groupRKs + groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) + makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk) + makenewRK _ = error "composedFaceGroups: RK case" + groupRK v = do fcs <- VMap.lookup v (faceMap dwInfo) + rd <- find isRD fcs + lk <- find (matchingShortE rd) fcs + rk <- find (matchingJoinE lk) fcs + return [rd,lk,rk] + + newLKs = map makenewLK groupLKs + groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) + makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk) + makenewLK _ = error "composedFaceGroups: LK case" + groupLK v = do fcs <- VMap.lookup v (faceMap dwInfo) + ld <- find isLD fcs + rk <- find (matchingShortE ld) fcs + lk <- find (matchingJoinE rk) fcs + return [ld,rk,lk] + + +-- |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 checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails. +-- It does not assume the given Tgraph is forced. +-- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info). +oldPartCompose:: Tgraph -> ([TileFace],Tgraph) +oldPartCompose g = runTry $ onFail "oldPartCompose:\n" $ + do let dwInfo = oldGetDartWingInfo g + (~remainder,newFaces) = partComposeFacesFrom dwInfo + checked <- tryConnectedNoCross newFaces + return (remainder,checked) + + +-- | oldGetDWIassumeF (not exported but used to define oldGetDartWingInfo). +-- oldGetDWIassumeF 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. +oldGetDWIassumeF:: Bool -> Tgraph -> DartWingInfo +oldGetDWIassumeF isForced g = + DartWingInfo { largeKiteCentres = IntSet.toList allKcs + , largeDartBases = IntSet.toList allDbs + , unknowns = IntSet.toList allUnks + , faceMap = dwFMap + , unMapped = unused + } where + (drts,kts) = partition isDart (faces g) + -- special case of vertexFacesMap for dart wings only + -- using only relevant vertices where there is a dart wing. + -- i.e only wingVs for darts and only oppVs and originVs for kites. + -- The map is built first from darts, then kites are added. + (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts + -- all kite halves added to relevant dart wings of the dart wing faces map + where -- the unused list records half kites not added to any dart wing + dartWMap = foldl' insertD VMap.empty drts + -- maps all dart wing vertices to 1 or 2 half darts + insertD vmap f = VMap.alter (addD f) (wingV f) vmap + addD f Nothing = Just [f] + addD f (Just fs) = Just (f:fs) + insertK (vmap,unsd) f = + let opp = oppV f + org = originV f + in case (VMap.lookup opp vmap, VMap.lookup org vmap) of + (Just _ ,Just _) -> (VMap.alter (addK f) opp $ VMap.alter (addK f) org vmap, unsd) + (Just _ , Nothing) -> (VMap.alter (addK f) opp vmap, unsd) + (Nothing, Just _ ) -> (VMap.alter (addK f) org vmap, unsd) (Nothing, Nothing) -> (vmap, f:unsd) addK _ Nothing = Nothing -- not added to map if it is not a dart wing vertex @@ -159,7 +350,7 @@ -- kcs = kite centres of larger kites, -- dbs = dart bases of larger darts, -- unks = unclassified dart wing vertices --- processD now uses a triple of IntSets rather than lists +-- Uses a triple of IntSets rather than lists processD (kcs, dbs, unks) rd@(RD (orig, w, _)) = -- classify wing tip w if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else-- already classified let @@ -167,9 +358,9 @@ -- Just fcs = VMap.lookup w dwFMap -- faces at w in if w `elem` map originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else - -- wing is a half kite origin => largeDartBases + -- wing is a half kite origin => largeDartBase if (w,orig) `elem` map longE (filter isLD fcs) then (IntSet.insert w kcs,dbs,unks) else - -- long edge rd shared with an ld => largeKiteCentres + -- long edge rd shared with an ld => largeKiteCentre if isForced || length fcs == 1 then (kcs, dbs, IntSet.insert w unks) else case findFarK rd fcs of -- extra inspection only needed for unforced Tgraphs Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of rd @@ -201,16 +392,18 @@ fcs = dwFMap VMap.! w -- faces at w in if w `elem` map originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else - -- wing is a half kite origin => nodeDB + -- wing is a half kite origin => largeDartBase if (orig,w) `elem` map longE (filter isRD fcs) then (IntSet.insert w kcs,dbs,unks) else - -- long edge ld shared with an rd => nodeKC + -- long edge ld shared with an rd => largeKiteCentre if isForced || length fcs == 1 then (kcs, dbs, IntSet.insert w unks) else - case findFarK ld fcs of + case findFarK ld fcs of -- extra inspection only needed for unforced Tgraphs Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of ld Just lk@(LK _) -> case find (matchingShortE lk) fcs of - Just (RK _) -> (IntSet.insert w kcs,dbs,unks) -- short edge lk shared with an rk => largeKiteCentres - Just (RD _) -> (kcs,IntSet.insert w dbs,unks) -- short edge lk shared with an rd => largeDartBases + Just (RK _) -> (IntSet.insert w kcs,dbs,unks) + -- short edge lk shared with an rk => largeKiteCentres + Just (RD _) -> (kcs,IntSet.insert w dbs,unks) + -- short edge lk shared with an rd => largeDartBases _ -> let newfcs = filter (isAtV (wingV lk)) (faces g) -- faces at lk wing in @@ -239,59 +432,9 @@ find (matchingJoinE rk) (filter isLK fcs) findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" --- |partCompFacesAssumeF (not exported but used to build 2 cases: partComposeFaces, partComposefacesF) --- If the boolean is True then assumptions are made that the Tgraph is forced, --- making everything more efficient. -partCompFacesAssumeF :: Bool -> Tgraph -> ([TileFace],[TileFace]) -partCompFacesAssumeF isForced g = (remainder, newFaces) where - dwInfo = if isForced then getDartWingInfoForced (labelAsForced g) else getDartWingInfo g - ~remainder = if isForced then unMapped dwInfo ++ concatMap (faceMap dwInfo VMap.!) (unknowns dwInfo) - else faces g \\ concatMap concat [groupRDs, groupLDs, groupRKs, groupLKs] - newFaces = newRDs ++ newLDs ++ newRKs ++ newLKs - - newRDs = map makenewRD groupRDs - groupRDs = mapMaybe groupRD (largeDartBases dwInfo) - makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) - makenewRD _ = error "composedFaceGroups: RD case" - groupRD v = do fcs <- VMap.lookup v (faceMap dwInfo) - rd <- find isRD fcs - lk <- find (matchingShortE rd) fcs - return [rd,lk] - - newLDs = map makenewLD groupLDs - groupLDs = mapMaybe groupLD (largeDartBases dwInfo) - makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld) - makenewLD _ = error "composedFaceGroups: LD case" - groupLD v = do fcs <- VMap.lookup v (faceMap dwInfo) - ld <- find isLD fcs - rk <- find (matchingShortE ld) fcs - return [ld,rk] - - newRKs = map makenewRK groupRKs - groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) - makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk) - makenewRK _ = error "composedFaceGroups: RK case" - groupRK v = do fcs <- VMap.lookup v (faceMap dwInfo) - rd <- find isRD fcs - lk <- find (matchingShortE rd) fcs - rk <- find (matchingJoinE lk) fcs - return [rd,lk,rk] - - newLKs = map makenewLK groupLKs - groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) - makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk) - makenewLK _ = error "composedFaceGroups: LK case" - groupLK v = do fcs <- VMap.lookup v (faceMap dwInfo) - ld <- find isLD fcs - rk <- find (matchingShortE ld) fcs - lk <- find (matchingJoinE rk) fcs - return [ld,rk,lk] - - - - +{- -- |Creates a list of new composed faces, each paired with a list of old faces (components of the new face) --- using dart wing information. (Only used to illustrate composeK in Extras) +-- using dart wing information. No longer used. composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where @@ -333,6 +476,5 @@ lk <- find (matchingJoinE rk) fcs return [ld,rk,lk] - - +-} diff --git a/src/Tgraph/Extras.hs b/src/Tgraph/Extras.hs --- a/src/Tgraph/Extras.hs +++ b/src/Tgraph/Extras.hs @@ -236,14 +236,23 @@ -- 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) = partComposeFacesFrom changedInfo + tryConnectedNoCross newfaces +{- composeK :: Tgraph -> Tgraph composeK g = runTry $ tryConnectedNoCross newfaces where - dwInfo = getDartWingInfo g + dwInfo = runTry $ tryGetDartWingInfo g changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo , unknowns = [] } -- newfaces = snd $ partCompFacesFrom changedInfo 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). diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs --- a/src/TgraphExamples.hs +++ b/src/TgraphExamples.hs @@ -96,7 +96,7 @@ import Diagrams.Prelude import PKD -import Tgraph.Prelude as NoWarn (makeUncheckedTgraph) +--import Tgraph.Prelude as NoWarn (makeUncheckedTgraph) import Data.List (intersect,find) -- for emplaceChoices @@ -253,7 +253,7 @@ vp = makeVP badlyBrokenDart comp = compose badlyBrokenDart vpComp = restrictVP vp $ faces comp - vpFailed = restrictVP vp $ (snd . partComposeFaces) comp + vpFailed = restrictVP vp $ (snd . runTry . tryPartComposeFaces) comp -- |figure showing the result of removing incomplete tiles (those that do not have their matching halftile) -- to a 3 times decomposed sun. @@ -360,9 +360,9 @@ boundaryFDart4, boundaryFDart5 :: Tgraph -- |graph of the boundary faces only of a forced graph (dartDs!!4) -boundaryFDart4 = NoWarn.makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 +boundaryFDart4 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 -- |graph of the boundary faces only of a forced graph (dartDs!!5) -boundaryFDart5 = NoWarn.makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) +boundaryFDart5 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) boundaryFDart4Fig,boundaryFDart5Fig :: OKBackend b => Diagram b -- |figure of the boundary faces only of a forced graph (dartDs!!4). @@ -428,10 +428,9 @@ emplaceChoices = emplaceChoicesForced . forceF where emplaceChoicesForced:: Forced Tgraph -> [Tgraph] - emplaceChoicesForced fg | nullFaces g' = chooseUnknowns [(unknowns $ getDartWingInfo g0, g0)] + emplaceChoicesForced fg | nullFaces g' = chooseUnknowns [(unknowns $ getDartWingInfoForced fg, forgetF fg)] | otherwise = force . decompose <$> emplaceChoicesForced fg' - where g0 = forgetF fg - fg' = composeF fg + where fg' = composeF fg g' = forgetF fg' chooseUnknowns :: [([Vertex],Tgraph)] -> [Tgraph] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -69,6 +69,9 @@ ,LK (3,2,13),RK (3,13,11),RK (3,14,4),LK (3,11,14),LK (7,4,14),RK (7,14,12) ] +-- |Example to test composing of unforced Tgraph +extraBrokenDart :: Tgraph +extraBrokenDart = removeFaces [RK(25,60,61),LK(25,24,60)] badlyBrokenDart graphPropSpec :: Spec graphPropSpec = describe "Test Properties of Tgraphs" $ do @@ -125,7 +128,11 @@ length (fst $ partCompose $ force $ dartDs !!3) `shouldBe` 58 context "partComposeF and ForceF" $ it "Number of remainder faces when part composing forceF (dartDs !!3) should be 58" $ - length (fst $ partCompose $ force $ dartDs !!3) `shouldBe` 58 + length (fst $ partComposeF $ forceF $ dartDs !!3) `shouldBe` 58 + context "partCompose of reduced Tgraph (extraBrokenDart)" $ + it "Number of remainder/composed faces when part composing extraBrokenDart should be (5,18)" $ + (length $ fst res,length $ faces $ snd res) + `shouldBe` (5,18) where res = partCompose extraBrokenDart graphLabelCheck :: Spec graphLabelCheck = describe "Label critical examples check" $ do