{-# LANGUAGE TupleSections
  , BangPatterns 
  #-}
module Picture
    ( module Picture.Data
    , blank
    , polygon
    , polygonZ
    , polygonCol
    , poly3
    , poly3Col
    , bezierQuad
    , arc
    , arcSolid
    , thickArc
    , thickCircle
    , thickLine
    , thickLineCol
    , circleSolid
    , circleSolidCol
    , circle
    , line
    , lineCol
    , text
    , pictures
    , translate
    , rotate
    , scale
    , color
    , withAlpha
    , greyN
    , red       
    , green     
    , blue      
    , yellow    
    , cyan      
    , magenta   
    , rose      
    , violet    
    , azure     
    , aquamarine
    , chartreuse
    , orange    
    , white     
    , black
    , dim
    , light
    , dark
    , bright
    , mixColors
    , zeroZ
    , setDepth
    , addDepth
    , setLayer
    )
  where
import Geometry
import Geometry.Vector3D
--import Geometry.Data
import Picture.Data

--import Data.List
--import Data.Bifunctor
--import qualified Data.DList as DL
--import Graphics.Rendering.OpenGL (lineWidth, ($=))
--import Control.Lens

blank :: Picture
{-# INLINE blank #-}
blank = []

polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon ps = map (f . zeroZ) $ polyToTris ps
  where
    f pos = Verx pos black [] 0 polyNum

polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
  where
    f pos = Verx pos black [z] 0 polyzNum

polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol vs = polyToTris $ map f vs
  where
    f (V2 x y,col) = Verx (V3 x y 0) col [] 0 polyNum

poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
poly3 = poly3Col . map (, black)

poly3Col :: [(Point3,RGBA)] -> Picture
{-# INLINE poly3Col #-}
poly3Col vs = map f $ polyToTris vs
  where
    f (pos,col) = Verx pos col [] 0 polyNum

-- note that much of work computing the width of the bezier curve is done here
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
bezierQuad cola colc ra rc a b c 
    | a == b && b == c = blank
    | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
    | otherwise = bzhelp
        [(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1        0         )
        ,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1        0         )
        ,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0        1         )
        ,( aX, cola, V2 1        0        , V2 (fa' aX) (fc' aX)  )
        ,( cX, colc, V2 0        1        , V2 (fa' cX) (fc' cX)  )
        ,( bX, colb, V2 0        0        , V2 (fa' bX) (fc' bX)  )
        ,( bX, colb, V2 0        0        , V2 (fa' bX) (fc' bX)  )
        ]
  where 
    colb = mixColors 0.5 0.5 cola colc
    b2a | isLHS a b c = a -.- b
        | otherwise   = b -.- a
    aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
    aX  = a -.- aRadVec
    aIn = a +.+ aRadVec
    b2c | isLHS a b c = b -.- c
        | otherwise   = c -.- b
    cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
    cX  = c -.- cRadVec
    cIn = c +.+ cRadVec
    bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
    bX  = b +.+ bRadVec
    bIn = b -.- bRadVec
    fa = extrapolate aX cX bX 
    fc = extrapolate cX aX bX
    fa' = extrapolate aIn cIn bIn
    fc' = extrapolate cIn aIn bIn

bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = map f
  where
    f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] 0 bezNum

-- given a one and two zeros of a linear function over x and y,
-- determine the function
-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) = 
    (       x * ( ay - by )
        +   y * ( bx - ax )
        +   (ax * by - bx * ay)
    ) 
    / 
    (       ox * ( ay - by )
        +   ax * ( by - oy )
        +   bx * ( oy - ay )
    )

color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c = map $ overCol (const c)

translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 !a !b (V3 x y z) = V3 (x+a) (y+b) z

translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate !x !y = map $! overPos $! translate3 x y

setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)

addDepth :: Float -> Picture -> Picture
{-# INLINE addDepth #-}
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))

