Hate (empty) → 0.1.4.2

raw patch · 35 files changed

+2018/−0 lines, 35 filesdep +GLFW-bdep +GLUtildep +Hatesetup-changed

Dependencies added: GLFW-b, GLUtil, Hate, JuicyPixels, JuicyPixels-util, OpenGL, base, bytestring, lens, mtl, multimap, random, stm, transformers, vect, vect-opengl, vector

Files

• Hate.cabal +133/−0
• LICENSE +20/−0
• Setup.hs +2/−0
• samples/sample_asteroids.hs +133/−0
• samples/sample_scheduler.hs +51/−0
• samples/sample_shapes.hs +38/−0
• samples/sample_sprite.hs +70/−0
• samples/sample_spritesheet.hs +54/−0
• src/Hate.hs +16/−0
• src/Hate/Common.hs +246/−0
• src/Hate/Common/Instances.hs +13/−0
• src/Hate/Common/Scheduler.hs +97/−0
• src/Hate/Common/Types.hs +60/−0
• src/Hate/Events.hs +106/−0
• src/Hate/Events/Types.hs +26/−0
• src/Hate/Graphics.hs +27/−0
• src/Hate/Graphics/Backend.hs +32/−0
• src/Hate/Graphics/Backend/Compat.hs +106/−0
• src/Hate/Graphics/Backend/Compat/Shaders.hs +53/−0
• src/Hate/Graphics/Backend/Compat/Types.hs +12/−0
• src/Hate/Graphics/Backend/Modern.hs +108/−0
• src/Hate/Graphics/Backend/Modern/Shaders.hs +24/−0
• src/Hate/Graphics/Backend/Modern/Types.hs +12/−0
• src/Hate/Graphics/Backend/Util.hs +120/−0
• src/Hate/Graphics/Pipeline.hs +10/−0
• src/Hate/Graphics/Pipeline/Util.hs +52/−0
• src/Hate/Graphics/Rendering.hs +27/−0
• src/Hate/Graphics/Shader.hs +73/−0
• src/Hate/Graphics/Shapes.hs +38/−0
• src/Hate/Graphics/Sprite.hs +111/−0
• src/Hate/Graphics/Types.hs +41/−0
• src/Hate/Math.hs +28/−0
• src/Hate/Math/Transformable/Class.hs +6/−0
• src/Hate/Math/Types.hs +12/−0
• src/Hate/Math/Util.hs +61/−0

@@ -0,0 +1,133 @@+name:                Hate+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change++version:             0.1.4.2+synopsis:            A small 2D game framework.+description:         A small 2D game framework. +stability:           experimental+homepage:            http://github.com/bananu7/Hate+license:             MIT+license-file:        LICENSE+author:              Bartek Banachewicz+maintainer:          bananu7@o2.pl+category:            Graphics+build-type:          Simple+cabal-version:       >=1.18++library+  -- Modules exported by the library.+  exposed-modules:    Hate+                      Hate.Graphics+                      Hate.Graphics.Shapes+                      Hate.Math+                      Hate.Math.Types+                      Hate.Common.Scheduler+                      Hate.Events+                      Hate.Events.Types+                      +  other-modules:      Hate.Common+                      Hate.Common.Types+                      Hate.Common.Instances+                      Hate.Math.Transformable.Class+                      Hate.Math.Util+                      Hate.Graphics.Pipeline+                      Hate.Graphics.Pipeline.Util+                      Hate.Graphics.Shader+                      Hate.Graphics.Types+                      Hate.Graphics.Rendering+                      Hate.Graphics.Sprite+                      Hate.Graphics.Backend+                      Hate.Graphics.Backend.Util+                      Hate.Graphics.Backend.Compat+                      Hate.Graphics.Backend.Compat.Shaders+                      Hate.Graphics.Backend.Compat.Types+                      Hate.Graphics.Backend.Modern+                      Hate.Graphics.Backend.Modern.Shaders+                      Hate.Graphics.Backend.Modern.Types+                       ++  hs-source-dirs:      .,src+  -- Modules included in this library but not exported.+  -- other-modules:       +  +  -- Other library packages from which modules are imported.+  build-depends:       base >= 4.6 && < 4.9,+                       GLFW-b >= 1.4 && < 1.4.7,+                       GLUtil >= 0.7,+                       OpenGL > 2.9.1,+                       transformers,+                       mtl,+                       vect,+                       vect-opengl,+                       vector,+                       JuicyPixels,+                       JuicyPixels-util,+                       bytestring,+                       multimap,+                       stm > 2.4++  default-language:    Haskell2010+  ghc-options:         -Wall -ferror-spans++executable sample_shapes+  main-is:          sample_shapes.hs+  hs-source-dirs:   samples +  build-depends:    base >= 4.6 && < 4.9,+                    GLFW-b >= 1.4 && < 1.4.7,+                    GLUtil >= 0.7,+                    OpenGL > 2.9.1,+                    transformers, mtl, vect, vect-opengl, vector, JuicyPixels, JuicyPixels-util,+                    Hate+  default-language: Haskell2010++executable sample_scheduler+  main-is:          sample_scheduler.hs+  hs-source-dirs:   samples +  build-depends:    base >= 4.6 && < 4.9,+                    GLFW-b >= 1.4 && < 1.4.7,+                    GLUtil >= 0.7,+                    OpenGL > 2.9.1,+                    transformers, mtl, vect, vect-opengl, vector, JuicyPixels, JuicyPixels-util,+                    Hate,+                    lens+  default-language: Haskell2010++executable sample_sprite+  main-is:          sample_sprite.hs+  hs-source-dirs:   samples +  build-depends:    base >= 4.6 && < 4.9,+                    GLFW-b >= 1.4 && < 1.4.7,+                    GLUtil >= 0.7,+                    OpenGL > 2.9.1,+                    transformers, mtl, vect, vect-opengl, vector, JuicyPixels, JuicyPixels-util,+                    Hate,+                    random, lens+  default-language: Haskell2010++executable sample_spritesheet+  main-is:          sample_spritesheet.hs+  hs-source-dirs:   samples +  build-depends:    base >= 4.6 && < 4.9,+                    GLFW-b >= 1.4 && < 1.4.7,+                    GLUtil >= 0.7,+                    OpenGL > 2.9.1,+                    transformers, mtl, vect, vect-opengl, vector, JuicyPixels, JuicyPixels-util,+                    Hate,+                    random, lens+  default-language: Haskell2010++executable sample_asteroids+  main-is:          sample_asteroids.hs+  hs-source-dirs:   samples +  build-depends:    base >= 4.6 && < 4.9,+                    GLFW-b >= 1.4 && < 1.4.7,+                    GLUtil >= 0.7,+                    OpenGL > 2.9.1,+                    transformers, mtl, vect, vect-opengl, vector, JuicyPixels, JuicyPixels-util,+                    Hate,+                    random, lens+  default-language: Haskell2010++

@@ -0,0 +1,20 @@+The MIT License (MIT)++Copyright (c) 2014 Bartek Banachewicz++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,133 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Hate
+import Hate.Graphics
+import Vec2Lens (x,y)
+
+import Control.Applicative
+import Control.Lens
+import System.Random
+
+-- sample 4
+
+data EntityState = EntityState {
+    _pos :: Vec2,
+    _vel :: Vec2,
+    _rot :: Float,
+    _rotVel :: Float
+}
+makeLenses ''EntityState
+
+data Asteroid = Asteroid {
+    _asteroidEntity :: EntityState,
+    _size :: Int
+}
+makeLenses ''Asteroid
+makeFields ''Asteroid
+
+data Player = Player {
+    _playerEntity :: EntityState
+}
+makeLenses ''Player
+makeFields ''Player
+
+data SampleState = SampleState {
+    _playerSprite :: Sprite,
+    _smallAsteroidSprite :: Sprite,
+    _mediumAsteroidSprite :: Sprite,
+    _bigAsteroidSprite :: Sprite,
+    _asteroids :: [Asteroid],
+    _player :: Player
+}
+makeLenses ''SampleState
+
+data VisualRepresentation = SmallAsteroidSprite | MediumAsteroidSprite | BigAsteroidSprite | PlayerSprite
+class ToVisual a where
+    toVisual :: a -> VisualRepresentation
+
+instance ToVisual Player where
+    toVisual (Player _) = PlayerSprite
+
+instance ToVisual Asteroid where
+    toVisual (Asteroid _ sz) | sz < 2 = SmallAsteroidSprite
+                             | sz < 4 = MediumAsteroidSprite
+                             | otherwise = BigAsteroidSprite
+
+randomAsteroids :: Int -> IO [Asteroid] 
+randomAsteroids n = replicateM n randomAsteroid
+
+randomAsteroid :: IO Asteroid
+randomAsteroid = do
+    px <- getStdRandom $ randomR (0,800)
+    py <- getStdRandom $ randomR (0,800)
+    vx <- getStdRandom $ randomR (-2, 2)
+    vy <- getStdRandom $ randomR (-2, 2)
+    vr <- getStdRandom $ randomR (-0.1, 0.1)
+    sz <- getStdRandom $ randomR (1, 5)
+
+    let e = EntityState (Vec2 px py) (Vec2 vx vy) 0 vr
+    return $ Asteroid e sz
+
+initialPlayer :: Player
+initialPlayer = Player $ EntityState (Vec2 200 200) (Vec2 0 0) 0 0
+
+sampleLoad :: LoadFn SampleState
+sampleLoad = SampleState <$> loadSprite "samples/asteroids/ship.png" 
+                         <*> loadSprite "samples/asteroids/asteroid_small.png" 
+                         <*> loadSprite "samples/asteroids/asteroid_medium.png" 
+                         <*> loadSprite "samples/asteroids/asteroid_big.png" 
+                         <*> randomAsteroids 10
+                         <*> pure initialPlayer
+
+sampleDraw :: DrawFn SampleState
+sampleDraw s = (map draw (s ^. asteroids)) ++ [draw (s ^. player)]
+    where
+        draw :: (HasEntity a EntityState, ToVisual a) => a -> DrawRequest
+        draw a = (entityToTransform a) . sprite Middle . visualToSprite . toVisual $ a
+
+        visualToSprite SmallAsteroidSprite = s ^. smallAsteroidSprite
+        visualToSprite MediumAsteroidSprite = s ^. mediumAsteroidSprite
+        visualToSprite BigAsteroidSprite = s ^. bigAsteroidSprite
+        visualToSprite PlayerSprite = s ^. playerSprite
+
+        entityToTransform :: HasEntity a EntityState => a -> DrawRequest -> DrawRequest
+        entityToTransform a = let e = a ^. entity in ((rotated (e ^. rot)) . (translate (e ^. pos)))
+
+sampleUpdate :: UpdateFn SampleState
+sampleUpdate _ = do
+    asteroids . traversed %= updateEntity
+    player %= updateEntity
+    steerShip
+    where
+        updateEntity :: HasEntity a EntityState => a -> a
+        updateEntity a = a & (entity . pos +~ a ^. entity . vel)
+                           & (entity . rot +~ a ^. entity . rotVel)
+                           -- damping:
+                           & (entity . vel *~ 0.99)
+                           & (entity . rotVel *~ 0.99)
+                           & screenWarp
+
+        screenWarp a = a & (if a ^. entity . pos . x > 1024 then entity . pos . x -~ 1024 else id)
+                         & (if a ^. entity . pos . y > 768  then entity . pos . y -~ 768 else id)
+                         & (if a ^. entity . pos . x < 0 then entity . pos . x +~ 1024 else id)
+                         & (if a ^. entity . pos . y < 0 then entity . pos . y +~ 768 else id)
+
+
+        steerShip = do
+            r <- use $ player . entity . rot
+            whenKeyPressed Key'Up $ player . entity . vel += (rotateVec r (Vec2 0 (negate 1)))
+            whenKeyPressed Key'Left $ player . entity . rotVel -= 0.01
+            whenKeyPressed Key'Right $ player . entity . rotVel += 0.01
+
+config :: Config
+config = 
+    Config
+        { windowTitle = "Sample - Asteroids"
+        , windowSize  = (1024, 768)
+        }
+
+main :: IO ()
+main = runApp config sampleLoad sampleUpdate sampleDraw

