module Picture.Tree
    ( picToLTree
    )
    where
import Picture.Data
import Geometry

import Data.Bifunctor
import Data.List

-- todo: refactor out the layer check somehow
-- consider generalising to alternative rather than using LTree
picToLTree :: Maybe Int -> Picture -> LTree RenderType
{-# INLINE picToLTree #-}
picToLTree mx (Polygon i ps)
    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToLTree mx (PolygonCol i vs)
    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
        where (ps,cs) = unzip vs
picToLTree mx (BezierQuad i vs) 
    = filtB mx i $ 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 mx (Circle i colC colE r)
    = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC)
                                         ,( (-r,-r,0), colE)
                                         ,( ( r,-r,0), black)
                                         ]
picToLTree mx (ThickArc i startA endA rad wdth) 
    = filtB mx i $ LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
picToLTree mx (Line i ps) 
    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
picToLTree mx (LineCol i vs) 
    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
        where (ps,cs) = unzip vs
picToLTree mx (Text i s) 
    = filtB mx i $ LLeaf $ RenderText $ stringToList s
picToLTree j Blank = LBranches []
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic)) 
    = picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic
picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . 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

filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType
{-# INLINE filtB #-}
filtB mx i t | Just i == mx || Nothing == mx = t
             | otherwise                     = LBranches []

doubleLine :: [a] -> [a]
{-# INLINE doubleLine #-}
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
doubleLine _ = []

white = (1,1,1,1)
black = (0,0,0,1)

polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-}
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
polyToTris _ = []

scaleT :: (Float,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3)
{-# INLINE scaleT #-}
scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))

overPos :: (Point3 -> Point3) -> RenderType -> RenderType
{-# INLINE overPos #-}
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
overPos f (RenderLine vs) = RenderLine $ 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 (a,b,c))  = RenderArc (f a,b,c)

overRot :: Float -> RenderType -> RenderType
{-# INLINE overRot #-}
overRot ang (RenderArc (a,b,(r,s,t,v))) = RenderArc (a,b,(r+ang,s+ang,t,v))
overRot _ ren = ren

overCol :: (Point4 -> Point4) -> RenderType -> RenderType
{-# INLINE overCol #-}
overCol f (RenderPoly vs)      = RenderPoly $ map (second $ f) vs
overCol f (RenderLine vs)      = RenderLine $ 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 (a,b,c))   = RenderArc (a,f b,c)

overSca :: (Point2 -> Point2) -> RenderType -> RenderType
{-# INLINE overSca #-}
overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs
overSca f p = p

stringToList :: String -> [(Point3,Point4,Point3)]
{-# INLINE stringToList #-}
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
                         [0,0.9*dimText..]
                         $ map charToTuple s
    --where dimText = 100
dimText :: Float
dimText = 100

charToTuple :: Char -> (Point3,Point4,Point3)
{-# INLINE charToTuple #-}
charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
    where offset = fromIntegral (fromEnum c) - 32

translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
    where (x',y') = rotateV a (x,y)