PenroseKiteDart 1.2 → 1.2.1
raw patch · 8 files changed
+146/−94 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Tgraph.Prelude: drawLocatedEdge :: OKBackend b => VertexLocMap -> Dedge -> Diagram b
+ Tgraph.Prelude: drawLocatedEdges :: OKBackend b => VertexLocMap -> [Dedge] -> Diagram b
+ Tgraph.Prelude: makeLD :: Vertex -> Vertex -> Vertex -> TileFace
+ Tgraph.Prelude: makeLK :: Vertex -> Vertex -> Vertex -> TileFace
+ Tgraph.Prelude: makeRD :: Vertex -> Vertex -> Vertex -> TileFace
+ Tgraph.Prelude: makeRK :: Vertex -> Vertex -> Vertex -> TileFace
+ Tgraphs: drawBoundaryJoins :: OKBackend b => Tgraph -> VPatch -> Diagram b
+ TileLib: joinDashing :: (HasStyle c, N c ~ Double) => c -> c
- HalfTile: LD :: rep -> HalfTile rep
+ HalfTile: LD :: !rep -> HalfTile rep
- HalfTile: LK :: rep -> HalfTile rep
+ HalfTile: LK :: !rep -> HalfTile rep
- HalfTile: RD :: rep -> HalfTile rep
+ HalfTile: RD :: !rep -> HalfTile rep
- HalfTile: RK :: rep -> HalfTile rep
+ HalfTile: RK :: !rep -> HalfTile rep
- Tgraph.Compose: DartWingInfo :: [Vertex] -> [Vertex] -> [Vertex] -> IntMap [TileFace] -> DartWingInfo
+ Tgraph.Compose: DartWingInfo :: ![Vertex] -> ![Vertex] -> ![Vertex] -> IntMap [TileFace] -> DartWingInfo
- Tgraph.Compose: [largeDartBases] :: DartWingInfo -> [Vertex]
+ Tgraph.Compose: [largeDartBases] :: DartWingInfo -> ![Vertex]
- Tgraph.Compose: [largeKiteCentres] :: DartWingInfo -> [Vertex]
+ Tgraph.Compose: [largeKiteCentres] :: DartWingInfo -> ![Vertex]
- Tgraph.Compose: [unknowns] :: DartWingInfo -> [Vertex]
+ Tgraph.Compose: [unknowns] :: DartWingInfo -> ![Vertex]
- TileLib: colourDKG :: (Drawable a, OKBackend b) => (Colour Double, Colour Double, Colour Double) -> a -> Diagram b
+ TileLib: colourDKG :: (Drawable a, OKBackend b, Color c1, Color c2, Color c3) => (c1, c2, c3) -> a -> Diagram b
- TileLib: fillDK :: (Drawable a, OKBackend b) => Colour Double -> Colour Double -> a -> Diagram b
+ TileLib: fillDK :: (Drawable a, OKBackend b, Color c1, Color c2) => c1 -> c2 -> a -> Diagram b
- TileLib: fillKD :: (Drawable a, OKBackend b) => Colour Double -> Colour Double -> a -> Diagram b
+ TileLib: fillKD :: (Drawable a, OKBackend b, Color c1, Color c2) => c1 -> c2 -> a -> Diagram b
- TileLib: fillOnlyPiece :: OKBackend b => Colour Double -> Piece -> Diagram b
+ TileLib: fillOnlyPiece :: (OKBackend b, Color c) => c -> Piece -> Diagram b
- TileLib: fillPieceDK :: OKBackend b => Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram b
+ TileLib: fillPieceDK :: (OKBackend b, Color c1, Color c2) => c1 -> c2 -> HalfTile (V2 Double) -> Diagram b
- TileLib: leftFillPieceDK :: OKBackend b => Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram b
+ TileLib: leftFillPieceDK :: (OKBackend b, Color c1, Color c2) => c1 -> c2 -> HalfTile (V2 Double) -> Diagram b
Files
- CHANGELOG.md +15/−0
- PenroseKiteDart.cabal +1/−1
- src/HalfTile.hs +5/−5
- src/Tgraph/Compose.hs +17/−17
- src/Tgraph/Decompose.hs +13/−11
- src/Tgraph/Prelude.hs +46/−21
- src/Tgraphs.hs +10/−4
- src/TileLib.hs +39/−35
CHANGELOG.md view
@@ -1,5 +1,20 @@ # Revision history for PenroseKiteDart +## version 1.2.1 -- 2025-4-2++Added: drawBoundaryJoins, joinDashing++Renamed: drawEdge, drawEdges as drawLocatedEdge, drawLocatedEdges+Depracating: drawEdge, drawEdges++Generalised: colourDKG, fillDK, fillKD, fillPieceDK, fillOnlyPiece+to work with AlphaColours as well as Colours++Deprecating: colourMaybeDKG, fillMaybeDK, fillMaybePieceDK++Added (strict) makeRD, makeLD, makeRK, makeLK to Tgraph.Prelude++ ## version 1.2 -- 2024-12-1 Release candidate:
PenroseKiteDart.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: PenroseKiteDart-version: 1.2+version: 1.2.1 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
src/HalfTile.hs view
@@ -9,7 +9,7 @@ -} {-# LANGUAGE TypeFamilies #-} -- needed for Transformable Instance {-# LANGUAGE FlexibleInstances #-} -- needed for Transformable Instance-{-# LANGUAGE StrictData #-}+-- {-# LANGUAGE StrictData #-} module HalfTile ( HalfTile(..)@@ -34,10 +34,10 @@ For Pieces - rep is V2 Double For TileFaces (in Tgraphs) rep is (Vertex,Vertex,Vertex) -}-data HalfTile rep = LD rep -- ^ Left Dart- | RD rep -- ^ Right Dart- | LK rep -- ^ Left Kite- | RK rep -- ^ Right Kite+data HalfTile rep = LD !rep -- ^ Left Dart+ | RD !rep -- ^ Right Dart+ | LK !rep -- ^ Left Kite+ | RK !rep -- ^ Right Kite deriving (Show,Eq) -- | Note this ignores the tileLabels when comparing.
src/Tgraph/Compose.hs view
@@ -9,7 +9,7 @@ This module includes the main composition operations compose, partCompose, tryPartCompose but also exposes getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and composedFaceGroups for debugging and experimenting. -}-{-# LANGUAGE StrictData #-} +-- {-# LANGUAGE StrictData #-} module Tgraph.Compose ( compose@@ -74,7 +74,7 @@ -- and a Tgraph made from the composed faces without checking for connectedness and no crossing boundaries. -- This relies on a proof that the result of composing a forced Tgraph does not require these checks. uncheckedPartCompose:: Tgraph -> ([TileFace],Tgraph)-uncheckedPartCompose g = (remainder, makeUncheckedTgraph newfaces) where+uncheckedPartCompose g = (remainder, makeUncheckedTgraph $! evalFaces newfaces) where (remainder,newfaces) = partComposeFacesWith getDartWingInfoForced g -- |partComposeFaces g - produces a pair of the remainder faces (faces from g which will not compose)@@ -103,9 +103,9 @@ -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. -- It includes a faceMap from dart wings to faces at that vertex. data DartWingInfo = DartWingInfo - { largeKiteCentres :: [Vertex]- , largeDartBases :: [Vertex]- , unknowns :: [Vertex]+ { largeKiteCentres :: ![Vertex]+ , largeDartBases :: ![Vertex]+ , unknowns :: ![Vertex] , faceMap :: VMap.IntMap [TileFace] } deriving Show @@ -222,38 +222,38 @@ composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where - faceGroupRDs = fmap (\gp -> (makeRD gp,gp)) groupRDs + faceGroupRDs = fmap (\gp -> (makenewRD gp,gp)) groupRDs groupRDs = mapMaybe groupRD (largeDartBases dwInfo)- makeRD [rd,lk] = RD(originV lk, originV rd, oppV lk) - makeRD _ = error "composedFaceGroups: RD case"+ 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] - faceGroupLDs = fmap (\gp -> (makeLD gp,gp)) groupLDs + faceGroupLDs = fmap (\gp -> (makenewLD gp,gp)) groupLDs groupLDs = mapMaybe groupLD (largeDartBases dwInfo) - makeLD [ld,rk] = LD(originV rk, oppV rk, originV ld)- makeLD _ = error "composedFaceGroups: LD case"+ 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] - faceGroupRKs = fmap (\gp -> (makeRK gp,gp)) groupRKs + faceGroupRKs = fmap (\gp -> (makenewRK gp,gp)) groupRKs groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) - makeRK [rd,_,rk] = RK(originV rd, wingV rk, originV rk)- makeRK _ = error "composedFaceGroups: RK case"+ 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] - faceGroupLKs = fmap (\gp -> (makeLK gp,gp)) groupLKs + faceGroupLKs = fmap (\gp -> (makenewLK gp,gp)) groupLKs groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) - makeLK [ld,_,lk] = LK(originV ld, originV lk, wingV lk)- makeLK _ = error "composedFaceGroups: LK case"+ 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
src/Tgraph/Decompose.hs view
@@ -9,6 +9,8 @@ This module defines decompose and decompositions for Tgraphs, but also exposes two auxiliary functions for debugging and experimenting. -}+{-# LANGUAGE BangPatterns #-}+ module Tgraph.Decompose ( decompose , decompositions@@ -33,19 +35,19 @@ -- |Decompose a Tgraph. decompose :: Tgraph -> Tgraph decompose g = makeUncheckedTgraph newFaces where- newFaces = concatMap (decompFace (phiVMap g)) (faces g)+ pvmap = phiVMap g+ !newFaces = evalFaces $ concatMap (decompFace pvmap) (faces g) -- |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.+-- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace 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] newVs = [v+1..v+n]- n = length phiReps- v = maxV g+ !n = length phiReps+ !v = maxV g edgeVMap = Map.fromList $ zip phiReps newVs ++ zip (fmap reverseD phiReps) newVs -- |Decompose a face producing new faces. @@ -55,15 +57,15 @@ decompFace:: Map.Map Dedge Vertex -> TileFace -> [TileFace] decompFace newVFor fc = case fc of RK(a,b,c) -> [RK(c,x,b), LK(c,y,x), RD(a,x,y)]- where x = (Map.!) newVFor (a,b)- y = (Map.!) newVFor (c,a)+ where !x = (Map.!) newVFor (a,b)+ !y = (Map.!) newVFor (c,a) LK(a,b,c) -> [LK(b,c,y), RK(b,y,x), LD(a,x,y)]- where x = (Map.!) newVFor (a,b)- y = (Map.!) newVFor (c,a) + where !x = (Map.!) newVFor (a,b)+ !y = (Map.!) newVFor (c,a) RD(a,b,c) -> [LK(a,x,c), RD(b,c,x)]- where x = (Map.!) newVFor (a,b)+ where !x = (Map.!) newVFor (a,b) LD(a,b,c) -> [RK(a,b,x), LD(c,x,b)]- where x = (Map.!) newVFor (a,c)+ where !x = (Map.!) newVFor (a,c) -- |infinite list of decompositions of a Tgraph decompositions :: Tgraph -> [Tgraph]
src/Tgraph/Prelude.hs view
@@ -18,6 +18,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-} module Tgraph.Prelude ( module HalfTile@@ -86,6 +87,10 @@ , graphEFMap , defaultAlignment -- * Other Face/Vertex Operations+ , makeRD+ , makeLD+ , makeRK+ , makeLK , faceVs , faceVList , faceVSet@@ -159,8 +164,8 @@ -- * Drawing Edges with a VPatch or a VertexLocationMap , drawEdgesVP , drawEdgeVP- , drawEdges- , drawEdge+ , drawLocatedEdges+ , drawLocatedEdge -- * Vertex Location and Touching Vertices , locateVertices , addVPoint@@ -171,6 +176,8 @@ , touching , touchingVerticesGen , locateVerticesGen+ , drawEdges+ , drawEdge ) where import Data.List ((\\), intersect, union, elemIndex,foldl',find,nub)@@ -269,10 +276,10 @@ tryCorrectTouchingVs fcs = onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $ tryTgraphProps $ nub $ renumberFaces touchVs fcs- -- renumberFaces allows for a non 1-1 relabelling represented by a list + -- renumberFaces allows for a many to 1 relabelling represented by a list where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices --- |renumberFaces allows for a non 1-1 relabelling represented by a list of pairs.+-- |renumberFaces allows for a many to 1 relabelling represented by a list of pairs. -- It is used only for tryCorrectTouchingVs in Tgraphs which then checks the result renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace] renumberFaces prs = fmap renumberFace where@@ -283,20 +290,15 @@ differing = filter $ uncurry (/=) -- |Creates a (possibly invalid) Tgraph from a list of faces.--- It does not perform checks on the faces. Use makeTgraph (defined in Tgraphs module) or checkedTgraph to perform checks.+-- It does not perform checks on the faces. Use makeTgraph or checkedTgraph to perform checks. -- This is intended for use only when checks are known to be redundant.--- It also fully evaluates the list of faces (to reduce space leaks). makeUncheckedTgraph:: [TileFace] -> Tgraph-makeUncheckedTgraph fcs = Tgraph (evalFaces fcs)+makeUncheckedTgraph = Tgraph -- . evalFaces -- |force evaluation of a list of faces. evalFaces :: [TileFace] -> [TileFace]-evalFaces fcs = facesMaxV fcs `seq` fcs--{- -- |force evaluation of a face.-evalFace ::TileFace -> TileFace-evalFace face = oppV face `seq` wingV face `seq` originV face `seq` face- -}+evalFaces fcs = find (has0 . tileRep) fcs `seq` fcs where+ has0 (x,y,z) = x==0 || y==0 || z==0 {-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties and producing an error if a check fails.@@ -594,11 +596,24 @@ defaultAlignment g | nullGraph g = error "defaultAlignment: applied to empty Tgraph\n" | otherwise = lowestJoin $ faces g +makeRD,makeLD,makeRK,makeLK :: Vertex -> Vertex -> Vertex -> TileFace+-- |make an RD (strict in arguments)+makeRD !x !y !z = RD(x,y,z)+-- |make an LD (strict in arguments)+makeLD !x !y !z = LD(x,y,z)+-- |make an RK (strict in arguments)+makeRK !x !y !z = RK(x,y,z)+-- |make an LK (strict in arguments)+makeLK !x !y !z = LK(x,y,z) -- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace+{-# Inline faceVs #-} faceVs::TileFace -> (Vertex,Vertex,Vertex) faceVs = tileRep-+{- faceVs f = let tr = tileRep f+ (x,y,z) = tr+ in x `seq` y `seq` z `seq` tr+ -} -- |list of (three) face vertices in order clockwise starting with origin faceVList::TileFace -> [Vertex] faceVList = (\(x,y,z) -> [x,y,z]) . faceVs@@ -1086,28 +1101,38 @@ -- Will raise an error if any vertex of the edges is not a key in the vertex to location mapping of the VPatch. drawEdgesVP :: OKBackend b => VPatch -> [Dedge] -> Diagram b-drawEdgesVP = drawEdges . vLocs --foldMap (drawEdgeVP vp)+drawEdgesVP = drawLocatedEdges . vLocs --foldMap (drawEdgeVP vp) -- |produce a diagram of a single edge (given a VPatch) -- Will raise an error if either vertex of the edge is not a key in the vertex to location mapping of the VPatch. drawEdgeVP:: OKBackend b => VPatch -> Dedge -> Diagram b-drawEdgeVP = drawEdge . vLocs+drawEdgeVP = drawLocatedEdge . vLocs -- |produce a diagram of a list of edges (given a mapping of vertices to locations) -- Will raise an error if any vertex of the edges is not a key in the mapping.-drawEdges :: OKBackend b =>+drawLocatedEdges :: OKBackend b => VertexLocMap -> [Dedge] -> Diagram b-drawEdges = foldMap . drawEdge+drawLocatedEdges = foldMap . drawLocatedEdge + -- |produce a diagram of a single edge (given a mapping of vertices to locations). -- Will raise an error if either vertex of the edge is not a key in the mapping.-drawEdge :: OKBackend b =>- VertexLocMap -> Dedge -> Diagram b-drawEdge vpMap (a,b) = case (VMap.lookup a vpMap, VMap.lookup b vpMap) of+drawLocatedEdge :: OKBackend b =>+ VertexLocMap -> Dedge -> Diagram b+drawLocatedEdge vpMap (a,b) = case (VMap.lookup a vpMap, VMap.lookup b vpMap) of (Just pa, Just pb) -> pa ~~ pb _ -> error $ "drawEdge: location not found for one or both vertices "++ show (a,b) ++ "\n" +-- |deprecated (use drawLocatedEdges)+drawEdges :: OKBackend b =>+ VertexLocMap -> [Dedge] -> Diagram b+drawEdges = drawLocatedEdges++-- |deprecated (use drawLocatedEdge)+drawEdge :: OKBackend b =>+ VertexLocMap -> Dedge -> Diagram b+drawEdge = drawLocatedEdge {-| locateVertices: processes a list of faces to associate points for each vertex using a default scale and orientation.
src/Tgraphs.hs view
@@ -27,6 +27,7 @@ -- * Smart drawing of Tgraphs , smart , boundaryJoinFaces+ , drawBoundaryJoins , drawJoinsFor , smartdraw , restrictSmart@@ -119,7 +120,7 @@ -- smart (labelSize normal draw) g smart :: OKBackend b => (VPatch -> Diagram b) -> Tgraph -> Diagram b-smart dr g = drawJoinsFor (boundaryJoinFaces g) vp <> dr vp+smart dr g = drawBoundaryJoins g vp <> dr vp where vp = makeVP g -- |select the halftile faces of a Tgraph with a join edge on the boundary.@@ -128,10 +129,15 @@ boundaryJoinFaces g = fmap snd $ incompleteHalves bdry $ boundary bdry where bdry = makeBoundaryState g --- |given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces.+-- draw boundary join edges of a Tgraph using a given VPatch+drawBoundaryJoins :: OKBackend b => Tgraph -> VPatch -> Diagram b+drawBoundaryJoins g vp = drawEdgesVP vp (map joinE $ boundaryJoinFaces g) # joinDashing++-- |Given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces.+-- Will raise an error if any vertex in the faces does not have a location in the VPatch. drawJoinsFor:: OKBackend b => [TileFace] -> VPatch -> Diagram b-drawJoinsFor fcs vp = drawWith dashjOnly (subVP vp fcs)+drawJoinsFor fcs vp = drawWith dashjOnly (restrictVP vp fcs) -- |same as draw except adding dashed lines on boundary join edges. smartdraw :: OKBackend b => Tgraph -> Diagram b@@ -142,7 +148,7 @@ -- This can be used instead of smart when an appropriate vp is already available. restrictSmart :: OKBackend b => Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b-restrictSmart g dr vp = drawJoinsFor (boundaryJoinFaces g) rvp <> dr rvp+restrictSmart g dr vp = drawBoundaryJoins g rvp <> dr rvp where rvp = restrictVP vp $ faces g -- |smartRotateBefore vfun a g - a tricky combination of smart with rotateBefore.
src/TileLib.hs view
@@ -73,6 +73,7 @@ , scales , phiScales , phiScaling+ , joinDashing ) where import Diagrams.Prelude@@ -167,9 +168,13 @@ dashjOnly :: OKBackend b => Piece -> Diagram b -- dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey -dashjOnly piece = drawJoin piece # dashing [dashmeasure,dashmeasure] 0 # lw ultraThin- where dashmeasure = normalized 0.003 `atLeast` output 0.5+dashjOnly piece = drawJoin piece # joinDashing +-- 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@@ -181,24 +186,26 @@ drawJoin piece = strokeLine $ fromOffsets [joinVector piece] -- |fillOnlyPiece col piece - fills piece with colour col without drawing any lines.-fillOnlyPiece :: OKBackend b =>- Colour Double -> Piece -> Diagram b-fillOnlyPiece col piece = drawRoundPiece piece # fc col # lw none+-- Can be used with both Colour and AlphaColour+fillOnlyPiece :: (OKBackend b, Color c) =>+ c -> Piece -> Diagram b+fillOnlyPiece col piece = drawRoundPiece piece # fillColor col # lw none -- |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.-fillPieceDK :: OKBackend b =>- Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram b-fillPieceDK dcol kcol piece = drawPiece piece <> fillOnlyPiece col piece where- col = case piece of (LD _) -> dcol- (RD _) -> dcol- (LK _) -> kcol- (RK _) -> kcol+-- Can be used with both Colour and AlphaColour+fillPieceDK :: (OKBackend b, Color c1, Color c2) =>+ c1 -> c2 -> HalfTile (V2 Double) -> Diagram b+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 --- |fillMaybePieceDK d k piece - draws the half-tile piece and possibly fills as well:--- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol--- Nothing indicates no fill for either darts or kites or both.+-- |fillMaybePieceDK *Deprecated* +-- (use fillPieceDK which works with AlphaColours such as transparent as well as Colours) fillMaybePieceDK :: OKBackend b => Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram b fillMaybePieceDK d k piece = drawPiece piece <> filler where@@ -213,11 +220,12 @@ -- |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).-leftFillPieceDK :: OKBackend b =>- Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram b+-- Works with AlphaColours as well as Colours.+leftFillPieceDK :: (OKBackend b, Color c1, Color c2) =>+ c1 -> c2 -> HalfTile (V2 Double) -> Diagram b leftFillPieceDK dcol kcol pc =- case pc of (LD _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fc dcol- (LK _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fc kcol+ case pc of (LD _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fillColor dcol+ (LK _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fillColor kcol _ -> mempty -- |experiment uses a different rule for drawing half tiles.@@ -263,20 +271,20 @@ a -> Diagram b drawj = drawWith dashjPiece -fillDK, fillKD :: (Drawable a, OKBackend b) =>- Colour Double -> Colour Double -> a -> Diagram b+fillDK, fillKD :: (Drawable a, OKBackend b, Color c1, Color c2) =>+ c1 -> c2 -> a -> Diagram b -- |fillDK dcol kcol a - draws and fills a with colour dcol for darts and kcol for kites. -- Note the order D K.+-- Works with AlphaColours as well as Colours. fillDK c1 c2 = drawWith (fillPieceDK c1 c2) -- |fillKD kcol dcol a - draws and fills a with colour kcol for kites and dcol for darts. -- Note the order K D.+-- Works with AlphaColours as well as Colours. fillKD c1 c2 = fillDK c2 c1 --- |fillMaybeDK c1 c2 a - draws a and maybe fills as well:--- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol--- Nothing indicates no fill for either darts or kites or both--- Note the order D K.+-- |fillMaybeDK *Deprecated*+-- (Use fillDK which works with AlphaColours such as transparent as well as Colours). fillMaybeDK :: (Drawable a, OKBackend b) => Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram b fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2)@@ -284,22 +292,18 @@ -- |colourDKG (c1,c2,c3) p - fill in a drawable with colour c1 for darts, colour c2 for kites and -- colour c3 for grout (that is, the non-join edges). -- Note the order D K G.-colourDKG :: (Drawable a, OKBackend b) =>- (Colour Double, Colour Double, Colour Double) -> a -> Diagram b-colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lc c3+-- Can be used with both Colour and AlphaColour+colourDKG :: (Drawable a, OKBackend b, Color c1, Color c2, Color c3) =>+ (c1,c2,c3) -> a -> Diagram b+colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lineColor c3 --- |colourMaybeDKG (d,k,g) a - draws a and possibly fills as well:--- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol--- Nothing indicates no fill for either darts or kites or both--- The g argument is for grout - i.e the non-join edges round tiles.--- Edges are drawn with gcol if g = Just gcol and not drawn if g = Nothing.+-- |colourMaybeDKG *Deprecated*+-- (Use colourDKG which works with AlphaColours such as transparent as well as Colours) colourMaybeDKG:: (Drawable a, OKBackend b) => (Maybe (Colour Double), Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram b colourMaybeDKG (d,k,g) a = fillMaybeDK d k a # maybeGrout g where maybeGrout (Just c) = lc c maybeGrout Nothing = lw none-- {-| Decomposing splits each located piece in a patch into a list of smaller located pieces to create a refined patch.