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

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

module Wumpus.Drawing.Shapes.Semicircle
  ( 

    Semicircle
  , DSemicircle
  , semicircle

  ) where

import Wumpus.Drawing.Paths.Absolute
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 Semicircle u = Semicircle 
      { sc_ctm          :: ShapeCTM u
      , sc_radius       :: !u 
      }

type instance DUnit (Semicircle u) = u

-- | Height minor and major.
--
data SyntheticProps u = SP
      { sc_hminor  :: u
      , sc_hmajor  :: u
      }

type instance DUnit (SyntheticProps u) = u

  
type DSemicircle = Semicircle Double


instance Functor Semicircle where
  fmap f (Semicircle ctm r) = Semicircle (fmap f ctm) (f r)



-- | Use the formula:
--
-- >   4r
-- >  ---
-- >  3pi
--
-- to get the yminor.
--
synthesizeProps :: Floating u => u -> SyntheticProps u
synthesizeProps radius = 
    SP { sc_hminor = hminor, sc_hmajor = hmajor  }
  where
    hminor = (4 * radius) / (3 * pi)
    hmajor = radius - hminor


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

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


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

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

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


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

-- | 'runDisplaceCenter' : @ ( radius
--                           * height_minor 
--                           * height_major -> Vec ) * semicircle -> Point @
--
runDisplaceCenter :: (Real u, Floating u) 
                  => (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u
runDisplaceCenter fn (Semicircle { sc_ctm       = ctm
                                 , sc_radius    = radius }) = 
    projectFromCtr (fn radius hminor hmajor) ctm
  where
    props  = synthesizeProps radius  
    hminor = sc_hminor props
    hmajor = sc_hmajor props

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

instance (Real u, Floating u) => 
    ApexAnchor (Semicircle u) where
  apex = runDisplaceCenter $ \_ _    cmaj -> V2 0  cmaj

instance (Real u, Floating u) => 
    BottomCornerAnchor (Semicircle u) where
  bottomLeftCorner  = runDisplaceCenter $ \r hminor _  -> V2 (-r) (-hminor)
  bottomRightCorner = runDisplaceCenter $ \r hminor _  -> V2  r   (-hminor)

instance (Real u, Floating u) => 
    CardinalAnchor (Semicircle u) where
  north = apex
  south = runDisplaceCenter $ \_ cmin _    -> V2 0  (-cmin)
  east  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 x 0
  west  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 (-x) 0

-- | Use Pythagoras formula for working out the /east/ and /west/
-- distances. A right-triangle is formed below the centroid, 
-- radius is the hypotenuese, hminor is the other side.
--
pyth :: Floating u => u -> u -> u
pyth hyp s1 = sqrt $ pow2 hyp - pow2 s1
  where
    pow2 = (^ (2::Int))


instance (Real u, Floating u, Tolerance u) => 
    CardinalAnchor2 (Semicircle 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 (Semicircle u) where
  radialAnchor theta = runDisplaceCenter (scRadialVec theta)

-- helpers

-- | Semicircle does not fit into a QuadrantAlg easily.
--
-- So all the work has to be done here.
--
scRadialVec :: (Real u, Floating u, Ord u, Tolerance u)
            => Radian -> u -> u -> u -> Vec2 u
scRadialVec theta radius hminor _ = go (circularModulo theta)
  where
    (lang,rang)                     = baselineRange radius hminor
    (bctr, br, _, bl)               = constructionPoints radius hminor
    plane                           = inclinedLine zeroPt theta
    base_line                       = LineSegment bl br
    left_curve                      = mkCurve radius half_pi bctr
    right_curve                     = mkCurve radius 0 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



mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u
mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3
  where
    (BezierCurve p0 p1 p2 p3) = bezierMinorArc half_pi radius theta ctr



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




-- | '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 radius hminor = (lang, rang)
  where
    ang   = toRadian $ atan (radius / hminor)
    lang  = (1.5*pi) - ang
    rang  = (1.5*pi) + ang

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

-- | 'semicircle'  : @ radius -> Shape @
--
semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
           => u -> Shape Semicircle u
semicircle radius = 
    let props = synthesizeProps radius
    in makeShape (mkSemicircle radius) 
                 (mkSemicirclePath radius (sc_hminor props))
          


mkSemicircle :: InterpretUnit u
             => u -> LocThetaQuery u (Semicircle u)
mkSemicircle radius = qpromoteLocTheta $ \ctr theta -> 
    pure $ Semicircle { sc_ctm    = makeShapeCTM ctr theta
                      , sc_radius = radius
                      }



-- TODO - need to check other shapes to see if the are deriving 
-- the center properly...
--
mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
                 => u -> u -> LocThetaQuery u (AbsPath u)
mkSemicirclePath radius cminor = qpromoteLocTheta $ \pt theta ->
    let ctr = dispPerpendicular (-cminor) theta pt
    in pure $ curvePath $ bezierArcPoints pi radius theta ctr