diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,91 @@ # Revision history for PenroseKiteDart +## version 1.11 + +Significant changes to P3 tiling (rhombuses) and drawing P3 style. + +- Renamed module TileLibP3 as Tgraph.Rhombuses + +- Renamed some P3 functions, types, classes (for consistency) + - P3_HalfTile renamed as HalfTile_P3 + - P3_Piece renamed as Piece_P3 + - P3_Patch renamed as Patch_P3 + - joinVectorP3 renamed as joinVector_P3 + - drawnEdgesP3 renamed as drawnEdges_P3 + - decompP2toP3 renamed as decompPatchP2toP3 + - decompP3toP2 renamed as decompPatchP3toP2 + - drawPieceP3 renamed as drawPiece_P3 + - drawjPieceP3 renamed as drawjPiece_P3 + - drawJPieceP3 renamed as drawJPiece_P3 + - P3_Drawable renamed as Drawable_P3 + - P3_DrawableLabelled renamed as DrawableLabelled_P3 + - labelColourSizeP3 renamed as labelColourSize_P3 + - labelSizeP3 renamed as labelSize_P3 + - labelledP3 renamed as labelled_P3 + - drawP3With renamed as drawWith_P3 + - drawP3 renamed as draw_P3 + - drawjP3 renamed as drawj_P3 + - drawJP3 renamed as drawJ_P3 +- Added + - makeEVnewMap + - checkConnectedNoCross + - Tgraph_P3() + - decomposeToRhombuses + - decomposeToTgraph + - decomposeRhombuses + - tryComposeToRhombuses + - quickComposeToRhombuses + - TileFace_P3 + - tryConnectedNoCross_P3 + - tryComposeToFaces_P3 + - quickComposeToFaces_P3 + - faces_P3 + - maxV_P3 + - vertexSet_P3 + - faceVSet_P3 + - faceVs_P3 + - faceVList_P3 + - originV_P3 + - oppV_P3 + - wingV_P3 + - join_P3 + - isWide + - isNarrow + - dedges_P3 + - VPatch_P3(vLocs_P3,vpFaces_P3) + - makeVP_P3 + - dropLabels_P3 + - convertVPatch_P3 + - convertVPatch + - deformVPatch_P3 + - HalfTile_P3(LW,RW,LN,RN) + - tileRep_P3 + - joinVector_P3 + - drawnEdges_P3 + - Piece_P3 + - decompPieceP2toP3 + - decompPieceP3toP2 + - Patch_P3 + - decompPatchP2toP3 + - decompPatchP3toP2 + - drawPiece_P3 + - drawjPiece_P3 + - drawJPiece_P3 + - fillOnlyPiece_P3 + - fillOnlyPieceWN + - fillPieceWN + - Drawable_P3(..) + - draw_P3 + - drawj_P3 + - drawJ_P3 + - fillWN + - fillNW + - DrawableLabelled_P3(..) + - labelSize_P3 + - labelled_P3 + - composeToRhombusProblem (in TgraphExamples) + + ## version 1.10.1 - VPatch is now deformable 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.10.1 +version: 1.11 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 @@ -31,7 +31,6 @@ CheckBackend HalfTile TileLib - TileLibP3 Try Tgraph.Prelude Tgraph.Decompose @@ -40,6 +39,7 @@ Tgraph.Relabelling Tgraph.Extras Tgraph.Grid + Tgraph.Rhombuses TgraphExamples other-modules: Paths_PenroseKiteDart diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -34,16 +34,24 @@ _ <- traceMarkerIO "finished (unchecked) composing" wait _ <- traceMarkerIO "starting checked compose" - let !newcfkD = {-# SCC "checkedCompose" #-} compose $ recoverGraph fkD + let !newcfkD = {-# SCC "checkedCompose" #-} compose fkD putStrLn $ "Number of faces of new checked compose is " ++ show (faceCount newcfkD) _ <- traceMarkerIO "finished checked compose" +{- wait + _ <- traceMarkerIO "starting tryComposeToRhombuses" + let !crfkD = {-# SCC "tryComposeToRhombuses" #-} runTry $ tryComposeToRhombuses $ recoverGraph fkD + putStrLn $ "Number of faces of quickCompose is " + ++ show (faceCount_P3 crfkD) + _ <- traceMarkerIO "finished tryComposeToRhombuses" + wait _ <- traceMarkerIO "starting quickCompose" - let !qcfkD = {-# SCC "quickCompose" #-} quickCompose $ recoverGraph fkD + let !qcfkD = {-# SCC "quickCompose" #-} quickCompose fkD putStrLn $ "Number of faces of quickCompose is " ++ show (faceCount qcfkD) _ <- traceMarkerIO "finished quickCompose" + -} return () diff --git a/src/HalfTile.hs b/src/HalfTile.hs --- a/src/HalfTile.hs +++ b/src/HalfTile.hs @@ -68,10 +68,10 @@ -- {-# INLINE tileRep #-} -- |return the representation of a half-tile tileRep:: HalfTile rep -> rep -tileRep (LD !r) = r -tileRep (RD !r) = r -tileRep (LK !r) = r -tileRep (RK !r) = r +tileRep (LD r) = r +tileRep (RD r) = r +tileRep (LK r) = r +tileRep (RK r) = r -- |half-tile predicate isLD,isRD,isLK,isRK,isDart,isKite :: HalfTile rep -> Bool diff --git a/src/PKD.hs b/src/PKD.hs --- a/src/PKD.hs +++ b/src/PKD.hs @@ -36,7 +36,7 @@ -- * Smart drawing of Tgraphs and other extras , module Tgraph.Extras -- * Converting to P3 (rhombus) tilings and drawing - , module TileLibP3 + , module Tgraph.Rhombuses ) where @@ -47,5 +47,5 @@ import Tgraph.Relabelling import Tgraph.Force import Tgraph.Extras -import TileLibP3 +import Tgraph.Rhombuses diff --git a/src/Tgraph/Decompose.hs b/src/Tgraph/Decompose.hs --- a/src/Tgraph/Decompose.hs +++ b/src/Tgraph/Decompose.hs @@ -23,9 +23,9 @@ ) where import Data.Map.Strict(Map) -import qualified Data.Map.Strict as Map ((!), fromList) -import Data.List(sort) +import qualified Data.Map.Strict as Map ((!)) + import Tgraph.Prelude @@ -47,19 +47,21 @@ pvmap = phiVMap 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 Tgraph.Extras module. phiVMap :: HasFaces a => a -> Map Dedge Vertex -phiVMap x = edgeVMap where +phiVMap x = makeEVnewMap (maxV x) (concatMap facePhiEdges (faces x)) +{- phiVMap x = edgeVMap where --phiReps = sort [e | e@(a,b) <- phiEdges fcs, a Try Tgraph tryConnectedNoCross [] = Right emptyTgraph -tryConnectedNoCross fcs = tryConnectedNoCross' fcs (dedges fcs) (vertexSet fcs) +tryConnectedNoCross fcs = do _ <- tryConnectedNoCross' (dedges fcs) (vertexSet fcs) + return (Tgraph fcs) + -- |(not exported) A variant of tryConnectedNoCross with precalculated dedge list and vertex set. -- Checks for no crossing boundaries and connectedness. +-- Returns Right () on passing checks. +-- Returns Left lines if a test fails, where lines describes the problem found. +-- This is used by tryTgraphProps after other checks have been made. +tryConnectedNoCross' :: [Dedge] -> IntSet -> Try () +tryConnectedNoCross' deslist vs = -- no arguments are null + let des = Set.fromList deslist + bes = missingRevSet des -- boundaryESetFrom + duplicateBVs = duplicates $ verticesForBEs bes + crossing = not $ null duplicateBVs + isConnected = null (snd $ connectedBy (bes<>des) (IntSet.findMin vs) vs) + in if not isConnected + then failReport + "tryConnectedNoCross': (Not connected)\n" + else if crossing + then failReports + ["tryConnectedNoCross': Crossing boundaries found at " + ,show duplicateBVs + ,"\n" + ] + else Right () + +-- |Exported check for connectedness and no crossing boundaries taking just a dedge list. +-- Returns Right () on passing checks. +-- Returns Left lines if a test fails, where lines describes the problem found. +checkConnectedNoCross :: [Dedge] -> Try () +checkConnectedNoCross [] = Right () +checkConnectedNoCross deslist = -- not null + let des = Set.fromList deslist + bes = missingRevSet des -- boundaryESetFrom + duplicateBVs = duplicates $ verticesForBEs bes + crossing = not $ null duplicateBVs + vs = IntSet.fromList (map fst deslist <> map snd deslist) + isConnected = null (snd $ connectedBy (bes<>des) (IntSet.findMin vs) vs) + in if not isConnected + then failReport + "checkConnectedNoCross: (Not connected)\n" + else if crossing + then failReports + ["checkConnectedNoCross: Crossing boundaries found at " + ,show duplicateBVs + ,"\n" + ] + else Right () + +{- OLDER +-- |(not exported) A variant of tryConnectedNoCross with precalculated dedge list and vertex set. +-- Checks for no crossing boundaries and connectedness. -- The given dedge list must be all the dedges in the faces, -- and the given vertex set must be all the vertices in the faces. -- The faces must not be null. @@ -432,8 +484,8 @@ bes = missingRevSet des -- boundaryESetFrom duplicateBVs = duplicates $ verticesForBEs bes crossing = not $ null duplicateBVs - connectedFcs = null (snd $ connectedBy (bes<>des) (IntSet.findMin vs) vs) - in if not connectedFcs + isConnected = null (snd $ connectedBy (bes<>des) (IntSet.findMin vs) vs) + in if not isConnected then failReports ["tryConnectedNoCross: Non-valid Tgraph (Not connected)\n" ,"with faces\n" @@ -450,6 +502,7 @@ ,"\n" ] else Right (Tgraph fcs) + -} -- |Used in testing. ---Checks if there are repeated vertices within any TileFace for a list of TileFaces. @@ -544,7 +597,6 @@ -- |There are crossing boundaries if vertices occur more than once -- in the boundary vertices. - crossingBoundaries :: HasFaces a => a -> Bool crossingBoundaries = not . null . crossingBVs -- Used in testing @@ -753,21 +805,21 @@ -- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace faceVs::TileFace -> (Vertex,Vertex,Vertex) -faceVs = evalTriple . tileRep +faceVs = tileRep --- |force evaluation of a triple +{- -- |force evaluation of a triple evalTriple :: (Int,Int,Int) -> (Int,Int,Int) evalTriple tr@(a,b,c) = a `seq` b `seq` c `seq` tr - + -} -- |list of (three) face vertices in order clockwise starting with origin faceVList::TileFace -> [Vertex] --- faceVList = (\(x,y,z) -> [x,y,z]) . faceVs -faceVList f = [a,b,c] where (a,b,c) = faceVs f +faceVList = asList . faceVs where + asList (a,b,c) = [a,b,c] + -- |the set of vertices of a face faceVSet :: TileFace -> VertexSet --- faceVSet = IntSet.fromList . faceVList -faceVSet f = IntSet.insert a $ IntSet.insert b $ IntSet.insert c IntSet.empty - where (a,b,c) = faceVs f +faceVSet = asSet . faceVs where + asSet (a,b,c) = IntSet.insert a $ IntSet.insert b $ IntSet.insert c IntSet.empty -- |firstV, secondV and thirdV vertices of a face are counted clockwise starting with the origin @@ -823,12 +875,7 @@ isAtV:: Vertex -> TileFace -> Bool isAtV v f = v==a || v==b || v==c where (a,b,c) = faceVs f -{- -isAtV v (LD(a,b,c)) = v==a || v==b || v==c -isAtV v (RD(a,b,c)) = v==a || v==b || v==c -isAtV v (LK(a,b,c)) = v==a || v==b || v==c -isAtV v (RK(a,b,c)) = v==a || v==b || v==c - -} + -- |hasVIn vs f - asks if face f has an element of vs as a vertex hasVIn:: [Vertex] -> TileFace -> Bool hasVIn vs face = not $ null $ faceVList face `intersect` vs @@ -1040,6 +1087,20 @@ -- | look up a face for an edge in an edge-face map faceForEdge :: Dedge -> Map Dedge TileFace -> Maybe TileFace faceForEdge = Map.lookup + +-- | Given a starting int v and a list of directed edges des (mixed, not necessarily both directions) +-- create a map from edges to new integers above v, such that: +-- 1) The edges are both directions of edges in des without repetitions. +-- 2) Both (a,b) and (b,a) get the same integer. +-- The edges get consecutive integers after being sorted +-- (where if a>b then (a,b) gets the integer assigned to (b,a)). +makeEVnewMap :: Vertex -> [Dedge] -> Map Dedge Vertex +makeEVnewMap v des = themap where + themap = Map.fromList $ zip reps newVs ++ zip (map reverseD reps) newVs + reps = sort [e | e@(a,b) <- missingRevs des <> des , a Try Tgraph_P3 +tryConnectedNoCross_P3 rs = do + _ <- onFail " tryConnectedNoCross_P3- : result has crossing boundary or is not connected\n" $ + checkConnectedNoCross (dedges_P3 rs) + return (Tgraph_P3 rs) + +-- |Decompose a Tgraph into Tgraph_P3 (rhombuses) +-- The new vertex numbers are generated with phiVMap from Tgraph.Decompose +decomposeToRhombuses :: Tgraph -> Tgraph_P3 +decomposeToRhombuses g = Tgraph_P3 rs where + rs = concatMap convert (faces g) + newVFor = phiVMap g --makeEVnewMap (maxV g) (map joinE $ filter isKite $ faces g) + -- newVFor = makeEVnewMap (maxV g) (map joinE $ filter isKite $ faces g) + convert (LK(a,b,c)) = [ RW (a,b,x), RN (c,x,b) ] where x = newVFor Map.! (a,c) + convert (RK(a,b,c)) = [ LW (a,x,c), LN (b,c,x) ] where x = newVFor Map.! (a,b) + convert (LD(a,b,c)) = [ RW(c,a,b) ] + convert (RD(a,b,c)) = [ LW(b,c,a) ] + +-- |decompose a Tgraph_P3 (rhombuses) to a Tgraph +decomposeToTgraph :: Tgraph_P3 -> Tgraph +decomposeToTgraph (Tgraph_P3 rs) = makeTgraph (concatMap split rs) where + split (RN(a,b,c)) = [LK(c,a,b)] + split (LN(a,b,c)) = [RK(b,c,a)] + split (RW(a,b,c)) = [LD(a,x,c), RK(b,c,x)] where x = (Map.!) newVFor (a,b) + split (LW(a,b,c)) = [RD(a,b,x), LK(c,x,b)] where x = (Map.!) newVFor (a,c) + newVFor = makeEVnewMap v (map join_P3 (filter isWide rs)) + v = maxV_P3 rs + +-- |Decompose a Tgraph_P3 (via an intermediate Tgraph) +decomposeRhombuses :: Tgraph_P3 -> Tgraph_P3 +decomposeRhombuses = decomposeToRhombuses . decomposeToTgraph + + +-- | Try to compose a Tgraph to Tgraph_P3 (rhombuses). +-- This can fail with crossing boundaries even on a forced Tgraph (e.g. force sun3Dart) +-- It can also fail on an incorrect Tgraph (it uses tryGetDartWingInfo which uses tryForce). +-- +-- First convert all halftile pairs sharing a short edge +-- (dart and kite -> half Wide rhombus; kite and kite -> full Narrow rhombus). +-- Then convert half kites with a boundary short edge that do not have an unknown oppV. +-- Drop all other half kites and darts with a short edge on the boundary. +tryComposeToRhombuses :: Tgraph -> Try Tgraph_P3 +tryComposeToRhombuses g = + do rhombs <- tryComposeToFaces_P3 g + onFail "tryComposeToRhombuses: result has crossing boundary or is not connected\n" + $ tryConnectedNoCross_P3 rhombs + +-- | Try to compose a Tgraph to Rhombuses (TileFace_P3). +-- This can fail with crossing boundaries even on a forced Tgraph (e.g. force sun3Dart) +-- It can also fail on an incorrect Tgraph (it uses tryGetDartWingInfo which uses tryForce). +-- +-- First convert all halftile pairs sharing a short edge +-- (dart and kite -> half Wide rhombus; kite and kite -> full Narrow rhombus). +-- Then convert half kites with a boundary short edge that do not have an unknown oppV. +-- Drop all other half kites and darts with a short edge on the boundary. +tryComposeToFaces_P3 :: Tgraph -> Try [TileFace_P3] +tryComposeToFaces_P3 g = + do dwi <- tryGetDartWingInfo g + return $ composeRhombs (largeKiteCentres dwi) (faces g) + where + composeRhombs lkcs fcs = extraNs ++ rhombs1 where + (rhombs1, remainders) = process ([], Map.empty) fcs + ordrd p@(a,b) | a process (ans, Map.insert sh f m) more + Just f' -> process (combine f f' ++ans, Map.delete sh m) more + -- kite wing becomes origin of narrow rhombus + combine (LK(a,b,c)) (RK(d,_,_)) = [RN(b,c,a),LN(b,d,c)] + combine (RK(d,c,b)) (LK(a,_,_)) = [LN(b,d,c),RN(b,c,a)] + -- dart origin becomes origin of wide rhombus + combine (LD(a,_,c)) (RK(d,_,_)) = [RW(a,d,c)] + combine (RK(d,c,_)) (LD(a,_,_)) = [RW(a,d,c)] + combine (RD(a,b,_)) (LK(d,_,_)) = [LW(a,b,d)] + combine (LK(d,_,b)) (RD(a,_,_)) = [LW(a,b,d)] + combine _ _ = error "tryComposeToRhombuses (combine): non matching pair of faces" + -- convert candidate half kites with boundary short edge. + extraNs = map convert candidates + -- candidate is kite with short edge on boundary and + -- kite oppV is a largeKiteCentre (not an unknown) + candidates = filter (\f -> isKite f && (oppV f `elem` lkcs)) remainders + -- kite wing becomes origin of narrow rhombus half + convert (LK(a,b,c)) = RN(b,c,a) + convert (RK(d,c,b)) = LN(b,d,c) + convert _ = error "tryComposeToRhombuses (convert) found dart" + +-- | (quick) Compose a Tgraph to Tgraph_P3 (rhombuses). +-- This is an approximation for unforced Tgraphs, avoiding use of force. +-- It can fail with crossing boundaries even on a forced Tgraph (e.g. force sun3Dart) +-- +-- First convert all halftile pairs sharing a short edge +-- (dart and kite -> half Wide rhombus; kite and kite -> full Narrow rhombus). +-- Then convert half kites with a boundary short edge that share their long edge with a dart. +-- Drop all other half kites and darts with a short edge on the boundary. +-- Thus information can be lost in the conversion. +quickComposeToRhombuses :: Tgraph -> Tgraph_P3 +quickComposeToRhombuses = runTry . tryConnectedNoCross_P3 . quickComposeToFaces_P3 + +-- | (quick) Compose Rhombuses (TileFace_P3) from a Tgraph +-- This is an approximation for unforced Tgraphs, avoiding use of force. +-- +-- First convert all halftile pairs sharing a short edge +-- (dart and kite -> half Wide rhombus; kite and kite -> full Narrow rhombus). +-- Then convert half kites with a boundary short edge that share their long edge with a dart. +-- Drop all other half kites and darts with a short edge on the boundary. +-- Thus information can be lost in the conversion. +quickComposeToFaces_P3 :: Tgraph -> [TileFace_P3] +quickComposeToFaces_P3 g = rhombs where + rhombs = extraNs ++ process Map.empty (faces g) + ordrd p@(a,b) | a process (Map.insert sh f m) more + Just f' -> combine f f' ++ process m more + -- kite wing becomes origin of narrow rhombus + combine (LK(a,b,c)) (RK(d,_,_)) = [RN(b,c,a),LN(b,d,c)] + combine (RK(d,c,b)) (LK(a,_,_)) = [LN(b,d,c),RN(b,c,a)] + -- dart origin becomes origin of wide rhombus + combine (LD(a,_,c)) (RK(d,_,_)) = [RW(a,d,c)] + combine (RK(d,c,_)) (LD(a,_,_)) = [RW(a,d,c)] + combine (RD(a,b,_)) (LK(d,_,_)) = [LW(a,b,d)] + combine (LK(d,_,b)) (RD(a,_,_)) = [LW(a,b,d)] + combine _ _ = error "composeToRhombuses (combine): non matching pair of faces" + -- convert candidate half kites with boundary short edge. + extraNs = let bs = makeBoundaryState g + ks = map snd $ boundaryEdgeFilter Short candidate bs (boundary bs) + in map convert ks + -- candidate is kite with short edge on boundary and + -- dart origin at kite wing (i.e. kite wing is king or queen) + candidate bs f = isKite f && isDartOrigin bs (wingV f) + -- kite wing becomes origin of narrow rhombus half + convert (LK(a,b,c)) = RN(b,c,a) + convert (RK(d,c,b)) = LN(b,d,c) + convert _ = error "composeToRhombuses (convert) found dart" + +-- |Count the half rhombuses +faceCount_P3 :: Tgraph_P3 -> Int +faceCount_P3 = length . faces_P3 + +-- |Get the TileFace_P3 list from a Tgraph_P3 +faces_P3 :: Tgraph_P3 -> [TileFace_P3] +faces_P3 (Tgraph_P3 rs) = rs + +-- | max vertex in a list of TileFace_P3 (0 for the empty list) +maxV_P3 :: [TileFace_P3] -> Int +maxV_P3 [] = 0 +maxV_P3 rs = IntSet.findMax $ vertexSet_P3 rs + +-- | set of vertices in a list of TileFace_P3 +vertexSet_P3 :: [TileFace_P3] -> VertexSet +vertexSet_P3 = mconcat . map faceVSet_P3 + +-- | set of vertices in a TileFace_P3 +faceVSet_P3 :: TileFace_P3 -> VertexSet +faceVSet_P3 r = IntSet.insert a $ IntSet.insert b $ IntSet.insert c IntSet.empty + where (a,b,c) = faceVs_P3 r + +-- | triple of vertices in a TileFace_P3 (clockwise from origin) +faceVs_P3 :: TileFace_P3 -> (Vertex, Vertex, Vertex) +faceVs_P3 (LW tr) = tr +faceVs_P3 (RW tr) = tr +faceVs_P3 (LN tr) = tr +faceVs_P3 (RN tr) = tr + +-- | list of 3 vertices in a TileFace_P3 (clockwise from origin) +faceVList_P3 :: TileFace_P3 -> [Vertex] +faceVList_P3 r = [a,b,c] where (a,b,c) = faceVs_P3 r + +-- | origin vertex of a TileFace_P3 +originV_P3 :: TileFace_P3 -> Vertex +originV_P3 r = a where (a,_,_) = faceVs_P3 r + +-- | opp vertex of a TileFace_P3 +oppV_P3 :: TileFace_P3 -> Vertex +oppV_P3 (LW(_,_,c)) = c +oppV_P3 (RW(_,b,_)) = b +oppV_P3 (LN(_,_,c)) = c +oppV_P3 (RN(_,b,_)) = b + +-- | wing vertex of a TileFace_P3 +wingV_P3 :: TileFace_P3 -> Vertex +wingV_P3 (LW(_,b,_)) = b +wingV_P3 (RW(_,_,c)) = c +wingV_P3 (LN(_,b,_)) = b +wingV_P3 (RN(_,_,c)) = c + +-- | join edge of a TileFace_P3 (clockwise = toward origin for LW and LN, away for RW and RN) +join_P3 :: TileFace_P3 -> Dedge +join_P3 (LW(a,_,c)) = (c,a) +join_P3 (RW(a,b,_)) = (a,b) +join_P3 (LN(a,_,c)) = (c,a) +join_P3 (RN(a,b,_)) = (a,b) + +-- | Is the half rhombus a wide one (LW,RW)? +isWide :: TileFace_P3 -> Bool +isWide (LW _) = True +isWide (RW _) = True +isWide _ = False + +-- | Is the half rhombus a narrow one (LN,RN)? +isNarrow :: TileFace_P3 -> Bool +isNarrow = not . isWide + +-- |Directed edges of a list of half rhombuses (clockwise round each ) +dedges_P3 :: [TileFace_P3] -> [Dedge] +dedges_P3 = concatMap (delist . faceVs_P3) + where delist (a,b,c) = [(a,b),(b,c),(c,a)] + +-- |VPatch_P3 is a version of VPatch for TileFace_P3s (vertex locations are the same - VertexLocMap) +data VPatch_P3 = VPatch_P3 {vLocs_P3 :: VertexLocMap, vpFaces_P3 :: [TileFace_P3]} deriving Show + +-- |needed for making VPatch_P3 transformable +type instance V VPatch_P3 = V2 +-- |needed for making VPatch_P3 transformable +type instance N VPatch_P3 = Double + +-- |A VPatch_P3 can be transformed. +instance Transformable VPatch_P3 where + transform :: Transformation V2 Double -> VPatch_P3 -> VPatch_P3 + transform t vp3 = vp3 {vLocs_P3 = VMap.map (transform t) (vLocs_P3 vp3)} + +-- | A VPatch_P3 can be deformed +instance Deformable VPatch_P3 VPatch_P3 where + deform :: Deformation V2 V2 Double -> VPatch_P3 -> VPatch_P3 + deform d vp = vp{vLocs_P3 = VMap.map (deform d) (vLocs_P3 vp)} + + deform' :: Double -> Deformation V2 V2 Double -> VPatch_P3 -> VPatch_P3 + deform' r d vp = vp{vLocs_P3 = VMap.map (deform' r d) (vLocs_P3 vp)} + +-- | Explicitly typed instance of deform for a VPatch_P3 +-- (This can avoid the need for type annotations when using deform) +deformVPatch_P3 :: Deformation V2 V2 Double -> VPatch_P3 -> VPatch_P3 +deformVPatch_P3 = deform + +-- |Create a VPatch_P3 from a Tgraph_P3 (uses decomposeToTgraph) +makeVP_P3 :: Tgraph_P3 -> VPatch_P3 +makeVP_P3 p@(Tgraph_P3 rs) = VPatch_P3 {vLocs_P3 = vlocsP3 , vpFaces_P3 = rs} where + vlocs = locateGraphVertices (decomposeToTgraph p) + vs = vertexSet_P3 rs + vlocsP3 = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) vlocs + +-- | Convert a VPatch_P3 to a P3_Patch (by dropping labels and calculating vectors) +dropLabels_P3 :: VPatch_P3 -> Patch_P3 +dropLabels_P3 vp = map convert (vpFaces_P3 vp) where + locations = vLocs_P3 vp + convert face = case (VMap.lookup (originV_P3 face) locations , VMap.lookup (wingV_P3 face) locations, VMap.lookup (oppV_P3 face) locations) of + (Just p, Just p', Just p'') -> fmap (const [p' .-. p, p'' .-. p']) face `at` p -- using HalfTile functor fmap + _ -> error $ "dropLabelsP3': Vertex location not found for some vertices:\n " + ++ show (faceVList_P3 face \\ VMap.keys locations) ++ "\n" + +-- | Convert a VPatch to a VPatch_P3 by substituting P3 faces. +-- A check is made to ensure vertices in the P3 faces are keys in the location map, +-- raising an error if any are missing. +convertVPatch :: [TileFace_P3] -> VPatch -> VPatch_P3 +convertVPatch rs vp + | IntSet.null diffSet = VPatch_P3 {vLocs_P3 = vlocsP3, vpFaces_P3 = rs} + | otherwise = error $ "convertVPatch: missing locations for: " + ++ show diffSet ++ "\n" + where + vs = vertexSet_P3 rs + vlocs = vLocs vp + source = VMap.keysSet vlocs + diffSet = IntSet.difference vs source + vlocsP3 = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) vlocs + +-- | Convert a VPatch_P3 to a VPatch by substituting (dart,kite) faces. +-- A check is made to ensure vertices in the faces are keys in the location map, +-- raising an error if any are missing. +convertVPatch_P3 :: [TileFace] -> VPatch_P3 -> VPatch +convertVPatch_P3 fcs vp3 + | IntSet.null diffSet = VPatch {vLocs = vlocs, vpFaces = fcs} + | otherwise = error $ "convertVPatch: missing locations for: " + ++ show diffSet ++ "\n" + where + vs = vertexSet fcs + vlocsP3 = vLocs_P3 vp3 + source = VMap.keysSet vlocsP3 + diffSet = IntSet.difference vs source + vlocs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) vlocsP3 + + +-- | Penrose P3 Tiling uses wide and narrow rhombuses +-- These are split into half tiles (triangles) as with kites and darts +data HalfTile_P3 a + = LW a -- ^ Left Wide Rhombus + | RW a -- ^ Right Wide Rhombus + | LN a -- ^ Left Narrow Rhombus + | RN a -- ^ Right Narrow Rhombus + deriving (Show,Eq) + +{-# INLINE tileRep_P3 #-} +-- | tileRep_P3 produces the representation without the label (LW,RW,LN,RN) +tileRep_P3 :: HalfTile_P3 a -> a +tileRep_P3 (LW a) = a +tileRep_P3 (RW a) = a +tileRep_P3 (LN a) = a +tileRep_P3 (RN a) = a + +-- |Needed for Transformable instance of HalfTile_P3 - requires TypeFamilies +type instance N (HalfTile_P3 a) = N a +-- |Needed for Transformable instance of HalfTile_P3 - requires TypeFamilies +type instance V (HalfTile_P3 a) = V a +-- |HalfTile_P3 inherits Transformable - Requires FlexibleInstances +instance Transformable a => Transformable (HalfTile_P3 a) where + transform t = fmap (transform t) + +-- |A Piece_P3 is a HalfTile_P3 with a list of two vectors for the drawn edges. +-- The join vector for a wide rhombus is on the long diagonal, +-- and the join vector for a narrow rhombus is along the short diagonal. +-- The choice of which vertex is the origin is derived from conversions +-- from Darts and Kites (P2 tilings) +type Piece_P3 = HalfTile_P3 [V2 Double] + +-- |The drawn edges of a Piece_P3 excluding the join edge (as a list of vectors) +-- starting from the origin. +drawnEdges_P3 :: Piece_P3 -> [V2 Double] +drawnEdges_P3 = tileRep_P3 + +-- |The join edge vector of a Piece_P3 (from origin) +joinVector_P3 :: Piece_P3 -> V2 Double +joinVector_P3 = sumV . drawnEdges_P3 + +-- |Make HalfTile_P3 a Functor +instance Functor HalfTile_P3 where + fmap f (LW rep) = LW (f rep) + fmap f (RW rep) = RW (f rep) + fmap f (LN rep) = LN (f rep) + fmap f (RN rep) = RN (f rep) + +-- |Converting from P2 to P3 tilings at the Patch level. +-- Half darts become half wide rhombuses (LD->RW,RD->LW). +-- The rhombus origin is the dart wing, the rhombus opp is the dart origin, so +-- the rhombus join is the dart long edge. +-- Half kites are decomposed to a half wide and a half narrow rhombus +-- (LK -> RW and RN, RK -> LW and LN). +-- For wide rhombuses, the origin is the kite origin and rhombus opp is the kite wing +-- (the join is the kite long edge). +-- For narrow rhombuses, the origin is the kite opp and the rhombus wing is the kite opp +-- (the join is toward the kite origin.) +decompPieceP2toP3 :: Located Piece -> [Located Piece_P3] +decompPieceP2toP3 lp = case viewLoc lp of + (p, LK [z1,z2]) -> [ RW [s1, s2] `at` p + , RN [negate z2, negate s2] `at` p.+^j + ] + where j = sumV [z1,z2] + s1 = (phi-1) *^ j + s2 = z1 ^-^ s1 + (p, RK [z1,z2]) -> [ LW [s1, s2] `at` p + , LN [negate z2, negate s2] `at` p.+^j + ] + where j = sumV [z1,z2] + s1 = (phi-1) *^ j + s2 = z1 ^-^ s1 + (p, LD [z1,z2]) -> [ RW [z2,s1] `at` p.+^ z1] + where s1 = negate (sumV [z1,z2]) + (p, RD [z1,z2]) -> [ LW [z2,s1] `at` p.+^ z1] + where s1 = negate (sumV [z1,z2]) + other -> error $ "decompPieceP2toP3: " ++ show other ++ "/n" + +-- |Converting located pieces from P3 to P2 tilings. +-- Half narrow rhombuses become half kites (LN->RK,RN->LK). +-- The rhombus wing becomes the kite origin and the rhombus origin becomes the kite wing. +-- Half wide rhombuses are decomposed to a half dart and a half kite +-- (RW -> LD and RK, LW -> RD and LK). +-- The wide rhombus origin becomes the dart origin, and the wide rhombus opp becomes the kite origin. +-- The wide rhombus wing becomes both the kite opp and dart wing. +decompPieceP3toP2 :: Located Piece_P3 -> [Located Piece] +decompPieceP3toP2 lp = case viewLoc lp of + (p, LW [z1,z2]) -> + [ RD [z1,s] `at` p + , LK [ (1-phi)*^j, negate s] `at` (p.+^j) + ] where j = sumV [z1,z2] + s = (2-phi) *^ j ^-^ z1 + (p, RW [z1,z2]) -> + [ LD [z1,s] `at` p + , RK [ (1-phi)*^j, negate s] `at` (p.+^j) + ] where j = sumV [z1,z2] + s = (2-phi) *^ j ^-^ z1 + (p, LN [z1,z2]) -> [ RK [negate z1, sumV [z1,z2]] `at` p .+^ z1] + (p, RN [z1,z2]) -> [ LK [negate z1, sumV [z1,z2]] `at` p .+^ z1] + other -> error $ "decompPieceP3toP2: " ++ show other ++ "/n" + + +-- | a Patch_P3 is analagous to a Patch (but for for Piece_P3s) +type Patch_P3 = [Located Piece_P3] + +-- |Conversion from a Patch to a Patch_P3 (Kites and Darts to Rhombuses) +decompPatchP2toP3 :: Patch -> Patch_P3 +decompPatchP2toP3 = concatMap decompPieceP2toP3 + +-- |Conversion from a Patch_P3 to a Patch (Rhombuses to Kites and Darts) +-- Note this does not reverse decompPatchP2toP3, but the combination +-- decompPatchP3toP2 . decompPatchP2toP3 is equivalent to a decompose operation (decompPatch) +decompPatchP3toP2 :: Patch_P3 -> Patch +decompPatchP3toP2 = concatMap decompPieceP3toP2 + + +-- |Draws the two drawn edges of a Piece_P3 +drawPiece_P3 :: OKBackend b => Piece_P3 -> Diagram b +drawPiece_P3 = strokeLine . fromOffsets . drawnEdges_P3 + + +-- |Draw dashed join only of a Piece_P3. +dashJOnly_P3 :: OKBackend b => Piece_P3 -> Diagram b +dashJOnly_P3 p = joinDashing (strokeLine $ fromOffsets [joinVector_P3 p]) + +-- |Draws all edges of a Piece_P3 using a faint dashed line for the join edge +-- (J for plain dashed Join, j for faint dashed join) +drawjPiece_P3 :: OKBackend b => Piece_P3 -> Diagram b +drawjPiece_P3 = drawPiece_P3 <> lw ultraThin . dashJOnly_P3 + +-- |Draws all edges of a Piece_P3 using a dashed line for the join edge +-- (J for plain dashed Join, j for faint dashed join) +drawJPiece_P3 :: OKBackend b => Piece_P3 -> Diagram b +drawJPiece_P3 = drawPiece_P3 <> dashJOnly_P3 + +-- |Fills a Piece_P3 with a colour (without drawn edges) +fillOnlyPiece_P3 :: (OKBackend b, Color c) => + c -> Piece_P3 -> Diagram b +fillOnlyPiece_P3 c p = + lw none $ fillColor c $ + strokeLoop $ closeLine $ fromOffsets $ drawnEdges_P3 p + +-- |Fills a Piece_P3 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 -> Piece_P3 -> Diagram b +fillOnlyPieceWN cw cn rp = filledpiece where + filledpiece = case rp of + (LW _ ) -> fillOnlyPiece_P3 cw rp + (RW _ ) -> fillOnlyPiece_P3 cw rp + _ -> fillOnlyPiece_P3 cn rp + +-- |Fills and draws a Piece_P3 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 -> Piece_P3 -> Diagram b +fillPieceWN cw cn = drawPiece_P3 <> fillOnlyPieceWN cw cn + + +-- | A class for things that can be turned to diagrams when given a function to draw Piece_P3s. +class Drawable_P3 a where + drawWith_P3 :: OKBackend b => + (Piece_P3 -> Diagram b) -> a -> Diagram b + +-- | Tgraph_P3 can be drawn (as faces_P3) +instance Drawable_P3 Tgraph_P3 where + -- | turn a Tgraph_P3 into a diagram given a function for drawing P3_Pieces. + drawWith_P3 :: OKBackend b => (Piece_P3 -> Diagram b) -> Tgraph_P3 -> Diagram b + drawWith_P3 pd = drawWith_P3 pd . makeVP_P3 + +-- | VPatch_P3 can be drawn (as rhombuses) +instance Drawable_P3 VPatch_P3 where + -- | turn a VPatch_P3 into a diagram given a function for drawing P3_Pieces. + drawWith_P3 :: OKBackend b => (Piece_P3 -> Diagram b) -> VPatch_P3 -> Diagram b + drawWith_P3 pd = drawWith_P3 pd . dropLabels_P3 + +-- | A Patch_P3 is Drawable_P3. +instance Drawable_P3 Patch_P3 where + -- | turn a Patch_P3 into a diagram given a function for drawing Piece_P3s. + drawWith_P3 :: OKBackend b => (Piece_P3 -> Diagram b) -> Patch_P3 -> Diagram b + drawWith_P3 pd = position . fmap (viewLoc . mapLoc pd) + +-- | A Tgraph is Drawable_P3. +instance Drawable_P3 Tgraph where + drawWith_P3 :: OKBackend b => (Piece_P3 -> Diagram b) -> Tgraph -> Diagram b + drawWith_P3 pd = drawWith_P3 pd . makeVP + +-- | A VPatch is Drawable_P3. +instance Drawable_P3 VPatch where + drawWith_P3 :: OKBackend b => (Piece_P3 -> Diagram b) -> VPatch -> Diagram b + drawWith_P3 pd = drawWith_P3 pd . dropLabels + +-- | A Patch is also Drawable_P3 (by conversion to a Patch_P3). +instance Drawable_P3 Patch where + drawWith_P3 :: OKBackend b => (Piece_P3 -> Diagram b) -> Patch -> Diagram b + drawWith_P3 pd = drawWith_P3 pd . decompPatchP2toP3 + +-- |The main drawing function for anything Drawable_P3 +draw_P3 :: (OKBackend b, Drawable_P3 a) => + a -> Diagram b +draw_P3 = drawWith_P3 drawPiece_P3 + +-- |An alternative drawing function for anything Drawable_P3 adding faint dashed lines for join edges +-- (J for plain dashed Join, j for faint dashed join) +drawj_P3 :: (OKBackend b, Drawable_P3 a) => + a -> Diagram b +drawj_P3 = drawWith_P3 drawjPiece_P3 + +-- |An alternative drawing function for anything Drawable_P3 adding dashed lines for join edges +-- (J for plain dashed Join, j for faint dashed join) +drawJ_P3 :: (OKBackend b, Drawable_P3 a) => + a -> Diagram b +drawJ_P3 = drawWith_P3 drawJPiece_P3 + +-- |The main draw and fill function for anything Drawable_P3. +-- The first colour is used for wide rhombuses, and the second for narrow rhombuses. +-- (Note the order W N). +fillWN :: (OKBackend b, Drawable_P3 a, Color cw, Color cn) => + cw -> cn -> a -> Diagram b +fillWN cw cn = drawWith_P3 (fillPieceWN cw cn) + +-- |A variation on fillWN where +-- the first colour is for narrow rhombuses, the second for wide rhombuses. +-- (Note the order N W). +fillNW :: (OKBackend b, Drawable_P3 a, Color cw, Color cn) => + cw -> cn -> a -> Diagram b +fillNW = flip fillWN --drawWith_P3 (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 Patch_P3es). +-- So labelColourSize_P3 c m modifies a Patch_P3 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 DrawableLabelled_P3 a where + labelColourSize_P3 :: OKBackend b => + Colour Double -> Measure Double -> (Patch_P3 -> Diagram b) -> a -> Diagram b + +-- | Tgraph_P3 can be drawn with labels (as faces_P3) +instance DrawableLabelled_P3 Tgraph_P3 where + labelColourSize_P3 c m d = labelColourSize_P3 c m d . makeVP_P3 + +-- | VPatch_P3 can be drawn with labels (as rhombuses) +instance DrawableLabelled_P3 VPatch_P3 where + labelColourSize_P3 c m d vp3 = drawLabels <> d (dropLabels_P3 vp3) where + drawLabels = position $ drawlabel <$> VMap.toList (vLocs_P3 vp3) + drawlabel(v,p) = (p, baselineText (show v) # fontSize m # fc c) + +-- | Tgraphs can be drawn (Rhombus/P3 style) with labels +-- Thus using such a vertex for alignment will raise an error. +instance DrawableLabelled_P3 Tgraph where + labelColourSize_P3 c m d = labelColourSize_P3 c m d . decomposeToRhombuses --makeVP + +-- | 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 DrawableLabelled_P3 VPatch where + labelColourSize_P3 c m d vp = drawLabels <> d p3Patch where + p3Patch = decompPatchP2toP3 $ dropLabels vp + drawLabels = position $ drawlabel <$> VMap.toList (extendLocs_P3 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 +extendLocs_P3 :: VPatch -> VertexLocMap +extendLocs_P3 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 "extendLocs_P3: Missing location for a kite join" + + +-- | Default Version of labelColourSize_P3 with colour red. +-- Example usage: labelSize_P3 tiny draw_P3 a , labelSize_P3 normal drawj_P3 a +labelSize_P3 :: (OKBackend b, DrawableLabelled_P3 a) => + Measure Double -> (Patch_P3 -> Diagram b) -> a -> Diagram b +labelSize_P3 = labelColourSize_P3 red + +-- | Default Version of labelColourSize_P3 using red and small (rather than normal label size). +-- Example usage: labelled_P3 draw_P3 a , labelled_P3 drawj_P3 a +labelled_P3 :: (OKBackend b, DrawableLabelled_P3 a) => + (Patch_P3 -> Diagram b) -> a -> Diagram b +labelled_P3 = labelColourSize_P3 red small --(normalized 0.023) diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs --- a/src/TgraphExamples.hs +++ b/src/TgraphExamples.hs @@ -97,6 +97,7 @@ , extendChoicesFig -- * Example showing a P3 tiling , testRhombus + , composeToRhombusProblem -- * Examples showing VPatch transform and deform , testVPTransform , deformExample @@ -528,8 +529,9 @@ lw ultraThin (aligning (1,5) draw d) --- | An example to illustrate drawing P3 tiling (rhombuses). --- The top part (filled) is a 5 times decomposed sunGraph converted to rhombuses (P3) when drawn. +-- | An example to illustrate drawing a Tgraph as a P3 tiling (rhombuses). +-- The top part (filled) is a 5 times decomposed sunGraph which is +-- converted to rhombuses (P3) when drawn. -- The bottom part is the 5 times decomposed sunGraph reflected about its x-axis. testRhombus :: OKBackend b => Diagram b testRhombus = padBorder $ lw veryThin $ @@ -537,6 +539,16 @@ === draw g # reflectY where g = decompositions sunGraph !! 5 + +-- |This example shows that force sun3Dart (left), when composed to rhombuses (right), +-- has a crossing boundary. The lime coloured faces are (remainder) half kites +-- not included in the composition. +composeToRhombusProblem :: OKBackend b => Diagram b +composeToRhombusProblem = padBorder $ lw thin $ hsep 0.5 [draw vp, fillWN grey lightgray vp3 <> lc lime (draw vp)] + where g = force sun3Dart + vp = alignedVP (1,4) g + vp3 = convertVPatch rhom vp + rhom = runTry $ tryComposeToFaces_P3 g -- |Performs a shearY transform before and after drawing a forced queenGraph with labels. -- The left figure shows an untransformed forced queenGraph. diff --git a/src/TileLibP3.hs b/src/TileLibP3.hs deleted file mode 100644 --- a/src/TileLibP3.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-| -Module : TileLibP3 -Description : Converting between Kites and Darts (P2 tiles) to Rhombuses (P3 tiles) and drawing -Copyright : (c) Chris Reade, 2021 -License : BSD-style -Maintainer : chrisreade@mac.com -Stability : experimental - -This module introduces Penrose\'s P3 tilings (narrow and wide rhombuses). -It includes P3_HalfTiles, P3_Pieces and P3_Patches to represent and draw -rhombuses plus conversion to and from Darts and Kites (the P2 tiles). -A class P3_Drawable is introduced with instance P3_Patch, Patch, VPatch, Tgraph -and generalised drawing functions for drawing P3 tilings. --} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -- needed for P3_Drawable P3_Patch -{-# LANGUAGE Strict #-} --- {-# LANGUAGE TypeOperators #-} -- needed for type equality constraints ~ - -module TileLibP3 - ( - -- * P3_HalfTiles - P3_HalfTile(..) - -- , tileRepP3 - , joinVectorP3 - , drawnEdgesP3 - -- * P3_Pieces - , P3_Piece - -- * Converting (located) Pieces - , decompPieceP2toP3 - , decompPieceP3toP2 - -- * Converting Patches - , P3_Patch - , decompP2toP3 - , decompP3toP2 - -- * Drawing P3_Pieces - , drawPieceP3 - , drawjPieceP3 - , drawJPieceP3 - , fillOnlyPieceP3 - , fillOnlyPieceWN - , fillPieceWN - -- * P3_Drawable Class - , P3_Drawable(..) - -- * Drawing functions producing P3 Rhombuses - , drawP3 - , drawjP3 - , drawJP3 - , fillWN - , fillNW - -- * P3_DrawableLabelled Class - , P3_DrawableLabelled(..) - -- * Adding labels to functions producing P3 Rhombuses - , labelSizeP3 - , labelledP3 - ) where - -import Diagrams.Prelude ---import Diagrams.TwoD.Text (Text) -- now in CheckBackend - -import CheckBackend -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 - = LW a -- ^ Left Wide Rhombus - | RW a -- ^ Right Wide Rhombus - | LN a -- ^ Left Narrow Rhombus - | RN a -- ^ Right Narrow Rhombus - deriving (Show,Eq) - -{-# INLINE tileRepP3 #-} --- | tileRepP3 produces the representation without the label (LW,RW,LN,RN) -tileRepP3 :: P3_HalfTile a -> a -tileRepP3 (LW a) = a -tileRepP3 (RW a) = a -tileRepP3 (LN a) = a -tileRepP3 (RN a) = a - --- |Needed for Transformable instance of P3_HalfTile - requires TypeFamilies -type instance N (P3_HalfTile a) = N a --- |Needed for Transformable instance of P3_HalfTile - requires TypeFamilies -type instance V (P3_HalfTile a) = V a --- |P3_HalfTile inherits Transformable - Requires FlexibleInstances -instance Transformable a => Transformable (P3_HalfTile a) where - transform t = fmap (transform t) - --- |A P3_Piece is a P3_Halftile with a list of two vectors for the drawn edges. --- The join vector for a wide rhombus is on the long diagonal, --- and the join vector for a narrow rhombus is along the short diagonal. --- The choice of which vertex is the origin is derived from conversions --- from Darts and Kites (P2 tilings) -type P3_Piece = P3_HalfTile [V2 Double] - --- |The drawn edges of a P3_Piece excluding the join edge (as a list of vectors) --- starting from the origin. -drawnEdgesP3 :: P3_Piece -> [V2 Double] -drawnEdgesP3 = tileRepP3 - --- |The join edge vector of a P3_Piece (from origin) -joinVectorP3 :: P3_Piece -> V2 Double -joinVectorP3 = sumV . drawnEdgesP3 - --- |Make P3_Halftile a Functor -instance Functor P3_HalfTile where - fmap f (LW rep) = LW (f rep) - fmap f (RW rep) = RW (f rep) - fmap f (LN rep) = LN (f rep) - fmap f (RN rep) = RN (f rep) - --- |Converting from P2 to P3 tilings. --- Half darts become half wide rhombuses (LD->RW,RD->LW). --- The rhombus origin is the dart wing, the rhombus opp is the dart origin, so --- the rhombus join is the dart long edge. --- Half kites are decomposed to a half wide and a half narrow rhombus --- (LK -> RW and RN, RK -> LW and LN). --- For wide rhombuses, the origin is the kite origin and rhombus opp is the kite wing --- (the join is the kite long edge). --- For narrow rhombuses, the origin is the kite opp and the rhombus wing is the kite opp --- (the join is toward the kite origin.) -decompPieceP2toP3 :: Located Piece -> [Located P3_Piece] -decompPieceP2toP3 lp = case viewLoc lp of - (p, LK [z1,z2]) -> [ RW [s1, s2] `at` p - , RN [negate z2, negate s2] `at` p.+^j - ] - where j = sumV [z1,z2] - s1 = (phi-1) *^ j - s2 = z1 ^-^ s1 - (p, RK [z1,z2]) -> [ LW [s1, s2] `at` p - , LN [negate z2, negate s2] `at` p.+^j - ] - where j = sumV [z1,z2] - s1 = (phi-1) *^ j - s2 = z1 ^-^ s1 - (p, LD [z1,z2]) -> [ RW [z2,s1] `at` p.+^ z1] - where s1 = negate (sumV [z1,z2]) - (p, RD [z1,z2]) -> [ LW [z2,s1] `at` p.+^ z1] - where s1 = negate (sumV [z1,z2]) - other -> error $ "decompPieceP2toP3: " ++ show other ++ "/n" - --- |Converting from P3 to P2 tilings. --- Half narrow rhombuses become half kites (LN->RK,RN->LK). --- The rhombus wing becomes the kite origin and the rhombus origin becomes the kite wing. --- Half wide rhombuses are decomposed to a half dart and a half kite --- (RW -> LD and RK, LW -> RD and LK). --- The wide rhombus origin becomes the dart origin, and the wide rhombus opp becomes the kite origin. --- The wide rhombus wing becomes both the kite opp and dart wing. -decompPieceP3toP2 :: Located P3_Piece -> [Located Piece] -decompPieceP3toP2 lp = case viewLoc lp of - (p, LW [z1,z2]) -> - [ RD [z1,s] `at` p - , LK [ (1-phi)*^j, negate s] `at` (p.+^j) - ] where j = sumV [z1,z2] - s = (2-phi) *^ j ^-^ z1 - (p, RW [z1,z2]) -> - [ LD [z1,s] `at` p - , RK [ (1-phi)*^j, negate s] `at` (p.+^j) - ] where j = sumV [z1,z2] - s = (2-phi) *^ j ^-^ z1 - (p, LN [z1,z2]) -> [ RK [negate z1, sumV [z1,z2]] `at` p .+^ z1] - (p, RN [z1,z2]) -> [ LK [negate z1, sumV [z1,z2]] `at` p .+^ z1] - other -> error $ "decompPieceP3toP2: " ++ show other ++ "/n" - - --- | a P3_Patch is analagous to a Patch (but for for P3_Pieces) -type P3_Patch = [Located P3_Piece] - --- |Conversion from a Patch to a P3_Patch (Kites and Darts to Rhombuses) -decompP2toP3 :: Patch -> P3_Patch -decompP2toP3 = concatMap decompPieceP2toP3 - --- |Conversion from a P3_Patch to a Patch (Rhombuses to Kites and Darts) --- Note this does not reverse decompP2toP3, but the combination --- decompP3toP2 . decompP2toP3 is equivalent to a decompose operation (decompPatch) -decompP3toP2 :: P3_Patch -> Patch -decompP3toP2 = concatMap decompPieceP3toP2 - - --- |Draws the two drawn edges of a P3_Piece -drawPieceP3 :: OKBackend b => P3_Piece -> Diagram b -drawPieceP3 = strokeLine . fromOffsets . drawnEdgesP3 - - --- |Draw dashed join only of a P3_Piece. -dashJOnlyP3 :: OKBackend b => P3_Piece -> Diagram b -dashJOnlyP3 p = joinDashing (strokeLine $ fromOffsets [joinVectorP3 p]) - --- |Draws all edges of a P3_Piece using a faint dashed line for the join edge --- (J for plain dashed Join, j for faint dashed join) -drawjPieceP3 :: OKBackend b => P3_Piece -> Diagram b -drawjPieceP3 = drawPieceP3 <> lw ultraThin . dashJOnlyP3 - --- |Draws all edges of a P3_Piece using a dashed line for the join edge --- (J for plain dashed Join, j for faint dashed join) -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 - --- |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 - - --- | A class for things that can be turned to diagrams when given a function to draw P3_Pieces. -class P3_Drawable a where - drawP3With :: OKBackend b => - (P3_Piece -> Diagram b) -> a -> Diagram b - --- | A P3_Patch is P3_Drawable. -instance P3_Drawable P3_Patch where - -- | turn a P3_Patch into a diagram given a function for drawing P3_Pieces. - drawP3With :: OKBackend b => (P3_Piece -> Diagram b) -> P3_Patch -> Diagram b - drawP3With pd = position . fmap (viewLoc . mapLoc pd) - --- | A Patch is also P3_Drawable (by conversion to a P3_Patch). -instance P3_Drawable Patch where - drawP3With :: OKBackend b => (P3_Piece -> Diagram b) -> Patch -> Diagram b - drawP3With pd = drawP3With pd . decompP2toP3 - --- | A VPatch is P3_Drawable. -instance P3_Drawable VPatch where - drawP3With :: OKBackend b => (P3_Piece -> Diagram b) -> VPatch -> Diagram b - drawP3With pd = drawP3With pd . dropLabels - --- | A Tgraph is P3_Drawable. -instance P3_Drawable Tgraph where - drawP3With :: OKBackend b => (P3_Piece -> Diagram b) -> Tgraph -> Diagram b - drawP3With pd = drawP3With pd . makeVP - --- |The main drawing function for anything P3_Drawable -drawP3 :: (OKBackend b, P3_Drawable a) => - a -> Diagram b -drawP3 = drawP3With drawPieceP3 - --- |An alternative drawing function for anything P3_Drawable adding faint dashed lines for join edges --- (J for plain dashed Join, j for faint dashed join) -drawjP3 :: (OKBackend b, P3_Drawable a) => - a -> Diagram b -drawjP3 = drawP3With drawjPieceP3 - --- |An alternative drawing function for anything P3_Drawable adding dashed lines for join edges --- (J for plain dashed Join, j for faint dashed join) -drawJP3 :: (OKBackend b, P3_Drawable a) => - a -> Diagram b -drawJP3 = drawP3With drawJPieceP3 - --- |The main draw and fill function for anything P3_Drawable. --- The first colour is used for wide rhombuses, and the second for narrow rhombuses. --- (Note the order W N). -fillWN :: (OKBackend b, P3_Drawable a, Color cw, Color cn) => - cw -> cn -> a -> Diagram b -fillWN cw cn = drawP3With (fillPieceWN cw cn) - --- |A variation on fillWN where --- the first colour is for narrow rhombuses, the second for wide rhombuses. --- (Note the order N W). -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)