PenroseKiteDart 1.4.4 → 1.4.5

raw patch · 6 files changed

+196/−53 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−1
• PenroseKiteDart.cabal +1/−1
• src/Tgraph/Decompose.hs +15/−10
• src/Tgraph/Prelude.hs +7/−6
• src/TileLib.hs +49/−21
• src/TileLibP3.hs +101/−14

@@ -1,6 +1,28 @@ # Revision history for PenroseKiteDart -## version 1.4.4  -- 2025-8-9+## version 1.4.5  -- 2025-8-3+added:+    class P3_DrawableLabelled (instances VPatch, Tgraph)+    with labelColourSizeP3, labelSizeP3, labelledP3++    drawjP3 (renamed from dashjP3)+    fillOnlyPieceDK+    drawjPiece (renamed from dashjPiece)+    drawnEdges (renamed from pieceEdges)++    decomposeFaces+    fillOnlyPieceDK++exposed:+    P3_Patch, bothDir, missingRevs, extractLowestJoin++generalised:+    phiVMap++deprecated:+    dashjP3, dashjPiece, pieceEdges (all renamed)++## version 1.4.4  -- 2025-7-9  Fixed bug in remainder faces for new partComposeF 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           PenroseKiteDart-version:        1.4.4+version:        1.4.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

