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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Shapes.Derived
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Simple shapes - rectangle, circle diamond, ellipse.
-- 
--------------------------------------------------------------------------------

module Wumpus.Basic.Shapes.Derived
  ( 
    Rectangle
  , DRectangle
  , rectangle
  , rrectangle

  , mkRectangle   -- hidden in Shim module

  , Circle
  , DCircle
  , circle

  , Diamond
  , DDiamond
  , diamond
  , rdiamond

  , Ellipse
  , DEllipse
  , ellipse


  ) where

import Wumpus.Basic.Graphic
import Wumpus.Basic.Paths
import Wumpus.Basic.Paths.RoundCorners
import Wumpus.Basic.Shapes.Base
import Wumpus.Basic.Utils.Intersection

import Wumpus.Core                              -- package: wumpus-core

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

import Control.Applicative


-- Note - Specific shapes - Rectangle, Circle, etc. - should _NOT_
-- have affine instances. 
--
-- Transformations should only operate on the Shape type. Once a
-- Shape has been drawn the resultant Rectangle, Circle... cannot 
-- be further transformed, as this would dis-associate the Anchors
-- from the Graphic.
--

--------------------------------------------------------------------------------
-- Rectangle

data Rectangle u = Rectangle 
      { rect_ctm    :: ShapeCTM u
      , rect_hw     :: !u
      , rect_hh     :: !u 
      }
  deriving (Eq,Ord,Show)

type DRectangle = Rectangle Double


type instance DUnit (Rectangle u) = u


runRectangle :: (u -> u -> ShapeGeom u a) -> Rectangle u -> a
runRectangle mf (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = 
   runShapeGeom ctm $ mf hw hh 

instance (Real u, Floating u) => CenterAnchor (Rectangle u) where
  center = runRectangle (\ _ _ -> shapeCenter)


instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where
  north = runRectangle $ \_  hh -> projectPoint $ P2 0 hh
  south = runRectangle $ \_  hh -> projectPoint $ P2 0 (-hh)
  east  = runRectangle $ \hw _  -> projectPoint $ P2 hw 0
  west  = runRectangle $ \hw _  -> projectPoint $ P2 (-hw) 0

instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where
  northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh
  southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh)
  southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh)
  northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh


instance (Real u, Floating u) => RadialAnchor (Rectangle u) where
  radialAnchor theta = runRectangle $ \hw hh -> 
    projectPoint $ rectangleIntersect hw hh theta

-- Note - the answer needs projecting with the CTM...
--
rectangleIntersect :: (Real u, Floating u) 
                   => u -> u -> Radian -> Point2 u
rectangleIntersect hw hh theta = 
    maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh 


-- | 'rectangle'  : @ width * height -> shape @
--
rectangle :: (Real u, Floating u) => u -> u -> LocShape u Rectangle
rectangle w h = 
    makeShape (traceLinePoints . rectanglePoints (0.5*w) (0.5*h))
              (mkRectangle (0.5*w) (0.5*h))
          

-- | 'rectangle'  : @ round_length * width * height -> shape @
--
rrectangle :: (Real u, Floating u) => u -> u -> u -> LocShape u Rectangle
rrectangle round_dist w h = 
    makeShape (roundEvery round_dist . rectanglePoints (0.5*w) (0.5*h))
              (mkRectangle (0.5*w) (0.5*h))
         



mkRectangle :: u -> u -> ShapeConstructor u Rectangle
mkRectangle hw hh = \ctm -> 
    Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }



rectanglePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]
rectanglePoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [se,ne,nw,sw]
  where
    se = P2   hw  (-hh)
    ne = P2   hw    hh
    nw = P2 (-hw)   hh
    sw = P2 (-hw) (-hh) 





--------------------------------------------------------------------------------
-- Circle

data Circle u = Circle 
      { circ_ctm    :: ShapeCTM u
      , circ_radius :: !u 
      }
  deriving (Eq,Show)
  
type DCircle = Circle Double

type instance DUnit (Circle u) = u

runCircle :: (u -> ShapeGeom u a) -> Circle u -> a
runCircle mf (Circle { circ_ctm =ctm, circ_radius = radius }) = 
   runShapeGeom ctm $ mf radius 


instance (Real u, Floating u) => CenterAnchor (Circle u) where
  center = runCircle (\_ -> shapeCenter)


instance (Real u, Floating u) => CardinalAnchor (Circle u) where
  north = runCircle $ \r -> projectPoint $ P2 0    r
  south = runCircle $ \r -> projectPoint $ P2 0  (-r)
  east  = runCircle $ \r -> projectPoint $ P2 r    0
  west  = runCircle $ \r -> projectPoint $ P2 (-r) 0


instance (Real u, Floating u) => CardinalAnchor2 (Circle 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) => RadialAnchor (Circle u) where
  radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r



-- | 'circle'  : @ radius -> shape @
--
circle :: (Real u, Floating u) => u -> LocShape u Circle
circle radius = makeShape (traceCurvePoints . circlePoints radius)
                          (mkCircle radius)
          


