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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Paths.Base.RelPath
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Relative path type - this should be more amenable for building 
-- complex drawings than the PrimPath type in Wumpus-Core.
-- 
-- Note - RelPath is not directly equivalent to AbsPath.
-- AbsPath is more powerful - as it is expected to have more 
-- demanding use-cases (e.g. connector paths).
--
--------------------------------------------------------------------------------

module Wumpus.Drawing.Paths.Base.RelPath
  ( 


  -- * Relative path type

    RelPath
  , DRelPath

  -- * Construction
  , empty
  , line1
  , curve1
  , vertexPath
  , curvedPath
  
  , circular

  -- * Queries
  , null


  -- * Concat
  , append
  , consLineTo
  , snocLineTo
  , consCurveTo
  , snocCurveTo


  -- * Conversion
  , fromPathAlgVertices
  , fromPathAlgCurves

  , toPrimPath
  , toAbsPath
  , strokeRelPath

  ) where


import Wumpus.Drawing.Paths.Base.AbsPath ( AbsPath )
import qualified Wumpus.Drawing.Paths.Base.AbsPath as Abs

import Wumpus.Basic.Geometry
import Wumpus.Basic.Kernel                      -- package: wumpus-basic
import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl, join )
import qualified Wumpus.Basic.Utils.JoinList as JL

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace

import qualified Data.Foldable          as F
import Data.Monoid
import qualified Data.Traversable       as T
import Prelude hiding ( null )





-- | Relative Path data type.
-- 
-- Note this type is more limited than AbsPath, it does not
-- support /introspective/ operations like @length@ or anchors.
--
newtype RelPath u = RelPath { getRelPath :: JoinList (RelPathSeg u) }
  deriving (Eq,Show)

type instance DUnit (RelPath u) = u


type DRelPath = RelPath Double

-- No annotations...
-- 
data RelPathSeg u = RelLineSeg  (Vec2 u)
                  | RelCurveSeg (Vec2 u) (Vec2 u) (Vec2 u)
  deriving (Eq,Show)


type instance DUnit (RelPathSeg u) = u



--------------------------------------------------------------------------------

instance Functor RelPath where
  fmap f = RelPath . fmap (fmap f) . getRelPath

instance Functor RelPathSeg where
  fmap f (RelLineSeg v1)        = 
      RelLineSeg (fmap f v1)

  fmap f (RelCurveSeg v1 v2 v3) = 
      RelCurveSeg (fmap f v1) (fmap f v2) (fmap f v3)


instance Monoid (RelPath u) where
  mempty  = empty
  mappend = append


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


-- | An empty relative path is acceptible to Wumpus because 
-- it is always drawn as a LocGraphic.
--
empty :: RelPath u 
empty = RelPath mempty

-- | Create a relative path from a single straight line.
--
line1 :: Vec2 u -> RelPath u
line1 = RelPath . JL.one . RelLineSeg


-- | Create a relative path from a single Bezier curve.
--
curve1 :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u
curve1 v1 v2 v3 = RelPath $ JL.one $ RelCurveSeg v1 v2 v3


vertexPath :: [Vec2 u] -> RelPath u
vertexPath [] = empty
vertexPath (x:xs) = go (line1 x) xs
  where
    go acc []     = acc
    go acc (v:vs) = go (acc `snocLineTo` v) vs



curvedPath :: [Vec2 u] -> RelPath u
curvedPath xs = case xs of 
    (v1:v2:v3:vs) -> go (curve1 v1 v2 v3) vs
    _             -> empty
  where
    go acc (v1:v2:v3:vs) = go (acc `append` curve1 v1 v2 v3) vs
    go acc _             = acc



circular :: Floating u => u -> RelPath u
circular = snd . fromPathAlgCurves . circlePathAlg 

--------------------------------------------------------------------------------
-- Queries

null :: RelPath u -> Bool
null = JL.null . getRelPath



--------------------------------------------------------------------------------
-- Concat 

infixr 1 `append`



append :: RelPath u -> RelPath u -> RelPath u
append (RelPath se0) (RelPath se1) = RelPath $ se0 `join` se1


consLineTo :: Vec2 u -> RelPath u -> RelPath u 
consLineTo v1 (RelPath se) = RelPath $ JL.cons (RelLineSeg v1) se

snocLineTo :: RelPath u -> Vec2 u -> RelPath u
snocLineTo (RelPath se) v1 = RelPath $ JL.snoc se (RelLineSeg v1)



consCurveTo :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u 
consCurveTo v1 v2 v3 (RelPath se) = RelPath $ JL.cons (RelCurveSeg v1 v2 v3) se

snocCurveTo :: RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u
snocCurveTo (RelPath se) v1 v2 v3 = RelPath $ JL.snoc se (RelCurveSeg v1 v2 v3)





--------------------------------------------------------------------------------
-- Conversion

fromPathAlgVertices :: Num u => PathAlg u -> (Vec2 u, RelPath u)
fromPathAlgVertices = bimap fn vertexPath . runPathAlgVec
  where
    fn = maybe (V2 0 0) id

fromPathAlgCurves :: Num u => PathAlg u -> (Vec2 u, RelPath u)
fromPathAlgCurves = bimap fn curvedPath . runPathAlgVec
  where
    fn = maybe (V2 0 0) id


toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query PrimPath
toPrimPath start (RelPath segs) = 
    uconvertCtxF start       >>= \dstart -> 
    T.mapM uconvertCtxF segs >>= \dsegs  ->
    return $ relPrimPath dstart $ F.foldr fn [] dsegs
  where
    fn (RelLineSeg v1)        ac = relLineTo v1 : ac
    fn (RelCurveSeg v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac


toAbsPath :: (Floating u, Ord u, Tolerance u) 
          => Point2 u -> RelPath u -> AbsPath u
toAbsPath start (RelPath segs) = step1 start $ viewl segs
  where
    step1 p0 EmptyL                           = Abs.empty p0

    step1 p0 (RelLineSeg v1 :< se)            = 
        let (pth,end) = aline p0 v1 in step2 end pth (viewl se)

    step1 p0 (RelCurveSeg v1 v2 v3 :< se)     = 
        let (pth,end) = acurve p0 v1 v2 v3 in step2 end pth (viewl se)

    step2 _  acc EmptyL                       = acc
    step2 p0 acc (RelLineSeg v1 :< se)        = 
        let (s1,end) = aline p0 v1 
        in step2 end (acc `Abs.append` s1) (viewl se)

    step2 p0 acc (RelCurveSeg v1 v2 v3 :< se) = 
        let (s1,end) = acurve p0 v1 v2 v3 
        in step2 end (acc `Abs.append` s1) (viewl se)

    aline p0 v1                               = 
        let p1 = p0 .+^ v1 in (Abs.line1 p0 p1, p1)

    acurve p0 v1 v2 v3                        = 
        let p1 = p0 .+^ v1
            p2 = p1 .+^ v2
            p3 = p2 .+^ v3
        in (Abs.curve1 p0 p1 p2 p3, p3)



strokeRelPath :: InterpretUnit u => RelPath u -> LocGraphic u
strokeRelPath rp = 
    promoteR1 $ \start -> toPrimPath start rp >>= openStroke