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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Basic.Paths
-- Copyright   :  (c) Stephen Tetley 2010-2011
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Paths for /elementary/ shapes - rectangles...
-- 
-- \*\* - WARNING \*\* - half baked. 
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Geometry.Paths
  ( 

    PathAlg
  , runPathAlgPoint
  , runPathAlgVec
  , pathStartIsStart
  , pathStartIsLocus
  , pathIterateLocus

  , rectanglePathAlg
  , blRectanglePathAlg

  , diamondPathAlg
  , polygonPathAlg

  , arcPathAlg
  , circlePathAlg

  , LocCoordPath
  , coordinatePrimPath

  , rectangleCoordPath
  , diamondCoordPath
  , polygonCoordPath
  , isoscelesTriangleCoordPath
  , isoscelesTrianglePoints
  , equilateralTriangleCoordPath
  , equilateralTrianglePoints
  ) 
  where

import Wumpus.Basic.Geometry.Base
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)



-- TO CLARIFY - should all four side paths of a rectangle be 
-- generated, or three sides with the implication that close forms
-- the fourth?
--

pathStartIsStart :: [Vec2 u] -> PathAlg u
pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START
                              , path_alg_steps  = vs }



pathStartIsLocus :: [Vec2 u] -> PathAlg u
pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS
                              , path_alg_steps  = vs }

-- | Note this creates a path very the first vector represents a
-- @moveto@, then the subsequence vectors represent @linetos@.
-- 
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




-- | Supplied point is /center/, the genearated points are 
-- counter-clockwise so [ bl, br, tr, tl ] .
--
rectanglePathAlg :: Fractional u => u -> u -> PathAlg u
rectanglePathAlg w h = pathStartIsLocus [ vbl, vbr, vtr, vtl ]
  where
    vbl = vec (negate $ 0.5*w) (negate $ 0.5*h)
    vbr = hvec w
    vtr = vvec h
    vtl = hvec (-w) 

-- | Supplied point is /bottom-left/, subsequent points are 
-- counter-clockwise so [ bl, br, tr, tl ] .
--
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)
    

-- | '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 :: 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)



-- arcs - wedges - circles...

---------------------------------------------------------------------------
-- OLD ...

-- | A functional type from /initial point/ to point list.
--
type LocCoordPath u = Point2 u -> [Point2 u]


-- Note - extraction needs a naming scheme - extractFROM or 
-- extractTO? - in either case this might be queuing up 
-- name-clash problems.
--
-- The Path data type will also need a similar function...
--
 
-- | Relative unit version of 'coordinatePrimPathAU'.
--
coordinatePrimPath :: InterpretUnit u 
                   => LocCoordPath u -> Point2 u -> Query PrimPath
coordinatePrimPath fn pt = vertexPP $ fn pt



-- | Supplied point is /bottom-left/, subsequenct points are 
-- counter-clockwise so [ bl, br, tr, tl ] .
--
rectangleCoordPath :: Num u => u -> u -> LocCoordPath u
rectangleCoordPath w h bl = [ bl, br, tr, tl ]
  where
    br = bl .+^ hvec w
    tr = br .+^ vvec h
    tl = bl .+^ vvec h 



-- | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @
--
diamondCoordPath :: Num u => u -> u -> LocCoordPath u
diamondCoordPath hw hh ctr = [ s,e,n,w ]
  where
    s     = ctr .+^ vvec (-hh)
    e     = ctr .+^ hvec hw
    n     = ctr .+^ vvec hh
    w     = ctr .+^ hvec (-hw)
    

-- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ 
--
polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u
polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))
  where
    theta = (pi*2) / fromIntegral n
    
    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))
                | otherwise = Nothing



-- | @isocelesTriangle bw h pt@
--
-- Supplied point is the centriod of the triangle. This has a 
-- nicer visual balance than using half-height.
--
isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u
isoscelesTriangleCoordPath bw h ctr = [bl,br,top]
  where
    (bl,br,top) = isoscelesTrianglePoints bw h ctr


-- | @isocelesTriangle bw h pt@
--
-- Supplied point is the centriod of the triangle. This has a 
-- nicer visual balance than using half-height.
--
isoscelesTrianglePoints :: Floating u 
                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
isoscelesTrianglePoints bw h ctr = (bl, br, top) 
  where
    hw         = 0.5*bw 
    theta      = atan $ h / hw
    centroid_h = hw * tan (0.5*theta)
    top        = ctr .+^ vvec (h - centroid_h)
    br         = ctr .+^ V2   hw  (-centroid_h)
    bl         = ctr .+^ V2 (-hw) (-centroid_h)


-- | @ side_length * ctr -> [Points] @
--
equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u
equilateralTriangleCoordPath sl ctr = [bl, br, top] 
  where
    (bl,br,top) = equilateralTrianglePoints sl ctr

equilateralTrianglePoints :: Floating u 
                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
equilateralTrianglePoints sl = isoscelesTrianglePoints sl h
  where
    h = sl * sin (pi/3)