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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Shapes.Semiellipse
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Semiellipse.
-- 
--------------------------------------------------------------------------------

module Wumpus.Drawing.Shapes.Semiellipse
  ( 

    Semiellipse
  , DSemiellipse
  , semiellipse

  ) where

import Wumpus.Drawing.Paths
import Wumpus.Drawing.Shapes.Base

import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
import Wumpus.Basic.Geometry.Intersection
import Wumpus.Basic.Kernel

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space

import Control.Applicative



--------------------------------------------------------------------------------
-- Datatype

data Semiellipse u = Semiellipse 
      { se_ctm          :: ShapeCTM u
      , se_rx           :: !u 
      , se_ry           :: !u
      }

type instance DUnit (Semiellipse u) = u


data SyntheticProps u = SP
      { se_hminor  :: u
      , se_hmajor  :: u
      }

type instance DUnit (SyntheticProps u) = u
  
type DSemiellipse = Semiellipse Double

instance Functor Semiellipse where
  fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry)



synthesizeProps :: Floating u => u -> SyntheticProps u
synthesizeProps ry = 
    SP { se_hminor = ry_minor, se_hmajor = ry_major }
  where
    ry_minor = (4 * ry) / (3 * pi)
    ry_major = ry - ry_minor


--------------------------------------------------------------------------------
-- Affine trans

mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u
mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm


instance (Real u, Floating u) => Rotate (Semiellipse u) where
  rotate ang            = mapCTM (rotate ang)
              
instance (Real u, Floating u) => RotateAbout (Semiellipse u) where
  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)

instance Fractional u => Scale (Semiellipse u) where
  scale sx sy           = mapCTM (scale sx sy)

instance InterpretUnit u => Translate (Semiellipse u) where
  translate dx dy       = mapCTM (translate dx dy)


--------------------------------------------------------------------------------
-- Anchors


-- | 'runDisplaceCenter' : @ ( rx
--                           * ry 
--                           * ry_minor 
--                           * ry_major -> Vec ) * semiellipse -> Point @
--
runDisplaceCenter :: (Real u, Floating u) 
                  => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Anchor u
runDisplaceCenter fn (Semiellipse { se_ctm       = ctm
                                  , se_rx        = rx
                                  , se_ry        = ry  }) = 
    projectFromCtr (fn rx ry hminor hmajor) ctm
  where
    props  = synthesizeProps ry  
    hminor = se_hminor props
    hmajor = se_hmajor props




instance (Real u, Floating u) => 
    CenterAnchor (Semiellipse u) where
  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0

instance (Real u, Floating u, Tolerance u) => 
    ApexAnchor (Semiellipse u) where
  apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major

instance (Real u, Floating u) => 
    BottomCornerAnchor (Semiellipse u) where
  bottomLeftCorner  = runDisplaceCenter $ \rx _ ry_minor _  -> V2 (-rx) (-ry_minor)
  bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _  -> V2  rx   (-ry_minor)


instance (Real u, Floating u, Tolerance u) => 
    CardinalAnchor (Semiellipse u) where
  north = apex
  south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (-ry_minor)
  east  = radialAnchor 0
  west  = radialAnchor pi

instance (Real u, Floating u, Tolerance u) => 
    CardinalAnchor2 (Semiellipse u) where
  northeast = radialAnchor (0.25*pi)
  southeast = radialAnchor (1.75*pi)
  southwest = radialAnchor (1.25*pi)
  northwest = radialAnchor (0.75*pi)



instance (Real u, Floating u, Tolerance u) => 
    RadialAnchor (Semiellipse u) where
  radialAnchor theta = runDisplaceCenter (seRadialVec theta)


seRadialVec :: (Real u, Floating u, Ord u, Tolerance u)
            => Radian -> u -> u -> u -> u -> Vec2 u
seRadialVec theta rx ry hminor _ = go theta
  where
    (lang,rang)                     = baselineRange rx hminor
    (bctr, br, _, bl)               = constructionPoints rx ry hminor
    plane                           = inclinedLine zeroPt theta
    base_line                       = LineSegment bl br
    (right_curve,left_curve)        = bezierSemiellipse rx ry bctr
    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)
    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane 
         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane
         | otherwise                = post $ interCurveLine right_curve plane



-- | 'constructionPoints' : @ rx * ry * hminor -> 
--     (base_ctr, base_right, apex, base_left) @
--
-- Assumes centroid is (0,0).
--
constructionPoints :: Num u 
                   => u -> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)
constructionPoints rx ry hminor = (bctr, br, apx, bl)
  where
    bctr  = P2 0 (-hminor)
    br    = bctr .+^ hvec rx
    apx   = bctr .+^ vvec ry
    bl    = bctr .+^ hvec (-rx)




-- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @
--
-- Find the angle range where a ray from the centroid will cross
-- the baseline rather than cut the curve.
--
baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)
baselineRange rx hminor = (lang, rang)
  where
    ang   = toRadian $ atan (rx / hminor)
    lang  = (1.5*pi) - ang
    rang  = (1.5*pi) + ang



--------------------------------------------------------------------------------
-- Construction


-- | 'semiellipse'  : @ x_radius * y_radius -> Shape @
--
semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
            => u -> u -> Shape Semiellipse u
semiellipse rx ry = 
    let props = synthesizeProps ry
    in makeShape (mkSemiellipse rx ry) 
                 (mkSemiellipsePath rx ry (se_hminor props))
          



mkSemiellipse :: InterpretUnit u 
              => u -> u -> LocThetaQuery u (Semiellipse u)
mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta -> 
    pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta
                       , se_rx = rx
                       , se_ry = ry
                       }


mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
                  => u -> u -> u -> LocThetaQuery u (AbsPath u)
mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta ->
    let ctr = dispPerpendicular (-hminor) theta pt
        xs  = bezierSemiellipsePoints rx ry ctr
    in return $ curvePath $ map (rotateAbout theta ctr) xs 


bezierSemiellipsePoints :: Floating u
                        => u -> u -> Point2 u -> [Point2 u]
bezierSemiellipsePoints rx ry pt = [ p0, c1,c2,p3, c4,c5,p6 ]
  where 
    (BezierCurve p0 c1 c2 p3, BezierCurve _ c4 c5 p6) = bezierSemiellipse rx ry pt


-- For Geometry?

-- | Generate the bezier arcs for quadrants I and II. 
--
-- Drawing is expected to proceed CCW.
-- 
-- Note - Point is the (full) ellipse center.
--
bezierSemiellipse :: Floating u
                  => u -> u -> Point2 u -> (BezierCurve u, BezierCurve u)
bezierSemiellipse rx ry (P2 x y) = 
    (BezierCurve p00 c01 c02 p03, BezierCurve p03 c04 c05 p06)
  where
    lrx = rx * kappa
    lry = ry * kappa
    p00 = P2 (x + rx) y
    c01 = p00 .+^ vvec lry
    c02 = p03 .+^ hvec lrx

    p03 = P2 x (y + ry) 
    c04 = p03 .+^ hvec (-lrx)
    c05 = p06 .+^ vvec lry

    p06 = P2 (x - rx) y



kappa :: Floating u => u
kappa = 4 * ((sqrt 2 - 1) / 3)