PenroseKiteDart 1.4.5 → 1.5

raw patch · 6 files changed

+296/−109 lines, 6 filesdep ~basedep ~containersdep ~diagrams-libPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, diagrams-lib

API changes (from Hackage documentation)

Files

• CHANGELOG.md +31/−1
• PenroseKiteDart.cabal +1/−1
• src/Tgraph/Compose.hs +240/−98
• src/Tgraph/Extras.hs +10/−1
• src/TgraphExamples.hs +6/−7
• test/Spec.hs +8/−1

@@ -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

@@ -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

@@ -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] --+-} 

@@ -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).

@@ -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]

@@ -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