module Main where

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

--import Control.Monad.Trans    ( lift )
--import Control.Monad.IO.Class ( liftIO )

import FRP.Sodium ( Reactive, Behaviour, sync, sample, listen, value, newBehaviour )

main :: IO ()
main = do
    (sb, sf) <- sync $ newBehaviour Nothing :: IO (Behaviour (Maybe (Int, Int)), Maybe (Int, Int) -> Reactive ())

    getArgsAndInitialize
    createWindow "Main"

    reshapeCallback $= Just (reshape sf)
    displayCallback $= display sb

    mainLoop


color3 :: GLfloat -> GLfloat -> GLfloat -> IO ()
color3 r g b = color $ Color3 r g b


vertex2 :: GLfloat -> GLfloat -> IO ()
vertex2 x y = vertex $ Vertex2 x y

vertex3 :: GLfloat -> GLfloat -> GLfloat -> IO ()
vertex3 x y z = vertex $ Vertex3 x y z

type GlColor = Color3 GLfloat

makeGradientRow :: Int -> GLfloat -> GlColor -> GlColor -> IO ()
makeGradientRow iw y lColor rColor =
    let w = fromIntegral iw
    in mapM_ (renderPoint lColor rColor y w . fromIntegral) (take iw [0..])
    where
        renderPoint :: GlColor -> GlColor -> GLfloat -> GLfloat -> GLfloat -> IO ()
        renderPoint lc rc y w n = do
            let c = k `onRange` (lc,rc)
                k = x/w
                x = n
            color c
            vertex2 x y

makeLinearGradient :: Int -> Int -> GlColor -> GlColor -> IO ()
makeLinearGradient iw ih lColor rColor =
    let w = fromIntegral iw
        h = fromIntegral ih
    in mapM_ (\n -> makeGradientRow w n lColor rColor) (take h [0..])

makeQuadraGradient :: Int
                     -- ^ width
                     -> Int
                     -- ^ height
                     -> GlColor
                     -- ^ top left corner's color
                     -> GlColor
                     -- ^ top right corner's color
                     -> GlColor
                     -- ^ bottom left corner's color
                     -> GlColor
                     -- ^ bottom right corner's color
                     -> IO ()
makeQuadraGradient iw ih blc trc brc tlc = do
    let h = fromIntegral ih
        w = fromIntegral iw
    mapM_ (renderRow h iw tlc trc brc blc) (take ih [0..])
    where
        renderRow h w tlc trc brc blc n = do
            let yLeftCol  = k `onRange` (tlc, blc)
                yRightCol = k `onRange` (trc, brc)
                y         = n
                k         = n/h
            makeGradientRow w y yLeftCol yRightCol


onRange :: GLfloat -> (GlColor , GlColor) -> GlColor
k `onRange` ((Color3 ar ag ab), (Color3 br bg bb)) =
    let kr = ar + (br - ar) * k
        kg = ag + (bg - ag) * k
        kb = ab + (bb - ab) * k
    in Color3 kr kg kb



display :: Behaviour (Maybe (Int,Int)) -> DisplayCallback
display b = do
    clear [ ColorBuffer ]

    dimPairMay <- sync $ sample b
    case dimPairMay of
        Nothing -> return ()
        Just (w,h) -> do
            renderPrimitive Points $ do
                makeQuadraGradient w h (Color3 0.5 0.25 0.75) (Color3 0.75 0.25 0.25) (Color3 0.25 0.5 0.75) (Color3 0.75 0.5 0.5)
    flush

reshape :: (Maybe (Int,Int) -> Reactive ()) -> ReshapeCallback
reshape f size@(Size iw ih) = do
    viewport $= (Position 0 0, size)

    matrixMode $= Projection
    loadIdentity

    let w = fromIntegral iw
        h = fromIntegral ih
    ortho2D 0 w 0 h

    matrixMode $= Modelview 0
    loadIdentity

    let Size cintW cintH = size
        ww = fromIntegral cintW
        wh = fromIntegral cintH

    sync $ f $ Just (ww,wh)
    print size

    postRedisplay Nothing
