diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams-contrib.cabal b/diagrams-contrib.cabal new file mode 100644 --- /dev/null +++ b/diagrams-contrib.cabal @@ -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 diff --git a/src/Diagrams/Layout/Wrap.hs b/src/Diagrams/Layout/Wrap.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Layout/Wrap.hs @@ -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 +-- +-- 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. diff --git a/src/Diagrams/TwoD/Apollonian.hs b/src/Diagrams/TwoD/Apollonian.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Apollonian.hs @@ -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. +-- . +-- +----------------------------------------------------------------------------- + +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) + diff --git a/src/Diagrams/TwoD/Layout/Tree.hs b/src/Diagrams/TwoD/Layout/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Layout/Tree.hs @@ -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) diff --git a/src/Diagrams/TwoD/Path/Turtle.hs b/src/Diagrams/TwoD/Path/Turtle.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Path/Turtle.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Path.Turtle +-- Copyright : (c) 2011 Michael Sloan +-- License : BSD-style (see LICENSE) +-- Maintainer : Michael Sloan +-- +-- 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 diff --git a/src/Diagrams/TwoD/Path/Turtle/Aliases.hs b/src/Diagrams/TwoD/Path/Turtle/Aliases.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Path/Turtle/Aliases.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Path.Turtle.Aliases +-- Copyright : (c) 2011 Michael Sloan +-- License : BSD-style (see LICENSE) +-- Maintainer : Michael Sloan +-- +-- 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 diff --git a/src/Diagrams/TwoD/Tilings.hs b/src/Diagrams/TwoD/Tilings.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Tilings.hs @@ -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]