--------------------------------------------------------------
-- | 
-- Module      : Graphics.DrawingCombinators
-- Copyright   : (c) Luke Palmer 2008
-- License     : LGPL
--
-- Maintainer  : Luke Palmer <lrpalmer@gmail.com>
-- Stability   : experimental
-- Portability : presumably portable
--
-- Drawing combinators as a functional interface to OpenGL
-- (for 2D drawings only... for now).
--
-- This module is intended to be imported @qualified@, as in:
--
-- > import Graphics.DrawingCombinators as Draw
--
-- It is recommended that you use this module in combination
-- with SDL; it has not been tested in any other environments.
--------------------------------------------------------------

module Graphics.DrawingCombinators
    (
    -- * Basic types
      Drawing, runDrawing, draw, unsafeDraw, Vec2
    -- * Initialization
    , init
    -- * Geometric Primitives
    , point, line, regularPoly, circle
    -- * Transformations
    , translate, rotate, scale
    -- * Colors 
    , Color, color, colorFunc
    -- * Sprites (images from files)
    , Sprite, SpriteScaling(..), surfaceToSprite, imageToSprite, sprite
    -- * Text
    , Font, openFont, text
    )
where

import Prelude hiding (init)
import Data.Monoid
import Control.Monad
import Control.Monad.Reader
import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Graphics.Rendering.OpenGL.GLU as GLU
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL.Image as Image
import qualified Graphics.UI.SDL.TTF as TTF
import System.Mem.Weak
import Data.IORef 
import System.IO.Unsafe

type Vec2 = (Double,Double)
type Color = (Double,Double,Double,Double)

-- |Drawing is the main type built by combinators in this module.
-- It represents a picture that can be drawn using @draw@ 
-- after possibly being transformed.
--
-- The Monoid instance drawings works as follows: a `mappend` b
-- draws b "on top of" a.
newtype Drawing = Drawing { unDrawing :: ReaderT DrawCxt IO () }

