PenroseKiteDart 1.10.1 → 1.11

raw patch · 10 files changed

+900/−373 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +86/−0
• PenroseKiteDart.cabal +2/−2
• benchmark/Bench.hs +10/−2
• src/HalfTile.hs +4/−4
• src/PKD.hs +2/−2
• src/Tgraph/Decompose.hs +6/−4
• src/Tgraph/Prelude.hs +81/−20
• src/Tgraph/Rhombuses.hs +695/−0
• src/TgraphExamples.hs +14/−2
• src/TileLibP3.hs +0/−337

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

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

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

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

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

@@ -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<b]   phiReps = sort [e | fc <- faces x, e@(a,b) <- facePhiEdges fc , a<b]   newVs = [v+1..v+n]   n = length phiReps   v = maxV x   edgeVMap = Map.fromList $ zip phiReps newVs ++ zip (map reverseD phiReps) newVs -+ -} -- |Decompose a face producing new faces.  -- This requires an edge to vertex map to get a unique new vertex assigned to each phi edge -- (as created by phiVMap).

@@ -42,6 +42,7 @@ -- * Tgraph Property Checks   , tryTgraphProps   , tryConnectedNoCross+  , checkConnectedNoCross   , tryCorrectTouchingVs   , hasEdgeLoops   , duplicates@@ -97,6 +98,7 @@   , vertexFMap   , dedgeFMap   , buildEFMap+  , makeEVnewMap   , extractLowestJoin   , lowestJoin     -- * Other Face ops@@ -183,7 +185,7 @@   --, drawEdge   ) where -import Data.List ((\\),intersect,find,nub)+import Data.List ((\\),intersect,find,nub,sort) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) import Data.IntMap.Strict(IntMap)@@ -405,7 +407,8 @@                         ,"\n"                         ]            -- makes use of precalculated edges and vertices-      else tryConnectedNoCross' fcs deslist vs+      else do _ <- tryConnectedNoCross' deslist vs+              return $ Tgraph fcs  -- |Checks a list of faces for no crossing boundaries and connectedness. -- (No crossing boundaries and connected implies tile-connected).@@ -415,10 +418,59 @@ -- but can be used alone when other properties are known to hold (e.g. in tryPartCompose) tryConnectedNoCross:: [TileFace] -> 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<b]+    newVs = [v+1..v+n]+    n = length reps+  -- |Given a tileface (face) and a map from each directed edge to the (unique) tileface containing it (efMap) -- return the list of edge neighbours of face.

@@ -0,0 +1,695 @@+{-|+Module      : Rhombuses+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 HalfTile_P3, Piece_P3, Patch_P3, VPatch_P3, Tgraph_P3 to represent and draw+rhombuses plus conversion to and from Darts and Kites (the P2 tiles).+A class Drawable_P3 is introduced with instance Patch_P3, VPatch_P3, Tgraph_P3+as well as Patch, VPatch, Tgraph.+A class DrawableLabelled_P3 is introduced with instance VPatch_P3, Tgraph_P3+as well as VPatch, Tgraph.+and generalised drawing functions for drawing P3 tilings.+-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable_P3 Patch_P3+{-# LANGUAGE Strict                    #-}+-- {-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~++module Tgraph.Rhombuses +  ( +  -- * Tgraph_P3+    Tgraph_P3()+  , decomposeToRhombuses+  , decomposeToTgraph+  , decomposeRhombuses+  , tryComposeToRhombuses+  , quickComposeToRhombuses+  -- * TileFace_P3+  , TileFace_P3+  , tryConnectedNoCross_P3+  , tryComposeToFaces_P3+  , quickComposeToFaces_P3+  , faceCount_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+  , VPatch_P3(..)+  , makeVP_P3+  , dropLabels_P3+  , convertVPatch_P3+  , convertVPatch+  , deformVPatch_P3+  -- * HalfTile_P3+  , HalfTile_P3(..)+  , tileRep_P3+  , joinVector_P3+  , drawnEdges_P3+  -- * Piece_P3s+  , Piece_P3+  -- * Converting (located) Pieces+  , decompPieceP2toP3+  , decompPieceP3toP2+  -- * Converting Patches+  , Patch_P3+  , decompPatchP2toP3+  , decompPatchP3toP2+  -- * Drawing Piece_P3s+  , drawPiece_P3+  , drawjPiece_P3+  , drawJPiece_P3+  , fillOnlyPiece_P3+  , fillOnlyPieceWN+  , fillPieceWN+   -- * Drawable_P3 Class+  , Drawable_P3(..)+  -- * Drawing functions producing P3 Rhombuses+  , draw_P3+  , drawj_P3+  , drawJ_P3+  , fillWN+  , fillNW+  -- * DrawableLabelled_P3 Class+  , DrawableLabelled_P3(..)+  -- * Adding labels to functions producing P3 Rhombuses+  , labelSize_P3+  , labelled_P3+  ) 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 Tgraph.Force (makeBoundaryState, boundaryEdgeFilter, isDartOrigin)+import Tgraph.Compose ( DartWingInfo(largeKiteCentres), tryGetDartWingInfo)++import qualified Data.Map.Strict as Map ( (!),empty,elems,lookup,insert,delete)+import qualified Data.IntMap.Strict as VMap (fromList,toList,lookup,filterWithKey,keys,map,keysSet)+import qualified Data.IntSet as IntSet(empty,insert,findMax,member,null,difference)+import Data.List ( (\\) )+-- |Tgraph_P3 is a P3 (Rhombus) version of Tgraph+newtype Tgraph_P3 = Tgraph_P3 [TileFace_P3] deriving Show++-- |TileFace_P3 is a P3 (half rhombus) analagous to TileFace+type TileFace_P3 = HalfTile_P3 (Vertex,Vertex,Vertex)++-- |Given a list of half rhombuses, check they are connected with no crossing boundary+-- producing a Tgraph_P3 when successful.+tryConnectedNoCross_P3  :: [TileFace_P3] -> 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<b = p+                    | otherwise = (b,a)+    -- process keeps and produces a pair (rhombuses, map)+    -- The rhombuses are a result of combining two (P2) halftiles with matching short edge.+    -- The map stores single half kites or darts not yet matched, keyed by ordered short edge.+    -- The process deletes map entries that get combined as a rhombus.+    -- Thus the final map has unmatched kites and darts.+    process (ans,m) [] = (ans,Map.elems m) +    process (ans,m) (f:more) +        = let sh = ordrd (reverseD (shortE f))+            in case Map.lookup sh m of+            Nothing -> 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<b = p+                | otherwise = (b,a)+  process _ [] = [] -- the map m stores single halftiles, keyed by ordered short edge+  process m (f:more) = let sh = ordrd (reverseD (shortE f))+                       in case Map.lookup sh m of+                          Nothing -> 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)

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

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