diagrams-contrib (empty) → 0.1.0.0
raw patch · 11 files changed
+1400/−0 lines, 11 filesdep +basedep +colourdep +containerssetup-changed
Dependencies added: base, colour, containers, diagrams-lib, fclabels, force-layout, mtl, vector-space
Files
- CHANGES +18/−0
- LICENSE +30/−0
- README +26/−0
- Setup.hs +2/−0
- diagrams-contrib.cabal +37/−0
- src/Diagrams/Layout/Wrap.hs +107/−0
- src/Diagrams/TwoD/Apollonian.hs +218/−0
- src/Diagrams/TwoD/Layout/Tree.hs +293/−0
- src/Diagrams/TwoD/Path/Turtle.hs +164/−0
- src/Diagrams/TwoD/Path/Turtle/Aliases.hs +27/−0
- src/Diagrams/TwoD/Tilings.hs +478/−0
+ CHANGES view
@@ -0,0 +1,18 @@+0.1.0.0: 9 March 2012++ Initial release, containing:++ * Diagrams.Layout.Wrap, for laying out diagrams "wrapped" inside an+ arbitrary region (Michael Sloan)++ * Diagrams.TwoD.Tilings, for generating various 2D regular tilings+ (Brent Yorgey)++ * Diagrams.TwoD.Apollonian, for generating Apollonian gaskets (Brent+ Yorgey)++ * Diagrams.TwoD.Layout.Tree, tree layout and drawing algorithms+ (Brent Yorgey)++ * Diagrams.TwoD.Path.Turtle, creation of 2D paths using a stateful+ "turtle" interface (Michael Sloan)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011-2012, various (see headers of individual source files)++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Various nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,26 @@+This package is a repository for user contributions to the diagrams+project (http://projects.haskell.org/diagrams): generation of+specialized diagrams, fun or instructive examples, half-baked ideas,+stuff which is not sufficiently polished or general to go in the+diagrams-lib package but is nonetheless worth sharing. Any code is+welcome, as long as it conforms to a few simple standards:++ - Code must be released under a BSD3 license (see the LICENSE).++ - You must list yourself as the maintainer.++ - Try to keep external dependencies to a minimum; the goal is for+ diagrams-contrib to be easily installable by as many people as+ possible. New dependencies will be considered on a case-by-case+ basis. Dependencies involving the FFI will most likely be+ rejected. If you have some cool code using diagrams which+ requires big external dependencies, you should release it as a+ separate package rather than including it in diagrams-contrib.++ - There should at minimum be a Haddock comment on the module itself,+ explaining the purpose, giving some examples of use, etc.++ - It must compile with no warnings under -Wall. This may seem a bit+ draconian, but you'll get over it. If it makes you feel any+ better, you are welcome to turn off specific warnings for your+ module with an {-# OPTIONS_GHC -fno-warn-blah #-} pragma.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diagrams-contrib.cabal view
@@ -0,0 +1,37 @@+name: diagrams-contrib+version: 0.1.0.0+synopsis: Collection of user contributions to diagrams EDSL+description: A collection of user contributions for diagrams,+ an embedded domain-specific language for generation + of vector graphics.+homepage: http://projects.haskell.org/diagrams/+license: BSD3+license-file: LICENSE+author: Various+maintainer: diagrams-discuss@googlegroups.com+category: Graphics+build-type: Simple+cabal-version: >=1.8+extra-source-files: README, CHANGES+tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1+Source-repository head+ type: darcs+ location: http://patch-tag.com/r/byorgey/diagrams-contrib++library+ exposed-modules: Diagrams.Layout.Wrap,+ Diagrams.TwoD.Tilings,+ Diagrams.TwoD.Apollonian,+ Diagrams.TwoD.Layout.Tree,+ Diagrams.TwoD.Path.Turtle,+ Diagrams.TwoD.Path.Turtle.Aliases+ build-depends: base >= 4.2 && < 4.6,+ mtl ==2.0.*, + containers ==0.4.*, + vector-space >= 0.7 && < 0.9,+ colour >= 2.3.1 && < 2.4,+ diagrams-lib ==0.5.*,++ fclabels >= 1.0.4 && < 1.2,+ force-layout >= 0.1 && < 0.2+ hs-source-dirs: src
+ src/Diagrams/Layout/Wrap.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleContexts+ , ScopedTypeVariables+ , TypeFamilies+ #-}++------------------------------------------------------------------------+-- |+-- Module : Diagrams.Layout.Wrap+-- Copyright : (c) 2012 Michael Sloan +-- License : BSD-style (see the LICENSE file)+-- Maintainer : Michael Sloan <mgsloan at gmail>+--+-- An algorithm for filling space in a fashion akin to word-wrapping.+--+------------------------------------------------------------------------++module Diagrams.Layout.Wrap where++import Control.Arrow (first, (&&&))+import Data.Foldable (foldMap)+import Data.List (find, tails, inits)+import Diagrams.Prelude hiding (start)++-- TODO: Take into account the negative bounds, and iteratively refine+-- the list selection.++-- TODO: Search for a region before / after the target pick.++-- | @wrapDiagram@ post-processes the results of @wrapOutside@ /+-- @wrapInside@ into a Diagram of the result. This only works when+-- applying them to a list of diagrams.+wrapDiagram :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v))+ => ([(v, Diagram b v)], [Diagram b v]) -> Diagram b v+wrapDiagram = foldMap (uncurry translate) . fst++-- | @wrapOutside@ is the same as @wrapInside@, but with an inverted+-- predicate.+wrapOutside :: ( Enveloped a, v ~ V a+ , InnerSpace v, OrderedField (Scalar v) -- See [6.12.3] note below+ )+ => (Point v -> Bool) -> [v] -> Point v -> [a] -> ([(v, a)], [a])+wrapOutside f = wrapInside (not . f)++-- | fillInside greedily wraps content to fill a space defined by a+-- predicate. It is passed a list of vectors which express the+-- order of dimensions to be filled. In other words, wrapping RTL+-- text is done by passing in [unitX, unitY], to first exhaust+-- space horizontally, and then vertically.+--+-- Note that this function does not guarantee that there are not+-- points inside each positioned item for which the predicate is+-- False. Instead, only the corners of the bounds, along each axii,+-- are used.+wrapInside :: forall a v.+ ( Enveloped a, v ~ V a+ , InnerSpace v, OrderedField (Scalar v) -- See [6.12.3] note below+ )+ => (Point v -> Bool) -> [v] -> Point v+ -> [a] -> ([(v, a)], [a])+wrapInside f axis start = rec zeros+ where+ zeros = map snd . zip axis $ repeat (0, 0)+ norms = map normalized axis+ getVector = sumV . zipWith (^*) norms++-- [[min bound, max bound]] of each axis.+ boundsScalars :: a -> [[v]]+ boundsScalars d+ = flip map norms+ $ \v -> map (.-. origin) [envelopeP (negateV v) d, envelopeP v d]++-- Recurses on the list of items to lay out, maintaing a current set of+-- coefficients for the different axii, each paired with the maximum+-- boundary seen in that direction.+ rec :: [(Scalar v, Scalar v)] -> [a] -> ([(v, a)], [a])+ rec _ [] = (mempty, [])+ rec scs (d:ds) +-- Recurse a satisfactory position can be found, otherwise yields the+-- list of the remaining diagrams to be laid out.+ = maybe (mempty, d:ds)+ (\(v, scs') -> first ((v, d):) $ rec scs' ds)+ $ find (check . fst) potential+ where+ curB = boundsScalars d++-- Yields whether a given vector offset avoids collision.+ check v = all (f . (start .+^) . sumV . (v:)) $ sequence curB++-- Updates the max bounds of an axis.+ maxB [_, b] (x, m) = (x, max m $ x + magnitude b)+ maxB _ _ = error "Diagrams.Layout.Wrap.wrapInside:maxB: pattern-match failure. Please report this as a bug."++-- List of potential offsets to try, each paired with an updated list+-- of current / maxbound scalar coefficients for the axis.+ potential = map (getVector . map fst &&& zipWith maxB curB)+-- Try setting an axis to its max-seen bound, zeroing all preceding.+ . zipWith (++) (inits $ repeat (0, 0))+ . map dupFirstY+ . init $ tails scs++ dupFirstY ((_,x):xs) = (x,x):xs+ dupFirstY _ = error "Diagrams.Layout.Wrap.wrapInside:dupFirstY: pattern-match failure. Please report this as a bug."++-- [6.12.3]: It should be possible to infer the InnerSpace v and+-- OrderedField (Scalar v) constraints from Enveloped a, v ~ V a,+-- but GHC 6.12.3 cannot, so we redundantly list them here to+-- preserve support for 6.12.3.
+ src/Diagrams/TwoD/Apollonian.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE Rank2Types + , FlexibleContexts+ , ViewPatterns+ #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.Apollonian+-- Copyright : (c) 2011 Brent Yorgey+-- License : BSD-style (see LICENSE)+-- Maintainer : byorgey@cis.upenn.edu+--+-- Generation of Apollonian gaskets. Any three mutually tangent+-- circles uniquely determine exactly two others which are mutually+-- tangent to all three. This process can be repeated, generating a+-- fractal circle packing.+--+-- See J. Lagarias, C. Mallows, and A. Wilks, "Beyond the Descartes+-- circle theorem", Amer. Math. Monthly 109 (2002), 338--361.+-- <http://arxiv.org/abs/math/0101066>.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Apollonian + ( -- * Circles+ + Circle(..), mkCircle, center, radius+ + -- * Descartes' Theorem + , descartes, other, initialConfig+ + -- * Apollonian gasket generation+ + , apollonian+ + -- * Diagram generation+ + , drawCircle+ , drawGasket+ , apollonianGasket+ + ) where++import Data.Complex+import Data.Foldable (foldMap)++import Diagrams.Prelude hiding (radius, center)++import Control.Arrow (second)+import Data.Colour (transparent)++------------------------------------------------------------+-- Circles+------------------------------------------------------------++-- | Representation for circles that lets us quickly compute an+-- Apollonian gasket.+data Circle = Circle { bend :: Double + -- ^ The bend is the reciprocal of signed+ -- radius: a negative radius means the+ -- outside and inside of the circle are+ -- switched. The bends of any four mutually+ -- tangent circles satisfy Descartes'+ -- Theorem.+ , cb :: Complex Double + -- ^ /Product/ of bend and center represented+ -- as a complex number. Amazingly, these+ -- products also satisfy the equation of+ -- Descartes' Theorem.+ }+ deriving (Eq, Show)++-- | Create a @Circle@ given a signed radius and a location for its center.+mkCircle :: Double -- ^ signed radius+ -> P2 -- ^ center+ -> Circle+mkCircle r (unp2 -> (x,y)) = Circle (1/r) (b*x :+ b*y)+ where b = 1/r++-- | Get the center of a circle.+center :: Circle -> P2+center (Circle b (cbx :+ cby)) = p2 (cbx / b, cby / b)++-- | Get the (unsigned) radius of a circle.+radius :: Circle -> Double+radius = abs . recip . bend++liftF :: (forall a. Floating a => a -> a) -> Circle -> Circle+liftF f (Circle b c) = Circle (f b) (f c)++liftF2 :: (forall a. Floating a => a -> a -> a) -> Circle -> Circle -> Circle+liftF2 f (Circle b1 cb1) (Circle b2 cb2) = Circle (f b1 b2) (f cb1 cb2)++instance Num Circle where+ (+) = liftF2 (+)+ (-) = liftF2 (-)+ (*) = liftF2 (*)+ negate = liftF negate+ abs = liftF abs+ fromInteger n = Circle (fromInteger n) (fromInteger n)+ +instance Fractional Circle where+ (/) = liftF2 (/)+ recip = liftF recip++-- | The @Num@, @Fractional@, and @Floating@ instances for @Circle@+-- (all simply lifted elementwise over @Circle@'s fields) let us use+-- Descartes' Theorem directly on circles.+instance Floating Circle where+ sqrt = liftF sqrt++------------------------------------------------------------+-- Descartes' Theorem+------------------------------------------------------------++-- | Descartes' Theorem states that if @b1@, @b2@, @b3@ and @b4@ are+-- the bends of four mutually tangent circles, then +--+-- @+-- b1^2 + b2^2 + b3^2 + b4^2 = 1/2 * (b1 + b2 + b3 + b4)^2.+-- @+--+-- Surprisingly, if we replace each of the @bi@ with the /product/+-- of @bi@ and the center of the corresponding circle (represented+-- as a complex number), the equation continues to hold! (See the+-- paper referenced at the top of the module.)+--+-- @descartes [b1,b2,b3]@ solves for @b4@, returning both solutions.+-- Notably, @descartes@ works for any instance of @Floating@, which+-- includes both @Double@ (for bends), @Complex Double@ (for+-- bend/center product), and @Circle@ (for both at once).+descartes :: Floating a => [a] -> [a]+descartes [b1,b2,b3] = [r + s, -r + s]+ where r = 2 * sqrt (b1*b2 + b1*b3 + b2*b3)+ s = b1+b2+b3+descartes _ = error "descartes must be called on a list of length 3"++-- | If we have /four/ mutually tangent circles we can choose one of+-- them to replace; the remaining three determine exactly one other+-- circle which is mutually tangent. However, in this situation+-- there is no need to apply 'descartes' again, since the two+-- solutions @b4@ and @b4'@ satisfy+--+-- @+-- b4 + b4' = 2 * (b1 + b2 + b3)+-- @+--+-- Hence, to replace @b4@ with its dual, we need only sum the other+-- three, multiply by two, and subtract @b4@. Again, this works for+-- bends as well as bend/center products.+other :: Num a => [a] -> a -> a+other xs x = 2 * sum xs - x++-- | Generate an initial configuration of four mutually tangent+-- circles, given just the signed bends of three of them.+initialConfig :: Double -> Double -> Double -> [Circle]+initialConfig b1 b2 b3 = cs ++ [c4]+ where cs = [Circle b1 0, Circle b2 ((b2/b1 + 1) :+ 0), Circle b3 cb3]+ a = 1/b1 + 1/b2+ b = 1/b1 + 1/b3+ c = 1/b2 + 1/b3+ x = (b*b + a*a - c*c)/(2*a)+ y = sqrt (b*b - x*x)+ cb3 = b3*x :+ b3*y+ [c4,_] = descartes cs++------------------------------------------------------------+-- Gasket generation+------------------------------------------------------------++select :: [a] -> [(a, [a])]+select [] = []+select (x:xs) = (x,xs) : (map . second) (x:) (select xs)++-- | Given a threshold radius and a list of /four/ mutually tangent+-- circles, generate the Apollonian gasket containing those circles.+-- Stop the recursion when encountering a circle with an (unsigned)+-- radius smaller than the threshold.+apollonian :: Double -> [Circle] -> [Circle]+apollonian thresh cs + = cs+ ++ (concat . map (\(c,cs') -> apollonian' thresh (other cs' c) cs') . select $ cs)+ +apollonian' :: Double -> Circle -> [Circle] -> [Circle]+apollonian' thresh cur others+ | radius cur < thresh = []+ | otherwise = cur + : (concat $+ map (\(c, cs') -> apollonian' thresh+ (other (cur:cs') c) + (cur:cs') + ) + (select others)+ )++------------------------------------------------------------+-- Diagram generation+------------------------------------------------------------++-- | Draw a circle.+drawCircle :: (Renderable (Path R2) b) => Double -> Circle -> Diagram b R2+drawCircle w c = circle (radius c) # moveTo (center c)+ # lw w # fcA transparent++-- | Draw a generated gasket, using a line width 0.003 times the+-- radius of the largest circle.+drawGasket :: (Renderable (Path R2) b) => [Circle] -> Diagram b R2+drawGasket cs = foldMap (drawCircle w) cs+ where w = (*0.003) . maximum . map radius $ cs++-- | Draw an Apollonian gasket: the first argument is the threshold;+-- the recursion will stop upon reaching circles with radii less than+-- it. The next three arguments are bends of three circles.+apollonianGasket :: (Renderable (Path R2) b) + => Double -> Double -> Double -> Double -> Diagram b R2+apollonianGasket thresh b1 b2 b3 = drawGasket . apollonian thresh $ (initialConfig b1 b2 b3)+
+ src/Diagrams/TwoD/Layout/Tree.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , TemplateHaskell+ , NoMonomorphismRestriction+ , ScopedTypeVariables+ , FlexibleContexts+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.Layout.Tree+-- Copyright : (c) 2011 Brent Yorgey+-- License : BSD-style (see LICENSE)+-- Maintainer : byorgey@cis.upenn.edu+--+-- A collection of methods for laying out various kinds of trees.+-- This module is still experimental, and more layout methods will+-- probably be added over time.+--+-- Here is an example of using force-based layout on a binary tree:+--+-- > {-# LANGUAGE NoMonomorphismRestriction #-}+-- >+-- > import Diagrams.Prelude+-- > import Diagrams.Backend.Cairo.CmdLine+-- >+-- > import Diagrams.TwoD.Layout.Tree+-- >+-- > t = BNode 1 (BNode 8 (leaf 7) (leaf 2)) (BNode 6 (leaf 3) (leaf 4))+-- >+-- > main = do+-- > let Just t' = uniqueXLayout 1 1 t+-- > t'' = forceLayoutTree defaultForceLayoutTreeOpts t'+-- >+-- > defaultMain $+-- > renderTree (\n -> (text (show n) # fontSize 0.5+-- > <> circle 0.3 # fc white))+-- > (~~)+-- > t''+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Layout.Tree+ ( -- * Binary trees+ -- $BTree++ BTree(..)+ , leaf++ -- * Layout algorithms++ -- ** Binary tree layout++ , uniqueXLayout++ -- ** Force-directed layout+ -- $forcedirected++ , forceLayoutTree+ , ForceLayoutTreeOpts(..)+ , defaultForceLayoutTreeOpts++ , treeToEnsemble+ , label+ , reconstruct++ -- * Rendering++ , renderTree++ ) where++import Physics.ForceLayout++import Control.Applicative+import Control.Arrow (first, second)+import Control.Monad.State++import qualified Data.Foldable as F+import qualified Data.Map as M+import Data.Label (mkLabels)+import qualified Data.Label as L+import Data.Maybe+import qualified Data.Traversable as T+import Data.Tree++import Diagrams.Prelude hiding (e)++++------------------------------------------------------------+-- Binary trees+------------------------------------------------------------++-- $BTree+-- There is a standard type of rose trees ('Tree') defined in the+-- @containers@ package, but there is no standard type for binary+-- trees, so we define one here. Note, if you want to draw binary+-- trees with data of type @a@ at the leaves, you can use something+-- like @BTree (Maybe a)@ with @Nothing@ at internal nodes;+-- 'renderTree' lets you specify how to draw each node.++-- | Binary trees with data at internal nodes.+data BTree a = Empty | BNode a (BTree a) (BTree a)+ deriving (Eq, Ord, Read, Show, Functor, F.Foldable, T.Traversable)++-- | Convenient constructor for leaves.+leaf :: a -> BTree a+leaf a = BNode a Empty Empty++------------------------------------------------------------+-- Layout algorithms+------------------------------------------------------------++-- Unique X layout for binary trees. No two nodes share the same X+-- coordinate.++data Pos = Pos { _level :: Int+ , _horiz :: Int+ }+ deriving (Eq, Show)++mkLabels [''Pos]++incHoriz, up, down :: MonadState Pos m => m ()+incHoriz = modify (L.modify horiz (+1))+up = modLevel (subtract 1)+down = modLevel (+1)++modLevel :: MonadState Pos m => (Int -> Int) -> m ()+modLevel f = modify (L.modify level f)++pos2Point :: Double -> Double -> Pos -> P2+pos2Point cSep lSep (Pos l h) = p2 (fromIntegral h * cSep, -fromIntegral l * lSep)++--------------------------------------------------+-- Unique X layout for binary trees. No+-- two nodes share the same X coordinate.++-- | @uniqueXLayout xSep ySep t@ lays out the binary tree @t@ using a+-- simple recursive algorithm with the following properties:+--+-- * Every left subtree is completely to the left of its parent, and+-- similarly for right subtrees.+--+-- * All the nodes at a given depth in the tree have the same+-- y-coordinate. The separation distance between levels is given by+-- @ySep@.+--+-- * Every node has a unique x-coordinate. The separation between+-- successive nodes from left to right is given by @xSep@.++uniqueXLayout :: Double -> Double -> BTree a -> Maybe (Tree (a, P2))+uniqueXLayout cSep lSep t = (fmap . fmap . second) (pos2Point cSep lSep)+ $ evalState (uniqueXLayout' t) (Pos 0 0)+ where uniqueXLayout' Empty = return Nothing+ uniqueXLayout' (BNode a l r) = do+ down+ l' <- uniqueXLayout' l+ up+ p <- mkNode+ down+ r' <- uniqueXLayout' r+ up+ return $ Just (Node (a,p) (catMaybes [l', r']))+ mkNode = get <* incHoriz++--------------------------------------------------+-- Force-directed layout of rose trees++-- $forcedirected+-- Force-directed layout of rose trees.++-- | Assign unique ID numbers to the nodes of a tree, and generate an+-- 'Ensemble' suitable for simulating in order to do force-directed+-- layout of the tree. In particular,+--+-- * edges are modeled as springs+--+-- * nodes are modeled as point charges+--+-- * nodes are constrained to keep the same y-coordinate.+--+-- The input to @treeToEnsemble@+treeToEnsemble :: forall a. ForceLayoutTreeOpts+ -> Tree (a, P2) -> (Tree (a, PID), Ensemble R2)+treeToEnsemble opts t =+ ( fmap (first fst) lt+ , Ensemble+ [ (edges, \pt1 pt2 -> project unitX (hookeForce (springK opts) (edgeLen opts) pt1 pt2))+ , (sibs, \pt1 pt2 -> project unitX (coulombForce (staticK opts) pt1 pt2))+ ]+ particleMap+ )++ where lt :: Tree ((a,P2), PID)+ lt = label t++ particleMap :: M.Map PID (Particle R2)+ particleMap = M.fromList+ . map (second initParticle)+ . F.toList+ . fmap (swap . first snd)+ $ lt+ swap (x,y) = (y,x)++ edges, sibs :: [Edge]+ edges = extractEdges (fmap snd lt)+ sibs = extractSibs [fmap snd lt]++ extractEdges :: Tree PID -> [Edge]+ extractEdges (Node i cs) = map (((,) i) . rootLabel) cs+ ++ concatMap extractEdges cs++ extractSibs :: Forest PID -> [Edge]+ extractSibs [] = []+ extractSibs ts = (\is -> zip is (tail is)) (map rootLabel ts)+ ++ extractSibs (concatMap subForest ts)++-- sz = ala Sum foldMap . fmap (const 1) $ t+-- sibs = [(x,y) | x <- [0..sz-2], y <- [x+1 .. sz-1]]++-- | Assign unique IDs to every node in a tree (or other traversable structure).+label :: (T.Traversable t) => t a -> t (a, PID)+label = flip evalState 0 . T.mapM (\a -> get >>= \i -> modify (+1) >> return (a,i))++-- | Reconstruct a tree (or any traversable structure) from an+-- 'Ensemble', given unique identifier annotations matching the+-- identifiers used in the 'Ensemble'.+reconstruct :: Functor t => Ensemble R2 -> t (a, PID) -> t (a, P2)+reconstruct e = (fmap . second)+ (fromMaybe origin . fmap (L.get pos) . flip M.lookup (L.get particles e))++data ForceLayoutTreeOpts =+ FLTOpts+ { forceLayoutOpts :: ForceLayoutOpts R2 -- ^ Options to the force layout simulator, including damping+ , edgeLen :: Double -- ^ How long edges should be, ideally.+ -- This will be the resting length for+ -- the springs.+ , springK :: Double -- ^ Spring constant. The+ -- bigger the constant,+ -- the more the edges+ -- push/pull towards their+ -- resting length.+ , staticK :: Double -- ^ Coulomb constant. The+ -- bigger the constant, the+ -- more sibling nodes repel+ -- each other.+ }++defaultForceLayoutTreeOpts :: ForceLayoutTreeOpts+defaultForceLayoutTreeOpts =+ FLTOpts+ { forceLayoutOpts =+ FLOpts+ { damping = 0.8+ , energyLimit = Just 0.001+ , stepLimit = Just 1000+ }+ , edgeLen = sqrt 2+ , springK = 0.05+ , staticK = 0.1+ }++-- | Force-directed layout of rose trees. In particular,+--+-- * edges are modeled as springs+--+-- * nodes are modeled as point charges+--+-- * nodes are constrained to keep the same y-coordinate.+--+-- The input could be a tree already laid out by some other method,+-- such as 'uniqueXLayout'.+forceLayoutTree :: ForceLayoutTreeOpts -> Tree (a, P2) -> Tree (a, P2)+forceLayoutTree opts t = reconstruct (forceLayout (forceLayoutOpts opts) e) ti+ where (ti, e) = treeToEnsemble opts t++------------------------------------------------------------+-- Rendering+------------------------------------------------------------++-- | Draw a tree annotated with node positions, given functions+-- specifying how to draw nodes and edges.+renderTree :: (a -> Diagram b R2) -> (P2 -> P2 -> Diagram b R2)+ -> Tree (a, P2) -> Diagram b R2+renderTree renderNode renderEdge = alignT . centerX . renderTree'+ where+ renderTree' (Node (a,p) cs) =+ renderNode a # moveTo p+ <> mconcat (map renderTree' cs)+ <> mconcat (map (renderEdge p . snd . rootLabel) cs)
+ src/Diagrams/TwoD/Path/Turtle.hs view
@@ -0,0 +1,164 @@+-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.Path.Turtle+-- Copyright : (c) 2011 Michael Sloan+-- License : BSD-style (see LICENSE)+-- Maintainer : Michael Sloan <mgsloan at gmail>+--+-- Stateful domain specific language for diagram paths, modelled after the+-- classic \"turtle\" graphics language.+--+-----------------------------------------------------------------------------+module Diagrams.TwoD.Path.Turtle+ ( Turtle, TurtleT++ -- * Turtle control commands+ , runTurtle, runTurtleT++ -- * Motion commands+ , forward, backward, left, right++ -- * State accessors / setters+ , heading, setHeading, towards+ , pos, setPos++ -- * Drawing control+ , penHop, penUp, penDown, isDown+ , closeCurrent+ ) where++import Diagrams.Prelude++import qualified Control.Monad.State as ST+import Control.Monad.Identity++type TurtleT = ST.StateT TState++type Turtle = TurtleT Identity++data TState = TState Bool Deg (Path R2)++-- Unexported utilities++-- The path is stored backwards to make accumulation efficient.+-- TODO: consider keeping the output backwards, and always update the position?+-- This would make the "position" query more efficient.+getPath :: TState -> Path R2+getPath (TState d _ (Path xs))+ = Path . reverse+ $ map (\(p, (Trail ys c)) -> (p, Trail (reverse ys) c))+ $ if d then xs else tail xs++-- Adds a segment to the accumulated path.+logoseg :: Monad m => (Segment R2) -> TurtleT m ()+logoseg seg = ST.modify+ (\(TState d ang p) ->+ TState d ang $ modifyTrail+ (\(Trail xs c) -> Trail (rotate ang seg:xs) c) p)++modifyAngle :: Monad m => (Deg -> Deg) -> TurtleT m ()+modifyAngle f = ST.modify (\(TState d a p) -> TState d (f a) p)++modifyPath :: (Path R2 -> Path R2) -> TState -> TState+modifyPath f (TState d ang p) = TState d ang $ f p++modifyTrail :: (Trail v -> Trail v) -> Path v -> Path v+modifyTrail f (Path ((p, t) : ps)) = Path $ (p, f t) : ps+modifyTrail _ p = p++-- | A more general way to run the turtle. Returns a computation in the+-- underlying monad @m@ yielding a path consisting of the traced trails+runTurtleT :: (Monad m, Functor m) => TurtleT m a -> m (Path R2)+runTurtleT t = getPath . snd+ <$> ST.runStateT t (TState True 0 (Path [(origin, Trail [] False)]))++-- | Run the turtle, yielding a path consisting of the traced trails.+runTurtle :: Turtle a -> Path R2+runTurtle t = getPath . snd . ST.runState t+ $ TState True 0 (Path [(origin, Trail [] False)])++-- Motion commands++-- | Move the turtle forward, along the current heading.+forward :: Monad m => Double -> TurtleT m ()+forward x = logoseg $ Linear (r2 (x, 0))++-- | Move the turtle backward, directly away from the current heading.+backward :: Monad m => Double -> TurtleT m ()+backward x = logoseg $ Linear (r2 ((negate x), 0))++-- | Modify the current heading to the left by the specified angle in degrees.+left :: Monad m => Double -> TurtleT m ()+left a = modifyAngle (+ (Deg a))++-- | Modify the current heading to the right by the specified angle in degrees.+right :: Monad m => Double -> TurtleT m ()+right a = modifyAngle (subtract (Deg a))+++-- Based on "bezierFromSweepQ1" from Diagrams.TwoD.Arc+{-+smoothTurn f s =+ where (x,y) = rotate s (1, 0)+ (u,v) = ((4-x)/3, (1-x)*(3-x)/(3*y))++bezierFromSweepQ1 :: Rad -> Segment R2+bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ Cubic p2 p1 p0+ p2 = reflectY p1+-}++-- State accessors / setters++-- | Set the current turtle angle, in degrees.+setHeading :: Monad m => Double -> TurtleT m ()+setHeading a = modifyAngle (const (Deg a))++-- | Get the current turtle angle, in degrees.+heading :: Monad m => TurtleT m Double+heading = ST.gets (\(TState _ (Deg x) _) -> x)++-- | Sets the heading towards a given location.+towards :: Monad m => P2 -> TurtleT m ()+towards pt = do+ p <- pos+ setHeading . (*360) . (/tau) . uncurry atan2 . unr2 $ pt .-. p++-- | Set the current turtle X/Y position.+setPos :: Monad m => P2 -> TurtleT m ()+setPos p = ST.modify helper+ where+ helper (TState d a (Path ps))+ = TState d a $ Path $ (p, Trail [] False)+ : if d then ps else tail ps++-- | Get the current turtle X/Y position.+pos :: Monad m => TurtleT m P2+pos = ST.gets f+ where f (TState _ _ (Path ((p, t) : _))) = p .+^ trailOffset t+ f _ = error "Diagrams.TwoD.Path.Turtle.pos: no path. Please report this as a bug."++-- Drawing control.++-- | Starts a new path at the current location.+penHop :: Monad m => TurtleT m ()+penHop = pos >>= setPos++-- | Ends the current path, and enters into "penUp" mode+penUp :: Monad m => TurtleT m ()+penUp = penHop >> ST.modify (\(TState _ a p) -> TState False a p)++-- | Ends the current path, and enters into "penDown" mode+penDown :: Monad m => TurtleT m ()+penDown = penHop >> ST.modify (\(TState _ a p) -> TState True a p)++-- | Queries whether the pen is currently drawing a path or not.+isDown :: Monad m => TurtleT m Bool+isDown = ST.gets (\(TState d _ _) -> d)++-- | Closes the current path, to the last penDown / setPosition+-- Maintains current position - does this make sense?+closeCurrent :: Monad m => TurtleT m ()+closeCurrent = do+ p <- pos+ ST.modify $ modifyPath $ modifyTrail close+ setPos p
+ src/Diagrams/TwoD/Path/Turtle/Aliases.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.Path.Turtle.Aliases+-- Copyright : (c) 2011 Michael Sloan+-- License : BSD-style (see LICENSE)+-- Maintainer : Michael Sloan <mgsloan at gmail>+--+-- Adds compact aliases for turtle operations, to write code that looks even+-- more Turtle-y.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Path.Turtle.Aliases where++import Diagrams.TwoD.Path.Turtle++fd, bk, lt, rt :: Double -> Turtle ()++fd = forward+bk = backward++lt = left+rt = right++pu, pd :: Turtle ()+pu = penUp+pd = penDown
+ src/Diagrams/TwoD/Tilings.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE TypeFamilies + , FlexibleContexts + , ScopedTypeVariables+ , ViewPatterns+ , CPP+ #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.Tilings+-- Copyright : (c) 2011 Brent Yorgey+-- License : BSD-style (see LICENSE)+-- Maintainer : byorgey@cis.upenn.edu+--+-- Tools for generating and drawing plane tilings made of regular+-- polygons.+--+-----------------------------------------------------------------------------+module Diagrams.TwoD.Tilings (+ + -- * The ring Q[sqrt 2, sqrt 3]+ + Q236, rt2, rt3, rt6+ + , toDouble+ + , Q2, toR2, toP2+ + -- * Regular polygons + + , TilingPoly(..) + , polySides, polyFromSides+ , polyCos, polySin+ , polyRotation, polyExtRotation+ + -- * Tilings + + -- ** Types + , Tiling(..)+ , Edge, mkEdge+ + , Polygon(..)+ + -- ** Generation+ + , TilingState(..), initTilingState + , TilingM+ + , generateTiling+ + -- ** Pre-defined tilings + + , t3, t4, t6+ , mk3Tiling, t4612, t488, t31212+ + , t3636+ , semiregular+ , rot+ , t3464, t33434, t33344, t33336L, t33336R+ + -- * Diagrams + + , drawEdge+ , drawPoly+ , polyColor+ , drawTiling+ , drawTilingStyled+ + ) where+ +import Control.Monad.State+#if __GLASGOW_HASKELL__ >= 704+import Control.Monad.Writer hiding ((<>))+#else+import Control.Monad.Writer+#endif++import Data.List (mapAccumL, sort)+import Data.Function (on)+import Data.VectorSpace+import Control.Arrow++import qualified Data.Set as S+import qualified Data.Foldable as F++import Data.Colour+import Diagrams.Prelude hiding (e)++------------------------------------------------------------+-- The ring Q[sqrt(2), sqrt(3)]+------------------------------------------------------------++-- Instead of using Doubles, which can't be compared for equality, it+-- suffices to use elements of the rationals with sqrt(2) and sqrt(3)+-- adjoined.++-- | @Q236 a b c d@ represents @a + b sqrt(2) + c sqrt(3) + d+-- sqrt(6)@.+data Q236 = Q236 Rational Rational Rational Rational+ deriving (Eq, Ord, Show, Read)++-- | Convert a @Q236@ value to a @Double@.+toDouble :: Q236 -> Double+toDouble (Q236 a b c d) = fromRational a + + fromRational b * sqrt 2 + + fromRational c * sqrt 3 + + fromRational d * sqrt 6++rt2, rt3, rt6 :: Q236+rt2 = Q236 0 1 0 0+rt3 = Q236 0 0 1 0+rt6 = rt2*rt3++instance Num Q236 where+ (+) = (^+^)+ (-) = (^-^)+ (Q236 a1 b1 c1 d1) * (Q236 a2 b2 c2 d2) =+ Q236 (a1*a2 + 2*b1*b2 + 3*c1*c2 + 6*d1*d2)+ (a1*b2 + b1*a2 + 3*c1*d2 + 3*d1*c2)+ (a1*c2 + 2*b1*d2 + c1*a2 + 2*d1*b2)+ (a1*d2 + b1*c2 + c1*b2 + d1*a2)+ abs (Q236 a b c d) = Q236 (abs a) (abs b) (abs c) (abs d)+ fromInteger z = Q236 (fromInteger z) 0 0 0+ signum = error "no signum for Q236"+ +instance AdditiveGroup Q236 where+ zeroV = Q236 0 0 0 0+ (Q236 a1 b1 c1 d1) ^+^ (Q236 a2 b2 c2 d2) + = Q236 (a1 + a2) (b1 + b2) (c1 + c2) (d1 + d2)+ negateV (Q236 a b c d) = Q236 (-a) (-b) (-c) (-d)+ +instance VectorSpace Q236 where+ type Scalar Q236 = Rational+ s *^ (Q236 a b c d) = Q236 (s * a) (s * b) (s * c) (s * d)++type Q2 = (Q236, Q236)++toR2 :: Q2 -> R2+toR2 = r2 . (toDouble *** toDouble)++toP2 :: Q2 -> P2+toP2 = p2 . (toDouble *** toDouble)++------------------------------------------------------------+-- Polygons+------------------------------------------------------------++-- | Regular polygons which may appear in a tiling of the plane.+data TilingPoly = Triangle | Square | Hexagon | Octagon | Dodecagon+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++polySides :: Num a => TilingPoly -> a+polySides Triangle = 3+polySides Square = 4+polySides Hexagon = 6+polySides Octagon = 8+polySides Dodecagon = 12++polyFromSides :: (Num a, Eq a, Show a) => a -> TilingPoly+polyFromSides 3 = Triangle+polyFromSides 4 = Square+polyFromSides 6 = Hexagon+polyFromSides 8 = Octagon+polyFromSides 12 = Dodecagon+polyFromSides n = error $ "Bad polygon number: " ++ show n++-- | Cosine of a polygon's internal angle.+polyCos :: TilingPoly -> Q236+polyCos Triangle = (1/2) *^ 1+polyCos Square = 0+polyCos Hexagon = (-1/2) *^ 1+polyCos Octagon = (-1/2) *^ rt2+polyCos Dodecagon = (-1/2) *^ rt3++-- | Sine of a polygon's internal angle.+polySin :: TilingPoly -> Q236+polySin Triangle = (1/2) *^ rt3+polySin Square = 1+polySin Hexagon = (1/2) *^ rt3+polySin Octagon = (1/2) *^ rt2+polySin Dodecagon = (1/2) *^ 1++{-+ R_th = ( cos th -sin th )+ ( sin th cos th )++-}++-- | Rotate by polygon internal angle.+polyRotation :: TilingPoly -> Q2 -> Q2+polyRotation p (x,y) = (x*c - y*s, x*s + y*c)+ where c = polyCos p+ s = polySin p++{-+ (cos th sin th) ( -1 0 ) = (-cos th -sin th)+ (-sin th cos th) ( 0 -1 ) (sin th -cos th)+-}++-- | Rotate by polygon external angle.+polyExtRotation :: TilingPoly -> Q2 -> Q2+polyExtRotation p (x,y) = (-x*c - y*s, x*s - y*c)+ where c = polyCos p+ s = polySin p++------------------------------------------------------------+-- Tilings+------------------------------------------------------------++-- | A tiling, represented as a sort of zipper. @curConfig@ indicates+-- the polygons around the current vertex, in couterclockwise order+-- starting from the edge along which we entered the vertex.+-- @follow@ allows one to move along an edge to an adjacent vertex,+-- where the edges are numbered counterclockwise from zero,+-- beginning with the edge along which we entered the current+-- vertex.+data Tiling = Tiling { curConfig :: [TilingPoly]+ , follow :: Int -> Tiling+ }++-- | An edge is represented by a pair of vertices. Do not use the+-- @Edge@ constructor directly; use 'mkEdge' instead.+data Edge = Edge Q2 Q2+ deriving (Eq, Ord, Show)++-- | Smart constructor for @Edge@, which puts the vertices in a+-- canonical order.+mkEdge :: Q2 -> Q2 -> Edge+mkEdge v1 v2 | v1 <= v2 = Edge v1 v2+ | otherwise = Edge v2 v1++-- | A polygon is represented by a list of its vertices, in+-- counterclockwise order. However, the @Eq@ and @Ord@ instances+-- for polygons ignore the order.+newtype Polygon = Polygon { polygonVertices :: [Q2] }+ deriving Show++instance Eq Polygon where+ (Polygon vs1) == (Polygon vs2) = sort vs1 == sort vs2+ +instance Ord Polygon where+ compare = compare `on` (sort . polygonVertices)++-- | The state maintained while generating a tiling, recording which+-- vertices have been visited and which edges and polygons have been+-- drawn.+data TilingState = TP { visitedVertices :: (S.Set Q2)+ , visitedEdges :: (S.Set Edge)+ , visitedPolygons :: (S.Set Polygon)+ }++initTilingState :: TilingState+initTilingState = TP S.empty S.empty S.empty++-- | The @TilingM@ monad tracks a @TilingState@, and can output+-- elements of some monoid @w@ along the way.+type TilingM w a = WriterT w (State TilingState) a++generateTiling :: forall w. Monoid w+ => Tiling -- ^ The tiling to generate+ -> Q2 -- ^ The location of the starting vertex.+ -> Q2 -- ^ The starting direction, i.e. the+ -- direction along which we came into+ -- the starting vertex.+ -> (Q2 -> Bool) -- ^ Predicate on vertices specifying+ -- which should be visited. The+ -- vertices for which the predicate+ -- evaluates to True must form a+ -- single connected component.+ -> (Edge -> w) -- ^ what to do with edges+ -> (Polygon -> w) -- ^ what to do with polygons+ -> w+generateTiling t v d vPred e p + = evalState (execWriterT (generateTiling' t v d)) initTilingState where+ + generateTiling' :: Tiling -> Q2 -> Q2 -> TilingM w () + generateTiling' t v d+ -- stop if the current vertex fails the predicate+ | not (vPred v) = return ()+ | otherwise = do+ ts <- get+ + -- stop if we've seen this vertex before+ when (v `S.notMember` visitedVertices ts) $ do+ + -- otherwise, mark it as visited + modify (\ts -> ts { visitedVertices = v `S.insert` visitedVertices ts })+ + -- get the neighboring vertices and the polygons surrounding+ -- this vertex, and filter out ones we've already generated+ let (neighbors, polys) = genNeighbors t v d+ edges = S.fromList $ map (mkEdge v) neighbors+ edges' = edges `S.difference` visitedEdges ts+ polys' = polys `S.difference` visitedPolygons ts+ + -- generate some edges and polygons+ F.mapM_ (tell . e) edges'+ F.mapM_ (tell . p) polys'+ + -- remember that we generated them+ modify (\ts -> ts { visitedEdges = edges' `S.union` visitedEdges ts })+ modify (\ts -> ts { visitedPolygons = polys' `S.union` visitedPolygons ts })+ + -- follow edges and continue recursively+ zipWithM_ (\d i -> generateTiling' (follow t i) (v ^+^ d) d) + (map (^-^ v) $ neighbors) [0..]++-- | Generate the neighboring vertices and polygons of a given vertex.+genNeighbors :: Tiling -> Q2 -> Q2 -> ([Q2], S.Set Polygon)+genNeighbors t v d = (neighbors, S.fromList polys) where+ (neighbors, polys) + = unzip . snd+ $ mapAccumL + (\d' poly -> (polyRotation poly d', (v ^+^ d', genPolyVs poly v d')))+ (negateV d)+ (curConfig t)+ +-- | Generate the vertices of the given polygon, with one vertex at the given point+-- and an adjacent vertex at the given offset.+genPolyVs :: TilingPoly + -> Q2 -- ^ one vertex+ -> Q2 -- ^ vector to second vertex+ -> Polygon+genPolyVs p v d = Polygon+ . scanl (^+^) v + . take (polySides p - 1)+ . iterate (polyExtRotation p) + $ d++------------------------------------------------------------+-- Diagrams+------------------------------------------------------------++-- | Draw an edge with the given style.+drawEdge :: Renderable (Path R2) b => Style R2 -> Edge -> Diagram b R2+drawEdge s (Edge v1 v2) = (toP2 v1 ~~ toP2 v2) # applyStyle s++-- | Draw a polygon with the given style.+drawPoly :: Renderable (Path R2) b => (Polygon -> Style R2) -> Polygon -> Diagram b R2+drawPoly s p = applyStyle (s p) . fromVertices . map toP2 . polygonVertices $ p++-- Simple per-polygon color scheme+polyColor :: (Floating a, Ord a) => TilingPoly -> Colour a+polyColor Triangle = yellow+polyColor Square = mediumseagreen+polyColor Hexagon = blueviolet+polyColor Octagon = lightsteelblue+polyColor Dodecagon = cornflowerblue++-- | Draw a tiling, with a given width and height and default colors+-- for the polygons.+drawTiling :: (Renderable (Path R2) b, Backend b R2) + => Tiling -> Double -> Double -> Diagram b R2+drawTiling = + drawTilingStyled + (mempty # lw 0.02)+ (\p -> mempty + # lw 0+ # fc ( polyColor + . polyFromSides + . length + . polygonVertices+ $ p+ )+ )+ +-- | Draw a tiling with customizable styles for the polygons. This is+-- just an example, which you can use as the basis of your own+-- tiling-drawing routine.+drawTilingStyled :: (Renderable (Path R2) b, Backend b R2) + => Style R2 -> (Polygon -> Style R2)+ -> Tiling -> Double -> Double -> Diagram b R2+drawTilingStyled eStyle pStyle t w h = + mkDia $ generateTiling t (0,0) (1,0) inRect++ -- draw the edges and polygons into separate+ -- diagrams, so we can make sure all the edges are+ -- overlaid on top of all the polygons at the end+ (liftA2 (,) (drawEdge eStyle) mempty)+ (liftA2 (,) mempty (drawPoly pStyle))+ where+ inRect ((unr2 . toR2) -> (x,y)) = -w/2 <= x && x <= w/2 && -h/2 <= y && y <= h/2+ mkDia (es, ps) = viewRect (es <> ps)+ viewRect = withEnvelope (rect w h :: D R2)++------------------------------------------------------------+-- Some pre-defined tilings+------------------------------------------------------------++-- Regular tilings+ +t3 :: Tiling+t3 = Tiling (replicate 6 Triangle) (const t3)++t4 :: Tiling+t4 = Tiling (replicate 4 Square) (const t4)++t6 :: Tiling+t6 = Tiling (replicate 3 Hexagon) (const t6)++-- Semi-regular tilings++-- | Create a tiling with the same 3 polygons surrounding each vertex.+-- The argument is the number of sides of the polygons surrounding a vertex.+mk3Tiling :: [Int] -> Tiling+mk3Tiling (ps@[a,b,c])+ = Tiling + (map polyFromSides ps)+ (\i -> case i `mod` 3 of+ 0 -> mk3Tiling (reverse ps)+ 1 -> mk3Tiling [a,c,b]+ 2 -> mk3Tiling [b,a,c]+ _ -> error "i `mod` 3 is not 0, 1,or 2! the sky is falling!"+ ) +mk3Tiling _ = error "mk3Tiling may only be called on a list of length 3."++t4612 :: Tiling+t4612 = mk3Tiling [4,6,12]++t488 :: Tiling+t488 = mk3Tiling [4,8,8]++t31212 :: Tiling+t31212 = mk3Tiling [3,12,12]++t3636 :: Tiling+t3636 = mkT [3,6,3,6]+ where mkT :: [Int] -> Tiling+ mkT ps = Tiling (map polyFromSides ps)+ (\i -> mkT $ if even i then reverse ps else ps)++-- | Create a tiling where every vertex is the same up to rotation and+-- translation (but /not/ reflection). Arbitrarily pick one of the+-- edges emanating from a vertex and number the edges+-- counterclockwise starting with 0 for the chosen edge.+semiregular :: [Int] -- ^ The number of sides of the polygons+ -- surrounding a typical vertex,+ -- counterclockwise starting from edge 0.+ -> [Int] -- ^ The transition list: if the /i/th entry of+ -- this list is /j/, it indicates that the edge+ -- labeled /i/ is labeled /j/ with respect to+ -- the vertex on its other end.+ -> Tiling+semiregular ps trans = mkT 0+ where mkT i = Tiling+ (map polyFromSides (rot i ps))+ (\j -> mkT $ rot i trans !! j)++rot :: (Num a, Eq a) => a -> [t] -> [t]+rot 0 xs = xs+rot _ [] = []+rot n (x:xs) = rot (n-1) (xs ++ [x])++t3464 :: Tiling+t3464 = semiregular [4,3,4,6] [3,2,1,0]++{-++The above is worth a few lines of explanation. There is only one type+of vertex, of degree 4, hence there are four possible states depending+on which edge one entered the vertex on. We can arbitrarily choose+state 0 to be the one in which the surrounding polygons, ccw from the+edge on which the vertex was entered, are 4,3,4,6. The second list+then records the states in which one ends up after following edges 0,+1, 2... (numbered ccw with edge 0 being the one entered on) starting+from state 0. The transitions from other states can be worked out by+appropriate cyclic shifts.++The tilings below are worked out in a similar manner.++-}++t33434, t33344, t33336L, t33336R :: Tiling+t33434 = semiregular [3,4,3,4,3] [0,2,1,4,3]+t33344 = semiregular [4,3,3,3,4] [0,4,2,3,1]+t33336L = semiregular [3,3,3,3,6] [4,1,3,2,0]+t33336R = semiregular [3,3,3,3,6] [4,2,1,3,0]