-- |Draw a Drawing on the screen in the current OpenGL coordinate
-- system (which, in absense of information, is (-1,-1) in the
-- lower left and (1,1) in the upper right.
runDrawing :: Drawing -> IO ()
runDrawing d = runReaderT (unDrawing d) initDrawCxt

-- |Like runDrawing, but clears the screen first.  This is so
-- you can use this module and pretend that OpenGL doesn't
-- exist at all.
draw :: Drawing -> IO ()
draw d = do
    GL.clear [GL.ColorBuffer]
    runDrawing d

-- |Convert an IO action into a drawing, for when you need
-- some OpenGL capabilities that are not implemented in this
-- module.  If you use this, please behave.
unsafeDraw :: IO () -> Drawing
unsafeDraw = Drawing . lift

data DrawCxt 
    = DrawCxt { colorTrans :: Color -> Color }

initDrawCxt = DrawCxt { colorTrans = id }

instance Monoid Drawing where
    mempty = Drawing $ return ()
    mappend (Drawing a) (Drawing b) = Drawing $ a >> b


{----------------
  Initialization
----------------}

-- |Perform initialization of the library.  This can fail.
init :: IO ()
init = do
    wasinit <- TTF.wasInit
    when (not wasinit) $ do
        success <- TTF.init
        when (not success) $ fail "SDL_ttf initialization failed"


{----------------
  Geometric Primitives
-----------------}

-- | Draw a single pixel at the specified point.
point :: Vec2 -> Drawing
point (ax,ay) = Drawing $ lift $
    GL.renderPrimitive GL.Points $
        GL.vertex $ GL.Vertex2 ax ay

-- | Draw a line connecting the two given points.
line :: Vec2 -> Vec2 -> Drawing
line (ax,ay) (bx,by) = Drawing $ lift $ 
    GL.renderPrimitive GL.Lines $ do
        GL.vertex $ GL.Vertex2 ax ay
        GL.vertex $ GL.Vertex2 bx by

-- | Draw a regular polygon centered at the origin with n sides.
regularPoly :: Int -> Drawing
regularPoly n = Drawing $ lift $ do
    let scaler = 2 * pi / fromIntegral n :: Double
    GL.renderPrimitive GL.TriangleFan $ do
        GL.vertex $ (GL.Vertex2 0 0 :: GL.Vertex2 Double)
        forM_ [0..n] $ \s -> do
            let theta = scaler * fromIntegral s
            GL.vertex $ GL.Vertex2 (cos theta) (sin theta)

-- | Draw a unit circle centered at the origin.  This is equivalent
-- to @regularPoly 24@.
circle :: Drawing
circle = regularPoly 24


{-----------------
  Transformations
------------------}

-- | Translate the given drawing by the given amount.
translate :: Vec2 -> Drawing -> Drawing
translate (byx,byy) d = Drawing $ do
    r <- ask
    lift $ GL.preservingMatrix $ do
        GL.translate (GL.Vector3 byx byy 0)
        runReaderT (unDrawing d) r

-- | Rotate the given drawing counterclockwise by the
-- given number of radians.
rotate :: Double -> Drawing -> Drawing
rotate rad d = Drawing $ do
    r <- ask
    lift $ GL.preservingMatrix $ do
        GL.rotate (180 * rad / pi) (GL.Vector3 0 0 1)
        runReaderT (unDrawing d) r

-- | @scale x y d@ scales @d@ by a factor of @x@ in the
-- horizontal direction and @y@ in the vertical direction.
scale :: Double -> Double -> Drawing -> Drawing
scale x y d = Drawing $ do
    r <- ask
    lift $ GL.preservingMatrix $ do
        GL.scale x y 1
        runReaderT (unDrawing d) r

{------------
  Colors
-------------}

-- | @colorFunc f d@ modifies all colors appearing in @d@ with
-- the function @f@.  For example:
--
-- > colorFunc (\(r,g,b,a) -> (r,g,b,a/2)) d
--
-- Will draw d at greater transparency, regardless of the calls
-- to color within.
colorFunc :: (Color -> Color) -> Drawing -> Drawing
colorFunc cf d = Drawing $ do
    r <- ask
    let trans    = colorTrans r
        newtrans = trans . cf
        oldcolor = trans (1,1,1,1)
        newcolor = newtrans (1,1,1,1)
    setColor newcolor
    local (const (r { colorTrans = newtrans })) $ unDrawing d
    setColor oldcolor
    where
    setColor (r,g,b,a) = lift $ GL.color $ GL.Color4 r g b a

-- | @color c d@ sets the color of the drawing to exactly @c@.
color :: Color -> Drawing -> Drawing
color c = colorFunc (const c)


{-------------------------
  Sprites (bitmap images)
-------------------------}

-- | A sprite represents a bitmap image.
data Sprite = Sprite { spriteObject :: GL.TextureObject
                     , spriteWidthRat :: Double
                     , spriteHeightRat :: Double
                     , spriteWidth :: Double
                     , spriteHeight :: Double
                     }

-- FUUUUUUUUUCKKK Why doesn't glGenTextures work!!??
-- Anyway here is me hacking around it...
textureHack :: IORef [GL.GLuint]
textureHack = unsafePerformIO $ newIORef [1..]

allocateTexture :: IO GL.TextureObject
allocateTexture = do
    {- -- This is how it *should* be done.  wtf is going on!?
    [obj] <- GL.genObjectNames 1
    good <- GL.isObjectName obj
    unless good $ fail "Failed to generate valid object wtf!"
    return obj
    -}
    b <- atomicModifyIORef textureHack (\(x:xs) -> (xs,x))
    return $ GL.TextureObject b

freeTexture :: GL.TextureObject -> IO ()
freeTexture (GL.TextureObject b) = do
    GL.deleteObjectNames [GL.TextureObject b]
    modifyIORef textureHack (b:)

-- | Indicate how a nonrectangular image is to be mapped to a sprite.
data SpriteScaling
    -- | ScaleMax will set the maximum of the height and width of the image to 1.
    = ScaleMax    
    -- | ScaleWidth will set the width of the image to 1, and scale the height appropriately.
    | ScaleWidth  
    -- | ScaleHeight will set the height of the image to 1, and scale the width appropriately. 
    | ScaleHeight

-- | Convert an SDL.Surface to a Sprite.
surfaceToSprite :: SpriteScaling -> SDL.Surface -> IO Sprite
surfaceToSprite scaling surf = do
    surf' <- padSurface surf
    obj <- allocateTexture
    oldtex <- GL.get (GL.textureBinding GL.Texture2D)
    GL.textureBinding GL.Texture2D GL.$= Just obj
    pixels <- SDL.surfaceGetPixels surf'
    bytesPerPixel <- SDL.pixelFormatGetBytesPerPixel (SDL.surfaceGetPixelFormat surf')
    let pixelFormat = case bytesPerPixel of
                        3 -> GL.RGB
                        4 -> GL.RGBA
    GL.textureFunction GL.$= GL.Modulate
    GL.textureFilter GL.Texture2D GL.$= ((GL.Linear', Nothing), GL.Linear')
    GL.textureWrapMode GL.Texture2D GL.S GL.$= (GL.Mirrored, GL.Repeat)
    GL.textureWrapMode GL.Texture2D GL.T GL.$= (GL.Mirrored, GL.Repeat)
    GL.texImage2D Nothing GL.NoProxy 0 (GL.RGBA')  -- ? proxy level internalformat
                  (GL.TextureSize2D 
                    (fromIntegral $ SDL.surfaceGetWidth surf')
                    (fromIntegral $ SDL.surfaceGetHeight surf'))
                  0 -- border
                  (GL.PixelData pixelFormat GL.UnsignedByte pixels)
    GL.textureBinding GL.Texture2D GL.$= oldtex
    let (w,w') = (SDL.surfaceGetWidth  surf, SDL.surfaceGetWidth  surf')
        (h,h') = (SDL.surfaceGetHeight surf, SDL.surfaceGetHeight surf')
    let (scalew, scaleh) = scaleFunc w h
    let sprite = Sprite { spriteObject = obj
                        , spriteWidthRat  = fromIntegral w / fromIntegral w'
                        , spriteHeightRat = fromIntegral h / fromIntegral h'
                        , spriteWidth  = scalew
                        , spriteHeight = scaleh
                        }
                            
    addFinalizer sprite $ do
        freeTexture obj
    return sprite

    where
    scaleFunc w h =
        case scaling of
             ScaleMax ->
                 ( fromIntegral w / fromIntegral (max w h)
                 , fromIntegral h / fromIntegral (max w h) )
             ScaleWidth ->
                 ( 1, fromIntegral h / fromIntegral w )
             ScaleHeight ->
                 ( fromIntegral w / fromIntegral h, 1 )

nextPowerOf2 x = head $ dropWhile (< x) $ iterate (*2) 1
isPowerOf2 x = x == nextPowerOf2 x

padSurface :: SDL.Surface -> IO SDL.Surface
padSurface surf 
    | newWidth == oldWidth && newHeight == oldHeight = return surf
    | otherwise = do
        surf' <- SDL.createRGBSurfaceEndian [] newWidth newHeight 32
        SDL.setAlpha surf [] 0xff
        SDL.blitSurface surf Nothing surf' Nothing
        return surf'
    where
    oldWidth  = SDL.surfaceGetWidth surf
    oldHeight = SDL.surfaceGetHeight surf
    newWidth  = nextPowerOf2 oldWidth
    newHeight = nextPowerOf2 oldHeight

-- | Load an image from a file and create a sprite out of it.
imageToSprite :: SpriteScaling -> FilePath -> IO Sprite
imageToSprite scaling path = Image.load path >>= surfaceToSprite scaling

-- | Draw a sprite at the origin.
sprite :: Sprite -> Drawing
sprite spr = Drawing $ liftIO $ do
    oldtex <- GL.get (GL.textureBinding GL.Texture2D)
    GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr)
    GL.renderPrimitive GL.Quads $ do
        let (xofs, yofs) = (0.5 * spriteWidth spr, 0.5 * spriteHeight spr)
            (xrat, yrat) = (spriteWidthRat spr, spriteHeightRat spr)
        GL.texCoord $ GL.TexCoord2 0 (0 :: Double)
        GL.vertex   $ GL.Vertex2 (-xofs) yofs
        GL.texCoord $ GL.TexCoord2 xrat 0
        GL.vertex   $ GL.Vertex2 xofs yofs
        GL.texCoord $ GL.TexCoord2 xrat yrat
        GL.vertex   $ GL.Vertex2 xofs (-yofs)
        GL.texCoord $ GL.TexCoord2 0 yrat
        GL.vertex   $ GL.Vertex2 (-xofs) (-yofs)
    GL.textureBinding GL.Texture2D GL.$= oldtex

{---------
 Text
---------}

data Font = Font { getFont :: TTF.Font }

-- | Load a TTF font from a file.
openFont :: String -> Int -> IO Font
openFont path res = do
    font <- TTF.openFont path res
    let font' = Font font
    return font'

textSprite :: Font -> String -> IO Sprite
textSprite font str = do
    surf <- TTF.renderTextBlended (getFont font) str (SDL.Color 255 255 255)
    surfaceToSprite ScaleHeight surf

-- | Draw a string using a font.  The resulting string will have height 1.
text :: Font -> String -> Drawing
text font str = sprite $ unsafePerformIO $ textSprite font str