@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}++import Hate+import Hate.Graphics.Shapes+import Hate.Common.Scheduler++import Control.Lens++data SampleState = SampleState {+    _radius :: Float,+    _sched :: Scheduler SampleState,+    _firstRun :: Bool+}+makeLenses ''SampleState++sampleLoad :: LoadFn SampleState+sampleLoad = return $ SampleState 0 emptyScheduler True++sampleDraw :: DrawFn SampleState+sampleDraw p = [translate (Vec2 150 150) $ circle (p ^. radius)]++schedule' evt = sched %= (flip schedule) evt++every' t evt = every t evt >>= schedule'+after' t evt = after t evt >>= schedule'++sampleUpdate :: UpdateFn SampleState+sampleUpdate _ = do+    -- repeated action+    use firstRun >>= \p -> when p $ do+        every' 1 $ radius += 50+        firstRun .= False+        +    use sched >>= process >>= assign sched++    -- queue a waiting action+    whenKeyPressed Key'Space $ after' 2 $ radius += 20++    -- continuous action+    radius *= 0.95++config :: Config+config =+    Config+        { windowTitle = "Sample - Scheduler"+        , windowSize  = (1024, 768)+        }++main :: IO ()+main = runApp config sampleLoad sampleUpdate sampleDraw

@@ -0,0 +1,38 @@+import Hate+import Hate.Graphics.Shapes++data SampleState = SampleState {+    r :: Int,+    p :: Vec2+}++sampleLoad :: LoadFn SampleState+sampleLoad = return $ SampleState 0 (Vec2 150 150)++green :: Float -> Vec4+green e = Vec4 0.0 e 0.0 1.0++sampleDraw :: DrawFn SampleState+sampleDraw (SampleState r p) =+    [ translate p $ colored (green $ (fromIntegral r) / 150.0) $ circle (fromIntegral r)+    , line p (Vec2 300 300)+    ]++sampleUpdate :: UpdateFn SampleState+sampleUpdate events = do+    modify $ \s -> if r s > 150 then s { r = 0 }+                                else s { r = r s + 1 }++    forM_ events $ \e -> case e of+        EventCursorPos x y -> modify $ \s -> s { p = Vec2 x y }+        _ -> return ()++config :: Config+config =+    Config+        { windowTitle = "Sample - Shapes"+        , windowSize  = (1280, 768)+        }++main :: IO ()+main = runApp config sampleLoad sampleUpdate sampleDraw

@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+import Hate
+import Hate.Graphics
+import Vec2Lens (x,y)
+
+import Control.Applicative
+import Control.Lens
+import System.Random
+
+-- sample 4
+
+data Sehe = Sehe {
+    _pos :: Vec2,
+    _vel :: Vec2
+}
+makeLenses ''Sehe
+
+data SampleState = SampleState {
+    _seheSprite :: Sprite,
+    _sehes :: [Sehe]
+}
+makeLenses ''SampleState
+
+generateSehes :: IO [Sehe] 
+generateSehes = replicateM 100 generateSehe
+
+generateSehe :: IO Sehe
+generateSehe = do
+    px <- getStdRandom $ randomR (0,300)
+    py <- getStdRandom $ randomR (0,300)
+    vx <- getStdRandom $ randomR (-5, 5)
+    vy <- getStdRandom $ randomR (-5, 5)
+
+    return $ Sehe (Vec2 px py) (Vec2 vx vy)
+
+sampleLoad :: LoadFn SampleState
+sampleLoad = SampleState <$> loadSprite "samples/image.png" 
+                         <*> generateSehes
+
+sampleDraw :: DrawFn SampleState
+sampleDraw s = map (\(Sehe p v) -> translate p $ sprite TopLeft (s ^. seheSprite)) $ s ^. sehes
+
+moveSehe :: Sehe -> Sehe
+moveSehe = updatePos . updateVel
+    where
+        updateVel :: Sehe -> Sehe
+        updateVel s = s & (if bounceX then vel . x %~ negate else id)
+                        & (if bounceY then vel . y %~ negate else id)
+            where
+                bounceX = outOfBounds (s ^. pos . x) (0, 1024 - 128)
+                bounceY = outOfBounds (s ^. pos . y) (0, 786 - 128)
+                outOfBounds v (lo, hi) = v < lo || v > hi
+
+        updatePos :: Sehe -> Sehe
+        updatePos (Sehe p v) = Sehe (p + v) v
+
+sampleUpdate :: UpdateFn SampleState
+sampleUpdate _ = sehes . traverse %= moveSehe
+
+config :: Config
+config = 
+    Config
+        { windowTitle = "Sample - Sprite"
+        , windowSize  = (1024, 768)
+        }
+
+main :: IO ()
+main = runApp config sampleLoad sampleUpdate sampleDraw

@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+import Hate
+import Hate.Graphics
+
+import Control.Applicative
+import Control.Lens
+import System.Random
+
+-- sample 4
+
+data Koala = Koala {
+    _pos :: Vec2,
+    _num :: Int
+}
+makeLenses ''Koala
+
+data SampleState = SampleState {
+    _koalaSpriteSheet :: SpriteSheet,
+    _koalas :: [Koala]
+}
+makeLenses ''SampleState
+
+generateKoalas :: IO [Koala] 
+generateKoalas = mapM generateKoala [0..24]
+
+generateKoala :: Int -> IO Koala
+generateKoala i = do
+    let px = 128 * (fromIntegral $ i `div` 5)
+    let py = 128 * (fromIntegral $ i `mod` 5)
+    n <- getStdRandom $ randomR (0 :: Int,3)
+
+    return $ Koala (Vec2 px py) n
+
+sampleLoad :: LoadFn SampleState
+sampleLoad = SampleState <$> loadSpriteSheet "samples/nooble.png" (2,2)
+                         <*> generateKoalas
+
+sampleDraw :: DrawFn SampleState
+sampleDraw s = map (\(Koala p n) -> translate p $ spriteSheet TopLeft (n `div` 10) (s ^. koalaSpriteSheet)) $ s ^. koalas
+
+sampleUpdate :: UpdateFn SampleState
+sampleUpdate _ = koalas . traverse . num %= \n -> if n > 39 then 0 else n+1
+
+config :: Config
+config = 
+    Config
+        { windowTitle = "Sample - Sprite"
+        , windowSize  = (1024, 768)
+        }
+
+main :: IO ()
+main = runApp config sampleLoad sampleUpdate sampleDraw

@@ -0,0 +1,16 @@+module Hate +    ( module Hate.Common+    , module Hate.Math+    , module Hate.Events.Types+    , module Control.Monad.State+    , module Control.Monad.Reader+    , module Graphics.UI.GLFW+    ) where++import Control.Monad.State+import Control.Monad.Reader (ask)+import Graphics.UI.GLFW (Key(..))++import Hate.Common (LoadFn, UpdateFn, DrawFn, whenKeyPressed, runApp, Config(..))+import Hate.Math+import Hate.Events.Types

