halive-0.1.5: demo/Window.hs

{-# LANGUAGE ViewPatterns #-}
module Window where


import Control.Monad
import SDL
import Control.Monad.Trans
import Control.Exception
import Linear
import Linear.Affine
import Data.Text (Text)
import Control.Lens

createGLWindow :: MonadIO m => Text -> m (Window, GLContext)
createGLWindow windowName = do
    initialize
        [ InitVideo
        , InitEvents
        -- , InitJoystick , InitGameController
        ]
    window <- createWindow windowName defaultWindow
        { windowOpenGL = Just $ defaultOpenGL
            { glProfile = Core Normal 4 1
            }
        , windowHighDPI = True
        , windowInitialSize = V2 640 480
        --, windowPosition = Centered
        , windowPosition = Absolute (P (V2 100 100))
        , windowResizable = True
        }
    glContext <- glCreateContext window
    glMakeCurrent window glContext
    swapInterval $= ImmediateUpdates
    return (window, glContext)

withWindow windowName = bracket (createGLWindow windowName)
    (\(win, ctx) -> do
        destroyWindow win
        glDeleteContext ctx)

whileWindow :: MonadIO m => Window -> ([Event] -> m a) -> m ()
whileWindow window action = do
    let loop = do
            --liftIO (putStrLn "pollEvents")
            events <- pollEvents
            --liftIO (putStrLn "action")
            _ <- action events
            let shouldQuit = (QuitEvent `elem`) $ map eventPayload events
            unless shouldQuit loop
    loop
    destroyWindow window


windowPosToWorldPos :: (Epsilon a, Real a, Floating a)
                    => V2 a
                    -> M44 a
                    -> V2 a
                    -> a
                    -> V3 a
windowPosToWorldPos winSize viewProj coord depth = rayStart + rayDir * realToFrac depth
    where
        V2 xNDC yNDC = win2Ndc coord winSize
        rayStart = ndc2Wld (V4 xNDC yNDC (-1.0) 1.0)
        rayEnd   = ndc2Wld (V4 xNDC yNDC 0.0    1.0)
        rayDir   = normalize (rayEnd ^-^ rayStart)
        -- Converts from window coordinates (origin top-left) to normalized device coordinates
        win2Ndc (V2 x y) (V2 w h) =
            V2 ((x / w - 0.5) * 2)
               ((((h - y) / h) - 0.5) * 2)
        -- Converts from normalized device coordinates to world coordinates
        ndc2Wld i = hom2Euc (invViewProj !* i)
        -- Converts from homogeneous coordinates to Euclidean coordinates
        hom2Euc v = (v ^/ (v ^. _w)) ^. _xyz
        invViewProj = inv44 viewProj