Engine.hs

{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, EmptyDataDecls #-}
module Engine where

import FRP.Sodium

import Control.Applicative
import Control.Monad
import Data.List
import Data.Typeable
import Graphics.Rendering.OpenGL as GL hiding (Triangle, Rect, translate)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT hiding (Rect, translate)
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import System.Time
import Debug.Trace

import Image

frameRate :: Num a => a
frameRate = 40

type Coord = Double
type Point = (Coord, Coord)
type Vector = (Coord, Coord)
type Rect = (Point, Vector)   -- Central point and size from centre to edge
type Sprite = (Rect, String)

data MouseEvent = MouseDown Point | MouseMove Point | MouseUp Point
    deriving Show

-- | True if the point is inside the rectangle
inside :: Point -> Rect -> Bool
inside (x, y) ((ox, oy), (wx, wy)) =
    x >= ox - wx && x <= ox + wx &&
    y >= oy - wy && y <= oy + wy

-- | True if the two rectangles overlap
overlaps :: Rect -> Rect -> Bool
overlaps ((x0, y0), (w0, h0)) ((x1, y1), (w1, h1)) =
    let ax0 = x0 - w0
        ay0 = y0 - h0
        ax1 = x0 + w0
        ay1 = y0 + h0
        bx0 = x1 - w1
        by0 = y1 - h1
        bx1 = x1 + w1
        by1 = y1 + h1
    in ax1 > bx0 &&
       ay1 > by0 &&
       ax0 < bx1 &&
       ay0 < by1

-- | Get system time in seconds since the start of the Unix epoch
-- (1 Jan 1970).
getTime :: IO Double
getTime = do
    (TOD sec pico) <- getClockTime
    return $!
        (fromIntegral sec) +
        (fromIntegral pico) / 1000000000000

data M deriving Typeable

-- | Game, which takes mouse event and time as input, and a list of sprites to draw
-- as output. Time is updated once per animation frame.
type Game p = Event p MouseEvent -> Behaviour p Double -> Reactive p (Behaviour p [Sprite])

runGame :: String -> Game M -> IO ()
runGame title game = do

    (eMouse, pushMouse) <- newEvent
    (eTime, pushTime) <- newEvent
    spritesRef <- newIORef []
    _ <- synchronously $ do
        time <- hold 0 eTime
        sprites <- game eMouse time
        listenValueIO sprites (writeIORef spritesRef)

    _ <- GLUT.getArgsAndInitialize
    GLUT.initialDisplayMode $= [GLUT.DoubleBuffered]
    GLUT.createWindow title
    GLUT.windowSize $= GLUT.Size 700 500
    blend $= Enabled
    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
    multisample $= Enabled
    shadeModel $= Smooth
    polygonSmooth $= Enabled
    hint PolygonSmooth $= Nicest
    hint LineSmooth $= Nicest
    normalize $= Enabled

    texturesRef <- newIORef M.empty
    t0 <- getTime
    GLUT.displayCallback $= display texturesRef t0 pushTime spritesRef
    let motion (GLUT.Position x y) = do
            pt <- toScreen x y
            synchronously $ pushMouse (MouseMove pt)
    GLUT.motionCallback $= Just motion
    GLUT.passiveMotionCallback $= Just motion
    GLUT.keyboardMouseCallback $= Just (\key keyState mods pos -> do
            case (key, keyState, pos) of
                (GLUT.MouseButton GLUT.LeftButton, GLUT.Down, GLUT.Position x y) ->
                    synchronously . pushMouse . MouseDown =<< toScreen x y
                (GLUT.MouseButton GLUT.LeftButton, GLUT.Up,   GLUT.Position x y) ->
                    synchronously . pushMouse . MouseUp   =<< toScreen x y
                _ -> return ()
        )
    GLUT.addTimerCallback (1000 `div` frameRate) $ repaint
    GLUT.mainLoop
  where
    toScreen :: GLint -> GLint -> IO (Coord, Coord)
    toScreen x y = do
        (_, Size w h) <- get viewport
        let aspect = fromIntegral w / fromIntegral h
            sx = 0.001/aspect
            sy = 0.001
            xx = 2 * ((fromIntegral x / fromIntegral w) - 0.5) / sx
            yy = 2 * (0.5 - (fromIntegral y / fromIntegral h)) / sy
        return (xx, yy)
    repaint = do
        GLUT.postRedisplay Nothing
        GLUT.addTimerCallback (1000 `div` frameRate) $ repaint

    period = 1 / frameRate

    display :: IORef (Map String (TextureImage, TextureObject))
            -> Double
            -> (Double -> Reactive M ())
            -> IORef [Sprite]
            -> IO ()
    display texturesRef t0 pushTime spritesRef = do

        t <- subtract t0 <$> getTime
        synchronously $ pushTime t

        sprites <- readIORef spritesRef

        clearColor $= Color4 0 0 0 (1 :: GLclampf)
        --clearColor $= Color4 0.1 0.1 0.15 (1 :: GLclampf)
        clear [ColorBuffer{-, DepthBuffer-}]
        loadIdentity

        (_, Size w h) <- get viewport
        let aspect = fromIntegral w / fromIntegral h
        scale (0.001/aspect) 0.001 (0.001 :: GLfloat)

        forM_ sprites $ \(((posX, posY),(sizeX, sizeY)),imgFile) -> do
            textures <- readIORef texturesRef
            (TextureImage iWidth iHeight pWidth pHeight _ _, to) <- case imgFile `M.lookup` textures of
                Just (ti, to) -> return (ti, to)
                Nothing       -> do
                    ti <- loadTexture imgFile False
                    to <- createTexture ti
                    modifyIORef texturesRef (M.insert imgFile (ti, to))
                    return $ (ti, to)

            preservingMatrix $ do
                texture Texture2D $= Enabled
                textureBinding Texture2D $= Just to
                GL.translate $ Vector3 (realToFrac posX) (realToFrac posY) (0 :: GLdouble)
                let w2 = realToFrac sizeX :: GLdouble
                    h2 = realToFrac sizeY :: GLdouble
                    cx = realToFrac pWidth / realToFrac iWidth :: GLfloat
                    cy = realToFrac pHeight / realToFrac iHeight :: GLfloat
                renderPrimitive Polygon $ do
                    texCoord $ TexCoord2 0 cy
                    vertex $ Vertex2 (-w2) (-h2)
                    texCoord $ TexCoord2 cx cy
                    vertex $ Vertex2 w2 (-h2)
                    texCoord $ TexCoord2 cx 0
                    vertex $ Vertex2 w2 h2
                    texCoord $ TexCoord2 0 (0 :: GLfloat)
                    vertex $ Vertex2 (-w2) h2
                texture Texture2D $= Disabled
            --translate $ Vector3 0 0 (0.001 :: GLdouble)

        GLUT.swapBuffers