@@ -0,0 +1,246 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++{-|+Module      : HateCommon+Description : Core and common parts of the Hate framework.+License     : MIT+Maintainer  : bananu7@o2.pl+Stability   : experimental+Portability : requires OpenGL and GLFW build+-}++module Hate.Common +    ( module Hate.Common.Types+    , module Hate.Common.Instances+    , Hate.Common.Types.Hate(..)    +    , runApp+    , getKey+    , whenKeyPressed+    ) where++import Hate.Util +import Hate.Common.Types+import Hate.Common.Instances()+import Hate.Events++import Hate.Graphics.Rendering+import Hate.Graphics.Backend++import Control.Monad.State+import Control.Applicative++import System.Exit+import System.IO++import Graphics.Rendering.OpenGL(($=))+import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLFW as G++import Data.Maybe++import Control.Concurrent (threadDelay)++-- Assuming this doesn't change, for now+-- this actually controls update rate, as the display+-- rate is vsynced+desiredFPS = 60.0+desiredSPF = 1.0 / desiredFPS++stderrErrorCallback :: G.ErrorCallback+stderrErrorCallback _ = hPutStrLn stderr+ +--keyCallback :: G.KeyCallback+--keyCallback win key _ action _ =+--    when (key == G.Key'Escape && action == G.KeyState'Pressed) $+--        G.setWindowShouldClose win True        ++choose :: [IO (Maybe a)] -> IO (Maybe a)+choose [] = return Nothing+choose (x:xs) = do+    a <- x+    if isJust a+        then return a -- short-circuit+        else choose xs -- eventually fall to Nothing++data GlContextDescriptor = GlContextDescriptor {+    majVersion :: Int,+    minVersion :: Int,+    forwardCompat :: Bool+} deriving Show++hateInitWindow :: String -> (Int, Int) -> IO G.Window+hateInitWindow titl wSize = do+    G.setErrorCallback (Just stderrErrorCallback)+    successfulInit <- G.init+    -- if init failed, we exit the program+    bool successfulInit (hateFailureExit "GLFW Init failed") $ do+        mw <- choose+            [ tryOpenWindow (GlContextDescriptor 4 5 True) wSize titl+            , tryOpenWindow (GlContextDescriptor 4 5 False) wSize titl+            , tryOpenWindow (GlContextDescriptor 4 4 True) wSize titl+            , tryOpenWindow (GlContextDescriptor 3 3 True) wSize titl+            , tryOpenWindow (GlContextDescriptor 3 3 False) wSize titl+            ]++        case mw of+            Nothing -> G.terminate >> (hateFailureExit "Window creation failed")+            Just win -> do+                G.makeContextCurrent mw+                G.swapInterval 1 --vsync+                hateInitGL+                return win++tryOpenWindow :: GlContextDescriptor -> (Int, Int) -> String -> IO (Maybe G.Window)+tryOpenWindow cd (width, height) titl = do+    putStrLn $ "Opening Window (" ++ show cd ++ ")"++    G.windowHint (G.WindowHint'ContextVersionMajor (majVersion cd))+    G.windowHint (G.WindowHint'ContextVersionMinor (minVersion cd))+    G.windowHint (G.WindowHint'OpenGLForwardCompat (forwardCompat cd))+    G.windowHint (G.WindowHint'OpenGLProfile G.OpenGLProfile'Core)+    G.windowHint (G.WindowHint'OpenGLDebugContext True)+    G.createWindow width height titl Nothing Nothing++hateInitGL :: IO ()+hateInitGL = do+    GL.blend $= GL.Enabled+    GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)++hateFailureExit :: String -> IO a+hateFailureExit errMsg = do+    hPutStrLn stderr errMsg+    exitFailure++hateSuccessfulExit :: G.Window -> IO b+hateSuccessfulExit win = do+    G.destroyWindow win+    G.terminate+    exitSuccess++-- this function is so generic because it used to work with universally+-- quantified Renderer. Now that libraryState uses RendererI it's not strictly+-- necessary, but I don't mind leaving it here either.+updateRendererState :: (forall r. Renderer r => (r -> IO (a, r))) -> HateInner us a+updateRendererState mutator = do+    g <- gets libraryState+    case g of+        (LibraryState{ graphicsState = gs, ..}) -> do+            (ret, ngs) <- liftIO $ mutator gs+            modify $ \g -> g { libraryState = LibraryState { graphicsState = ngs, .. }}+            return $ ret++runHateDraw :: (forall r. Renderer r => StateT r IO a) -> HateInner us a+runHateDraw m = updateRendererState (runStateT m)++hateLoop :: HateInner us ()+hateLoop = do+    gs <- get+    let w = window gs++    shouldClose <- (liftIO . G.windowShouldClose) w+    unless shouldClose $ do +        liftIO $ do+            (width, height) <- G.getFramebufferSize w+            --let ratio = fromIntegral width / fromIntegral height+    +            GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral width) (fromIntegral height))+            GL.clear [GL.ColorBuffer]++        -- call user drawing function+        let drawRequests = drawFn gs $ userState gs+        runHateDraw $ render drawRequests++        -- update the game state in constant intervals+        Just t <- liftIO G.getTime+        let tDiff = t - (lastUpdateTime gs)++        evts <- reverse <$> fetchEvents+        let groupedEvts = groupEventsByTime (lastUpdateTime gs) desiredSPF evts++        when (tDiff > desiredSPF) $ if length groupedEvts > 0+            then mapM_ hateUpdate groupedEvts+            else hateUpdate []+++        when (tDiff < desiredSPF) $ liftIO $+            threadDelay (floor $ 1000000 * (desiredSPF - tDiff))++        liftIO $ do +            G.swapBuffers w+            G.pollEvents+        hateLoop++groupEventsByTime :: Time -> Time -> [TimedEvent] -> [[TimedEvent]]+groupEventsByTime _ _ [] = []+groupEventsByTime lastTime frameLength evts = current : groupEventsByTime (lastTime + frameLength) frameLength next+    where+        (current, next) = span inCurrentFrame evts+        inCurrentFrame = ((lastTime + frameLength) >) . fst++hateUpdate :: [TimedEvent] -> HateInner us ()+hateUpdate evts = do+    handleInternalEvents . map snd $ evts++    -- uncomment to print all the events out    +    -- liftIO $ mapM print evts++    let allowedEvts = filter allowedEvent . map snd $ evts++    gs <- get+    runHate $ (updateFn gs) allowedEvts+    modify $ \x -> x { lastUpdateTime = lastUpdateTime x + desiredSPF }++handleInternalEvents :: [Event] -> HateInner us ()+handleInternalEvents = mapM_ handleEvent+    where+        handleEvent e = case e of+            EventWindowSize xs ys -> do+                liftIO $ GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral xs) (fromIntegral ys))+                runHateDraw $ updateScreenSize (xs, ys)+            _ -> return ()++getKey :: G.Key -> Hate us Bool+getKey k = UnsafeHate $ do+    gs <- get+    stt <- liftIO $ G.getKey (window gs) k +    return $ keystateToBool stt+    where keystateToBool s+            | s == G.KeyState'Released = False+            | otherwise = True++whenKeyPressed :: G.Key -> Hate us () -> Hate us ()+whenKeyPressed k action = do+    b <- getKey k+    if b then action +         else return ()++-- This function is called after the window has been created+pickRenderer :: (Int, Int) -> IO RendererI+pickRenderer ws = do+    (G.Version vMaj vMin _) <- G.getVersion+    if vMaj >= 4+        then initialRendererStateModern ws+        else initialRendererStateCompat ws++initialLibraryState :: Config -> IO LibraryState+initialLibraryState cfg = LibraryState <$> pickRenderer (windowSize cfg)+                                       <*> initialEventsState++runApp :: Config -> LoadFn us -> UpdateFn us -> DrawFn us -> IO ()+runApp config ldFn upFn drFn = do+    win <- hateInitWindow (windowTitle config) (windowSize config)+    libState <- initialLibraryState config++    setCallbacks (eventsState libState) win++    print $! "Loading user state"+    initialUserState <- ldFn++    time <- fromJust <$> G.getTime+    evalStateT hateLoop $ HateState { userState = initialUserState, window = win, drawFn = drFn, updateFn = upFn, libraryState = libState, lastUpdateTime = time }+    hateSuccessfulExit win    

@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++module Hate.Common.Instances() where++import Hate.Common.Types+import Control.Monad.State++instance MonadState us (Hate us) where+    get = UnsafeHate $ gets userState++    put s = UnsafeHate $ do+            gs <- get+            put $ gs { userState = s }

@@ -0,0 +1,97 @@+{-# LANGUAGE RankNTypes #-}
+
+{-|
+Module      : Hate.Common.Scheduler
+Description : Event scheduler for Hate programs
+License     : MIT
+Maintainer  : bananu7@o2.pl
+Stability   : experimental
+
+Scheduler allows you to use FRP-ish style of delaying and
+scheduling actions.
+
+-}
+
+module Hate.Common.Scheduler 
+    ( every
+    , after
+    , process
+    , emptyScheduler
+    , schedule
+    , Scheduler
+    )
+where
+
+import Hate.Common.Types
+
+import Data.MultiMap
+import Data.Maybe (catMaybes)
+import Control.Monad.State
+
+type Time = Double
+type EventAction us = Hate us ()
+
+data ScheduledEvent us = OneTimeEvent Time (EventAction us) | RepetitiveEvent Time Time (EventAction us)
+instance Show (ScheduledEvent us) where
+    show (OneTimeEvent t _) = "OneTimeEvent (t = " ++ show t ++ ")"
+    show (RepetitiveEvent t i _) = "RepetitiveEvent (t = " ++ show t ++ ", interval = " ++ show i ++ ")"
+
+fire :: ScheduledEvent us -> Hate us ()
+fire (OneTimeEvent _ a) = a
+fire (RepetitiveEvent _ _ a) = a
+
+-- |This represents a control structure for your events.
+-- You can use multiple schedulers and update them basing on the
+-- state of your application.
+type Scheduler us = MultiMap Time (ScheduledEvent us)
+instance (Show a, Show b) => Show (MultiMap a b) where
+    show x = show . toMap $ x
+
+-- |Schedules an action to run every @t@ seconds.
+every :: Time -> Hate us () -> Hate us (ScheduledEvent us)
+every interval action = do
+    t <- UnsafeHate $ gets lastUpdateTime
+    return $ RepetitiveEvent t interval action
+
+-- |Schedules an action to run once, after @t@ seconds.
+after :: Time -> Hate us () -> Hate us (ScheduledEvent us)
+after t a = do
+    currentTime <- UnsafeHate $ gets lastUpdateTime
+    return $ OneTimeEvent (t + currentTime) a
+
+-- |This is a main way to update the scheduler and run appropriate events.
+-- Typically you'll want to be running it every update.
+process :: Scheduler us -> Hate us (Scheduler us)
+process sched = do
+    currTime <- UnsafeHate $ gets lastUpdateTime
+    --UnsafeHate . liftIO $ putStrLn ("currenttime " ++ show currTime)
+
+    let maybeEvents = findMinWithValues sched
+    case maybeEvents of 
+        Just (t, nearestEvents) ->
+            if currTime > t then do
+                mapM_ fire nearestEvents
+
+                let sched' = delete t sched
+                let updatedEvents = catMaybes . Prelude.map (updateEvent currTime) $ nearestEvents
+
+                let sched'' = Prelude.foldr (flip schedule) sched' updatedEvents
+
+                process sched'' -- recursive call to inspect the next batch
+            else return sched -- no events to fire yet
+        Nothing -> return sched -- no events scheduled at all
+
+-- |This is provided in case the underlying implementation should change.
+emptyScheduler :: Scheduler us
+emptyScheduler = empty
+
+-- |Adds a new event to scheduler and returns an updated one.
+schedule :: Scheduler us -> ScheduledEvent us -> Scheduler us
+schedule sched evt = case evt of
+    OneTimeEvent time _ -> insert time evt sched
+    RepetitiveEvent time _ _ -> insert time evt sched
+
+
+updateEvent :: Time -> ScheduledEvent us -> Maybe (ScheduledEvent us)
+updateEvent _ (OneTimeEvent _ _) = Nothing
+updateEvent _ (RepetitiveEvent lastFire interval act) = Just $ RepetitiveEvent (lastFire+interval) interval act

@@ -0,0 +1,60 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}++module Hate.Common.Types+    ( Config(..)+    , LibraryState(..)+    , HateState(..)+    , HateInner+    , Hate(..)+    , LoadFn+    , UpdateFn+    , DrawFn+    )+where++import Control.Monad.State+import Control.Applicative+import qualified Graphics.UI.GLFW as G++import Hate.Graphics.Types(DrawRequest)+import Hate.Graphics.Rendering+import Hate.Events.Types (Event, EventsState)++data LibraryState = LibraryState {+    graphicsState :: RendererI,+    eventsState :: EventsState+}++{-| Configuration object to pass to `runApp` -}+data Config+    = Config+        { windowTitle :: String+        , windowSize :: (Int, Int)+        } deriving (Eq, Show)++data HateState us = HateState { +    userState :: us,+    libraryState :: LibraryState,+    window :: G.Window,+    drawFn :: DrawFn us,+    updateFn :: UpdateFn us,+    lastUpdateTime :: Double+}++-- |HateInner is the actual implementation backend+type HateInner us a = StateT (HateState us) IO a++-- |Hate Monad restricts user operations+newtype Hate us a = UnsafeHate { runHate :: HateInner us a }+    deriving (Functor, Applicative, Monad, MonadIO)++{- |This is one of the three functions that the user has to+provide in order to use the framework. It's a regular IO+function, so it's not limited in any way. It has to produce+initial state of the user's program. -}+type LoadFn userStateType = IO userStateType++type UpdateFn us = [Event] -> Hate us ()++type DrawFn us = us -> [DrawRequest]

@@ -0,0 +1,106 @@+module Hate.Events
+    ( initialEventsState
+    , setCallbacks
+    , fetchEvents
+    , allowedEvent
+    , module Hate.Events.Types
+    )
+where
+
+import qualified Graphics.UI.GLFW as GLFW
+
+import Control.Concurrent.STM    (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue)
+import Hate.Events.Types
+import Hate.Common.Types
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State.Class (gets)
+import Control.Applicative
+import Data.Maybe
+
+import GHC.Float (double2Float)
+
+initialEventsState :: IO EventsState
+initialEventsState = newTQueueIO :: IO (TQueue TimedEvent)
+
+{- The code has been borrowed from GLFW-b-demo; thanks @bsl -}
+
+-- I assume only one window can be used by the framework
+
+time = fromJust <$> GLFW.getTime
+
+writeWithTime :: TQueue TimedEvent -> Event -> IO ()
+writeWithTime tc e = time >>= \t -> atomically . writeTQueue tc $ (t, e)
+
+errorCallback           :: TQueue TimedEvent -> GLFW.Error -> String                                                            -> IO ()
+windowPosCallback       :: TQueue TimedEvent -> GLFW.Window -> Int -> Int                                                       -> IO ()
+windowSizeCallback      :: TQueue TimedEvent -> GLFW.Window -> Int -> Int                                                       -> IO ()
+windowCloseCallback     :: TQueue TimedEvent -> GLFW.Window                                                                     -> IO ()
+windowRefreshCallback   :: TQueue TimedEvent -> GLFW.Window                                                                     -> IO ()
+windowFocusCallback     :: TQueue TimedEvent -> GLFW.Window -> GLFW.FocusState                                                  -> IO ()
+windowIconifyCallback   :: TQueue TimedEvent -> GLFW.Window -> GLFW.IconifyState                                                -> IO ()
+framebufferSizeCallback :: TQueue TimedEvent -> GLFW.Window -> Int -> Int                                                       -> IO ()
+mouseButtonCallback     :: TQueue TimedEvent -> GLFW.Window -> GLFW.MouseButton   -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
+cursorPosCallback       :: TQueue TimedEvent -> GLFW.Window -> Double -> Double                                                 -> IO ()
+cursorEnterCallback     :: TQueue TimedEvent -> GLFW.Window -> GLFW.CursorState                                                 -> IO ()
+scrollCallback          :: TQueue TimedEvent -> GLFW.Window -> Double -> Double                                                 -> IO ()
+keyCallback             :: TQueue TimedEvent -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys            -> IO ()
+charCallback            :: TQueue TimedEvent -> GLFW.Window -> Char                                                             -> IO ()
+
+errorCallback           tc e s            = writeWithTime tc $ EventError           e s
+windowPosCallback       tc _ x y          = writeWithTime tc $ EventWindowPos       x y
+windowSizeCallback      tc _ w h          = writeWithTime tc $ EventWindowSize      w h
+windowCloseCallback     tc _              = writeWithTime tc $ EventWindowClose
+windowRefreshCallback   tc _              = writeWithTime tc $ EventWindowRefresh
+windowFocusCallback     tc _ fa           = writeWithTime tc $ EventWindowFocus     fa
+windowIconifyCallback   tc _ ia           = writeWithTime tc $ EventWindowIconify   ia
+framebufferSizeCallback tc _ w h          = writeWithTime tc $ EventFramebufferSize w h
+mouseButtonCallback     tc _ mb mba mk    = writeWithTime tc $ EventMouseButton     mb mba mk
+cursorPosCallback       tc _ x y          = writeWithTime tc $ EventCursorPos       (double2Float x) (double2Float y)
+cursorEnterCallback     tc _ ca           = writeWithTime tc $ EventCursorEnter     ca
+scrollCallback          tc _ x y          = writeWithTime tc $ EventScroll          x y
+keyCallback             tc _ k sc ka mk   = writeWithTime tc $ EventKey             k sc ka mk
+charCallback            tc _ c            = writeWithTime tc $ EventChar            c
+
+setErrorCallback :: TQueue TimedEvent -> IO ()
+setErrorCallback eventsChan = GLFW.setErrorCallback $ Just $ errorCallback eventsChan
+
+setCallbacks :: EventsState -> GLFW.Window -> IO ()
+setCallbacks eventsChan win = do
+    GLFW.setWindowPosCallback       win $ Just $ windowPosCallback       eventsChan
+    GLFW.setWindowSizeCallback      win $ Just $ windowSizeCallback      eventsChan
+    GLFW.setWindowCloseCallback     win $ Just $ windowCloseCallback     eventsChan
+    GLFW.setWindowRefreshCallback   win $ Just $ windowRefreshCallback   eventsChan
+    GLFW.setWindowFocusCallback     win $ Just $ windowFocusCallback     eventsChan
+    GLFW.setWindowIconifyCallback   win $ Just $ windowIconifyCallback   eventsChan
+    GLFW.setFramebufferSizeCallback win $ Just $ framebufferSizeCallback eventsChan
+    GLFW.setMouseButtonCallback     win $ Just $ mouseButtonCallback     eventsChan
+    GLFW.setCursorPosCallback       win $ Just $ cursorPosCallback       eventsChan
+    GLFW.setCursorEnterCallback     win $ Just $ cursorEnterCallback     eventsChan
+    GLFW.setScrollCallback          win $ Just $ scrollCallback          eventsChan
+    GLFW.setKeyCallback             win $ Just $ keyCallback             eventsChan
+    GLFW.setCharCallback            win $ Just $ charCallback            eventsChan
+
+fetchEvents :: HateInner us [TimedEvent]
+fetchEvents = fetchEvents' []
+    where 
+        fetchEvents' :: [TimedEvent] -> HateInner us [TimedEvent]
+        fetchEvents' xs = do
+            tc <- gets (eventsState . libraryState)
+            me <- liftIO $ atomically $ tryReadTQueue tc
+            case me of
+                Just e -> fetchEvents' (e:xs)
+                Nothing -> return xs
+
+-- | Some events aren't meant to impact the user, and should be handled
+-- internally by framework instead.
+
+allowedEvent :: Event -> Bool
+allowedEvent (EventWindowClose)       = True
+allowedEvent (EventWindowFocus _)     = True
+allowedEvent (EventMouseButton _ _ _) = True
+allowedEvent (EventCursorPos _ _)     = True
+allowedEvent (EventScroll _ _)        = True
+allowedEvent (EventKey _ _ _ _)       = True
+allowedEvent (EventChar _)            = True
+allowedEvent _ = False

@@ -0,0 +1,26 @@+module Hate.Events.Types where
+
+import Control.Concurrent.STM (TQueue)
+import qualified Graphics.UI.GLFW as GLFW
+
+type EventsState = TQueue TimedEvent
+type Time = Double
+
+data Event =
+    EventError           !GLFW.Error !String
+  | EventWindowPos       !Int !Int
+  | EventWindowSize      !Int !Int
+  | EventWindowClose
+  | EventWindowRefresh
+  | EventWindowFocus     !GLFW.FocusState
+  | EventWindowIconify   !GLFW.IconifyState
+  | EventFramebufferSize !Int !Int
+  | EventMouseButton     !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys
+  | EventCursorPos       !Float !Float
+  | EventCursorEnter     !GLFW.CursorState
+  | EventScroll          !Double !Double
+  | EventKey             !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys
+  | EventChar            !Char
+  deriving Show
+
+type TimedEvent = (Time, Event)

@@ -0,0 +1,27 @@+{-|+Module      : Hate.Graphics+Description : Hate graphics +License     : MIT+Maintainer  : bananu7@o2.pl+Stability   : experimental+Portability : To whatever has OpenGL in a reasonable version.++This module contains graphics+-}++module Hate.Graphics+    ( module Hate.Graphics.Pipeline+    , module Hate.Graphics.Pipeline.Util+    , module Hate.Graphics.Types+    , module Hate.Graphics.Rendering+    , module Hate.Graphics.Sprite+    , module Hate.Graphics.Shapes+    )+where++import Hate.Graphics.Pipeline+import Hate.Graphics.Pipeline.Util+import Hate.Graphics.Types+import Hate.Graphics.Rendering+import Hate.Graphics.Sprite+import Hate.Graphics.Shapes

@@ -0,0 +1,32 @@+module Hate.Graphics.Backend 
+    ( RendererI(..)
+    , initialRendererStateModern
+    , initialRendererStateCompat
+    )
+where
+
+import qualified Hate.Graphics.Backend.Modern as Modern
+import qualified Hate.Graphics.Backend.Compat as Compat
+
+import Hate.Graphics.Rendering
+
+import Control.Monad.State
+
+instance Renderer RendererI where
+    contextRequirements (RendererImpl a) = contextRequirements a
+    --initialRendererState s = fmap RendererImpl $ initialRendererState s
+    updateScreenSize s = do
+        (RendererImpl a) <- get
+        a' <- execStateT (updateScreenSize s) a
+        put $ RendererImpl a'
+
+    render x = do
+        (RendererImpl a) <- get
+        a' <- execStateT (render x) a
+        put $ RendererImpl a'
+
+initialRendererStateModern :: (Int, Int) -> IO RendererI
+initialRendererStateCompat :: (Int, Int) -> IO RendererI
+
+initialRendererStateModern s = fmap RendererImpl $ Modern.initialGraphicsState s
+initialRendererStateCompat s = fmap RendererImpl $ Compat.initialGraphicsState s

@@ -0,0 +1,106 @@+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Hate.Graphics.Backend.Compat (BackendCompat(), initialGraphicsState) where
+
+import Hate.Graphics.Backend.Compat.Types
+import Hate.Graphics.Backend.Compat.Shaders
+
+import Hate.Math
+import Hate.Graphics.Rendering
+import Hate.Graphics.Pipeline.Util
+import Hate.Graphics.Pipeline
+import Hate.Graphics.Types
+import Hate.Graphics.Backend.Util
+
+
+import Control.Monad.State
+
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.GLUtil as U
+
+import Data.Vect.Float.OpenGL (orthoMatrix)
+import Data.List (groupBy)
+import Data.Maybe
+import Control.Applicative
+
+instance Renderer BackendCompat where
+    --initialRendererState = initialGraphicsState
+    render = renderBatch
+    contextRequirements _ = DesktopContext 4 4
+    updateScreenSize = updateScreenSz
+
+type Action a = (MonadState BackendCompat m, MonadIO m) => m a
+
+initialGraphicsState :: (Int, Int) -> IO BackendCompat
+initialGraphicsState screenSz =
+    BackendCompat <$> createPipelineNoUniformBindings solidColorPipelineDescs
+                  <*> createPipelineNoUniformBindings texturingPipelineDescs
+                  <*> createVertexStream
+                  <*> pure screenSz
+
+renderBatch :: [DrawRequest] -> Action ()
+renderBatch ds = mapM_ (\xs -> renderPipelineBatch (pipeline . head $ xs) xs) $ groupBy equalPipeline ds
+    where
+        a `equalPipeline` b = pipeline a == pipeline b
+
+renderPipelineBatch :: PipelineDescription -> [DrawRequest] -> Action ()
+renderPipelineBatch p ds = do
+    pip <- case p of
+        SolidColorPipeline color -> do
+            pip <- gets solidColorPipeline -- todo set up a proper solid color,
+            liftIO $ do
+                activatePipeline pip
+                colorUniformLocation <- GL.get $ GL.uniformLocation (program pip) "in_color"
+                GL.uniform colorUniformLocation $= color
+                return pip
+        TexturingPipeline texId -> do
+            pip <- gets texturingPipeline
+            liftIO $ activatePipeline pip
+            liftIO $ GL.textureBinding GL.Texture2D $= Just texId
+            return pip
+
+    forM_ ds $ \d -> do
+        let mat = transformation d .*. origin d
+        setScreenTransformationUniform mat pip
+
+        fromVertArrayIntoGlobal (vertices d, texCoords d)
+        let primitiveMode = vertexLayoutToGLLayout $ vertexLayout d
+        renderGlobalVertexStream primitiveMode
+
+setScreenTransformationUniform :: Mat4 -> Pipeline -> Action ()
+setScreenTransformationUniform t pip = do
+    (screenSizeX, screenSizeY) <- gets screenSize
+
+    let orthoScreenMat = orthoMatrix (0, (fromIntegral screenSizeX)) ((fromIntegral screenSizeY), 0) (-10, 10)
+    let drawMat = (transpose orthoScreenMat) .*. t
+    liftIO $ setUniformM4 pip "screen_transformation" drawMat
+
+renderGlobalVertexStream :: GL.PrimitiveMode -> Action ()
+renderGlobalVertexStream primitiveMode = do
+    vs <- gets globalVertexStream
+    liftIO $ do
+        GL.bindVertexArrayObject $= Just (vao vs)
+        GL.drawArrays primitiveMode 0 (fromIntegral $ vertNum vs)
+
+updateScreenSz :: (Int, Int) -> Action ()
+updateScreenSz sz = modify $ \g -> g { screenSize = sz }
+
+fromVertArrayInto :: ([Vec2], Maybe [Vec2]) -> VertexStream -> Action VertexStream
+fromVertArrayInto (verts, maybeTexCoords) s = liftIO $ do
+    GL.bindBuffer GL.ArrayBuffer $= Just (vbo s)
+    U.replaceBuffer GL.ArrayBuffer verts
+
+    -- fill in texture coordinates if needed
+    let texCoords' = fromMaybe (calculateTexCoords verts) maybeTexCoords
+    GL.bindBuffer GL.ArrayBuffer $= Just (texVbo s)
+    U.replaceBuffer GL.ArrayBuffer texCoords'
+
+    return $ s { vertNum = length verts }
+
+fromVertArrayIntoGlobal :: ([Vec2], Maybe [Vec2]) -> Action ()
+fromVertArrayIntoGlobal xs = do
+    m <- gets globalVertexStream
+    m' <- fromVertArrayInto xs m
+    modify $ \x -> x { globalVertexStream = m' }

@@ -0,0 +1,53 @@+module Hate.Graphics.Backend.Compat.Shaders
+    ( createPipelineNoUniformBindings
+    )
+where
+
+import Hate.Graphics.Shader
+import Hate.Graphics.Pipeline
+import Hate.Graphics.Pipeline.Util
+import qualified Data.ByteString.Char8 as BS (ByteString, pack)
+
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.GLUtil as U
+
+import Data.Maybe (catMaybes)
+
+shaderStr :: ShaderDesc -> String
+shaderStr (ShaderDesc p ins outs unifs body) = header ++ "void main() {\n" ++ body ++ "\n}\n"
+    where versionStr = "#version 330 core"
+          precisionStr = show p
+          inputsStr = unlines . map show $ ins
+          outputsStr = unlines . map show $ outs
+          uniformsStr = unlines . map show $ unifs
+          header = unlines [versionStr, precisionStr, inputsStr, outputsStr, uniformsStr]
+
+shaderBStr :: ShaderDesc -> BS.ByteString
+shaderBStr sd = BS.pack $ shaderStr sd
+
+-- |This is a workaround for pre-4.2 OpenGL
+createPipelineNoUniformBindings :: (ShaderDesc, ShaderDesc) -> IO Pipeline
+createPipelineNoUniformBindings (sdv, sdf) = do
+    let (bindsV, sdv') = stripUniformBindings sdv
+    let (bindsF, sdf') = stripUniformBindings sdf
+
+    p <- createPipelineSource (shaderBStr sdv') (shaderBStr sdf')
+    mapM_ (applyPendingUniformBinding p) (bindsV ++ bindsF) 
+    return p
+
+data PendingUniformBinding = PendingUniformBinding String GL.TextureUnit
+
+stripUniformBindings :: ShaderDesc -> ([PendingUniformBinding], ShaderDesc)
+stripUniformBindings sd = (,) (catMaybes . map uniformToPendingUniform . sdUniforms $ sd) (strip sd)
+    where strip sd = sd { sdUniforms = map strip1 $ sdUniforms sd }
+          strip1 (Uniform typeTag _ name) = Uniform typeTag Nothing name
+
+uniformToPendingUniform :: Uniform -> Maybe PendingUniformBinding
+uniformToPendingUniform (Uniform typeTag maybeBinding name) = 
+    fmap (\(Binding x) -> PendingUniformBinding name (GL.TextureUnit (fromIntegral x))) maybeBinding
+
+applyPendingUniformBinding :: Pipeline -> PendingUniformBinding -> IO ()
+applyPendingUniformBinding p (PendingUniformBinding name x) = do
+    loc <- GL.get $ GL.uniformLocation (program p) name
+    GL.uniform loc $= x

@@ -0,0 +1,12 @@+module Hate.Graphics.Backend.Compat.Types where
+
+import Hate.Graphics.Types
+import Hate.Graphics.Pipeline
+
+-- supposedly needs more vertex streams and pipelines in the future
+data BackendCompat = BackendCompat { 
+    solidColorPipeline :: Pipeline,
+    texturingPipeline :: Pipeline,
+    globalVertexStream :: VertexStream,
+    screenSize :: (Int, Int)
+}

@@ -0,0 +1,108 @@+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Hate.Graphics.Backend.Modern (BackendModern(), initialGraphicsState) where
+
+import Hate.Graphics.Backend.Modern.Types
+
+import Hate.Math
+import Hate.Graphics.Backend.Modern.Shaders
+import Hate.Graphics.Rendering
+import Hate.Graphics.Pipeline.Util
+import Hate.Graphics.Pipeline
+import Hate.Graphics.Types
+import Hate.Graphics.Backend.Util
+
+import Control.Monad.State
+
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.GLUtil as U
+
+import Data.Vect.Float.OpenGL (orthoMatrix)
+import Data.List (groupBy)
+import Data.Maybe
+import Control.Applicative
+
+instance Renderer BackendModern where
+    --initialRendererState = initialGraphicsState
+    render = renderBatch
+    contextRequirements _ = DesktopContext 4 4
+    updateScreenSize = updateScreenSz
+
+type Action a = (MonadState BackendModern m, MonadIO m) => m a
+
+initialGraphicsState :: (Int, Int) -> IO BackendModern
+initialGraphicsState screenSz =
+    BackendModern <$> createPipeline solidColorPipelineDescs
+                  <*> createPipeline texturingPipelineDescs
+                  <*> createVertexStream
+                  <*> pure screenSz
+
+renderBatch :: [DrawRequest] -> Action ()
+renderBatch ds = mapM_ (\xs -> renderPipelineBatch (pipeline . head $ xs) xs) $ groupBy equalPipeline ds
+    where
+        a `equalPipeline` b = pipeline a == pipeline b
+
+-- informal contract > p == pipeline . head $ ds
+renderPipelineBatch :: PipelineDescription -> [DrawRequest] -> Action ()
+renderPipelineBatch p ds = do
+    pip <- case p of
+        SolidColorPipeline color -> do
+            pip <- gets solidColorPipeline
+            liftIO $ do
+                activatePipeline pip
+                colorUniformLocation <- GL.get $ GL.uniformLocation (program pip) "in_color"
+                GL.uniform colorUniformLocation $= color
+                return pip
+
+        TexturingPipeline texId -> do
+            pip <- gets texturingPipeline
+            liftIO $ activatePipeline pip
+            liftIO $ GL.textureBinding GL.Texture2D $= Just texId
+            return pip
+
+    forM_ ds $ \d -> do
+        let mat = transformation d .*. origin d
+        setScreenTransformationUniform mat pip
+
+        fromVertArrayIntoGlobal (vertices d, texCoords d)
+        let primitiveMode = vertexLayoutToGLLayout $ vertexLayout d
+        renderGlobalVertexStream primitiveMode
+
+setScreenTransformationUniform :: Mat4 -> Pipeline -> Action ()
+setScreenTransformationUniform t pip = do
+    (screenSizeX, screenSizeY) <- gets screenSize
+
+    let orthoScreenMat = orthoMatrix (0, (fromIntegral screenSizeX)) ((fromIntegral screenSizeY), 0) (-10, 10)
+    let drawMat = (transpose orthoScreenMat) .*. t
+    liftIO $ setUniformM4 pip "screen_transformation" drawMat
+
+renderGlobalVertexStream :: GL.PrimitiveMode -> Action ()
+renderGlobalVertexStream primitiveMode = do
+    vs <- gets globalVertexStream
+    liftIO $ do
+        GL.bindVertexArrayObject $= Just (vao vs)
+        GL.drawArrays primitiveMode 0 (fromIntegral $ vertNum vs)
+
+
+updateScreenSz :: (Int, Int) -> Action ()
+updateScreenSz sz = modify $ \g -> g { screenSize = sz }
+
+fromVertArrayInto :: ([Vec2], Maybe [Vec2]) -> VertexStream -> Action VertexStream
+fromVertArrayInto (verts, maybeTexCoords) s = liftIO $ do
+    GL.bindBuffer GL.ArrayBuffer $= Just (vbo s)
+    U.replaceBuffer GL.ArrayBuffer verts
+
+    -- fill in texture coordinates if needed
+    let texCoords' = fromMaybe (calculateTexCoords verts) maybeTexCoords
+    GL.bindBuffer GL.ArrayBuffer $= Just (texVbo s)
+    U.replaceBuffer GL.ArrayBuffer texCoords'
+
+    return $ s { vertNum = length verts }
+
+fromVertArrayIntoGlobal :: ([Vec2], Maybe [Vec2]) -> Action ()
+fromVertArrayIntoGlobal xs = do
+    m <- gets globalVertexStream
+    m' <- fromVertArrayInto xs m
+    modify $ \x -> x { globalVertexStream = m' }

@@ -0,0 +1,24 @@+module Hate.Graphics.Backend.Modern.Shaders
+	( createPipeline
+	)
+where
+
+import Hate.Graphics.Shader
+import Hate.Graphics.Pipeline
+import Hate.Graphics.Pipeline.Util
+import qualified Data.ByteString.Char8 as BS (ByteString, pack)
+
+shaderStr :: ShaderDesc -> String
+shaderStr (ShaderDesc p ins outs unifs body) = header ++ "void main() {\n" ++ body ++ "\n}\n"
+    where versionStr = "#version 440 core"
+          precisionStr = show p
+          inputsStr = unlines . map show $ ins
+          outputsStr = unlines . map show $ outs
+          uniformsStr = unlines . map show $ unifs
+          header = unlines [versionStr, precisionStr, inputsStr, outputsStr, uniformsStr]
+
+shaderBStr :: ShaderDesc -> BS.ByteString
+shaderBStr sd = BS.pack $ shaderStr sd
+
+createPipeline :: (ShaderDesc, ShaderDesc) -> IO Pipeline
+createPipeline (sdv, sdf) = createPipelineSource (shaderBStr sdv) (shaderBStr sdf)

@@ -0,0 +1,12 @@+module Hate.Graphics.Backend.Modern.Types where
+
+import Hate.Graphics.Types
+import Hate.Graphics.Pipeline
+
+-- supposedly needs more vertex streams and pipelines in the future
+data BackendModern = BackendModern { 
+    solidColorPipeline :: Pipeline,
+    texturingPipeline :: Pipeline,
+    globalVertexStream :: VertexStream,
+    screenSize :: (Int, Int)
+}

@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Hate.Graphics.Backend.Util where
+
+--import qualified Codec.Picture as JP
+--import Data.Vector.Storable (unsafeWith)
+
+import Hate.Graphics.Types
+import Hate.Graphics.Shader
+import Hate.Math
+
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.GLUtil as U
+import qualified Data.ByteString.Char8 as BS (ByteString)
+
+import Data.List (maximumBy)
+import Data.Ord
+
+createVertexStream :: IO VertexStream
+createVertexStream = do
+    _vao <- (GL.genObjectName :: IO GL.VertexArrayObject)
+    _vbo <- U.makeBuffer GL.ArrayBuffer ([] :: [Vec2])
+    _texVbo <- U.makeBuffer GL.ArrayBuffer ([] :: [Vec2])
+    let _vertNum = 0
+
+    GL.bindVertexArrayObject $= Just _vao
+    GL.bindBuffer GL.ArrayBuffer $= (Just _vbo)
+    GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled
+    GL.vertexAttribPointer (GL.AttribLocation 0) $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 U.offset0)
+
+    GL.bindBuffer GL.ArrayBuffer $= (Just _texVbo)
+    GL.vertexAttribArray (GL.AttribLocation 1) $= GL.Enabled
+    GL.vertexAttribPointer (GL.AttribLocation 1) $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 U.offset0)
+
+    return $ VertexStream { vao = _vao, vbo = _vbo, texVbo = _texVbo, vertNum = _vertNum }
+
+calculateTexCoords :: [Vec2] -> [Vec2]
+calculateTexCoords verts = map (flipY . pointwise scaleFactor) verts
+    where
+        maxX = _1 $ maximumBy (comparing _1) verts
+        maxY = _2 $ maximumBy (comparing _2) verts
+        scaleFactor = Vec2 (1 / maxX) (1 / maxY)
+        flipY (Vec2 x y) = Vec2 x y
+
+vertexLayoutToGLLayout :: VertexLayout -> GL.PrimitiveMode
+vertexLayoutToGLLayout FanVertexLayout = GL.TriangleFan
+vertexLayoutToGLLayout StripVertexLayout = GL.TriangleStrip
+vertexLayoutToGLLayout LinesVertexLayout = GL.Lines
+
+type ShaderSource = BS.ByteString
+
+-- global, shared pipeline things
+globalShader :: [Input] -> [Output] -> [Uniform] -> String -> ShaderDesc
+globalShader = ShaderDesc MediumPrecision
+
+globalVertexInputs :: [Input]
+globalVertexInputs =
+    [ Input Vec2Tag (Just $ Location 0) "position"
+    , Input Vec2Tag (Just $ Location 1) "texcoord"
+    ]
+
+globalVertexUniforms :: [Uniform]
+globalVertexUniforms = [Uniform Mat4Tag Nothing "screen_transformation"]
+
+globalVertexShader :: [Input] -> [Output] -> [Uniform] -> String -> ShaderDesc
+globalVertexShader i o u s = globalShader
+    (globalVertexInputs ++ i)
+    o
+    (globalVertexUniforms ++ u)
+    s
+
+globalFragmentOutputs :: [Output]
+globalFragmentOutputs = [Output Vec4Tag "color"]
+
+globalFragmentUniforms :: [Uniform]
+globalFragmentUniforms = [] -- TODO: add time
+
+globalFragmentShader :: [Input] -> [Uniform] -> String -> ShaderDesc
+globalFragmentShader i u s = globalShader
+    i
+    globalFragmentOutputs
+    (globalFragmentUniforms ++ u)
+    s
+
+makeGlobalPipelineDescs :: [Input] -> [Uniform] -> [Varying] -> [Uniform] -> String -> String -> (ShaderDesc, ShaderDesc)
+makeGlobalPipelineDescs vertexInputs vertexUniforms varyings fragmentUniforms vss fss =
+    ( globalVertexShader vertexInputs (map toOutput varyings) vertexUniforms vss
+    , globalFragmentShader (map toInput varyings) fragmentUniforms fss
+    )
+
+solidColorPipelineDescs :: (ShaderDesc, ShaderDesc)
+solidColorPipelineDescs = makeGlobalPipelineDescs [] [] []
+    [Uniform Vec4Tag Nothing "in_color"]
+    vss fss
+    where
+        vss = unlines
+            ["    gl_Position = screen_transformation * vec4(position, 0, 1);"
+            ]
+
+        fss = "    color = in_color;"
+
+texturingPipelineDescs :: (ShaderDesc, ShaderDesc)
+texturingPipelineDescs = makeGlobalPipelineDescs
+    [] -- no additional vertex inputs
+    [] -- no additional vertex uniforms
+    [ Varying Vec2Tag "var_position"
+    , Varying Vec2Tag "var_texcoord"
+    ]
+    [Uniform Sampler2DTag Nothing "mainTexture"] -- our sprite texture
+    vss
+    fss
+    where
+        vss = unlines
+            ["    gl_Position = screen_transformation * vec4(position, 0, 1);"
+            ,"    var_position = position / 10;"
+            ,"    var_texcoord = texcoord;"
+            ]
+        fss = "    color = texture(mainTexture, var_texcoord);"

@@ -0,0 +1,10 @@+module Hate.Graphics.Pipeline where++import qualified Graphics.Rendering.OpenGL as GL++-- |Pipeline object is a complete package needed to render something on the screen.+data Pipeline = Pipeline {+    vertexShader   :: GL.Shader,+    fragmentShader :: GL.Shader,+    program        :: GL.Program+    }

@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts #-}
+
+module Hate.Graphics.Pipeline.Util
+    ( activatePipeline
+    , setUniformM4 
+    , createPipelineSource   
+    )
+where
+
+import Hate.Graphics.Pipeline
+
+import Graphics.Rendering.OpenGL(($=))
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as U
+
+import Data.Vect.Float
+import Data.Vect.Float.OpenGL
+
+import qualified Data.ByteString as BS
+
+activatePipeline :: Pipeline -> IO ()
+activatePipeline p = GL.currentProgram $= Just (program p)
+
+--setUniformM3 :: Pipeline -> String -> Mat3 -> IO ()
+--setUniformM3 = setUniformMatGeneric U.uniformGLMat4
+
+setUniformM4 :: Pipeline -> String -> Mat4 -> IO ()
+setUniformM4 = setUniformMatGeneric U.uniformGLMat4
+
+setUniformMatGeneric setter pip name mat = do
+    activatePipeline pip
+    matLoc <- GL.get (GL.uniformLocation (program pip) name)
+
+    let tMat = mat
+    glmat <- makeGLMatrix tMat
+    setter matLoc $= glmat
+
+-- "deep" utils
+createPipelineSource :: BS.ByteString -> BS.ByteString -> IO Pipeline
+createPipelineSource vss fss = do 
+    vs <- U.loadShaderBS "VertexShader" GL.VertexShader vss
+    fs <- U.loadShaderBS "FragmentShader" GL.FragmentShader fss
+    prog <- U.linkShaderProgram [vs, fs]
+
+    return $ Pipeline vs fs prog
+
+-- |This function takes paths to vertex and fragment shaders
+createPipelineFromFiles :: FilePath -> FilePath -> IO Pipeline
+createPipelineFromFiles vertShaderPath fragShaderPath = do
+    vs <- BS.readFile vertShaderPath
+    fs <- BS.readFile fragShaderPath
+    createPipelineSource vs fs

@@ -0,0 +1,27 @@+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Hate.Graphics.Rendering where
+
+import Hate.Graphics.Types (DrawRequest)
+import Control.Monad.State
+import Control.Monad.IO.Class
+
+-- | Context type specifies the expectation on surroundings of the backend
+-- Desktop means OpenGL, ES - OpenGL ES, and Web - WebGL.
+-- Desktop context can require a minor and major version.
+data ContextRequirements = DesktopContext Int Int | ESContext Int | WebContext
+
+type ScreenSize = (Int, Int)
+
+-- | A class for renderer backends, i.e. something that can render stuff
+class Renderer a where
+    contextRequirements  :: a -> ContextRequirements
+    --initialRendererState :: ScreenSize -> IO a
+    updateScreenSize     :: (MonadState a m, MonadIO m) => ScreenSize -> m ()
+    render               :: (MonadState a m, MonadIO m) => [DrawRequest] -> m ()
+
+-- PIMPL MY RIDE
+data RendererI = forall a. (Renderer a) => RendererImpl a

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module Hate.Graphics.Shader where
+
+-- data
+type Name = String
+
+data FloatPrecision = HighPrecision | MediumPrecision | LowPrecision
+
+newtype Location = Location Int
+
+data TypeTag = FloatTag | Vec2Tag | Vec3Tag | Vec4Tag | Mat2Tag | Mat3Tag | Mat4Tag | Sampler2DTag
+
+data Input = Input TypeTag (Maybe Location) Name
+    
+data Output = Output TypeTag Name
+
+newtype Binding = Binding Int
+
+data Uniform = Uniform TypeTag (Maybe Binding) Name
+
+data Varying = Varying TypeTag Name
+
+data ShaderDesc = ShaderDesc {
+    sdFloatPrecision :: FloatPrecision,
+    sdInputs :: [Input],
+    sdOutputs :: [Output],
+    sdUniforms :: [Uniform],
+    sdBody :: String
+}
+
+-- show
+showMaybe :: Show a => Maybe a -> String
+showMaybe (Just x) = show x
+showMaybe Nothing = ""
+
+instance Show FloatPrecision where
+    show HighPrecision      = "precision highp float;"
+    show MediumPrecision    = "precision mediump float;"
+    show LowPrecision       = "precision lowp float;"
+
+instance Show Location where 
+    show (Location loc) =  "layout(location = " ++ show loc ++ ") "
+
+instance Show TypeTag where
+    show FloatTag = "float"
+    show Vec2Tag = "vec2"
+    show Vec3Tag = "vec3"
+    show Vec4Tag = "vec4"
+    show Mat2Tag = "mat2"
+    show Mat3Tag = "mat3"
+    show Mat4Tag = "mat4"
+    show Sampler2DTag = "sampler2D"
+
+instance Show Input where
+    show (Input tag loc name) = showMaybe loc ++ "in " ++ show tag ++ " " ++ name ++ ";"
+
+instance Show Output where
+    show (Output tag name) = "out " ++ show tag ++ " " ++ name ++ ";"
+
+instance Show Binding where 
+    show (Binding bnd) =  "layout(binding = " ++ show bnd ++ ") "
+
+instance Show Uniform where
+    show (Uniform tag bnd name) = showMaybe bnd ++ "uniform " ++ show tag ++ " " ++ name ++ ";"
+
+-- Utils
+
+toInput :: Varying -> Input
+toInput (Varying tag name) = Input tag Nothing name
+
+toOutput :: Varying -> Output
+toOutput (Varying tag name) = Output tag name

@@ -0,0 +1,38 @@+module Hate.Graphics.Shapes where
+
+import Hate.Graphics.Types
+import Hate.Math
+
+-- |Moves the drawn primitive. Note that order of operations matters.
+translate :: Vec2 -> DrawRequest -> DrawRequest
+translate p d = d { transformation = newT }
+    where oldT = transformation d
+          newT = oldT .*. positionToMatrix4 p
+
+-- |Scales the drawn primitive.
+scaled :: Vec2 -> DrawRequest -> DrawRequest
+scaled s d = d { transformation = newT }
+    where oldT = transformation d
+          newT = oldT .*. scaleToMatrix4 s
+
+-- |Rotates the drawn primitive in the Z axis (keeps it flat).
+rotated :: Float -> DrawRequest -> DrawRequest
+rotated r d = d { transformation = newT }
+    where oldT = transformation d
+          newT = oldT .*. rotationToMatrix4 r
+
+colored :: Color -> DrawRequest -> DrawRequest
+colored color (DrawRequest verts coords origin layout transf _) = DrawRequest verts coords origin layout transf (SolidColorPipeline color)
+
+-- |Constructs a 'DrawRequest' containing vertices in a shape of a circle.
+-- /Note that the current implementation always produces a fixed amount of vertices./
+circle :: Float -> DrawRequest
+circle r = DrawRequest verts Nothing one FanVertexLayout one (SolidColorPipeline (Vec4 1.0 1.0 1.0 1.0))
+    where
+        verts = map (flip rotateVec $ vec2 0 r) $ angles
+        angles = map ((* pi2) . (/ segNum)) $ [0..(segNum-1)]
+        pi2 = 2 * pi
+        segNum = 100
+
+line :: Vec2 -> Vec2 -> DrawRequest
+line start end = DrawRequest [start, end] Nothing one LinesVertexLayout one (SolidColorPipeline (Vec4 1.0 1.0 1.0 1.0))

@@ -0,0 +1,111 @@+module Hate.Graphics.Sprite 
+    ( loadSprite
+    , loadSpriteSheet
+    , sprite
+    , spriteSheet
+    , spritePart
+    )
+where
+
+import Hate.Graphics.Types
+import Hate.Math
+
+import qualified Codec.Picture as JP
+import qualified Codec.Picture.RGBA8 as JPU
+import Data.Vector.Storable (unsafeWith)
+
+import System.Exit
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (($=))
+
+import Control.Applicative
+
+--drawSquare t = draw $ Polygon $ transform t [vec 0 0, vec 0 1, vec 1 1, vec 1 0]
+
+loadImageDataIntoTexture :: JP.Image JP.PixelRGBA8 -> IO ()
+loadImageDataIntoTexture (JP.Image width height dat) = do
+    unsafeWith dat $ GL.build2DMipmaps GL.Texture2D GL.RGBA8 (fromIntegral width) (fromIntegral height)
+      . GL.PixelData GL.RGBA GL.UnsignedByte
+
+loadImageDataIntoTexture _ = error "Not yet supported"
+
+getImageSize :: JP.Image JP.PixelRGBA8 -> (Int, Int)
+getImageSize (JP.Image width height _) = (width, height)
+
+-- |Loads a file from disk and constructs a drawable sprite.
+loadSprite :: FilePath -> IO Sprite
+loadSprite path = do
+    image <- (fmap . fmap) JPU.fromDynamicImage $ JP.readImage path
+    case image of
+        (Left err) -> do print err
+                         exitWith (ExitFailure 1)
+        (Right imgData) -> do 
+            texId <- GL.genObjectName :: IO GL.TextureObject
+            GL.textureBinding GL.Texture2D $= Just texId
+            loadImageDataIntoTexture imgData
+            GL.textureFilter  GL.Texture2D GL.$= ((GL.Nearest, Just GL.Nearest), GL.Nearest)
+            GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)
+            GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)
+            return $ Sprite { texture = texId, size = getImageSize imgData }
+
+-- |Loads a sprite sheet from disk.
+loadSpriteSheet :: FilePath
+                -> (Int, Int) -- ^ The size in tiles of the sheet
+                -> IO SpriteSheet
+loadSpriteSheet path sz = SpriteSheet <$> loadSprite path <*> pure sz
+
+-- |Creates a 'DrawRequest' that draws a sprite. The 'OriginReference' parameter specifices the
+-- "hooking point" for the rotations and translations.
+sprite :: OriginReference -> Sprite -> DrawRequest
+sprite originRef (Sprite (w,h) t) = DrawRequest quad Nothing originMat FanVertexLayout one (TexturingPipeline t)
+    where
+        quad = [Vec2 0 0, Vec2 fw 0, Vec2 fw fh, Vec2 0 fh]
+        fw = fromIntegral w
+        fh = fromIntegral h
+        originMat = calcSpriteOriginMatrix originRef fw fh
+
+-- |Creates a 'DrawRequest' with a rectangle cut out of a regular sprite sheet. The number specifies the 
+-- index of the sprite, counting from the top-left one.
+spriteSheet :: OriginReference -> Int -> SpriteSheet -> DrawRequest
+spriteSheet originRef num (SpriteSheet (Sprite (w,h) t) (sx, sy)) = DrawRequest quad texCoords originMat FanVertexLayout one (TexturingPipeline t)
+    where 
+        quad = [Vec2 0 0, Vec2 fw 0, Vec2 fw fh, Vec2 0 fh]
+        texCoords = Just $ [ Vec2 txStart tyStart
+                           , Vec2 txEnd tyStart
+                           , Vec2 txEnd tyEnd
+                           , Vec2 txStart tyEnd
+                           ]
+
+        coordX = num `mod` sx
+        coordY = num `div` sx
+
+        txStart = fromIntegral coordX / fromIntegral sx
+        tyStart = fromIntegral coordY / fromIntegral sy
+        txEnd = fromIntegral (coordX + 1) / fromIntegral sx
+        tyEnd = fromIntegral (coordY + 1) / fromIntegral sy
+
+        fw = fromIntegral w / fromIntegral sx
+        fh = fromIntegral h / fromIntegral sy
+        originMat = calcSpriteOriginMatrix originRef fw fh
+
+-- | Creates a 'DrawRequest' with a rectangle cut out of a sprite
+spritePart :: (Vec2, Vec2) -> Sprite -> DrawRequest
+spritePart (Vec2 x1 y1, Vec2 x2 y2) (Sprite (w,h) t) = dr
+    where
+        dr = DrawRequest quad texCoords one FanVertexLayout one (TexturingPipeline t)
+        quad = [Vec2 0 0, Vec2 fw 0, Vec2 fw fh, Vec2 0 fh]
+
+        texCoords = Just $ [ Vec2 x1 y1
+                           , Vec2 x2 y1
+                           , Vec2 x2 y2
+                           , Vec2 x1 y2
+                           ]
+
+        fw = fromIntegral w * (x2-x1)
+        fh = fromIntegral h * (y2-y1)
+
+calcSpriteOriginMatrix :: OriginReference -> Float -> Float -> Mat4
+calcSpriteOriginMatrix originRef fw fh =
+    case originRef of
+        TopLeft -> one
+        Middle -> positionToMatrix4 $ Vec2 (-fw/2) (-fh/2)

@@ -0,0 +1,41 @@+module Hate.Graphics.Types where++import qualified Graphics.Rendering.OpenGL as GL+import Data.Vect.Float+import Data.Vect.Float.Instances()++-- |A general type for a graphical mesh, either in indexed or raw form.+data VertexStream = VertexStream {+    vao :: GL.VertexArrayObject,+    vbo :: GL.BufferObject,+    texVbo :: GL.BufferObject,+    vertNum :: Int+} deriving (Eq, Show)++-- userspace data+data PipelineDescription = SolidColorPipeline Vec4 | TexturingPipeline GL.TextureObject deriving (Eq, Show)++data VertexLayout = FanVertexLayout | StripVertexLayout | LinesVertexLayout deriving (Eq, Show)++data OriginReference = TopLeft | Middle deriving (Eq, Show)++data DrawRequest = DrawRequest { +    vertices :: [Vec2],+    texCoords :: Maybe [Vec2],+    origin :: Mat4,+    vertexLayout :: VertexLayout,+    transformation :: Mat4,+    pipeline :: PipelineDescription+} deriving (Eq, Show)++data Sprite = Sprite {+    size :: (Int, Int),+    texture :: GL.TextureObject+} deriving (Eq, Show)++data SpriteSheet = SpriteSheet {+    spriteRef :: Sprite,+    sheetSize :: (Int, Int)+}++type Color = Vec4

@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleInstances #-}
+
+{-|
+Module      : Hate.Math
+Description : Hate mathematical utilities
+License     : MIT
+Maintainer  : bananu7@o2.pl
+Stability   : provisional
+Portability : full
+
+This module mostly works with primitives from @Data.Vect@,
+adding some utilities useful in rendering and OpenGL
+interoperability.
+
+-}
+
+module Hate.Math 
+    ( module Data.Vect.Float
+    , module Hate.Math.Util
+    , module Hate.Math.Types
+    )
+where
+
+import Data.Vect.Float
+import Data.Vect.Float.Instances()
+
+import Hate.Math.Types
+import Hate.Math.Util

@@ -0,0 +1,6 @@+module Hate.Math.Transformable.Class where++import Hate.Math.Types++class Transformable t where+    transform :: Transformation -> t -> t

@@ -0,0 +1,12 @@+module Hate.Math.Types where+	+import Data.Vect.Float+import Data.Vect.Float.Instances()++data Transformation = Transformation { +    position :: Vec2,+    rotation :: Rotation,+    scale :: Vec2+} deriving (Eq, Show)++type Rotation = Float

@@ -0,0 +1,61 @@+module Hate.Math.Util where
+
+import Hate.Math.Types
+import Data.Vect.Float
+
+identityTransform :: Transformation
+identityTransform = Transformation 0 0 1
+
+rotateVec :: Rotation -> Vec2 -> Vec2
+rotateVec a (Vec2 x y) = Vec2 (x * cos a - y * sin a) (x * sin a + y * cos a)
+
+--type Vec2 = GL.Vertex2 Float
+vec2 :: Float -> Float -> Vec2 
+vec2 = Vec2
+
+toMatrix :: Transformation -> Mat3
+toMatrix (Transformation p r s) = rotationToMatrix r .*. positionToMatrix p .*. scaleToMatrix s
+
+positionToMatrix :: Vec2 -> Mat3
+positionToMatrix (Vec2 x y) = Mat3 
+    (Vec3 1 0 x)
+    (Vec3 0 1 y)
+    (Vec3 0 0 1)
+
+rotationToMatrix :: Float -> Mat3
+rotationToMatrix r = Mat3
+    (Vec3 (cos r) (negate $ sin r) 0)
+    (Vec3 (sin r) (         cos r) 0)
+    (Vec3 0                      0 1)
+
+scaleToMatrix :: Vec2 -> Mat3
+scaleToMatrix (Vec2 x y) = Mat3
+    (Vec3 x 0 0)
+    (Vec3 0 y 0)
+    (Vec3 0 0 1)
+
+
+toMatrix4 :: Transformation -> Mat4
+toMatrix4 (Transformation p r s) =  positionToMatrix4 p .*. rotationToMatrix4 r .*. scaleToMatrix4 s
+
+positionToMatrix4 :: Vec2 -> Mat4
+positionToMatrix4 (Vec2 x y) = Mat4
+    (Vec4 1 0 0 x)
+    (Vec4 0 1 0 y)
+    (Vec4 0 0 1 0)
+    (Vec4 0 0 0 1)
+
+rotationToMatrix4 :: Float -> Mat4
+rotationToMatrix4 r = Mat4
+    (Vec4 (cos r) (negate $ sin r) 0 0)
+    (Vec4 (sin r) (         cos r) 0 0)
+    (Vec4 0                      0 1 0)
+    (Vec4 0                      0 0 1)
+
+scaleToMatrix4 :: Vec2 -> Mat4
+scaleToMatrix4 (Vec2 x y) = Mat4
+    (Vec4 x 0 0 0)
+    (Vec4 0 y 0 0)
+    (Vec4 0 0 1 0)
+    (Vec4 0 0 0 1)
+