{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Basic.Paths -- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Path /algorithms/ for elementary shapes - rectangle, diamond, -- polygon. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Geometry.Paths ( PathAlg , runPathAlgPoint , runPathAlgVec , drawVertexPathAlg , pathStartIsStart , pathStartIsLocus , pathIterateLocus , rectanglePathAlg , blRectanglePathAlg , diamondPathAlg , isoscelesTriPathAlg , polygonPathAlg , arcPathAlg , circlePathAlg , parallelogramPathAlg , isoscelesTrapeziumPathAlg ) where import Wumpus.Basic.Geometry.Base import Wumpus.Basic.Geometry.Vertices import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Data.VectorSpace import Data.List ( unfoldr ) data PathAlgScheme = START_IS_START | START_IS_LOCUS deriving (Enum,Eq,Ord,Show) -- | A vector chain building a path. -- -- The vectors are relative to the predecessor, so the -- rendering of a 'PathAlg' iterates the start point. -- -- A polygon PathAlg should have steps for all sides of the -- polygon with the end point generated by the last vector -- coinciding with thet start point. -- data PathAlg u = PathAlg { path_alg_scheme :: PathAlgScheme , path_alg_steps :: [Vec2 u] } type instance DUnit (PathAlg u) = u runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u] runPathAlgPoint _ (PathAlg _ []) = [] runPathAlgPoint p0 (PathAlg scm (v0:xs)) | scm == START_IS_START = p0 : step (p0 .+^ v0) xs | otherwise = step (p0 .+^ v0) xs where step pt [] = [pt] step pt (v:vs) = pt : step (pt .+^ v) vs runPathAlgVec :: PathAlg u -> (Maybe (Vec2 u), [Vec2 u]) runPathAlgVec (PathAlg START_IS_LOCUS (v:vs)) = (Just v, vs) runPathAlgVec (PathAlg _ vs) = (Nothing, vs) drawVertexPathAlg :: InterpretUnit u => DrawStyle -> PathAlg u -> LocGraphic u drawVertexPathAlg style alg = promoteLoc $ \pt -> zapQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style -- | Create a PathAlg from the vertex list. -- -- When the PathAlg is run the supplied point will be the start -- of the path. -- pathStartIsStart :: [Vec2 u] -> PathAlg u pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START , path_alg_steps = vs } -- | Create a PathAlg from the vector list - the first vector -- displaces the /start point/ the subsequent vectors displace -- the /current tip/. Figuratively, this is rather like Logo -- /turtle drawing/. -- -- When the PathAlg is run, the supplied point is the /locus/ of -- the path and it does not form part of the path proper. -- -- This constructor is typically used to make /shape paths/ where -- the supplied point is the center and the generated path is the -- border. -- pathStartIsLocus :: [Vec2 u] -> PathAlg u pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS , path_alg_steps = vs } -- | Note this creates a path where the first vector represents a -- @moveto@, then the subsequence vectors represent @linetos@. -- -- | Create a PathAlg from the vector list - each vector in the -- input list iterates to the start point rather then the -- cumulative tip. -- -- When the PathAlg is run, the supplied point is the /locus/ of -- the path and it does not form part of the path proper. -- -- Like 'pathStartIsLocus', this constructor is typically used to -- make /shape paths/. Some shapes are easier to express as -- iterated displacements of the center rather than -- /turtle drawing/. -- pathIterateLocus :: Num u => [Vec2 u] -> PathAlg u pathIterateLocus [] = pathStartIsLocus [] pathIterateLocus (v0:xs) = pathStartIsLocus $ v0 : step v0 xs where step v1 [] = [v0 ^-^ v1] step v1 (v2:vs) = (v2 ^-^ v1) : step v2 vs -- | Implicit start point is /center/, the genearated moves are -- counter-clockwise so the move-list is -- -- > [ moveto_bl, moveto_br, moveto_tr, moveto_tl ] -- rectanglePathAlg :: Fractional u => u -> u -> PathAlg u rectanglePathAlg w h = pathStartIsLocus [ to_bl, to_br, to_tr, to_tl ] where to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h) to_br = hvec w to_tr = vvec h to_tl = hvec (-w) -- | Implicit start point is /bottom-left/, subsequent moves are -- counter-clockwise so the move-list is: -- -- > [ moveto_br, moveto_tr, moveto_tl, moveto_bl ] -- blRectanglePathAlg :: Num u => u -> u -> PathAlg u blRectanglePathAlg w h = pathStartIsStart [ vbr, vtr, vtl, vbl ] where vbr = hvec w vtr = vvec h vtl = hvec (-w) vbl = vvec (-h) -- | 'diamondPathAlg' : @ half_width * half_height -> PathAlg @ -- diamondPathAlg :: Num u => u -> u -> PathAlg u diamondPathAlg hw hh = pathIterateLocus [ vs,ve,vn,vw ] where vs = vvec (-hh) ve = hvec hw vn = vvec hh vw = hvec (-hw) -- | 'isoscelesTriPathAlg' : @ base_width * height -> PathAlg @ -- -- Start point is centtroid not incenter. -- isoscelesTriPathAlg :: Floating u => u -> u -> PathAlg u isoscelesTriPathAlg bw h = pathIterateLocus [ to_bl, to_br, to_apex ] where (to_bl, to_br, to_apex) = isoscelesTriangleVertices bw h -- | 'polygonPathAlg' : @ num_points * radius -> PathAlg @ -- polygonPathAlg :: Floating u => Int -> u -> PathAlg u polygonPathAlg n radius = pathIterateLocus $ unfoldr phi (0,top) where top = 0.5*pi theta = (2*pi) / fromIntegral n phi (i,ang) | i < n = Just (avec ang radius, (i+1,ang+theta)) | otherwise = Nothing -- | 'arcPathAlg' : @ radius * angle1 * angle2 -> PathAlg @ -- arcPathAlg :: Floating u => u -> Radian -> Radian -> PathAlg u arcPathAlg r ang1 ang2 = pathStartIsLocus $ step1 $ arcdiv ang1 ang2 where step1 [] = [] step1 ((a,b):xs) = let (v0,v1,v2,v3) = minorArcQuadVec r a b in v0 : v1: v2: v3 : step xs step [] = [] step ((a,b):xs) = let (_,v1,v2,v3) = minorArcQuadVec r a b in v1: v2: v3 : step xs -- | Helper - generate four vectors building a minor (<90 deg) -- arc. -- -- The first vec is from center - for cumulative arcs this should -- only taken once. -- minorArcQuadVec :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u, Vec2 u, Vec2 u) minorArcQuadVec r ang1 ang2 = (v0, v1, v2, v3) where (p1,p2,p3,p4) = bezierArc r ang1 ang2 zeroPt v0 = pvec zeroPt p1 v1 = pvec p1 p2 v2 = pvec p2 p3 v3 = pvec p3 p4 circlePathAlg :: (Fractional u, Floating u) => u -> PathAlg u circlePathAlg r = pathStartIsLocus vs where vs = hvec r : diff (flip pvec) (bezierCircle r zeroPt) -- | Helper - diff -- -- Note diff relies on the pointlist cycling the endpoint -- -- > [p0, ..., p0] -- -- This is how Wumpus-Core generates Bezier circles. -- diff :: (a -> a -> b) -> [a] -> [b] diff _ [] = [] diff op (x:xs) = step x xs where step _ [] = [] step a (b:bs) = b `op` a : step b bs -- | Helper - divide an arc into quadrants plus remainder. -- arcdiv :: Radian -> Radian -> [(Radian,Radian)] arcdiv ang1 ang2 | ang1 > ang2 = step ang1 (ang2 + 2 * pi) | otherwise = step ang1 ang2 where step a1 a2 | a1 == a2 = [] step a1 a2 | a2 - a1 > half_pi = norm (a1,a1+half_pi) : step (a1+half_pi) a2 | otherwise = [(a1,a2)] norm (a,b) = (circularModulo a, circularModulo b) -- | @ width * height * bottom_left_angle @ -- parallelogramPathAlg :: Floating u => u -> u -> Radian -> PathAlg u parallelogramPathAlg w h bl_ang = pathIterateLocus [ bl, br, tr, tl ] where (bl, br, tr, tl) = parallelogramVertices w h bl_ang -- | @ base_width * top_width * height @ -- isoscelesTrapeziumPathAlg :: Floating u => u -> u -> u -> PathAlg u isoscelesTrapeziumPathAlg bw tw h = pathIterateLocus [ bl, br, tr, tl ] where (bl, br, tr, tl) = isoscelesTrapeziumVertices bw tw h