@@ -15,6 +15,7 @@  module Tgraph.Decompose   ( decompose+  , decomposeFaces   , decompositions   -- * Exported auxiliary functions    , phiVMap@@ -37,20 +38,24 @@  -- |Decompose a Tgraph. decompose :: Tgraph -> Tgraph-decompose g = makeUncheckedTgraph newFaces where-    pvmap = phiVMap g-    newFaces = concatMap (decompFace pvmap) (faces g)-    -- evaluated = length newFaces `seq` newFaces--- |phiVMap g produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in g.--- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace and decompose.+decompose = makeUncheckedTgraph . decomposeFaces++-- |Decompose all the faces (using a phiVMap for new vertices).+decomposeFaces :: HasFaces a => a -> [TileFace]+decomposeFaces a = newFaces where+    pvmap = phiVMap (faces a)+    newFaces = concatMap (decompFace pvmap) (faces a)++-- |phiVMap fcs produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in fcs.+-- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace, decompFaces and decompose. -- (Sort is used to fix order of assigned numbers). -- (Exported for use in TrackedTgraphs in Tgraphs module).-phiVMap :: Tgraph -> Map.Map Dedge Vertex-phiVMap g = edgeVMap where-  phiReps = sort [(a,b) | (a,b) <- phiEdges g, a<b]+phiVMap :: HasFaces a => a -> Map.Map Dedge Vertex+phiVMap fcs = edgeVMap where+  phiReps = sort [(a,b) | (a,b) <- phiEdges fcs, a<b]   newVs = [v+1..v+n]   !n = length phiReps-  !v = maxV g+  !v = maxV fcs   edgeVMap = Map.fromList $ zip phiReps newVs ++ zip (map reverseD phiReps) newVs   -- |Decompose a face producing new faces. 

@@ -123,16 +123,16 @@   , hasDedge   , hasDedgeIn   , completeEdges---   , bothDir+  , bothDir --   , bothDirOneWay---   , missingRevs+  , missingRevs     -- * Other Face Operations   , edgeNb   , dedgesFacesMap   , buildEFMap   , faceForEdge   , edgeNbs---  , extractLowestJoin+  , extractLowestJoin   , lowestJoin     -- * VPatch and Conversions   , VPatch(..)@@ -1060,7 +1060,6 @@     drawWith pd vp = drawWith pd (dropLabels vp)  -- |converts a VPatch to a Patch, removing vertex information and converting faces to Located Pieces.--- (Usage can be confined to Drawable VPatch instance and DrawableLabelled VPatch instance.) dropLabels :: VPatch -> Patch dropLabels vp = map convert (faces vp) where   locations = vLocs vp@@ -1086,8 +1085,8 @@  -- | VPatches can be drawn with labels instance DrawableLabelled VPatch where-  labelColourSize c m d vp = drawLabels (vLocs vp) <> d (dropLabels vp) where-     drawLabels vpMap = position $ drawlabel <$> VMap.toList vpMap+  labelColourSize c m d vp = drawLabels <> d (dropLabels vp) where+     drawLabels = position $ drawlabel <$> VMap.toList (vLocs vp)      drawlabel(v,p) = (p, baselineText (show v) # fontSize m # fc c)  -- | Tgraphs can be drawn with labels@@ -1115,6 +1114,8 @@ centerOn a vp =     case findLoc a vp of         Just loca -> translate (origin .-. loca) vp+                     -- same as moveOriginTo loca vp+                     -- and as  moveOriginBy (loca .-. origin) vp         _ -> error $ "centerOn: vertex not found (Vertex " ++ show a ++ ")\n"  -- |alignXaxis takes a vertex pair (a,b) and a VPatch vp

@@ -30,16 +30,19 @@     -- * Drawing Pieces   , phi   , ttangle+  , drawnEdges   , pieceEdges   , wholeTileEdges   -- $OKBackend   , drawPiece+  , drawjPiece   , dashjPiece   , joinDashing   , dashjOnly   , drawRoundPiece   , drawJoin   , fillOnlyPiece+  , fillOnlyPieceDK   , fillPieceDK   -- , fillMaybePieceDK   , leftFillPieceDK@@ -75,6 +78,7 @@   , scales   , phiScales   , phiScaling+  --, realignX   ) where  import Diagrams.Prelude@@ -124,7 +128,7 @@ ttangle n = fromIntegral (n `mod` 10) *^tt              where tt = 1/10 @@ turn -{-|This produces a list of the two adjacent non-join tile directed edges of a piece starting from the origin.+{-|This produces a list of vectors representing the two adjacent non-join tile directed edges of a piece starting from the origin.  We consider left and right as viewed from the origin. This means that darts are reversed with respect to a view from the tail, but kites are@@ -133,18 +137,23 @@ So for right dart and left kite the edges are directed and ordered clockwise from the piece origin, and for left dart and right kite these are directed and ordered anti-clockwise from the piece origin. -}+drawnEdges:: Piece -> [V2 Double]+drawnEdges (LD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 9) v+drawnEdges (RD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 1) v+drawnEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v+drawnEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v++{-# DEPRECATED pieceEdges "Replaced by drawnEdges" #-}+-- |older name for drawnEdges pieceEdges:: Piece -> [V2 Double]-pieceEdges (LD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 9) v-pieceEdges (RD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 1) v-pieceEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v-pieceEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v+pieceEdges = drawnEdges  -- |the 4 tile edges of a completed half-tile piece (used for colour fill). -- These are directed and ordered clockwise from the origin of the tile. wholeTileEdges:: Piece -> [V2 Double] wholeTileEdges (LD v) = wholeTileEdges (RD v)-wholeTileEdges (RD v) = pieceEdges (RD v) ++ map negated (reverse $ pieceEdges (LD v))-wholeTileEdges (LK v) = pieceEdges (LK v) ++ map negated (reverse $ pieceEdges (RK v))+wholeTileEdges (RD v) = drawnEdges (RD v) ++ map negated (reverse $ drawnEdges (LD v))+wholeTileEdges (LK v) = drawnEdges (LK v) ++ map negated (reverse $ drawnEdges (RK v)) wholeTileEdges (RK v) = wholeTileEdges (LK v)  {- $OKBackend @@ -154,54 +163,72 @@ -- |drawing lines for the 2 non-join edges of a piece. drawPiece :: OKBackend b =>              Piece -> Diagram b-drawPiece = strokeLine . fromOffsets . pieceEdges+drawPiece = strokeLine . fromOffsets . drawnEdges  -- |same as drawPiece but with join edge added as faint dashed line.-dashjPiece :: OKBackend b =>+drawjPiece :: OKBackend b =>               Piece -> Diagram b-dashjPiece piece = drawPiece piece <> dashjOnly piece+drawjPiece = drawPiece <> dashjOnly +{-# DEPRECATED dashjPiece "Replaced by drawjPiece" #-}+-- |renamed as drawjPiece+dashjPiece :: OKBackend b =>+              Piece -> Diagram b+dashjPiece = drawjPiece  -- |draw join edge only (as faint dashed line). dashjOnly :: OKBackend b =>              Piece -> Diagram b--- dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey -dashjOnly piece = drawJoin piece # joinDashing+dashjOnly = joinDashing . drawJoin  -- |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 --- |same as drawPiece but with added join edge (also fillable as a loop).-drawRoundPiece :: OKBackend b =>-                  Piece -> Diagram b-drawRoundPiece = strokeLoop . closeLine . fromOffsets . pieceEdges- -- |draw join edge only. drawJoin :: OKBackend b =>             Piece -> Diagram b drawJoin piece = strokeLine $ fromOffsets [joinVector piece] +-- |same as drawPiece but with added join edge (also fillable as a loop).+drawRoundPiece :: OKBackend b =>+                  Piece -> Diagram b+drawRoundPiece = strokeLoop . closeLine . fromOffsets . drawnEdges++ -- |fillOnlyPiece col piece - fills piece with colour col without drawing any lines. -- Can be used with both Colour and AlphaColour fillOnlyPiece :: (OKBackend b, Color c) =>-                  c -> Piece -> Diagram b+                 c -> Piece -> Diagram b fillOnlyPiece col piece  = drawRoundPiece piece # fillColor col # lw none +-- |fillOnlyPieceDK dcol kcol piece - fills the half-tile piece+-- with colour dcol for darts and kcol for kites.+-- Note the order D K.+-- Can be used with both Colour and AlphaColour+fillOnlyPieceDK :: (OKBackend b, Color c1, Color c2) =>+                   c1 -> c2 -> HalfTile (V2 Double) -> Diagram b+fillOnlyPieceDK dcol kcol piece = +    if isDart piece +    then fillOnlyPiece dcol piece+    else fillOnlyPiece kcol piece+ -- |fillPieceDK dcol kcol piece - draws and fills the half-tile piece -- with colour dcol for darts and kcol for kites. -- Note the order D K. -- Can be used with both Colour and AlphaColour fillPieceDK :: (OKBackend b, Color c1, Color c2) =>-                c1 -> c2 -> HalfTile (V2 Double) -> Diagram b+               c1 -> c2 -> HalfTile (V2 Double) -> Diagram b+fillPieceDK dcol kcol = drawPiece <> fillOnlyPieceDK dcol kcol+{-  fillPieceDK dcol kcol piece = drawPiece piece <> filledPiece where   filledPiece = case piece of      (LD _) -> fillOnlyPiece dcol piece      (RD _) -> fillOnlyPiece dcol piece      (LK _) -> fillOnlyPiece kcol piece      (RK _) -> fillOnlyPiece kcol piece-+ -} -- |leftFillPieceDK dcol kcol pc fills the whole tile when pc is a left half-tile, -- darts are filled with colour dcol and kites with colour kcol. -- (Right half-tiles produce nothing, so whole tiles are not drawn twice).@@ -254,7 +281,7 @@ -- | alternative default case for drawing, adding dashed lines for join edges. drawj :: (Drawable a, OKBackend b) =>          a -> Diagram b-drawj = drawWith dashjPiece+drawj = drawWith drawjPiece  fillDK, fillKD :: (Drawable a, OKBackend b, Color c1, Color c2) =>                   c1 -> c2 -> a -> Diagram b@@ -437,6 +464,7 @@ phiScaling:: (Transformable a, V a ~ V2, N a ~ Double) => Double -> [a] -> [a] phiScaling _ [] = [] phiScaling s (d:more) = scale s d: phiScaling (phi*s) more+   

@@ -30,21 +30,29 @@   , decompPieceP2toP3   , decompPieceP3toP2   -- * Converting Patches+  , P3_Patch   , decompP2toP3   , decompP3toP2   -- * Drawing P3_Pieces-  --, drawnedgesP3+  --, drawnEdgesP3   , drawPieceP3-  , dashjPieceP3+  , drawjPieceP3   , fillOnlyPieceP3+  , fillOnlyPieceWN   , fillPieceWN    -- * P3_Drawable Class   , P3_Drawable(..)   -- * Drawing functions producing P3 Rhombuses   , drawP3+  , drawjP3   , dashjP3   , fillWN   , fillNW+  -- * P3_DrawableLabelled Class+  , P3_DrawableLabelled(..)+  -- * Adding labels to functions producing P3 Rhombuses+  , labelSizeP3+  , labelledP3   ) where  import Diagrams.Prelude@@ -54,7 +62,11 @@ import HalfTile import TileLib import Tgraph.Prelude+import Tgraph.Decompose ( phiVMap ) +import qualified Data.Map.Strict as Map ((!))+import qualified Data.IntMap.Strict as VMap (fromList, toList, lookup)+ -- | Penrose P3 Tiling uses wide and narrow rhombuses -- These are split into half tiles (triangles) as with kites and darts data P3_HalfTile a@@ -149,39 +161,59 @@ decompP3toP2 :: P3_Patch -> Patch decompP3toP2 = concatMap decompPieceP3toP2 --- |The drawn edges of a P3_Piece (as a list of vectors)-drawnedgesP3 :: P3_Piece -> [V2 Double]-drawnedgesP3 (LW v) = [z,v^-^z] where z = (phi-1)*^rotate (ttangle 1) v-drawnedgesP3 (RW v) = [z,v^-^z] where z = (phi-1)*^rotate (ttangle 9) v-drawnedgesP3 (LN v) = [z,v^-^z] where z = phi*^rotate (ttangle 2) v-drawnedgesP3 (RN v) = [z,v^-^z] where z = phi*^rotate (ttangle 8) v+-- |The drawn edges of a P3_Piece excluding the join edge (as a list of vectors)+drawnEdgesP3 :: P3_Piece -> [V2 Double]+drawnEdgesP3 (LW v) = [z,v^-^z] where z = (phi-1)*^rotate (ttangle 1) v+drawnEdgesP3 (RW v) = [z,v^-^z] where z = (phi-1)*^rotate (ttangle 9) v+drawnEdgesP3 (LN v) = [z,v^-^z] where z = phi*^rotate (ttangle 2) v+drawnEdgesP3 (RN v) = [z,v^-^z] where z = phi*^rotate (ttangle 8) v + -- |Draws the two drawn edges of a P3_Piece drawPieceP3 :: OKBackend b => P3_Piece -> Diagram b-drawPieceP3 = strokeLine . fromOffsets . drawnedgesP3+drawPieceP3 = strokeLine . fromOffsets . drawnEdgesP3 +-- |Draw dashed join only of a P3_Piece +dashjOnlyP3 :: OKBackend b => P3_Piece -> Diagram b+dashjOnlyP3 p = joinDashing (strokeLine $ fromOffsets [tileRepP3 p])++ -- |Draws all edges of a P3_Piece using a faint dashed line for the join edge-dashjPieceP3 :: OKBackend b => P3_Piece -> Diagram b-dashjPieceP3 p = drawPieceP3 p <> joinDashing (strokeLine $ fromOffsets [tileRepP3 p])+drawjPieceP3 :: OKBackend b => P3_Piece -> Diagram b+drawjPieceP3 = drawPieceP3 <> dashjOnlyP3  -- |Fills a P3_Piece with a colour (without drawn edges) fillOnlyPieceP3 :: (OKBackend b, Color c) =>                    c -> P3_Piece -> Diagram b fillOnlyPieceP3 c p =      lw none $ fillColor c $ -    strokeLoop $ closeLine $ fromOffsets $ drawnedgesP3 p+    strokeLoop $ closeLine $ fromOffsets $ drawnEdgesP3 p +-- |Fills a P3_Piece with one of 2 colours (but no drawn edges).+-- The first colour is used for wide rhombuses, and the second for narrow rhombuses.+-- (Note the order WN)+fillOnlyPieceWN :: (OKBackend b, Color cw, Color cn) =>+               cw -> cn -> P3_Piece -> Diagram b+fillOnlyPieceWN cw cn rp = filledpiece where+    filledpiece = case rp of+        (LW _ ) -> fillOnlyPieceP3 cw rp+        (RW _ ) -> fillOnlyPieceP3 cw rp+        _       -> fillOnlyPieceP3 cn rp+ -- |Fills and draws a P3_Piece with one of 2 colours -- The first colour is used for wide rhombuses, and the second for narrow rhombuses. -- (Note the order WN) fillPieceWN :: (OKBackend b, Color cw, Color cn) =>                cw -> cn -> P3_Piece -> Diagram b+fillPieceWN cw cn = drawPieceP3 <> fillOnlyPieceWN cw cn++{-  fillPieceWN cw cn rp = drawPieceP3 rp <> filledpiece where     filledpiece = case rp of         (LW _ ) -> fillOnlyPieceP3 cw rp         (RW _ ) -> fillOnlyPieceP3 cw rp         _       -> fillOnlyPieceP3 cn rp-+-}  -- | A class for things that can be turned to diagrams when given a function to draw P3_Pieces. class P3_Drawable a where@@ -215,9 +247,15 @@ drawP3 = drawP3With drawPieceP3  -- |An alternative drawing function for anything P3_Drawable adding dashed lines for join edges+drawjP3 :: (OKBackend b, P3_Drawable a) => +          a -> Diagram b+drawjP3 = drawP3With drawjPieceP3++{-# DEPRECATED dashjP3 "Replaced by drawjP3" #-}+-- |Deprecated (renamed as drawjP3) dashjP3 :: (OKBackend b, P3_Drawable a) =>            a -> Diagram b-dashjP3 = drawP3With dashjPieceP3+dashjP3 = drawjP3  -- |The main draw and fill function for anything P3_Drawable. -- The first colour is used for wide rhombuses, and the second for narrow rhombuses.@@ -232,3 +270,52 @@ fillNW :: (OKBackend b, P3_Drawable a, Color cw, Color cn) =>           cw -> cn -> a -> Diagram b fillNW = flip fillWN --drawP3With (fillPieceWN cw cn)+++-- | A class for things that can be drawn (P3 style) with labels when given a colour and a measure (size) for the labels and a +-- a draw function (for P3_Patches).+-- So labelColourSizeP3 c m  modifies a P3_Patch drawing function to add labels (of colour c and size measure m).+-- Measures are defined in Diagrams. In particular: tiny, verySmall, small, normal, large, veryLarge, huge.+class P3_DrawableLabelled a where+   labelColourSizeP3 :: OKBackend b => +                        Colour Double -> Measure Double -> (P3_Patch -> Diagram b) -> a -> Diagram b++-- | VPatches can be drawn (Rhombus/P3 style) with labels+-- NB: the additional vertices for P3 are only added when drawing and are not part of the VPatch.+-- Thus using such a vertex for alignment will raise an error.+instance P3_DrawableLabelled VPatch where+     labelColourSizeP3 c m d vp = drawLabels <> d p3Patch where+        p3Patch = decompP2toP3 $ dropLabels vp+        drawLabels = position $ drawlabel <$> VMap.toList (extendLocsP3 vp)+        drawlabel(v,p) = (p, baselineText (show v) # fontSize m # fc c)++-- | (Not exported) Extend the vertex locations of a VPatch with locations for new kite join vertices+-- appearing in (Rhombus/P3 style) drawing of tiles.+-- The new vertex numbers are generated with phiVMap from Tgraph.Decompose+extendLocsP3 :: VPatch -> VertexLocMap+extendLocsP3 vp = locmap <> VMap.fromList (map (locateNew . joinOfTile) (kites vp)) where+    locmap = vLocs vp+    newemap = phiVMap vp+    locateNew (a,b) = case (VMap.lookup a locmap, VMap.lookup b locmap) of+        (Just pa, Just pb) -> (newemap Map.! (a,b), pa .+^ (phi-1) *^ (pb .-. pa))+        _ -> error "extendLocsP3: Missing location for a kite join"++-- | Tgraphs can be drawn (Rhombus/P3 style) with labels+-- NB: the additional vertices for P3 are only added when drawing and are not part of the Tgraph+-- or its VPatch.+-- Thus using such a vertex for alignment will raise an error.+instance P3_DrawableLabelled Tgraph where+     labelColourSizeP3 c m d = labelColourSizeP3 c m d . makeVP++-- | Default Version of labelColourSizeP3 with colour red.+-- Example usage: labelSizeP3 tiny drawP3 a , labelSizeP3 normal drawjP3 a+labelSizeP3 :: (OKBackend b, P3_DrawableLabelled a) =>+               Measure Double -> (P3_Patch -> Diagram b) -> a -> Diagram b+labelSizeP3 = labelColourSizeP3 red++-- | Default Version of labelColourSizeP3 using red and small (rather than normal label size).+-- Example usage: labelledP3 drawP3 a , labelledP3 drawjP3 a+labelledP3 :: (OKBackend b, P3_DrawableLabelled a) =>+            (P3_Patch -> Diagram b) -> a -> Diagram b+labelledP3 = labelColourSizeP3 red small --(normalized 0.023)+