diagrams-lib-0.7: src/Diagrams/TwoD/Polygons.hs
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.TwoD.Polygons
-- Copyright : (c) 2011 diagrams-lib team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- This module defines a general API for creating various types of
-- polygons.
--
-----------------------------------------------------------------------------
module Diagrams.TwoD.Polygons(
-- * Polygons
PolyType(..)
, PolyOrientation(..)
, PolygonOpts(..)
, polygon
, polyTrail
-- ** Generating polygon vertices
, polyPolarTrail
, polySidesTrail
, polyRegularTrail
, orient
-- * Star polygons
, StarOpts(..)
, star
-- ** Function graphs
-- $graphs
, GraphPart(..)
, orbits, mkGraph
) where
import Control.Monad (forM, liftM)
import Control.Monad.ST (ST, runST)
import Data.Array.ST (STUArray, newArray, readArray,
writeArray)
import qualified Data.Foldable as F
import Data.List (maximumBy, minimumBy)
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (catMaybes)
import Data.Monoid (mconcat, mempty)
import Data.Ord (comparing)
import Data.AffineSpace ((.+^), (.-.))
import Data.Default.Class
import Data.VectorSpace (magnitude, normalized, project, (<.>),
(^*))
import Diagrams.Core
import Diagrams.Located
import Diagrams.Path
import Diagrams.Points (centroid)
import Diagrams.Segment
import Diagrams.Trail
import Diagrams.TrailLike
import Diagrams.TwoD.Transform
import Diagrams.TwoD.Types
import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y)
import Diagrams.Util (tau, ( # ))
-- | Method used to determine the vertices of a polygon.
data PolyType = forall a. Angle a => PolyPolar [a] [Double]
-- ^ A \"polar\" polygon.
--
-- * The first argument is a list of /central/
-- /angles/ from each vertex to the next.
--
-- * The second argument is a list of /radii/ from
-- the origin to each successive vertex.
--
-- To construct an /n/-gon, use a list of /n-1/
-- angles and /n/ radii. Extra angles or radii
-- are ignored.
--
-- Cyclic polygons (with all vertices lying on a
-- circle) can be constructed using a second
-- argument of @(repeat r)@.
| forall a. Angle a => PolySides [a] [Double]
-- ^ A polygon determined by the distance between
-- successive vertices and the angles formed by
-- each three successive vertices. In other
-- words, a polygon specified by \"turtle
-- graphics\": go straight ahead x1 units; turn by
-- angle a1; go straght ahead x2 units; turn by
-- angle a2; etc. The polygon will be centered at
-- the /centroid/ of its vertices.
--
-- * The first argument is a list of /vertex/
-- /angles/, giving the angle at each vertex
-- from the previous vertex to the next. The
-- first angle in the list is the angle at the
-- /second/ vertex; the first edge always starts
-- out heading in the positive y direction from
-- the first vertex.
--
-- * The second argument is a list of distances
-- between successive vertices.
--
-- To construct an /n/-gon, use a list of /n-2/
-- angles and /n-1/ edge lengths. Extra angles or
-- lengths are ignored.
| PolyRegular Int Double
-- ^ A regular polygon with the given number of
-- sides (first argument) and the given radius
-- (second argument).
-- | Determine how a polygon should be oriented.
data PolyOrientation = NoOrient -- ^ No special orientation; the first
-- vertex will be at (1,0).
-- This is the default.
| OrientH -- ^ Orient /horizontally/, so the
-- bottommost edge is parallel to
-- the x-axis.
| OrientV -- ^ Orient /vertically/, so the
-- leftmost edge is parallel to the
-- y-axis.
| OrientTo R2 -- ^ Orient so some edge is
-- /facing/ /in/ /the/ /direction/
-- /of/, that is, perpendicular
-- to, the given vector.
deriving (Eq, Ord, Show, Read)
-- | Options for specifying a polygon.
data PolygonOpts = PolygonOpts
{ polyType :: PolyType
-- ^ Specification for the polygon's vertices.
, polyOrient :: PolyOrientation
-- ^ Should a rotation be applied to the
-- polygon in order to orient it in a
-- particular way?
, polyCenter :: P2
-- ^ Should a translation be applied to the
-- polygon in order to place the center at a
-- particular location?
}
-- | The default polygon is a regular pentagon of radius 1, centered
-- at the origin, aligned to the x-axis.
instance Default PolygonOpts where
def = PolygonOpts (PolyRegular 5 1) OrientH origin
-- | Generate a polygon. See 'PolygonOpts' for more information.
polyTrail :: PolygonOpts -> Located (Trail R2)
polyTrail po = transform ori tr
where
tr = case polyType po of
PolyPolar ans szs -> polyPolarTrail ans szs
PolySides ans szs -> polySidesTrail ans szs
PolyRegular n r -> polyRegularTrail n r
ori = case polyOrient po of
OrientH -> orient unit_Y tr
OrientV -> orient unitX tr
OrientTo v -> orient v tr
NoOrient -> mempty
-- | Generate the polygon described by the given options.
polygon :: (TrailLike t, V t ~ R2) => PolygonOpts -> t
polygon = trailLike . polyTrail
-- | Generate the located trail of a polygon specified by polar data
-- (central angles and radii). See 'PolyPolar'.
polyPolarTrail :: Angle a => [a] -> [Double] -> Located (Trail R2)
polyPolarTrail [] _ = emptyTrail `at` origin
polyPolarTrail _ [] = emptyTrail `at` origin
polyPolarTrail ans (r:rs) = tr `at` p1
where
p1 = p2 (1,0) # scale r
tr = closeTrail . trailFromVertices $
zipWith
(\a l -> rotate a . scale l $ p2 (1,0))
(scanl (+) 0 ans)
(r:rs)
-- | Generate the vertices of a polygon specified by side length and
-- angles, and a starting point for the trail such that the origin
-- is at the centroid of the vertices. See 'PolySides'.
polySidesTrail :: Angle a => [a] -> [Double] -> Located (Trail R2)
polySidesTrail ans ls = tr `at` (centroid ps # scale (-1))
where
ans' = scanl (+) 0 ans
offsets = zipWith rotate ans' (map (unitY ^*) ls)
ps = scanl (.+^) origin offsets
tr = closeTrail . trailFromOffsets $ offsets
-- | Generate the vertices of a regular polygon. See 'PolyRegular'.
polyRegularTrail :: Int -> Double -> Located (Trail R2)
polyRegularTrail n r = polyPolarTrail
(take (n-1) . repeat $ (tau::Rad) / fromIntegral n)
(repeat r)
-- | Generate a transformation to orient a trail. @orient v t@
-- generates the smallest rotation such that one of the segments
-- adjacent to the vertex furthest in the direction of @v@ is
-- perpendicular to @v@.
orient :: R2 -> Located (Trail R2) -> T2
orient v = orientPoints v . trailVertices
orientPoints :: R2 -> [P2] -> T2
orientPoints v xs = rotation a
where
(n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3))
(zip3 (tail (cycle xs)) xs (last xs : init xs))
distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p)
sndOf3 (_,x,_) = x
a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2]
v' = normalized v
angleFromNormal o
| leftTurn o' v' = phi
| otherwise = negate phi
where
o' = normalized o
theta = acos (v' <.> o')
phi
| theta <= tau/4 = Rad $ tau/4 - theta
| otherwise = Rad $ theta - tau/4
------------------------------------------------------------
-- Function graphs
------------------------------------------------------------
-- $graphs
-- These functions are used to implement 'star', but are exported on
-- the offchance that someone else finds them useful.
-- | Pieces of a function graph can either be cycles or \"hairs\".
data GraphPart a = Cycle [a]
| Hair [a]
deriving (Show, Functor)
-- | @orbits f n@ computes the graph of @f@ on the integers mod @n@.
orbits :: (Int -> Int) -> Int -> [GraphPart Int]
orbits f n = runST genOrbits
where
f_n i = f i `mod` n
genOrbits :: ST s [GraphPart Int]
genOrbits = newArray (0,n-1) False >>= genOrbits'
genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int]
genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n-1] (genPart marks))
genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])
genPart marks i = do
tr <- markRho i marks
case tr of
[] -> return Nothing
_ -> return . Just . splitParts $ tr
markRho :: Int -> STUArray s Int Bool -> ST s [Int]
markRho i marks = do
isMarked <- readArray marks i
case isMarked of
True -> return []
False -> writeArray marks i True >>
liftM (i:) (markRho (f_n i) marks)
splitParts :: [Int] -> [GraphPart Int]
splitParts tr = hair ++ cyc
where hair | not (null tl) = [Hair $ tl ++ [f_n (last tl)]]
| otherwise = []
cyc | not (null body) = [Cycle body]
| otherwise = []
l = last tr
(tl, body) = span (/= f_n l) tr
-- | Generate a function graph from the given function and labels.
mkGraph :: (Int -> Int) -> [a] -> [GraphPart a]
mkGraph f xs = (map . fmap) (xs!!) $ orbits f (length xs)
------------------------------------------------------------
-- Star polygons
------------------------------------------------------------
-- | Options for creating \"star\" polygons, where the edges connect
-- possibly non-adjacent vertices.
data StarOpts = StarFun (Int -> Int)
-- ^ Specify the order in which the vertices should be
-- connected by a function that maps each vertex
-- index to the index of the vertex that should come
-- next. Indexing of vertices begins at 0.
| StarSkip Int
-- ^ Specify a star polygon by a \"skip\". A skip of
-- 1 indicates a normal polygon, where edges go
-- between successive vertices. A skip of 2 means
-- that edges will connect every second vertex,
-- skipping one in between. Generally, a skip of
-- /n/ means that edges will connect every /n/th
-- vertex.
-- | Create a generalized /star/ /polygon/. The 'StarOpts' are used
-- to determine in which order the given vertices should be
-- connected. The intention is that the second argument of type
-- @[P2]@ could be generated by a call to 'polygon', 'regPoly', or
-- the like, since a list of vertices is 'TrailLike'. But of course
-- the list can be generated any way you like. A @'Path' 'R2'@ is
-- returned (instead of any 'TrailLike') because the resulting path
-- may have more than one component, for example if the vertices are
-- to be connected in several disjoint cycles.
star :: StarOpts -> [P2] -> Path R2
star sOpts vs = graphToPath $ mkGraph f vs
where f = case sOpts of
StarFun g -> g
StarSkip k -> (+k)
graphToPath = mconcat . map partToPath
partToPath (Cycle ps) = pathFromLocTrail
. mapLoc closeTrail
. fromVertices
$ ps
partToPath (Hair ps) = fromVertices ps