```{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Basic.Paths
-- Copyright   :  (c) Stephen Tetley 2010-2011
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- 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 ->
liftQuery (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.
--
=> 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 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

```