{- Transform a picture into renderable objects. -}
module Picture.Tree
    ( picToLTree
    , picToLTree'
    , picToFTree
    , picToRenderList
    , picToAlt
    , picToRList
    )
    where
import Picture.Data
import Geometry
import Geometry.Data
--import StrictHelp
import Control.DeepSeq

import Data.Bifunctor
import Data.List
import qualified Data.DList as DL
import Control.Applicative
--import Data.Maybe (isNothing)

picToLTree'
    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
    -> LTree RenderType
picToLTree' x p = rnf (picToLTree x p) `seq` picToLTree x p

-- todo: refactor out the layer check somehow
-- consider generalising to alternative rather than using LTree
-- | Transform a picture into a tree of renderable objects
picToLTree 
    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
    -> LTree RenderType
--{-# INLINE picToLTree #-}
picToLTree _ (Polygon ps)
    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToLTree _ (PolygonZ ps z)
    = LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
picToLTree _ (PolygonCol vs)
    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
  where 
    (ps,cs) = unzip vs
picToLTree _ (Poly3D vs) = LLeaf $ RenderPoly $ polyToTris vs
picToLTree _ (BezierQuad vs) = LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
  where 
    (ps,cols,offps,rads) = unzip4 vs
    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
picToLTree _ (Circle colC colE r) = LLeaf $ RenderEllipse 
    [( (-r, r,0), colC)
    ,( (-r,-r,0), colE)
    ,( ( r,-r,0), black)
    ]
picToLTree _ (ThickArc startA endA rad wdth) = LLeaf $ RenderArc 
    [(  (0,0,0),black,(0,0,wdth))
    ,((xa,ya,0),black,(1,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
    ,(  (0,0,0),black,(0,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
    ,((xc,yc,0),black,(0,1,wdth))
    ]
  where
    (xa,ya) = rotateV startA (rad,0)
    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
    (xc,yc) = rotateV endA (rad,0)
picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
picToLTree _ Blank = LBranches []
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
--picToLTree j (Pictures pics) = LBranches . forceFoldable $ map (picToLTree j) pics
picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic
picToLTree (Just j) (OnLayer i pic) 
    | j == i = picToLTree Nothing pic
    | otherwise = LBranches []
picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic

picToFTree 
    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
    -> FTree RenderType
--{-# INLINE picToFTree #-}
picToFTree _ (Polygon ps)
    = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToFTree _ (PolygonZ ps z)
    = FLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
picToFTree _ (PolygonCol vs)
    = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
  where 
    (ps,cs) = unzip vs
picToFTree _ (Poly3D vs) = FLeaf $ RenderPoly $ polyToTris vs
picToFTree _ (BezierQuad vs) = FLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
  where 
    (ps,cols,offps,rads) = unzip4 vs
    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
picToFTree _ (Circle colC colE r) = FLeaf $ RenderEllipse 
    [( (-r, r,0), colC)
    ,( (-r,-r,0), colE)
    ,( ( r,-r,0), black)
    ]
picToFTree _ (ThickArc startA endA rad wdth) = FLeaf $ RenderArc 
    [(  (0,0,0),black,(0,0,wdth))
    ,((xa,ya,0),black,(1,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
    ,(  (0,0,0),black,(0,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
    ,((xc,yc,0),black,(0,1,wdth))
    ]
  where
    (xa,ya) = rotateV startA (rad,0)
    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
    (xc,yc) = rotateV endA (rad,0)
picToFTree _ (Text s) = FLeaf $ RenderText $ stringToList s
picToFTree _ Blank = FBranches []
picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
picToFTree j (OverPic f f' pic) = FBranch (overPos f . overCol f') $ picToFTree j pic
picToFTree (Just j) (OnLayer i pic) | j == i = picToFTree Nothing pic
                                    | otherwise = FBranches []
picToFTree Nothing  (OnLayer _ pic) = picToFTree Nothing pic

-- might want to use the Alt newType
picToAlt
    :: (Alternative t, Monoid (t RenderType))
    => Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
    -> t RenderType
{-# INLINE picToAlt #-}
picToAlt _ Blank = empty
picToAlt j (Pictures pics) = foldMap (picToAlt j) pics
picToAlt j (OverPic f f' (OverPic g g' pic)) = picToAlt j $ OverPic (f . g) (f' . g') pic
--picToAlt j (OverPic f f' (Pictures ps)) = concat $ fmap (picToAlt j . OverPic f f') ps
picToAlt j (OverPic f f' pic) = overPos f . overCol f' <$> picToAlt j pic
picToAlt (Just j) (OnLayer i pic)
    | j == i = picToAlt Nothing pic
    | otherwise = empty
picToAlt Nothing (OnLayer _ pic) = picToAlt Nothing pic
picToAlt _ pic = pure $ picToRenderType pic

picToRList 
    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
    -> DL.DList RenderType
picToRList = picToAlt

picToRenderList
    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
    -> [RenderType]
{-# INLINE picToRenderList #-}
picToRenderList _ Blank = []
picToRenderList j (Pictures pics) = concatMap (picToRenderList j) pics
picToRenderList j (OverPic f f' (OverPic g g' pic)) = picToRenderList j $ OverPic (f . g) (f' . g') pic
picToRenderList j (OverPic f f' (Pictures ps)) = concatMap (picToRenderList j . OverPic f f') ps
picToRenderList j (OverPic f f' pic) = overPos f . overCol f' <$> picToRenderList j pic
picToRenderList (Just j) (OnLayer i pic)
    | j == i = picToRenderList Nothing pic
    | otherwise = []
picToRenderList Nothing (OnLayer _ pic) = picToRenderList Nothing pic
picToRenderList _ pic = [picToRenderType pic]

picToRenderType 
    :: Picture
    -> RenderType
{-# INLINE picToRenderType #-}
picToRenderType (Polygon ps)
    = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToRenderType (PolygonZ ps z)
    = RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
picToRenderType (PolygonCol vs)
    = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
  where 
    (ps,cs) = unzip vs
picToRenderType (Poly3D vs) = RenderPoly $ polyToTris vs
picToRenderType (BezierQuad vs) = RenderBezQ $ zip3 (map zeroZ ps) cols rs
  where 
    (ps,cols,offps,rads) = unzip4 vs
    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
picToRenderType (Circle colC colE r) = RenderEllipse 
    [( (-r, r,0), colC)
    ,( (-r,-r,0), colE)
    ,( ( r,-r,0), black)
    ]
picToRenderType (ThickArc startA endA rad wdth) = RenderArc 
    [(  (0,0,0),black,(0,0,wdth))
    ,((xa,ya,0),black,(1,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
    ,(  (0,0,0),black,(0,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
    ,((xc,yc,0),black,(0,1,wdth))
    ]
  where
    (xa,ya) = rotateV startA (rad,0)
    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
    (xc,yc) = rotateV endA (rad,0)
picToRenderType (Text s) = RenderText $ stringToList s
picToRenderType _ = error "Tried to make a render type from a tree picture"
--
--picToAlternative
--    :: Alternative t
--    => Maybe Int
--    -> Picture
--    -> t RenderType
--picToAlternative _ Blank = empty
--picToAlternative j (Pictures pics) = undefined
    
white, black :: Color
white = (1,1,1,1)
black = (0,0,0,1)

overPos :: (Point3 -> Point3) -> RenderType -> RenderType
--{-# INLINE overPos #-}
overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
overPos f (RenderArc vs)  = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
overPos _ _ = undefined

overCol :: (Point4 -> Point4) -> RenderType -> RenderType
--{-# INLINE overCol #-}
overCol f (RenderPoly vs)     = RenderPoly    $ map (second f) vs
overCol f (RenderEllipse vs)  = RenderEllipse $ map (second f) vs
overCol f (RenderText vs)     = RenderText    $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderBezQ vs)     = RenderBezQ    $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderArc vs)      = RenderArc     $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderPolyZ vs)    = RenderPolyZ   $ map (\(a,b,c) -> (a,f b,c)) vs
overCol _ _ = undefined

-- no premature optimisation, consider changing to use texture arrays
stringToList :: String -> [(Point3,Point4,Point2)]
{-# INLINE stringToList #-}
--stringToList s = concat $ zipWith charToTuple [0,0.9*dimText ..] s
stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
  where
    dimText = 100

charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-}
charToTuple x c = 
    [((x-50,-100,0),    white,(offset,1))
    ,((x-50,100,0),     white,(offset,0))
    ,((x+50,100,0),   white,(offset+1,0))
    ,((x-50,-100,0),    white,(offset,1))
    ,((x+50,-100,0),  white,(offset+1,1))
    ,((x+50,100,0),   white,(offset+1,0))
    ]
  where 
    offset = fromIntegral (fromEnum c) - 32

--{- Translate a 3D vector in the x and y directions. -}
--translate3 :: Float -> Float -> Point3 -> Point3
--{-# INLINE translate3 #-}
--translate3 a b (x,y,z) = (x+a,y+b,z)