setLayer :: Int -> Picture -> Picture
{-# INLINE setLayer #-}
setLayer i = map f
  where
    f v = v {_vxLayer = i}

scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (V3 x y z) = V3 (x*a) (y*b) z

scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
--scale x y = map . second . overPos $ scale3 x y
scale x y = map $ overPos $ scale3 x y

rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate a = map $ overPos $ rotate3 a

pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
pictures = concat

makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
  where 
    angles = [a,a+step.. b]
    step = pi * 0.2

circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
circleSolid = circleSolidCol white white

circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = map f
    [(V3 (-r)   r  0, colC)
    ,(V3 (-r) (-r) 0, colE)
    ,(V3   r  (-r) 0, black)
    ]
  where
    f (pos,col) = Verx pos col [] 0 ellNum

circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = thickArc 0 (2*pi) rad 1

text :: String -> Picture
{-# INLINE text #-}
text s = map f $ stringToList s
  where
    f (pos,col,V2 a b) = Verx pos col [a,b] 0 textNum

line :: [Point2] -> Picture
{-# INLINE line #-}
line = flip thickLine 1

lineCol :: [(Point2,RGBA)] -> Picture
{-# INLINE lineCol #-}
lineCol = flip thickLineCol 1

thickLine :: [Point2] -> Float -> Picture
{-# INLINE thickLine #-}
thickLine ps t = pictures $ f ps
  where 
    f (x:y:ys) 
      | x == y      = f (x:ys)
      | otherwise   = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
    f _             = []
    n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))

thickLineCol :: [(Point2,RGBA)] -> Float -> Picture
{-# INLINE thickLineCol #-}
thickLineCol ps t = pictures $ f ps
  where 
    f ((x,c):(y,c'):ys) 
      | x == y      = f ((x,c):ys)
      | otherwise   = polygonCol 
        [(x +.+ n x y,c)
        ,(x -.- n x y,c)
        ,(y -.- n x y,c')
        ,(y +.+ n x y,c')
        ] : f ((y,c'):ys)
    f _             = []
    n a b = (t*0.5) *.* safeNormalizeV (vNormal (a -.- b))

thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
thickCircle = thickArc 0 (2*pi)

arcSolid
    :: Float -- ^ Start angle
    -> Float -- ^ End angle
    -> Float -- ^ Radius
    -> Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)

arc
    :: Float -- ^ Start angle
    -> Float -- ^ End angle
    -> Float -- ^ Radius
    -> Picture
arc startA endA rad = thickArc startA endA rad 1
{-# INLINE arc #-}

thickArc :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArc #-}
thickArc startA endA rad wdth
    | endA - startA > pi = pictures 
        [ thickArc (startA + pi) endA rad wdth
        , thickArcHelp startA (startA + pi) r w
        ]
    | otherwise = thickArcHelp startA endA r w
  where
    r = rad + 0.5 * wdth
    w = 1 - wdth / r

thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
{-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = map f 
    [  (V3 0 0 0,black,V3 0 0 wdth)
    ,(V3 xa ya 0,black,V3 1 0 wdth)
    ,(V3 xb yb 0,black,V3 1 1 wdth)
    ,  (V3 0 0 0,black,V3 0 0 wdth)
    ,(V3 xb yb 0,black,V3 1 1 wdth)
    ,(V3 xc yc 0,black,V3 0 1 wdth)
    ]
  where
    (V2 xa ya) = rotateV startA (V2 rad 0)
    (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
    (V2 xc yc) = rotateV endA (V2 rad 0)
    f (pos,col,V3 a b c) = Verx pos col [a,b,c] 0 arcNum

withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-}
withAlpha a (V4 x y z a') = V4 x y z (a*a')

red,green,blue,yellow,cyan,magenta,rose
    ,violet,azure,aquamarine,chartreuse,orange,white,black::Color
red       = V4   1   0   0 1 
green     = V4   0   1   0 1 
blue      = V4   0   0   1 1 
yellow    = V4   1   1   0 1  
cyan      = V4   0   1   1 1 
magenta   = V4   1   0   1 1  
rose      = V4   1   0 0.5 1 
violet    = V4 0.5   0   1 1  
azure     = V4   0 0.5   1 1 
aquamarine= V4   0   1 0.5 1 
chartreuse= V4 0.5   1   0 1
orange    = V4   1 0.5   0 1  
white     = V4   1   1   1 1 
black     = V4   0   0   0 1
{-# INLINE red        #-}
{-# INLINE green      #-}
{-# INLINE blue       #-}
{-# INLINE yellow     #-}
{-# INLINE cyan       #-}
{-# INLINE magenta    #-}
{-# INLINE rose       #-}
{-# INLINE violet     #-}
{-# INLINE azure      #-}
{-# INLINE aquamarine #-}
{-# INLINE chartreuse #-}
{-# INLINE orange     #-}
{-# INLINE white      #-}
{-# INLINE black      #-}

mixColors :: Float -> Float -> Color -> Color -> Color
{-# INLINE mixColors #-}
mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = 
    let fullrat = rata + ratb
        normrata = rata / fullrat
        normratb = ratb / fullrat
        f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
    in  V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)

light :: Color -> Color
{-# INLINE light #-}
light (V4 r g b a) = V4 (r+0.2) (g+0.2) (b+0.2) a

dark :: Color -> Color
{-# INLINE dark #-}
dark (V4 r g b a) = V4 (r-0.2) (g-0.2) (b-0.2) a
        
dim :: Color -> Color
{-# INLINE dim #-}
dim (V4 r g b a) = V4 (r/1.2) (g/1.2) (b/1.2) a

bright :: Color -> Color
{-# INLINE bright #-}
bright (V4 r g b a) = V4 (r*1.2) (g*1.2) (b*1.2) a

greyN :: Float -> Color
{-# INLINE greyN #-}
greyN x = toV4 (x,x,x,1)

overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-}
--overPos = over vxPos
overPos f vx = vx {_vxPos = f (_vxPos vx)}

overCol :: (Point4 -> Point4) -> Verx -> Verx
{-# INLINE overCol #-}
overCol f vx = vx {_vxCol = f (_vxCol vx)}

-- 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 = 
    [(V3 (x-50) (-100) 0, white,V2 offset     1)
    ,(V3 (x-50)   100  0, white,V2 offset     0)
    ,(V3 (x+50)   100  0, white,V2 (offset+1) 0)
    ,(V3 (x-50) (-100) 0, white,V2  offset    1)
    ,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1)
    ,(V3 (x+50)   100  0, white,V2 (offset+1) 0)
    ]
  where 
    offset = fromIntegral (fromEnum c) - 32