diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 diff --git a/src/Tgraph/Decompose.hs b/src/Tgraph/Decompose.hs --- a/src/Tgraph/Decompose.hs +++ b/src/Tgraph/Decompose.hs @@ -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 a -> Map.Map Dedge Vertex +phiVMap fcs = edgeVMap where + phiReps = sort [(a,b) | (a,b) <- phiEdges fcs, a 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 diff --git a/src/TileLib.hs b/src/TileLib.hs --- a/src/TileLib.hs +++ b/src/TileLib.hs @@ -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 + diff --git a/src/TileLibP3.hs b/src/TileLibP3.hs --- a/src/TileLibP3.hs +++ b/src/TileLibP3.hs @@ -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) +