mkCircle :: u -> ShapeConstructor u Circle
mkCircle radius = \ctm -> Circle { circ_ctm = ctm, circ_radius = radius }


circlePoints :: (Real u, Floating u) => u -> ShapeCTM u -> [Point2 u]
circlePoints radius ctm = runShapeGeom ctm $ mapM projectPoint all_points
  where
    all_points  = bezierCircle 2 radius zeroPt 



--------------------------------------------------------------------------------
-- Diamond


data Diamond u = Diamond 
      { dia_ctm   :: ShapeCTM u
      , dia_hw    :: !u
      , dia_hh    :: !u
      }

type DDiamond = Diamond Double

type instance DUnit (Diamond u) = u



runDiamond :: (u -> u -> ShapeGeom u a) -> Diamond u -> a
runDiamond mf (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = 
   runShapeGeom ctm $ mf hw hh 


instance (Real u, Floating u) => CenterAnchor (Diamond u) where
  center = runDiamond (\_ _ -> shapeCenter)

instance (Real u, Floating u) => CardinalAnchor (Diamond u) where
  north = runDiamond $ \_  hh -> projectPoint $ P2 0 hh
  south = runDiamond $ \_  hh -> projectPoint $ P2 0 (-hh)
  east  = runDiamond $ \hw _  -> projectPoint $ P2 hw 0
  west  = runDiamond $ \hw _  -> projectPoint $ P2 (-hw) 0

instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where
  northeast x = midpoint (north x) (east x)
  southeast x = midpoint (south x) (east x)
  southwest x = midpoint (south x) (west x)
  northwest x = midpoint (north x) (west x)



instance (Real u, Floating u) => RadialAnchor (Diamond u) where
   radialAnchor = diamondIntersect

-- Utils.Intersection needs improving...


diamondIntersect :: (Real u, Floating u) 
                 => Radian -> Diamond u -> Point2 u
diamondIntersect theta = runDiamond $ \hw hh ->  
    (\ctr ctm -> let ps = diamondPoints hw hh ctm 
                 in maybe ctr id $ findIntersect ctr theta $ polygonLines ps)
      <$> shapeCenter <*> askCTM 


midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v

-- | 'diamond'  : @ half_width * half_height -> shape @
--
-- Note - args might change to tull_width and full_height...
--
diamond :: (Real u, Floating u) => u -> u -> LocShape u Diamond
diamond hw hh = 
    makeShape (traceLinePoints . diamondPoints hw hh)
              (mkDiamond hw hh)
          

-- | 'rdiamond'  : @ round_length * half_width * half_height -> shape @
--
-- Note - args might change to full_width and full_height...
--
rdiamond :: (Real u, Floating u) => u -> u -> u -> LocShape u Diamond
rdiamond round_dist hw hh = 
    makeShape (roundEvery round_dist . diamondPoints hw hh)
              (mkDiamond hw hh)
         




mkDiamond :: (Real u, Floating u) => u -> u -> ShapeConstructor u Diamond
mkDiamond hw hh = \ctm -> Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }


diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]
diamondPoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [ s, e, n, w ]
  where
    s = P2   0  (-hh)
    e = P2   hw    0
    n = P2   0    hh
    w = P2 (-hw)   0 


--------------------------------------------------------------------------------
-- Ellipse


data Ellipse u = Ellipse
      { ell_ctm     :: ShapeCTM u 
      , ell_rx      :: !u
      , ell_ry      :: !u
      }

type DEllipse = Ellipse Double

type instance DUnit (Ellipse u) = u


runEllipse :: (u -> u -> ShapeGeom u a) -> Ellipse u -> a
runEllipse mf (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = 
   runShapeGeom ctm $ mf rx ry 


-- | x_radius is the unit length.
--
scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t
scaleEll rx ry = scale 1 (ry/rx) 


instance (Real u, Floating u) => CenterAnchor (Ellipse u) where
  center = runEllipse $ \_ _ -> shapeCenter


instance (Real u, Floating u) => RadialAnchor (Ellipse u) where
  radialAnchor theta = runEllipse $ \rx ry -> 
    projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx


instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where
  north = radialAnchor (0.5*pi)
  south = radialAnchor (1.5*pi)
  east  = radialAnchor  0
  west  = radialAnchor  pi


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


-- | 'ellipse'  : @ x_radii * y_radii -> shape @
--
ellipse :: (Real u, Floating u) => u -> u -> LocShape u Ellipse
ellipse rx ry = 
    makeShape (traceCurvePoints . ellipsePoints rx ry)
              (mkEllipse rx ry)
          

mkEllipse :: (Real u, Floating u) => u -> u -> ShapeConstructor u Ellipse
mkEllipse rx ry = \ctm -> Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }


ellipsePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]
ellipsePoints rx ry ctm = 
    runShapeGeom ctm $ mapM (projectPoint . scaleEll rx ry) all_points
  where
    all_points =  bezierCircle 2 rx zeroPt