{-# OPTIONS -Wall #-}


--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Basis.ShapeTrails
-- Copyright   :  (c) Stephen Tetley 2011-2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- 
--------------------------------------------------------------------------------

module Wumpus.Drawing.Basis.ShapeTrails
  (

    circle_trail
  , rcircle_trail

  , ellipse_trail
  , rellipse_trail

  , rectangle_trail
  , rrectangle_trail

  , diamond_trail
  , rdiamond_trail

  , isosceles_triangle_trail
  , risosceles_triangle_trail

  , semicircle_trail
  , rsemicircle_trail

  , semiellipse_trail
  , rsemiellipse_trail

  , parallelogram_trail
  , rparallelogram_trail

  , trapezium_trail
  , rtrapezium_trail

  )

  where

import Wumpus.Drawing.Basis.InclineTrails

import Wumpus.Basic.Kernel

import Wumpus.Core                              -- package: wumpus-core

-- import Data.AffineSpace                         -- package: vector-space
import Data.VectorSpace

import Data.Monoid


-- Shapes...

circle_trail :: (Real u, Floating u) => u -> AnaTrail u
circle_trail r = rcircle_trail r 0

rcircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
rcircle_trail r ang = 
    modifyAna (\v -> v ^-^ avec ang r) $ incline_circle $ avec ang (2 * r)



ellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
ellipse_trail rx ry = rellipse_trail rx ry 0

rellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rellipse_trail rx ry ang = 
    modifyAna (\v -> v ^-^ avec ang rx) $ incline_ellipse ry $ avec ang (2 * rx)


rectangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
rectangle_trail w h = rrectangle_trail w h 0


rrectangle_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rrectangle_trail w h ang = 
    anaCatTrail (orthoVec (negate $ 0.5 * w) (negate $ 0.5 * h) ang) catt
  where
    catt = mconcat [ trail_theta_right w ang
                   , trail_theta_up    h ang 
                   , trail_theta_left  w ang 
                   , trail_theta_down  h ang 
                   ]


diamond_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
diamond_trail w h = rdiamond_trail w h 0 

rdiamond_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rdiamond_trail w h ang = 
    anaCatTrail (theta_right hw ang) catt
  where
    hw   = 0.5 * w
    hh   = 0.5 * h
    catt = mconcat [ orthoCatTrail (-hw)   hh  ang
                   , orthoCatTrail (-hw) (-hh) ang 
                   , orthoCatTrail   hw  (-hh) ang 
                   , orthoCatTrail   hw    hh  ang 
                   ]


isosceles_triangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
isosceles_triangle_trail bw h = risosceles_triangle_trail bw h 0 

-- | Drawn at the centroid (1/3 * h).
--
risosceles_triangle_trail :: (Real u, Floating u) 
                          => u -> u -> Radian -> AnaTrail u
risosceles_triangle_trail bw h ang = 
    anaCatTrail (orthoVec (negate hbw) (negate $ h / 3) ang) catt
  where
    hbw  = 0.5 * bw
    catt = mconcat [ trail_theta_right bw ang
                   , orthoCatTrail (-hbw)   h  ang
                   , orthoCatTrail (-hbw) (-h) ang
                   ]


semicircle_trail :: (Real u, Floating u) => u -> AnaTrail u
semicircle_trail r = rsemicircle_trail r 0

rsemicircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
rsemicircle_trail r ang = 
    anaCatTrail (orthoVec (negate r) (negate hminor) ang) catt
  where
    -- hminor is the centroid formula for semicircle
    hminor = (4 * r) / (3 * pi)
    catt   =  trail_theta_right (2 * r) ang
           <> semicircleTrail CCW (avec ang (negate $ 2 * r) )



semiellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
semiellipse_trail rx ry = rsemiellipse_trail rx ry 0

rsemiellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rsemiellipse_trail rx ry ang = 
    anaCatTrail (orthoVec (negate rx) (negate hminor) ang) catt
  where
    -- hminor is the centroid formula for semiellipse
    hminor = (4 * ry) / (3 * pi)
    catt   =  trail_theta_right (2 * rx) ang
           <> semiellipseTrail CCW ry (avec ang (negate $ 2 * rx) )

-- | Note - bottom left angle must be smaller than 180deg, 
-- otherwise a runtime error is thrown.
--
parallelogram_trail :: Floating u => u -> u -> Radian -> AnaTrail u
parallelogram_trail w h bottom_left_ang = 
    rparallelogram_trail w h bottom_left_ang 0

-- | Note - bottom left angle must be smaller than 180deg, 
-- otherwise a runtime error is thrown.
--
rparallelogram_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u
rparallelogram_trail w h bl_ang ang
    | bl_ang >= ang180 = 
        error "rparallelogram_trail - bottom left angle >= 180."
    | otherwise     = anaCatTrail ctr_to_bl catt
  where
    -- Note - base_minor is negative for angles > 90
    base_minor = h / (fromRadian $ tan bl_ang)
                 
    vbase      = theta_right w ang
    vrhs       = orthoVec base_minor h ang
    vtop       = vreverse vbase
    vlhs       = vreverse vrhs
    ctr_to_bl  = vreverse $ 0.5 *^ (vbase ^+^ vrhs)
    catt       = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]


-- | Note - bottom left angle must be smaller than 180deg, 
-- otherwise a runtime error is thrown.
--
-- Also, no checking is perfomed on the relation between height
-- and bottom_left ang. Out of range values will draw \"twisted\"
-- trapezoids.
-- 
trapezium_trail :: Floating u => u -> u -> Radian -> AnaTrail u
trapezium_trail w h bottom_left_ang = 
    rtrapezium_trail w h bottom_left_ang 0


-- | Note - bottom left angle must be smaller than 180deg, 
-- otherwise a runtime error is thrown.
--
rtrapezium_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u
rtrapezium_trail bw h bl_ang ang  
    | bl_ang >= ang180 = error "rtrapezium_trail - bottom left angle >= 180."
    | otherwise        = anaCatTrail ctr_to_bl catt
  where
    -- Note - base_minor is negative for angles > 90
    base_minor = h / (fromRadian $ tan bl_ang)
    top_width  = bw - (2 * base_minor)
    vbase      = theta_right bw ang
    vrhs       = orthoVec (-base_minor) h ang
    vtop       = theta_left top_width ang
    vlhs       = orthoVec (-base_minor) (-h) ang
    ctr_to_bl  = orthoVec (negate $ 0.5 * bw) (negate $ 0.5 * h) ang
    catt       = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]