intiial commit

18 files changed, 2332 insertions, 0 deletions

diff --git a/Data/ByteStringBuilder.hs b/Data/ByteStringBuilder.hs
new file mode 100644
index 0000000..859d710
--- /dev/null
+++ b/Data/ByteStringBuilder.hs
@@ -0,0 +1,32 @@
+module Data.ByteStringBuilder where
+
+import Data.ByteString.Lazy as BSL
+import Data.ByteString.Lazy.Char8 as BSLC
+import Data.Word
+
+data ByteStringBuilder a = ByteStringBuilder ByteString a
+type Builder = ByteStringBuilder ()
+
+put :: ByteString -> Builder 
+put = flip ByteStringBuilder ()
+
+putS :: String -> Builder
+putS = put . BSLC.pack
+
+putSLn :: String -> Builder
+putSLn str = putS str >> putC '\n'
+
+putC :: Char -> Builder
+putC = put . BSLC.singleton
+
+putB :: Word8 -> Builder
+putB = put . BSL.singleton
+
+runBuilder :: Builder -> ByteString
+runBuilder (ByteStringBuilder bs _) = bs
+
+instance Monad ByteStringBuilder where
+    ByteStringBuilder a _ >> ByteStringBuilder b c = ByteStringBuilder (a `append` b) c
+    a@(ByteStringBuilder _ b) >>= func = a >> func b
+    return = ByteStringBuilder BSL.empty
+    fail = error
diff --git a/EventHandler.hs b/EventHandler.hs
new file mode 100644
index 0000000..4452c17
--- /dev/null
+++ b/EventHandler.hs
@@ -0,0 +1,3 @@
+module EventHandler where
+
+eventHandler
diff --git a/Final.hs b/Final.hs
new file mode 100644
index 0000000..a9c8ac4
--- /dev/null
+++ b/Final.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Graphics.Rendering.OpenGL as GL
+import Graphics.UI.SDL.Image as SDLImg
+import Graphics.UI.SDL as SDL
+import Graphics.SDL.SDLHelp
+import Graphics.Glyph.Util
+import Control.Monad
+
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.ObjLoader
+
+import qualified Data.Map as Map
+import Data.Word
+import Data.Array
+import Data.Array.IO
+
+import Debug.Trace
+import Data.Bits
+
+import TileShow
+import Resources
+import System.Random
+import Debug.Trace
+
+
+
+data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | 
+                Tundra | Unknown deriving Enum
+$(makeShow ''TileType)
+
+
+data Tile = Tile {
+    tileType :: TileType,
+    elevation :: Int
+} deriving Show
+
+buildArray :: SDL.Surface -> SDL.Surface -> IO (Array (Int,Int) Tile)
+buildArray terrain height = 
+    let w = min (SDL.surfaceGetWidth terrain) $ SDL.surfaceGetWidth height
+        h = min (SDL.surfaceGetHeight terrain) $ SDL.surfaceGetHeight height
+        conv (x,y) = 
+                let terrainVal = fromIntegral $ getPixelUnsafe x y terrain
+                    sumit word =
+                                ((word `shiftR` 8) .&. 0xFF) +
+                                ((word `shiftR`16) .&. 0xFF) +
+                                ((word `shiftR`24) .&. 0xFF)
+                    heightVal  = (fromIntegral.sumit) (getPixelUnsafe x y height)
+                    terrainVal' = Map.findWithDefault Main.Unknown terrainVal tileMap in
+                Tile terrainVal' heightVal
+        list = map conv [(x,y) | x <- [0..w-1], y <- [0..h-1]]
+
+        in do
+            putStrLn $ show (head list)
+            return $ listArray ((0,0),(w-1,h-1)) list
+
+printArray :: Array (Int,Int) Tile -> IO ()
+printArray arr = do
+    let (_,(w,h)) = bounds arr
+    putStrLn $ "w=" ++! w
+    putStrLn $ "h=" ++! h
+    forM_ [0..h-1] $ \y -> do
+        forM_ [0..w-1] $ \x -> do
+            let next = arr ! (x,y)
+            putStr $ (show $ tileType next) 
+        putStr "    "
+        forM_ [0..w-1] $ \x -> do
+            let next = arr ! (x,y)
+            putStr $ (elevShow $ elevation next) 
+        putStrLn ""
+    where elevShow x = 
+            let len = length elevMap
+                nx = x `div` 5 in
+            if nx > len then "=" else [elevMap !! nx]
+          elevMap = "`.,-~*<:!;%&#@0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+
+toColor :: TileType -> (GLfloat,GLfloat,GLfloat,GLfloat)
+toColor Tundra = (0.5,0.5,0.5,1.0)
+toColor Mountains = (0.5,0.4,0.03,1.0)
+toColor Grass = (0,0.3,0.0,1.0)
+toColor Jungle = (0,1.0,0.0,1.0)
+toColor Forest = (0,0.2,0.0,1.0)
+toColor Beach = (0.7,0.7,0.6,1.0)
+toColor Water = (0,0,1.0,1.0)
+
+tileMap :: Map.Map Word32 TileType
+tileMap =
+    let c = rgbToWord in
+    Map.insert    (c 100 100 100) Tundra  $
+    Map.insert    (c 128 100 20) Mountains  $
+    Map.insert    (c 0 100 0) Grass  $
+    Map.insert    (c 0 255 0) Jungle $
+    Map.insert    (c 0 50 0) Forest $
+    Map.insert    (c 255 255 255) Beach  $
+    Map.singleton (c 0 0 255) Water
+
+createBuilder :: Array (Int,Int) Tile -> BuilderM GLfloat ()
+createBuilder arr = do
+    let (_,(w,h)) = bounds arr
+
+    let lst = concatMap (\(x,y) ->
+            let g (x',z',w') = (x', fromIntegral (elevation $ arr ! (x',z')) / 10.0, z', w') in
+
+            [g (x,  y  ,1::Int),
+             g (x-1,y  ,1),
+             g (x-1,y-1,1),
+             g (x,  y-1,1)] )
+
+            [(x,y) | x <- [1..w], y <- [1..h]]
+
+    inferingNormals $ do
+        forM_ (trianglesFromQuads lst) $ \(x,y,z,_) -> do
+            let f = fromIntegral
+            let bUseTexture a = bColor4 (0,0,0,f a)
+            -- TODO un hardcode these
+            bUseTexture $ fromEnum (tileType $ arr ! (x,z))
+            bTexture2 (f x / 10.0, f z / 10.0)
+            bVertex3 (f x, y,f z)
+            
+createForestBuilder :: Array (Int,Int) Tile -> StdGen -> ObjectFile GLfloat -> BuilderM GLfloat ()
+createForestBuilder arr gen file = do
+
+    let (_,(w,h)) = bounds arr
+    let getElev x y = if x >= w || y >= h || x < 0 || y < 0 then 0 else fromIntegral (elevation $ arr ! (x,y)) /10.0
+    let !treeF = 
+         trace "build tree" $
+            basicBuildObject file
+
+    let run :: [Int] -> (Int,Int) -> BuilderM GLfloat [Int]
+        run rs (x,y) = do
+            let ((_:he), t) = splitAt (head rs `mod` 13 + 1) rs
+            let signum' = floor.signum
+
+            when (isForest x y) $ do
+                forM_ he $ \rand -> do
+                    let (a,b,_) = mapT3 f (toTup rand)
+                    let elev = getElev x y
+                    let elev_dx = getElev (x + signum' a) y
+                    let elev_dy = getElev x (y + signum' b)
+                    let realelev =
+                         ((elev * (1-abs a) + elev_dx * (abs a)) +
+                          (elev * (1-abs b) + elev_dy * (abs b))) / 2.0
+                    when (elev_dx > 0 && elev_dy > 0) $ do
+                        translating (fromIntegral x+a,realelev,fromIntegral y+b) $ do
+                            treeF
+                            
+
+            return t
+
+    _ <- foldM run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]
+
+    return ()
+    where isForest x y =
+            case tileType $ arr ! (x,y) of
+                Forest -> True
+                _ -> False
+          f x = (fromIntegral x - 128) / 128 * (sqrt 2 / 2)
+          toTup x = ( (x .&. 0xFF),
+                      (x `shiftR` 8) .&. 0xFF,
+                      (x `shiftR` 16) .&. 0xFF)
+        
+
+main :: IO ()
+main = do
+    putStrLn "Loading..."
+    terrain <- SDLImg.load "terrain.png"
+    height <- SDLImg.load "height.png"
+    putStrLn "Done Loading ..."
+
+    arr <- buildArray terrain height
+    putStrLn "Array Built"
+    -- printArray arr
+
+    surface <- simpleStartup "Spectical" (640,480)
+    stgen <- newStdGen
+    (log',file) <- loadObjFile "tree.obj"
+    mapM_ putStrLn log'
+
+    makeResources surface (createBuilder arr) (createForestBuilder arr stgen file) >>= startPipeline reshape eventHandle displayHandle updateHandle;
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
new file mode 100644
index 0000000..ec27a89
--- /dev/null
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -0,0 +1,283 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.BufferBuilder where
+
+import Control.Monad
+import Graphics.Rendering.OpenGL
+import Foreign.Storable
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Data.Array.Storable
+import Data.Setters
+import Debug.Trace
+import qualified Data.Foldable as Fold
+import Data.Sequence as Seq
+import Data.Map as Map
+
+import Graphics.Glyph.Mat4
+import Graphics.Glyph.Util
+import Graphics.Glyph.GLMath
+
+import System.IO.Unsafe
+import Unsafe.Coerce
+
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+bufferSize :: BufferBuilder3D -> Int
+bufferSize End = 0
+bufferSize (Plot _ _ l _) = l
+
+nelem :: BufferBuilder3D -> Int
+nelem End = 0
+nelem (Plot _ _ _ l) = l
+
+sizeofGLfloat :: Int
+sizeofGLfloat = 4
+
+class Monad a => IsModelBuilder b a where
+    plotVertex3 :: b -> b -> b -> a ()
+    plotNormal  :: b -> b -> b -> a ()
+    plotTexture :: b -> b ->a ()
+
+{- A state monad that keeps track of operations
+ - and will compile them into a buffer -}
+
+data BuilderM b a = BuilderM (Builder (BuildDatum b)) a
+data Builder b = Builder
+                    !(Builder b) -- before
+                    !(Builder b) -- after
+                  | LeafBuilder !(Seq b) deriving Show
+
+instance IsModelBuilder GLfloat (BuilderM GLfloat) where
+    plotVertex3 x y z = bVertex3 (x,y,z)
+    plotNormal x y z  = bNormal3 (x,y,z)
+    plotTexture x y   = bTexture2 (x,y)
+
+data BuildDatum b =
+    VertexLink (b,b,b)  |
+    NormalLink (b,b,b)  |
+    ColorLink (b,b,b,b) |
+    TextureLink (b,b) deriving Show
+
+data CompiledBuild b = CompiledBuild {
+    bStride :: Int,
+    bEnabled :: (Bool,Bool,Bool),
+    nElems  :: Int,
+    array :: Ptr b,
+    arrayBytes :: Int
+}
+
+bufferLength :: (Integral a) => CompiledBuild b -> a
+bufferLength = fromIntegral . nElems
+
+instance Show (CompiledBuild x) where
+    show (CompiledBuild stride enabled n ptr nbytes) =
+        "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++" ptr="++!ptr++" nbytes="++!nbytes++"]"
+
+instance (Num t) => Monad (BuilderM t) where
+    (BuilderM !builder1 _) >> (BuilderM !builder2 ret) =
+        BuilderM (builder1 ><> builder2) ret
+        where
+            b1@(LeafBuilder !seq1) ><> b2@(LeafBuilder !seq2) 
+                | Seq.length seq1 + Seq.length seq2 < 128 = LeafBuilder (seq1 >< seq2)
+                | otherwise = Builder b1 b2
+            (Builder !b1 !b2)  ><> leaf@(LeafBuilder !_)  =
+                (Builder b1 (b2 ><> leaf))
+            builder1 ><> builder2 = (Builder builder1 builder2)
+
+    b1@(BuilderM _ ret) >>= func = b1 >> func ret
+
+    return = BuilderM (LeafBuilder Seq.empty)
+    fail = undefined
+
+instance Functor Builder where
+    fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
+    fmap f (LeafBuilder seq) = (LeafBuilder (fmap f seq))
+
+instance Fold.Foldable Builder where
+    foldl f ini (Builder b1 b2) = 
+        Fold.foldl f (Fold.foldl f ini b1) b2
+    foldl f ini (LeafBuilder seq) =
+        Fold.foldl f ini seq
+
+    foldr f ini (Builder b1 b2) = 
+        Fold.foldr f (Fold.foldr f ini b2) b1
+    foldr f ini (LeafBuilder seq) =
+        Fold.foldr f ini seq
+
+expandBuilder :: Builder a -> b -> (b -> a -> (b,[a])) -> Builder a
+expandBuilder builder ini f = snd $ expandBuilder' builder ini f
+    where expandBuilder' :: Builder a -> b -> (b -> a -> (b,[a])) -> (b,Builder a)
+
+          expandBuilder' (Builder builder1 builder2) ini f = 
+            let (snowball1,newBuilder1) = expandBuilder' builder1 ini f
+                (snowball2,newBuilder2) = expandBuilder' builder2 snowball1 f in
+                (snowball2,Builder newBuilder1 newBuilder2)
+
+          expandBuilder' (LeafBuilder seq1) ini f = 
+            let (seq,snow) = Fold.foldl' (\(seq', snow) datum -> 
+                            let (snow',lst) = f snow datum in
+                            (seq' >< Seq.fromList lst,snow')) (Seq.empty,ini) seq1 in
+                (snow,LeafBuilder seq)
+
+{- Add a vertex to the current builder -}
+bVertex3 :: (a,a,a) -> BuilderM a ()
+bVertex3 vert = BuilderM (LeafBuilder (Seq.singleton $ VertexLink vert)) ()
+
+bTexture2 :: (a,a) -> BuilderM a ()
+bTexture2 tex = BuilderM (LeafBuilder (Seq.singleton $ TextureLink tex)) ()
+
+bNormal3 :: (a,a,a) -> BuilderM a ()
+bNormal3 norm = BuilderM (LeafBuilder (Seq.singleton $ NormalLink norm)) ()
+
+bColor4 :: (a,a,a,a) -> BuilderM a ()
+bColor4 col = BuilderM (LeafBuilder (Seq.singleton $ ColorLink col)) ()
+
+writeAndAvance :: (Storable a) => [a] -> Ptr a -> IO (Ptr a)
+writeAndAvance (a:as) ptr = poke ptr a >> writeAndAvance as (advancePtr ptr 1)
+writeAndAvance [] ptr = return ptr
+
+compilingBuilder :: (Storable b, Num b, Show b) => BuilderM b x -> IO (CompiledBuild b)
+compilingBuilder (BuilderM builder _) = do
+
+    putStrLn "COMPILING"
+    -- Size of the elements TODO unhardcode this
+    let sizeof = sizeOf $ builderElem builder
+                  where builderElem :: Builder (BuildDatum a) -> a
+                        builderElem _ = unsafeCoerce (0::Int)
+
+    {- Simply figure out what types of elementse
+     - exist in this buffer -}
+    let (bn,bc,bt,nVerts) = Fold.foldl' (\(bn,bc,bt,len) ele ->
+                                case ele of
+                                    NormalLink _ -> (True,bc,bt,len)
+                                    ColorLink _ -> (bn,True,bt,len)
+                                    TextureLink _ -> (bn,bc,True,len)
+                                    VertexLink _ -> (bn,bc,bt,len+1)) (False,False,False,0) builder
+    {- Calculate the stride; number of floats per element -}
+    let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof
+                    where (?) True = 1
+                          (?) False = 0
+
+    let nbytes = stride * nVerts
+    putStrLn $ "Mallocing array of size: " ++! nbytes
+    array <- mallocArray nbytes
+
+    -- Tuple
+    -- Pointer to current element, current normal/color/texture
+    putStrLn "Writing array buffer"
+    !_ <- Fold.foldlM (\(ptr, cn, cc, ct) ele ->
+           -- trace ("foldl " ++! ele) $
+            case ele of
+                NormalLink nn -> return (ptr,nn,cc,ct)
+                ColorLink nc -> return (ptr,cn,nc,ct)
+                TextureLink nt -> return (ptr,cn,cc,nt)
+                VertexLink vert -> do
+                  ptr' <- writeAndAvance (tp3 True vert) ptr >>=
+                            writeAndAvance (tp3 bn cn) >>=
+                            writeAndAvance (tp4 bc cc) >>=
+                            writeAndAvance (tp2 bt ct)
+                  return (ptr',cn,cc,ct) ) ( array, (0,0,0), (0,0,0,0), (0,0) ) builder
+    putStrLn "Buffer written"
+    let !compiledRet = CompiledBuild stride (bn,bc,bt) nVerts array nbytes
+    putStrLn $ "COMPILE COMPLETE" ++! compiledRet
+    return compiledRet
+
+  where
+      tp2 True (a,b)  = [a,b]
+      tp2 False _  = []
+ 
+      tp3 True (a,b,c) = [a,b,c]
+      tp3 False _ = []
+ 
+      tp4 True (a,b,c,d) = [a,b,c,d]
+      tp4 False _ = []
+
+storableArrayToBuffer :: (Storable el) => BufferTarget -> StorableArray Int el -> IO BufferObject
+storableArrayToBuffer target arr = do
+    let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
+    [buffer] <- genObjectNames 1
+    bindBuffer target $= Just buffer
+    len <- getBounds arr >>= (\(a,b) -> return $ (b - a) * sizeof )
+    withStorableArray arr $ \ptr ->
+        bufferData target $= (fromIntegral len, ptr, StaticDraw)
+    return buffer
+
+ptrToBuffer :: (Storable b) => BufferTarget -> Ptr b -> Int -> IO BufferObject
+ptrToBuffer target ptr len = do
+    -- len is length in bytes
+    [buffer] <- genObjectNames 1
+    bindBuffer target $= Just buffer
+    bufferData target $= (fromIntegral len, ptr, StaticDraw)
+    return buffer
+
+vertexArrayDescriptor :: CompiledBuild GLfloat -> VertexArrayDescriptor GLfloat
+vertexArrayDescriptor (CompiledBuild stride _ _ _ _) = VertexArrayDescriptor 3 Float (fromIntegral stride) (wordPtrToPtr 0)
+
+normalArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
+normalArrayDescriptor (CompiledBuild stride (True,_,_) _ _ _) =
+                Just $ VertexArrayDescriptor 3 Float
+                        (fromIntegral stride) (wordPtrToPtr (3*4))
+normalArrayDescriptor  _ = Nothing
+
+colorArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
+colorArrayDescriptor (CompiledBuild stride tup@(_,True,_) _ _ _) =
+                Just $ VertexArrayDescriptor 4 Float
+                        (fromIntegral stride) (wordPtrToPtr (offset tup))
+                where offset (b1,_,_) = if b1 then (6*4) else (3*4)
+                        
+colorArrayDescriptor  _ = Nothing
+
+textureArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
+textureArrayDescriptor (CompiledBuild stride tup@(_,_,True) _ _ _) =
+                Just $ VertexArrayDescriptor 2 Float
+                        (fromIntegral stride) (wordPtrToPtr (offset tup))
+                where offset (b1,b2,_) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
+                      ifp b x = if b then x else 0  
+textureArrayDescriptor  _ = Nothing
+createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject
+createBufferObject target (CompiledBuild _ _ _ arr len) = ptrToBuffer target arr len
+
+mapListInsert :: (Ord k) => k -> a -> Map.Map k [a] -> Map.Map k [a]
+mapListInsert key val map =
+    flip (Map.insert key) map $
+        case Map.lookup key map of
+            Nothing -> [val]
+            Just x -> (val:x)
+
+inferingNormals :: (RealFloat a,Ord a,Show a) => BuilderM a b -> BuilderM a b
+inferingNormals (BuilderM builder ret) =
+    let (normalMap,_,_) = Fold.foldl' (\(newMap, v1, v2) datum ->
+                            case datum of
+                                VertexLink w ->
+                                    case (v1,v2) of
+                                        (Just u, Just v) -> 
+                                            let (Vec3 normal) = (Vec3 u <-> Vec3 v) × (Vec3 u <-> Vec3 w) in
+                                            (insertWith (zipWithT3 (+)) w normal newMap, Nothing, Nothing)
+                                        (Just u, Nothing) -> (newMap, v1, Just w)
+                                        (Nothing,Nothing) -> (newMap, Just w, Nothing)
+                                _ -> (newMap,v1,v2)
+                                ) (Map.empty,Nothing,Nothing) builder in
+
+    let newBuilder = expandBuilder builder () $ \() datum ->
+         case datum of
+            VertexLink tup ->
+                let normalLink = NormalLink $ maybe (0,0,0) id $ Map.lookup tup normalMap in
+                ((),[normalLink, datum])
+            _ -> ((),[datum]) in
+
+    (BuilderM newBuilder ret)
+
+
+trianglesFromQuads :: [a] -> [a]
+trianglesFromQuads (a:b:c:d:xs) = [a,b,c,a,c,d] ++ trianglesFromQuads xs
+trianglesFromQuads l = l
+
+translating :: (Num a) => (a,a,a) -> BuilderM a b -> BuilderM a b
+translating trans (BuilderM builder ret) = do
+    BuilderM (flip fmap builder $ \datum ->
+                case datum of
+                    VertexLink tup -> VertexLink $ zipWithT3 (+) tup trans
+                    _ -> datum) ret
+translating _ x = x
diff --git a/Graphics/Glyph/ExtendedGL.hs b/Graphics/Glyph/ExtendedGL.hs
new file mode 100644
index 0000000..d42e973
--- /dev/null
+++ b/Graphics/Glyph/ExtendedGL.hs
@@ -0,0 +1,26 @@
+module Graphics.Glyph.ExtendedGL where
+
+import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL.Raw.ARB
+
+marshalPrimitiveMode :: PrimitiveMode -> GLenum
+marshalPrimitiveMode x = case x of
+   Points -> 0x0
+   Lines -> 0x1
+   LineLoop -> 0x2
+   LineStrip -> 0x3
+   Triangles -> 0x4
+   TriangleStrip -> 0x5
+   TriangleFan -> 0x6
+   Quads -> 0x7
+   QuadStrip -> 0x8
+   Polygon -> 0x9
+
+drawArraysInstanced :: PrimitiveMode -> ArrayIndex -> NumArrayIndices -> GLsizei -> IO ()
+drawArraysInstanced = glDrawArraysInstanced . marshalPrimitiveMode
+
+vertexAttributeDivisor :: AttribLocation -> SettableStateVar GLuint
+vertexAttributeDivisor (AttribLocation loc) =
+    makeSettableStateVar $ \val ->
+        glVertexAttribDivisor loc val
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
new file mode 100644
index 0000000..14f12e3
--- /dev/null
+++ b/Graphics/Glyph/GLMath.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -XFlexibleInstances #-}
+module Graphics.Glyph.GLMath where
+    import Graphics.Glyph.Mat4
+    import qualified Graphics.Rendering.OpenGL as GL
+    import Graphics.Rendering.OpenGL (GLfloat,Uniform,Vertex3(..),uniform,UniformComponent)
+    import Data.Angle
+    import Debug.Trace
+
+    data Vec2 a = Vec2 (a,a) deriving Show
+    data Vec3 a = Vec3 (a,a,a) deriving Show
+    data Vec4 a = Vec4 (a,a,a,a) deriving Show
+
+    instance UniformComponent a => Uniform (Vec3 a) where
+        uniform loc = GL.makeStateVar
+                        (do
+                            (Vertex3 x y z) <-
+                                GL.get (uniform loc)
+                            return (Vec3 (x,y,z)) )
+                        (\(Vec3 (x,y,z)) -> uniform loc GL.$= Vertex3 x y z)
+
+    instance UniformComponent a => Uniform (Vec4 a) where
+        uniform loc = GL.makeStateVar
+                        (do
+                            (GL.Vertex4 x y z w) <-
+                                GL.get (uniform loc)
+                            return (Vec4 (x,y,z,w)) )
+                        (\(Vec4 (x,y,z,w)) -> uniform loc GL.$= GL.Vertex4 x y z w)
+
+    class (Floating flT) => Vector flT b where
+        (<+>) :: b flT -> b flT -> b flT
+        (<->) :: b flT -> b flT -> b flT
+        norm :: b flT -> flT
+        normalize :: b flT -> b flT
+        vDot :: b flT -> b flT -> flT
+        vScale :: flT -> b flT -> b flT
+        vNegate :: b flT -> b flT
+
+
+    (<.>) :: (Vector a b) => b a -> b a -> a
+    (<.>) = vDot
+
+    (|||) :: (Vector a b) => b a -> a
+    (|||) = norm
+
+    instance (Floating flT) => Vector flT Vec2 where
+        (<+>) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a+c,b+d)
+        (<->) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a-c,b-d)
+        vDot (Vec2 (a,b)) (Vec2 (c,d)) = a * c + b * d
+        vScale c (Vec2 (a,b)) = Vec2 (a*c,b*c)
+        norm (Vec2 (a,b)) = sqrt (a*a + b*b)
+        normalize vec@(Vec2 (a,b)) = 
+            let n = norm vec in Vec2 (a/n,b/n)
+        vNegate (Vec2 (a,b)) = Vec2 (-a,-b)
+
+    instance (Floating flT) => Vector flT Vec3 where
+        (<+>) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a+d,b+e,c+f)
+        (<->) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a-d,b-e,c-f)
+        vDot (Vec3 (a,b,c)) (Vec3 (d,e,f)) = a * d + b * e + c * f
+        vScale x (Vec3 (a,b,c)) = Vec3 (a*x,b*x,c*x)
+        norm (Vec3 (a,b,c)) = sqrt (a*a + b*b + c*c)
+        normalize vec@(Vec3 (a,b,c)) = 
+            let n = norm vec in Vec3 (a/n,b/n,c/n)
+        vNegate (Vec3 (a,b,c)) = Vec3 (-a,-b,-c)
+
+    instance (Floating flT) => Vector flT Vec4 where
+        (<+>) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a+d,b+e,c+f,g+h)
+        (<->) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a-d,b-e,c-f,g-h)
+        vDot  (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = a * d + b * e + c * f + g * h
+        vScale x (Vec4 (a,b,c,d)) = Vec4 (a*x,b*x,c*x,d*x)
+        norm (Vec4 (a,b,c,d)) = sqrt (a*a + b*b + c*c + d*d)
+        normalize vec@(Vec4 (a,b,c,d)) = 
+            let n = norm vec in Vec4 (a/n,b/n,c/n,d/n)
+        vNegate (Vec4 (a,b,c,d)) = Vec4 (-a,-b,-c,-d)
+
+    cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+    cross (Vec3 (u1,u2,u3)) (Vec3 (v1,v2,v3)) =
+            Vec3 ( u2*v3 - u3*v2,
+                      u3*v1 - u1*v3,
+                      u1*v2 - u2*v1 )
+    (×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+    (×) = cross
+
+    lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
+    lookAtMatrix e@(Vec3 (ex,ey,ez)) c u =
+        let f@(Vec3 (fx,fy,fz)) = normalize (c <-> e)
+            s@(Vec3 (sx,sy,sz)) = normalize (f × u)
+            u'@(Vec3 (ux,uy,uz))   = s × f in 
+               Matrix (sx, ux, -fx, 0,
+                       sy, uy, -fy, 0,
+                       sz, uz, -fz, 0,
+                       -(s<.>e) , -(u'<.>e),  (f<.>e),  1 )
+
+    perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
+    {- as close to copied from glm as possible -}
+    perspectiveMatrix fov asp zn zf =
+        let tanHalfFovy = tangent (Degrees fov/2)
+            res00 = 1 / (asp * tanHalfFovy)
+            res11 = 1 / tanHalfFovy
+            res22 = - (zf + zn) / (zf - zn)
+            res23 = - 1
+            res32 = - (2 * zf * zn) / (zf - zn) in
+        trace ("res22=" ++ (show res22)) $
+        Matrix (res00, 0, 0, 0,
+                0, res11, 0, 0,
+                0, 0, res22, res23,
+                0, 0, res32, 0)
+
+    class VectorMatrix vecT matT where
+        vTranslate :: matT -> vecT -> matT
+        (-*|)  :: matT -> vecT -> vecT
+
+    instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
+        vTranslate (Matrix3 (a00,a01,a02,
+                             a10,a11,a12,
+                             a20,a21,a22)) (Vec3 (a,b,c)) =
+                        Matrix3 (a00,a01,a02+a,
+                                 a10,a11,a12+b,
+                                 a20,a21,a22+c)
+
+        (Matrix3 (a00,a01,a02,
+                 a10,a11,a12,
+                 a20,a21,a22)) -*| (Vec3 (a,b,c)) = 
+                                    Vec3 (a00 * a + a01 * b + a02 * c,
+                                          a10 * a + a11 * b + a12 * c,
+                                          a20 * a + a21 * b + a22 * c )
+
+
+
+
+    instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
+        vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
+        mat -*| tmp = glslMatMul mat tmp
+
+    glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
+    glslMatMul (Matrix (m00,m01,m02,m03,
+                m10,m11,m12,m13,
+                m20,m21,m22,m23,
+                m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
+                    Vec4 ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
+                           v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
+                           v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
+                           v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33 )
+
+    (==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+    (==>) = glslMatTranslate
+    glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+    glslMatTranslate
+        mat@(Matrix (m00,m01,m02,m03,
+                m10,m11,m12,m13,
+                m20,m21,m22,m23,
+                m30,m31,m32,m33)) vec =
+                    let (Vec4 (v0,v1,v2,v3)) = mat -*| vec in
+                    (Matrix (m00,m01,m02,m03,
+                             m10,m11,m12,m13,
+                             m20,m21,m22,m23,
+                             m30+v0,m31+v1,m32+v2,m33+v3))
+                    
diff --git a/Graphics/Glyph/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs
new file mode 100644
index 0000000..31be715
--- /dev/null
+++ b/Graphics/Glyph/GeometryBuilder.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.GeometryBuilder where
+
+import Data.Sequence as Seq
+import Data.Setters
+import Data.Maybe
+
+import Graphics.Glyph.Util
+import Graphics.Glyph.BufferBuilder
+
+import Data.ByteStringBuilder
+import Data.ByteString.Lazy
+import Data.ByteString.Lazy.Char8 as BSLC
+import Data.Foldable as Fold
+
+import Text.Printf
+
+data OutType = TriangleStrip | Triangles
+instance Show OutType where
+    show TriangleStrip = "triangle_strip"
+    show Triangles = "triangle_strip"
+
+buildSourceAsString :: GeometryBuilder a -> String
+buildSourceAsString = BSLC.unpack . buildSource
+
+buildSource :: GeometryBuilder a -> ByteString
+buildSource builder =
+    runBuilder $ do
+        putSLn "#version 150"
+        putSLn "#extension GL_ARB_explicit_attrib_location : enable"
+        putSLn "#extension GL_ARB_explicit_uniform_location : enable"
+        putSLn "layout(points) in ;"
+    
+        let isVertex (Vertex _ _ _ _) = True
+            isVertex _ = False
+        putSLn $ printf "layout(%s,max_vertices=%d) out ;"
+                    (show $ maybeDefault TriangleStrip $ gOutType builder)
+                    (Seq.length $ Seq.filter isVertex $ gList builder)
+
+        forM_ (textureOut builder) $ putSLn.("out vec2 "++) . (++";")
+        forM_ (normalOut builder) $ putSLn.("out vec3 "++) . (++";")
+        forM_ (positionOut builder) $ putSLn.("out vec4 "++) . (++";")
+        
+        let pjMatStr = fromJust (pjMatrixUniform builder >||> Just "pjMatrix")
+        let mvMatStr = fromJust (mvMatrixUniform builder >||> Just "mvMatrix")
+
+        Fold.mapM_ (putSLn.("uniform mat4 "++).(++";")) [pjMatStr, mvMatStr]
+
+        putSLn "void main() {"
+
+        let vertexOutF =
+             case positionOut builder of
+                Nothing ->
+                    printf "\tgl_Position = %s * (gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));"
+                        pjMatStr mvMatStr
+                Just str -> 
+                    printf "\tgl_Position = %s * (%s = gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));"
+                        pjMatStr str mvMatStr
+        let normalOutF = case normalOut builder of
+             Nothing -> const3 ""
+             Just str -> printf "\t%s = -inverse(transpose(mat3(%s))) * vec3(%f,%f,%f);" str mvMatStr
+
+        let textureOutF = case textureOut builder of
+             Nothing -> const2 ""
+             Just str -> printf "\t%s = vec2(%f,%f);" str
+
+        forM_ (gList builder) $ \datum ->
+            case datum of
+                Vertex x y z w -> putSLn $ vertexOutF x y z w
+                Normal x y z -> putSLn $ normalOutF x y z
+                Texture x y -> putSLn $ textureOutF x y
+                EmitVertex -> putSLn "\tEmitVertex();"
+                EndPrimitive -> putSLn "\tEndPrimitive();"
+        putSLn "}"
+
+data GeometryDatum =
+    Vertex  Float Float Float Float |
+    Texture Float Float |
+    Normal  Float Float Float |
+    EmitVertex |
+    EndPrimitive
+
+data GeometryBuilder a = GeometryBuilder {
+    gList :: (Seq GeometryDatum),
+
+    gOutType :: Maybe OutType,
+    pjMatrixUniform :: Maybe String,
+    mvMatrixUniform :: Maybe String,
+    maxVerts :: Maybe Int,
+
+    textureOut :: Maybe String,
+    normalOut :: Maybe String,
+    positionOut :: Maybe String,
+    gRet :: a
+}
+
+$(declareSetters ''GeometryBuilder)
+
+generating :: OutType -> GeometryBuilder () -> GeometryBuilder ()
+generating TriangleStrip builder = setGOutType (Just TriangleStrip) $ builder
+generating Triangles builder = do
+    let (nSeq,_) =
+         Fold.foldl' (\(tSeq,cnt) datum ->
+            case datum of
+                EmitVertex ->
+                    if cnt == (2::Int) then (tSeq |> datum |> EndPrimitive, 0)
+                    else (tSeq |> datum, cnt + 1)
+                _ -> (tSeq |> datum,cnt)
+            ) (Seq.empty, 0) (gList builder)
+
+    setGOutType (Just Triangles) $
+        setGList nSeq builder
+
+projectionMatrixUniform :: String -> GeometryBuilder ()
+projectionMatrixUniform str = setPjMatrixUniform (Just str) $ return ()
+
+modelViewMatrixUniform :: String -> GeometryBuilder ()
+modelViewMatrixUniform str = setMvMatrixUniform (Just str) $ return ()
+
+maxVerticies :: Int -> GeometryBuilder ()
+maxVerticies i = setMaxVerts (Just i) $ return ()
+
+textureOutput :: String -> GeometryBuilder ()
+textureOutput str = setTextureOut (Just str) $ return ()
+
+normalOutput :: String -> GeometryBuilder ()
+normalOutput str = setNormalOut (Just str) $ return ()
+
+positionOutput :: String -> GeometryBuilder ()
+positionOutput str = setPositionOut (Just str) $ return ()
+
+gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder ()
+gVertex4 x y z w = setGList (Seq.singleton $ Vertex x y z w) $ return ()
+
+gNormal3 :: Float -> Float -> Float -> GeometryBuilder ()
+gNormal3 x y z = setGList (Seq.singleton $ Normal x y z) $ return ()
+
+gTexture2 :: Float -> Float -> GeometryBuilder ()
+gTexture2 x y = setGList (Seq.singleton $ Texture x y) $ return ()
+
+gEmitVertex :: GeometryBuilder ()
+gEmitVertex = setGList (Seq.singleton $ EmitVertex) $ return ()
+
+gEndPrimitive :: GeometryBuilder ()
+gEndPrimitive = setGList (Seq.singleton $ EndPrimitive) $ return ()
+
+gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder ()
+gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex
+
+
+instance Monad GeometryBuilder where
+    aB >> bB = GeometryBuilder
+                (gList aB >< gList bB)
+                (select gOutType gOutType)
+                (select pjMatrixUniform pjMatrixUniform)
+                (select mvMatrixUniform mvMatrixUniform)
+                (select maxVerts maxVerts)
+                (select textureOut textureOut)
+                (select normalOut normalOut)
+                (select positionOut positionOut)
+                (gRet bB)
+                where select f1 f2 = (f1 bB) >||> (f2 aB)
+    aB >>= func = aB >> func (gRet aB)
+    return = GeometryBuilder
+                Seq.empty
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+    fail = error
+    
+
+instance IsModelBuilder Float GeometryBuilder where
+    plotVertex3 x y z = gVertex4E x y z 0
+    plotNormal = gNormal3
+    plotTexture = gTexture2
+
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
new file mode 100644
index 0000000..e359838
--- /dev/null
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Graphics.Glyph.GlyphObject (
+    GlyphObject,
+    getBufferObject,
+    getCompiledData,
+    getVertexAttribute,
+    getNormalAttribute,
+    getColorAttribute ,
+    getTextureAttribute,
+    getResources,
+    getSetupRoutine,
+    getTeardownRoutine,
+    getPrimitiveMode,
+    setBufferObject,
+    setCompiledData,
+    setVertexAttribute,
+    setNormalAttribute,
+    setColorAttribute ,
+    setTextureAttribute,
+    setResources,
+    setSetupRoutine,
+    setTeardownRoutine,
+    setPrimitiveMode,
+    prepare, teardown,
+    Drawable, draw, newGlyphObject,
+    newDefaultGlyphObject,
+    startClosure,
+    newDefaultGlyphObjectWithClosure
+) where
+
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL
+import Graphics.Glyph.ExtendedGL
+import Data.Setters
+
+import Control.Monad
+import Control.Applicative
+import Data.Maybe
+
+class Drawable a where
+    -- mvMat -> pMat -> obj -> IO ()
+    draw :: a -> IO ()
+
+data GlyphObject a = GlyphObject {
+    bufferObject :: BufferObject, -- buffer
+    compiledData :: (CompiledBuild GLfloat), -- compiled data
+    vertexAttribute :: AttribLocation, -- vertex attribute
+    normalAttribute :: (Maybe AttribLocation), -- normal attrib
+    colorAttribute  :: (Maybe AttribLocation), -- color attrib
+    textureAttribute :: (Maybe AttribLocation), -- texture attrib
+    resources :: a, -- Resources
+    setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
+    setupRoutine2 :: (Maybe (GlyphObject a -> IO ())), -- Setup
+    teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
+    primitiveMode :: PrimitiveMode
+}
+
+$(declareSetters ''GlyphObject)
+getBufferObject :: GlyphObject a -> BufferObject
+getBufferObject = bufferObject
+
+getCompiledData :: GlyphObject a -> (CompiledBuild GLfloat)
+getCompiledData = compiledData
+
+getVertexAttribute :: GlyphObject a -> AttribLocation
+getVertexAttribute = vertexAttribute
+
+getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getNormalAttribute = normalAttribute
+
+getColorAttribute  :: GlyphObject a -> (Maybe AttribLocation)
+getColorAttribute  = colorAttribute
+
+getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getTextureAttribute = textureAttribute
+
+getResources :: GlyphObject a -> a
+getResources = resources
+
+getSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ()))
+getSetupRoutine = setupRoutine
+
+getTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ()))
+getTeardownRoutine = teardownRoutine
+
+getPrimitiveMode :: GlyphObject a -> PrimitiveMode
+getPrimitiveMode = primitiveMode
+
+newGlyphObject :: BuilderM GLfloat x ->
+    AttribLocation ->
+    Maybe AttribLocation ->
+    Maybe AttribLocation ->
+    Maybe AttribLocation ->
+    a ->
+    Maybe (GlyphObject a -> IO ()) ->
+    Maybe (GlyphObject a -> IO ()) ->
+    PrimitiveMode ->
+    IO (GlyphObject a)
+
+newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mode = do
+    compiled <- compilingBuilder builder
+    buffer <- createBufferObject ArrayBuffer compiled
+    return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode
+
+prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+prepare a b = setSetupRoutine2 (Just b) a
+
+startClosure :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+startClosure a b = setSetupRoutine (Just b) a
+
+teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+teardown a b = setTeardownRoutine (Just b) a
+
+instance Drawable (GlyphObject a) where
+    draw = drawInstances 1
+
+drawInstances :: Int -> GlyphObject a -> IO ()
+drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 tearDown p) = do
+    {- Setup whatever we need for the object to draw itself -}
+    maybe (return ()) (Prelude.$obj) setup1
+    maybe (return ()) (Prelude.$obj) setup2
+
+    {- Get the array descriptors for the possible
+     - parts -}
+    let vad = vertexArrayDescriptor co
+    let nad = normalArrayDescriptor co
+    let cad = colorArrayDescriptor co
+    let tad = textureArrayDescriptor co
+
+    bindBuffer ArrayBuffer $= Just bo
+    let enabled = catMaybes $
+         map liftMaybe [(Just vAttr,Just vad), (nAttr, nad), (cAttr,cad), (tAttr,tad)]
+
+    forM_ enabled $ \(attr, ad) -> do
+        vertexAttribPointer attr $= (ToFloat, ad)
+        vertexAttribArray attr $= Enabled
+
+    drawArraysInstanced p 0 (bufferLength co) $ fromIntegral n
+        
+    forM_ enabled $ \(attr, _) -> do
+        vertexAttribArray attr $= Disabled
+        
+    {- Tear down whatever the object needs -}
+    maybe (return ()) (Prelude.$ obj) tearDown
+    where liftMaybe (Just a, Just b) = Just (a,b)
+          liftMaybe _ = Nothing
+
+instance (Show a) => Show (GlyphObject a) where
+    show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ _ p) =
+        "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
+            " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++"]"
+
+newDefaultGlyphObject :: BuilderM GLfloat x -> a -> IO (GlyphObject a)
+newDefaultGlyphObject builder resources =
+                        newGlyphObject builder
+                                       (AttribLocation 0) -- vertex
+                                       (Just $ AttribLocation 1) -- normal
+                                       (Just $ AttribLocation 2) -- color
+                                       (Just $ AttribLocation 3) -- texture
+                                       resources
+                                       Nothing -- setup
+                                       Nothing -- teardown
+                                       Triangles -- primitive
+
+newDefaultGlyphObjectWithClosure :: BuilderM GLfloat x -> a -> (GlyphObject a -> IO ()) -> IO (GlyphObject a)
+newDefaultGlyphObjectWithClosure builder res func =
+    liftM (flip startClosure func) $ newDefaultGlyphObject builder res 
+        
+    
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
new file mode 100644
index 0000000..546baa2
--- /dev/null
+++ b/Graphics/Glyph/Mat4.hs
@@ -0,0 +1,223 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.Mat4 where
+
+import Control.Monad
+
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
+
+import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL.Raw.Core31
+
+data Mat4 a = Matrix (a,a,a,a,
+                      a,a,a,a,
+                      a,a,a,a,
+                      a,a,a,a) | IdentityMatrix
+
+data Mat3 a = Matrix3 ( a,a,a,
+                        a,a,a,
+                        a,a,a ) | IdentityMatrix3
+
+class StorableMatrix t a where
+    fromList :: [t] -> a t
+    toPtr :: a t -> (Ptr t -> IO b) -> IO b
+    fromPtr :: Ptr t -> (a t -> IO b) -> IO b
+
+instance (Storable t) => StorableMatrix t Mat4 where
+    fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:m10:m11:m12:m13:m14:m15:m16:_) =
+        Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)
+
+    toPtr (Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)) fun =
+        allocaArray 16 $ \ptr -> do
+            pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16]
+            fun ptr
+
+    fromPtr ptr f = peekArray 16 ptr >>= f . fromList
+
+instance (Storable t) => StorableMatrix t Mat3 where
+    fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:_) =
+        Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)
+
+    toPtr (Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)) fun =
+        allocaArray 9 $ \ptr -> do
+            pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9]
+            fun ptr
+
+    fromPtr ptr f = peekArray 9 ptr >>= f . fromList
+
+instance Uniform (Mat4 GLfloat) where
+    uniform (UniformLocation loc)  = makeStateVar getter setter
+                    where setter mat = toPtr mat $ \ptr ->
+                                    glUniformMatrix4fv loc 1 (fromIntegral gl_FALSE) ptr
+                          getter :: IO (Mat4 GLfloat)
+                          getter = do
+                                pid <- liftM fromIntegral getCurrentProgram
+                                ( allocaArray 16 $ \buf -> do
+                                    glGetUniformfv pid loc buf
+                                    fromPtr buf return )
+
+instance Uniform (Mat3 GLfloat) where
+    uniform (UniformLocation loc)  = makeStateVar getter setter
+                    where setter mat = toPtr mat $ \ptr ->
+                                    glUniformMatrix3fv loc 1 (fromIntegral gl_FALSE) ptr
+                          getter :: IO (Mat3 GLfloat)
+                          getter = do
+                                pid <- liftM fromIntegral getCurrentProgram
+                                ( allocaArray 9 $ \buf -> do
+                                    glGetUniformfv pid loc buf
+                                    fromPtr buf return )
+
+getCurrentProgram :: IO GLint
+getCurrentProgram = alloca $ glGetIntegerv gl_CURRENT_PROGRAM >> peek
+
+instance (Show a) => Show (Mat4 a) where
+    show IdentityMatrix =
+        "[ 1 0 0 0\n" ++
+        "  0 1 0 0\n" ++
+        "  0 0 1 0\n" ++
+        "  0 0 0 1 ]\n"
+    show (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) =
+        "["++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n" ++
+        " "++! m10 ++ " " ++! m11 ++ " " ++! m12 ++ " " ++! m13 ++ "\n" ++
+        " "++! m20 ++ " " ++! m21 ++ " " ++! m22 ++ " " ++! m23 ++ "\n" ++
+        " "++! m30 ++ " " ++! m31 ++ " " ++! m32 ++ " " ++! m33 ++ "]"
+     where (++!) a = (a++) . show
+        
+
+    
+
+translateMat4 :: (Num a) => Mat4 a -> (a,a,a,a) -> Mat4 a
+translateMat4 IdentityMatrix x = translateMat4 (Matrix (1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1)) x
+translateMat4  (Matrix (m00,m01,m02,m03,
+                        m10,m11,m12,m13,
+                        m20,m21,m22,m23,
+                        m30,m31,m32,m33)) (v0,v1,v2,v3) =
+                Matrix (m00,m01,m02,m03+v0,
+                        m10,m11,m12,m13+v1,
+                        m20,m21,m22,m23+v2,
+                        m30,m31,m32,m33+v3)
+
+applyMatrix :: (Num a) => Mat4 a -> (a,a,a,a) -> (a,a,a,a)
+applyMatrix  (Matrix (m00,m01,m02,m03,
+              m10,m11,m12,m13,
+              m20,m21,m22,m23,
+              m30,m31,m32,m33)) (v0,v1,v2,v3) =
+                ( v0 * m00 + v1 * m01 + v2 * m02 + v3 * m03,
+                  v0 * m10 + v1 * m11 + v2 * m12 + v3 * m13,
+                  v0 * m20 + v1 * m21 + v2 * m22 + v3 * m23,
+                  v0 * m30 + v1 * m31 + v2 * m32 + v3 * m33 )
+
+applyMatrix IdentityMatrix v = v
+
+scaleMatrix :: (Num a) => Mat4 a -> (a,a,a) -> Mat4 a
+scaleMatrix IdentityMatrix (a,b,c) = Matrix ( a,0,0,0,
+                               0,b,0,0,
+                               0,0,c,0,
+                               0,0,0,1)
+
+scaleMatrix (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) (a,b,c)
+                    = Matrix ( m00*a,m01,m02,m03,
+                               m10,m11*b,m12,m13,
+                               m20,m21,m22*c,m23,
+                               m30,m31,m32,m33)
+
+applyMatrixToList :: (Num a) => Mat4 a -> [a] -> [a]
+applyMatrixToList IdentityMatrix t = t
+applyMatrixToList mat (a:b:c:xs) =
+    let (a',b',c',_) = applyMatrix mat (a,b,c,1) in
+    (a':b':c':applyMatrixToList mat xs)
+
+applyMatrixToList _ _ = []
+
+mulMatrix4 :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
+mulMatrix4 IdentityMatrix a = a
+mulMatrix4 a IdentityMatrix = a
+mulMatrix4
+    (Matrix (a00,a01,a02,a03,
+              a10,a11,a12,a13,
+              a20,a21,a22,a23,
+              a30,a31,a32,a33 ))
+    (Matrix (b00,b01,b02,b03,
+              b10,b11,b12,b13,
+              b20,b21,b22,b23,
+              b30,b31,b32,b33 )) =
+                Matrix  (b00*a00+b10*a01+b20*a02+b30*a03,
+                         b01*a00+b11*a01+b21*a02+b31*a03,
+                         b02*a00+b12*a01+b22*a02+b32*a03,
+                         b03*a00+b13*a01+b23*a02+b33*a03,
+
+                         b00*a10+b10*a11+b20*a12+b30*a13,
+                         b01*a10+b11*a11+b21*a12+b31*a13,
+                         b02*a10+b12*a11+b22*a12+b32*a13,
+                         b03*a10+b13*a11+b23*a12+b33*a13,
+
+                         b00*a20+b10*a21+b20*a22+b30*a23,
+                         b01*a20+b11*a21+b21*a22+b31*a23,
+                         b02*a20+b12*a21+b22*a22+b32*a23,
+                         b03*a20+b13*a21+b23*a22+b33*a23,
+
+                         b00*a30+b10*a31+b20*a32+b30*a33,
+                         b01*a30+b11*a31+b21*a32+b31*a33,
+                         b02*a30+b12*a31+b22*a32+b32*a33,
+                         b03*a30+b13*a31+b23*a32+b33*a33 )
+
+(|*|) :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
+(|*|) = mulMatrix4
+
+transpose4 :: Mat4 a -> Mat4 a
+transpose4 (Matrix
+                (m00,m01,m02,m03,
+                 m10,m11,m12,m13,
+                 m20,m21,m22,m23,
+                 m30,m31,m32,m33 ))  = (Matrix (m00, m10, m20, m30,
+                                                m01, m11, m21, m31,
+                                                m02, m12, m22, m32,
+                                                m03, m13, m23, m33))
+scale4 :: (Num a) => a -> Mat4 a -> Mat4 a
+scale4 n (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
+    Matrix (m11*n,m12*n,m13*n,m14*n,m21*n,m22*n,m23*n,m24*n,m31*n,m32*n,m33*n,m34*n,m41*n,m42*n,m43*n,m44*n)
+
+det4 :: (Num a) => Mat4 a -> a
+det4 (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
+          m11*m22*m33*m44 + m11*m23*m34*m42 + m11*m24*m32*m43
+        + m12*m21*m34*m43 + m12*m23*m31*m44 + m12*m24*m33*m41
+        + m13*m21*m32*m44 + m13*m22*m34*m41 + m13*m24*m31*m42
+        + m14*m21*m33*m42 + m14*m22*m31*m43 + m14*m23*m32*m41
+        - m11*m22*m34*m43 - m11*m23*m32*m44 - m11*m24*m33*m42
+        - m12*m21*m33*m44 - m12*m23*m34*m41 - m12*m24*m31*m43
+        - m13*m21*m34*m42 - m13*m22*m31*m44 - m13*m24*m32*m41
+        - m14*m21*m32*m43 - m14*m22*m33*m41 - m14*m23*m31*m42
+
+inv4 :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat4 a)
+inv4 mat@(Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
+        let b11 = m22*m33*m44 + m23*m34*m42 + m24*m32*m43 - m22*m34*m43 - m23*m32*m44 - m24*m33*m42
+            b12 = m12*m34*m43 + m13*m32*m44 + m14*m33*m42 - m12*m33*m44 - m13*m34*m42 - m14*m32*m43
+            b13 = m12*m23*m44 + m13*m24*m42 + m14*m22*m43 - m12*m24*m43 - m13*m22*m44 - m14*m23*m42
+            b14 = m12*m24*m33 + m13*m22*m34 + m14*m23*m32 - m12*m23*m34 - m13*m24*m32 - m14*m22*m33
+            b21 = m21*m34*m43 + m23*m31*m44 + m24*m33*m41 - m21*m33*m44 - m23*m34*m41 - m24*m31*m43
+            b22 = m11*m33*m44 + m13*m34*m41 + m14*m31*m43 - m11*m34*m43 - m13*m31*m44 - m14*m33*m41
+            b23 = m11*m24*m43 + m13*m21*m44 + m14*m23*m41 - m11*m23*m44 - m13*m24*m41 - m14*m21*m43
+            b24 = m11*m23*m34 + m13*m24*m31 + m14*m21*m33 - m11*m24*m33 - m13*m21*m34 - m14*m23*m31
+            b31 = m21*m32*m44 + m22*m34*m41 + m24*m31*m42 - m21*m34*m42 - m22*m31*m44 - m24*m32*m41
+            b32 = m11*m34*m42 + m12*m31*m44 + m14*m32*m41 - m11*m32*m44 - m12*m34*m41 - m14*m31*m42
+            b33 = m11*m22*m44 + m12*m24*m41 + m14*m21*m42 - m11*m24*m42 - m12*m21*m44 - m14*m22*m41
+            b34 = m11*m24*m32 + m12*m21*m34 + m14*m22*m31 - m11*m22*m34 - m12*m24*m31 - m14*m21*m32
+            b41 = m21*m33*m42 + m22*m31*m43 + m23*m32*m41 - m21*m32*m43 - m22*m33*m41 - m23*m31*m42
+            b42 = m11*m32*m43 + m12*m33*m41 + m13*m31*m42 - m11*m33*m42 - m12*m31*m43 - m13*m32*m41
+            b43 = m11*m23*m42 + m12*m21*m43 + m13*m22*m41 - m11*m22*m43 - m12*m23*m41 - m13*m21*m42
+            b44 = m11*m22*m33 + m12*m23*m31 + m13*m21*m32 - m11*m23*m32 - m12*m21*m33 - m13*m22*m31 in
+            case det4 mat of
+                0 -> Nothing
+                det -> Just $ (1 / det) `scale4` Matrix (b11,b12,b13,b14,b21,b22,b23,b24,b31,b32,b33,b34,b41,b42,b43,b44)
+
+trunc4 :: Mat4 a -> Mat3 a
+trunc4 (Matrix
+        (m11,m12,m13,_,
+         m21,m22,m23,_,
+         m31,m32,m33,_,
+          _ , _ , _ ,_)) = Matrix3 (m11,m12,m13,m21,m22,m23,m31,m32,m33)
+
+toNormalMatrix :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat3 a)
+toNormalMatrix mat = inv4 mat >>= return . trunc4 . transpose4
diff --git a/Graphics/Glyph/ObjLoader.hs b/Graphics/Glyph/ObjLoader.hs
new file mode 100644
index 0000000..78f010a
--- /dev/null
+++ b/Graphics/Glyph/ObjLoader.hs
@@ -0,0 +1,126 @@
+module Graphics.Glyph.ObjLoader where
+
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
+import Debug.Trace
+
+import Control.Monad
+import Data.Either
+import Data.String.Utils
+import Data.Array
+import System.IO
+import qualified Data.Map as M
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as C
+
+data ObjectFile a = ObjectFile [ObjectStatement a]
+
+data ObjectStatement a =
+    Nop |
+    VertexStatement (a,a,a)       |
+    TextureStatement (a,a)    |
+    VertexNormalStatement (a,a,a) |
+    UseMaterialStatement (String)           |
+    MaterialLibraryStatement String         |
+    FaceStatement [(Int,Int,Int)]   deriving Show
+
+foldl2 :: a -> [b] -> (a -> b -> a) -> a
+foldl2 a b c = foldl  c a b
+
+isNop :: ObjectStatement a -> Bool
+isNop x = case x of 
+    Nop -> True
+    _ -> False
+
+isVertex :: ObjectStatement a -> Bool
+isVertex (VertexStatement _) = True
+isVertex _ = False
+
+isNormal :: ObjectStatement a -> Bool
+isNormal (VertexNormalStatement _) = True
+isNormal _ = False
+
+isTexture :: ObjectStatement a -> Bool
+isTexture (TextureStatement _) = True
+isTexture _ = False
+
+basicBuildObject :: (Floating b, IsModelBuilder b a) => ObjectFile b -> a ()
+basicBuildObject (ObjectFile list) =
+    let fromList lst = listArray (0,length lst-1) lst in
+
+    -- Set up the lists as arrays for fast access
+    let vertexList  = fromList $ map (\stmt -> 
+                        case stmt of
+                            (VertexStatement v) -> v
+                            _ -> (0,0,0)) (filter isVertex list) in
+
+    let normalList  = fromList $ map (\stmt -> 
+                        case stmt of
+                            (VertexNormalStatement v) -> v
+                            _ -> (0,0,0)) (filter isNormal list) in
+
+    let textureList  = fromList $ map (\stmt -> 
+                        case stmt of
+                            (TextureStatement v) -> v
+                            _ -> (0,0)) (filter isTexture list) in
+
+    forM_ list $ \stmt ->
+        case stmt of
+            (FaceStatement arr) ->
+                forM_ arr $ \(a,b,c) -> do
+                    when (c >= 0) (uncurry3 plotNormal  $ normalList  ! (c-1))
+                    when (b >= 0) (uncurry  plotTexture $ textureList ! (b-1))
+                    when (a >= 0) (uncurry3 plotVertex3 $ vertexList  ! (a-1))
+            _ -> return ()
+                        
+
+loadObjFromBytestring :: (Read b) => L.ByteString -> ([String], ObjectFile b)
+loadObjFromBytestring _contents =
+    let contents::[L.ByteString] ; contents = C.split '\n' _contents in
+    let mys2n str = case str of
+         "" -> -1
+         _ -> read str in
+
+    let s2t s = case split "/" s of
+         [a,b,c] -> Just (mapT3 mys2n (a,b,c))
+         [a,b] -> Just (mapT3 mys2n (a,b,""))
+         [a] -> Just (mapT3 mys2n (a,"",""))
+         _ -> Nothing in
+
+    let compiled =
+            map (\(num,line) -> case words $ C.unpack line of
+    
+            [] -> Right Nop -- This is an empty line
+            (('#':_):_)  -> Right Nop -- This is a comment, so use a 'nop'
+            ("o":_) -> Right Nop -- Not really of use
+            
+            ["v",x,y,z]  -> Right $ VertexStatement ( (read x), (read y), (read z))
+            ["vt",x,y]   -> Right $ TextureStatement ( (read x), (read y))
+            ["vn",x,y,z] -> Right $ VertexNormalStatement ( (read x), (read y), (read z))
+            ["usemtl", mtl] -> Right $ UseMaterialStatement mtl
+            ["mtllib", lib] -> Right $ MaterialLibraryStatement lib
+
+            ("f":_tail) -> case mapM s2t _tail of
+                Just lst -> Right $ FaceStatement lst
+                _ -> Left $ foldl (++) "" ["Syntax error in face value on line ", show num, " `", C.unpack line, "'" ]
+
+            _ -> Left $ foldl (++) "" ["Unrecognized Sequence on line ", show num, " `", C.unpack line, "'" ]
+
+            ) (zip [(1::Int)..] contents) in
+
+    ( lefts compiled, ObjectFile (filter (not.isNop) $ rights compiled) )
+    
+
+loadObjFromHandle :: (Read b) => Handle -> IO ([String], ObjectFile b)
+loadObjFromHandle = loadObjFromHandleWithFilter id
+
+loadObjFromHandleWithFilter :: (Read b) => (L.ByteString -> L.ByteString) -> Handle -> IO ([String], ObjectFile b)
+loadObjFromHandleWithFilter _filter handle =
+    liftM (loadObjFromBytestring . _filter) (L.hGetContents handle)
+
+loadObjFile :: (Read b) => FilePath -> IO ([String], ObjectFile b)
+loadObjFile = loadObjFileWithFilter id
+
+loadObjFileWithFilter :: (Read b) => (L.ByteString -> L.ByteString) -> FilePath -> IO ([String], ObjectFile b)
+loadObjFileWithFilter filt path = loadObjFromHandleWithFilter filt =<< openFile path ReadMode
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
new file mode 100644
index 0000000..01f27b6
--- /dev/null
+++ b/Graphics/Glyph/Shaders.hs
@@ -0,0 +1,109 @@
+module Graphics.Glyph.Shaders where
+
+import Graphics.Rendering.OpenGL
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import Control.Monad
+import Data.Maybe
+import Data.List as List
+import Graphics.Glyph.Util
+
+{- Load a shader from a file giving the type of the shader
+ - to load.
+ - This function returns the shader log as a string and
+ - a shader as a maybe. Nothing if the shader didn't complie
+ - and Just if the shader did compile
+ -}
+class IsShaderSource a where
+    loadShader :: ShaderType -> a -> IO (String, Maybe Shader)
+
+instance IsShaderSource FilePath where
+    loadShader typ path = loadShader typ =<< BS.readFile path
+
+instance IsShaderSource BS.ByteString where
+    loadShader typ src = do
+        shader <- createShader typ
+        shaderSourceBS shader $= src
+        compileShader shader
+    
+        ok <- get (compileStatus shader)
+        infoLog <- get (shaderInfoLog shader)
+    
+        unless ok $
+            deleteObjectNames [shader]
+    
+        return ( infoLog, if not ok then Nothing else Just shader );
+
+instance IsShaderSource BSL.ByteString where
+    loadShader typ = loadShader typ . toStrict
+        where toStrict = BS.concat . BSL.toChunks
+
+
+{- Load multiple shaders -}
+loadShaders :: (IsShaderSource a) => [(ShaderType,a)] -> IO [(String, Maybe Shader)]
+loadShaders = mapM ( uncurry loadShader )
+
+{- Return the sucessfully complied shaders
+ - as a new array of working shaders -}
+workingShaders :: [(a, Maybe Shader)] -> [Shader]
+workingShaders = mapMaybe snd
+
+{- Create a program from a list of working shaders -}
+createShaderProgram :: [Shader] -> IO (String, Maybe Program)
+createShaderProgram shaders = do
+    p <- createProgram
+    mapM_ (attachShader p) shaders
+    linkProgram p
+
+    ok <- get $ linkStatus p
+    info <- get $ programInfoLog p
+
+    unless ok $
+        deleteObjectNames [p]
+
+    return ( info, not ok ? Nothing $ Just p )
+
+{- Creates a shader program, but will only build the program if all the
+ - shaders compiled correctly -}
+createShaderProgramSafe :: [(String,Maybe Shader)] -> IO (String, Maybe Program)
+createShaderProgramSafe shaders = 
+    not (List.all (isJust.snd) shaders) ?
+        return (concatMap fst shaders, Nothing) $
+        createShaderProgram $ workingShaders shaders
+        
+
+{- Get the uniform form a program. -}
+getUniform :: Uniform a => String -> IO (Maybe (StateVar a))
+getUniform name =
+    get currentProgram >>= (\pr -> case pr of
+            Just p -> liftM (Just . uniform) (get $ uniformLocation p name)
+            Nothing -> return Nothing )
+
+getUniformForProgram :: Uniform a => String -> Program -> IO (StateVar a)
+getUniformForProgram name prog =
+    liftM uniform (get $ uniformLocation prog name)
+    
+
+getUniformLocation :: String -> IO (Maybe UniformLocation)
+getUniformLocation name =
+    get currentProgram >>= maybe (return Nothing) (\prog ->
+        liftM Just (get $ uniformLocation prog name) )
+
+loadProgramSafe ::
+    (IsShaderSource a,
+     IsShaderSource b,
+     IsShaderSource c) =>
+        a -> b -> Maybe c -> IO (Maybe Program)
+loadProgramSafe vert frag geom = do
+    shaders <- sequence $ catMaybes [
+        Just $ loadShader VertexShader vert,
+        Just $ loadShader FragmentShader frag,
+        liftM (loadShader GeometryShader) geom]
+    -- mapM_ (putStrLn . fst) shaders
+    (linklog, maybeProg) <- createShaderProgramSafe shaders
+
+    if isNothing maybeProg then do
+        putStrLn "Failed to link program"
+        putStrLn linklog
+        return Nothing
+        else return maybeProg
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
new file mode 100644
index 0000000..7e86d2a
--- /dev/null
+++ b/Graphics/Glyph/Textures.hs
@@ -0,0 +1,39 @@
+module Graphics.Glyph.Textures where
+
+import Data.Array.Storable
+import Data.Word
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL
+import Control.Monad
+
+data Pixels =
+    PixelsRGB  (Int,Int) (StorableArray Int Word8) |
+    PixelsRGBA (Int,Int) (StorableArray Int Word8)
+
+pixelsArray :: Pixels -> StorableArray Int Word8
+pixelsArray (PixelsRGB  _ a) = a
+pixelsArray (PixelsRGBA _ a) = a
+-- construct a new 2d array of pixels
+makePixelsRGB :: (Int, Int) -> IO Pixels
+makePixelsRGB a@(w,h) = liftM (PixelsRGB a) (newArray_ (0,w*h-1))
+
+-- convert a list of rgb values to an array
+newPixelsFromListRGB :: (Int, Int) -> [(Word8,Word8,Word8)] -> IO Pixels
+newPixelsFromListRGB a@(w,h) lst = liftM (PixelsRGB a) $ (newListArray (0,w*h*3) .
+                                                    concatMap (\(x,y,z)->[x,y,z])) lst
+
+newPixelsFromListRGBA :: (Int, Int) -> [(Word8,Word8,Word8,Word8)] -> IO Pixels
+newPixelsFromListRGBA a@(w,h) lst = liftM (PixelsRGBA a) $ newListArray (0,w*h*4)
+                                                    (concatMap (\(x,y,z,q)->[x,y,z,q]) lst)
+
+attachPixelsToTexture :: Pixels -> TextureObject -> IO ()
+attachPixelsToTexture pixels tex =
+    withStorableArray (pixelsArray pixels) $ \ptr -> do
+        textureBinding Texture2D $= Just tex
+        case pixels of
+            PixelsRGB  (w,h) _ -> glTexImage2D gl_TEXTURE_2D 0 3 (f w) (f h) 0 gl_RGB gl_UNSIGNED_BYTE ptr
+            PixelsRGBA (w,h) _ -> glTexImage2D gl_TEXTURE_2D 0 4 (f w) (f h) 0 gl_RGBA gl_UNSIGNED_BYTE ptr
+        where f = fromIntegral
+
+
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
new file mode 100644
index 0000000..ba3b54a
--- /dev/null
+++ b/Graphics/Glyph/Util.hs
@@ -0,0 +1,257 @@
+module Graphics.Glyph.Util where
+
+import Data.Angle
+import Graphics.Rendering.OpenGL
+import Data.Maybe
+import Data.Char
+import Data.Either
+import Control.Exception
+
+import Data.Foldable as Fold
+
+if' :: Bool -> a -> a -> a
+if' True a _ = a
+if' False _ a = a
+
+(?) :: Bool -> a -> a -> a
+(?) = if'
+
+int :: (Integral a, Num b) => a -> b
+int = fromIntegral 
+
+uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a,b,c,d,e,f,g) -> h
+uncurry7 func (a,b,c,d,e,f,g) = func a b c d e f g
+
+uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a,b,c,d,e,f) -> g
+uncurry6 func (a,b,c,d,e,f) = func a b c d e f
+
+uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
+uncurry5 func (a,b,c,d,e) = func a b c d e
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
+uncurry4 func (a,b,c,d) = func a b c d
+
+uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e
+uncurry3 func (a,b,c) = func a b c
+
+const2 :: a -> b -> c -> a
+const2 = const.const
+
+const3 :: a -> b -> c -> d -> a
+const3 = const2.const
+
+const4 :: a -> b -> c -> d -> e -> a
+const4 = const3.const
+
+gsin :: (Floating a) => a -> a
+gsin = sine . Degrees
+
+gcos :: (Floating a) => a -> a
+gcos = cosine . Degrees
+
+toEuclidian :: (Floating a) => (a, a, a) -> (a, a, a)
+toEuclidian (r, th, ph) = (
+        -r * gsin th * gcos ph,
+         r * gsin ph,
+         r * gcos th * gcos ph
+    )
+
+mapT2 :: (a -> b) -> (a,a) -> (b,b) 
+mapT2 f (a, b) = (f a, f b)
+
+mapT3 :: (a -> b) -> (a,a,a) -> (b,b,b) 
+mapT3 f (a, b, c) = (f a, f b, f c)
+
+mapT4 :: (a -> b) -> (a,a,a,a) -> (b,b,b,b) 
+mapT4 f (a, b, c, d) = (f a, f b, f c, f d)
+
+mapT5 :: (a -> b) -> (a,a,a,a,a) -> (b,b,b,b,b) 
+mapT5 f (a, b, c, d, e) = (f a, f b, f c, f d, f e)
+
+mapT6 :: (a -> b) -> (a,a,a,a,a,a) -> (b,b,b,b,b,b) 
+mapT6 f (a, b, c, d, e, _f) = (f a, f b, f c, f d, f e, f _f)
+
+mapT7 :: (a -> b) -> (a,a,a,a,a,a,a) -> (b,b,b,b,b,b,b) 
+mapT7 f (a, b, c, d, e, _f, g) = (f a, f b, f c, f d, f e, f _f, f g)
+
+foldT2 :: (a -> b -> a) -> a -> (b,b) -> a
+foldT2 f ini (x,y) = ini `f` x `f` y
+
+foldT3 :: (a -> b -> a) -> a -> (b,b,b) -> a
+foldT3 f ini (x,y,z) = ini `f` x `f` y `f` z
+
+foldT4 :: (a -> b -> a) -> a -> (b,b,b,b) -> a
+foldT4 f ini (x,y,z,w) = ini `f` x `f` y `f` z `f` w
+
+foldT5 :: (a -> b -> a) -> a -> (b,b,b,b,b) -> a
+foldT5 f ini (x,y,z,w,v) = ini `f` x `f` y `f` z `f` w `f` v
+
+tup2Len :: (Real a,Floating b) => (a,a) -> b
+tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((**2).toFloating)
+
+tup3Len :: (Real a,Floating b) => (a,a,a) -> b
+tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((**2).toFloating)
+
+tup4Len :: (Real a,Floating b) => (a,a,a,a) -> b
+tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((**2).toFloating)
+
+tup5Len :: (Real a,Floating b) => (a,a,a,a,a) -> b
+tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((**2).toFloating)
+
+expand3 :: a -> (a,a,a)
+expand3 t = (t,t,t)
+
+expand4 :: a -> (a,a,a,a)
+expand4 t = (t,t,t,t)
+
+expand5 :: a -> (a,a,a,a,a)
+expand5 t = (t,t,t,t,t)
+
+expand6 :: a -> (a,a,a,a,a)
+expand6 t = (t,t,t,t,t)
+
+zipWithT2 :: (a -> b -> c) -> (a,a) -> (b,b) -> (c,c)
+zipWithT2 fu (a, b) (d, e) = (fu a d, fu b e)
+
+zipWithT3 :: (a -> b -> c) -> (a,a,a) -> (b,b,b) -> (c,c,c)
+zipWithT3 fu (a, b, c) (d, e, f) = (fu a d, fu b e, fu c f)
+
+zipWithT4 :: (a -> b -> c) -> (a,a,a,a) -> (b,b,b,b) -> (c,c,c,c)
+zipWithT4 fu (a, b, c, d) (e, f, g, h) = (fu a e, fu b f, fu c g, fu d h)
+
+toFloating :: (Real a, Floating b) => a -> b
+toFloating = fromRational . toRational
+
+(!!%) :: [a] -> Int -> a
+(!!%) lst idx = lst !! (idx `mod` length lst)
+
+(++!) :: (Show a) => String -> a -> String
+(++!) str = (str++) . show
+
+clamp :: (Ord a) => a -> (a, a) -> a 
+clamp var (low, high) = min (max var low) high
+
+floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble
+floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)
+
+floatVector :: (GLfloat,GLfloat,GLfloat) -> Vector3 GLdouble
+floatVector tup = uncurry3 Vector3 (mapT3 toFloating tup)
+
+-- Maps a function across a list, except this function
+-- can also be given a state variable like how foldl
+-- works
+mapWith :: (s -> a -> (b,s)) -> s -> [a] -> ([b], s)
+mapWith func state (x:xs) = 
+    let (x',s') = func state x in
+    let (l,s) = mapWith func s' xs in (x':l, s)
+
+mapWith _ s [] = ([],s)
+
+{- Useful function that accepts two functions
+ - and applies the third argument to both. Useful for
+ - building up data flows with the same argument. Such
+ - as:
+ -
+ - (bVertex3 >&> bNormal3) (0,0,1)
+ - vs
+ - bVertex3 (0,0,1) >> bNormal3 (0,0,1)
+ -}
+(>&>) :: (Monad m) => (a -> m b) -> (a -> m c) -> a -> m c
+(>&>) f1 f2 a = f1 a >> f2 a
+
+{- Instance where a monad can deconstruct
+ - when the operation has failed -}
+class (Monad m) => MonadHasFailure m where
+    isFail :: m a -> Bool
+
+instance MonadHasFailure Maybe where
+    isFail = isNothing
+
+instance MonadHasFailure [] where
+    isFail = null
+
+instance MonadHasFailure (Either a) where
+    isFail (Left _) = True
+    isFail _ = False
+
+
+{- A way of chaining together commands such
+ - that the first function in the chain that
+ - returns a non-failing result is the one
+ - that returns the result
+ -
+ - This is similar to the double pipe (||) operator
+ - in imperative languages but with monads instead of
+ - booleans.
+ -}
+(>|>) :: (MonadHasFailure m) => (a -> m c) -> (a -> m c) -> a -> m c
+(>|>) f1 f2 a =
+    let res = f1 a in
+    isFail res ? f2 a $ res
+
+(>||>) :: (MonadHasFailure m) => m a -> m a -> m a
+(>||>) a b
+        | isFail a = b
+        | otherwise = a
+
+whileM_ :: (Monad m) => (a -> Bool) -> m a -> a -> m a
+whileM_ func routine start = do
+    case func start of
+        True -> routine >>= whileM_ func routine
+        False -> return start
+
+whileM :: (Monad m) => (a -> Bool) -> m a -> a -> m [a]
+whileM bool routine' start' =
+    whileM' bool routine' start' []
+    where
+        whileM' func routine start lst = do
+            case func start of
+                True -> do
+                    next <- routine 
+                    whileM' func routine next (lst ++ [start])
+                False -> return lst
+
+untilM_ :: (Monad m) => (a -> Bool) -> m a -> m a
+untilM_ func routine = do
+    start <- routine
+    case func start of
+        True -> untilM_ func routine
+        False -> return start
+
+untilM :: (Monad m) => (a -> Bool) -> m a -> m [a]
+untilM func' routine' =
+    untilM' func' routine' []
+    where untilM' func routine lst = do
+            start <- routine
+            case func start of
+                True -> untilM' func routine (lst ++ [start])
+                False -> return lst
+
+dFold :: [a] -> b -> (a -> a -> b -> b) -> b
+dFold (x1:x2:xs) next func = dFold (x2:xs) (func x1 x2 next) func
+dFold _ next _ = next
+
+(!>>) :: a -> (a -> b) -> b
+(!>>) a f = a `seq` f a
+
+(!>>=) :: Monad m => m a -> (a -> m b) -> m b
+(!>>=) a f = a !>> (flip (>>=) f)
+
+toHex :: (Integral a,Show a) => a -> String
+toHex n | n == 0 = ""
+        | otherwise = 
+            let (quot',rem') = n `divMod` 16 in
+            toHex quot' ++ [(index' !! fromIntegral rem')]
+        where index' = "0123456789ABCDEFGHIJKlMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
+
+average :: (Fold.Foldable a, Real c, Fractional b) => a c -> b
+average lst =
+    let (sum',count) = Fold.foldl' (\(sum_,count_) x -> (sum_ + x, count_ + 1)) (0,0) lst in
+        (realToFrac sum') / count
+
+maybeDefault :: a -> Maybe a -> a
+maybeDefault a b = fromJust $ b >||> Just a
+
+maybeDefaultM :: (Monad m) => Maybe a -> (a -> m ()) -> m () -> m ()
+maybeDefaultM Nothing _ a = a
+maybeDefaultM (Just a) b _ = b a
diff --git a/Graphics/Rendering/HelpGL.hs b/Graphics/Rendering/HelpGL.hs
new file mode 100644
index 0000000..3ea66eb
--- /dev/null
+++ b/Graphics/Rendering/HelpGL.hs
@@ -0,0 +1,17 @@
+module Graphics.Rendering.HelpGL 
+( emptyRGBATexture )
+where
+
+import Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Foreign.Ptr
+
+import Foreign.Marshal.Array
+
+(?) :: (Integral a, Num b) => () -> a -> b
+(?) _ = fromIntegral
+
+
+emptyRGBATexture :: Int -> Int -> IO ()
+emptyRGBATexture w h =
+    texImage2D Texture2D NoProxy 0 RGBA' (TextureSize2D (()?w) (()?h)) 0 (PixelData RGBA UnsignedByte nullPtr)
diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs
new file mode 100644
index 0000000..8b09484
--- /dev/null
+++ b/Graphics/SDL/SDLHelp.hs
@@ -0,0 +1,126 @@
+module Graphics.SDL.SDLHelp where
+
+import Graphics.UI.SDL.Image as SDLImg
+import Graphics.UI.SDL as SDL 
+import Data.Word
+import Control.Monad
+import Graphics.Glyph.Util
+
+import Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL.Raw.Core31
+
+import Foreign.Storable
+import Foreign.Ptr
+import Data.Bits
+
+import System.IO.Unsafe
+import System.Endian
+import System.Exit
+
+data TextureData = TextureData {
+    textureSize :: (Int,Int),
+    textureObject :: TextureObject } deriving Show
+
+bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
+bindSurfaceToTexture surf to = do
+    textureBinding Texture2D $= Just to
+    bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
+    putStrLn $ "bpp: " ++! bbp
+    ptr <- surfaceGetPixels surf
+    glTexImage2D gl_TEXTURE_2D 0 bbp (w surf) (h surf) 0 (if bbp == 3 then gl_RGB else gl_RGBA) gl_UNSIGNED_BYTE ptr
+    return $ TextureData (w surf, h surf) to
+    where 
+          w :: (Integral a) => SDL.Surface -> a
+          w = fromIntegral . surfaceGetWidth
+          h :: (Integral a) => SDL.Surface -> a
+          h = fromIntegral . surfaceGetHeight
+
+textureFromSurface :: SDL.Surface -> IO TextureData
+textureFromSurface surf = makeTexture >>= (bindSurfaceToTexture surf >=> return)
+
+makeTexture :: IO TextureObject
+makeTexture = do
+    texobj <- liftM head $ genObjectNames 1
+    textureBinding Texture2D $= Just texobj
+    textureFilter Texture2D $= ((Linear', Nothing), Linear')
+    return texobj
+
+getPixel :: Int -> Int -> SDL.Surface -> IO Word32
+getPixel x y surf = do
+    bpp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
+    ptr <- (surfaceGetPixels surf >>= return.castPtr) :: IO (Ptr Word8)
+    let newPtr = ptr `plusPtr` (y * (fromIntegral $ surfaceGetPitch surf)) `plusPtr` (x * bpp)
+    
+    ret <- case bpp of
+        -- bytes = R G B A
+        1 -> liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word8)
+        2 -> liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word16)
+        3 -> do
+            ord1 <- liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word16)
+            ord2 <- liftM fromIntegral $ peek (castPtr (newPtr `plusPtr` 2) :: Ptr Word8)
+            return $ ((ord1 `shiftL` 16) + (ord2 `shiftL` 8)) + 0xFF
+        4 -> do
+            liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word32)
+        _ -> error "Unrecognized format"
+
+    return $ toBE32 ret
+
+getPixelUnsafe :: Int -> Int -> SDL.Surface -> Word32
+getPixelUnsafe x y surf = unsafePerformIO $ getPixel x y surf
+
+rgbToWord :: Word8 -> Word8 -> Word8 -> Word32
+rgbToWord r g b =
+    let tW32 x = (fromIntegral x) :: Word32 in
+    ( (tW32 r) `shiftL` 24) +
+    ( (tW32 g) `shiftL` 16) +
+    ( (tW32 b) `shiftL`  8) +
+    0xFF 
+
+wordToPixel :: Word32 -> Color4 Word8
+wordToPixel word =
+        Color4 (fromIntegral $ word .&. 0xFF)
+               (fromIntegral $ (word `shiftR` 8) .&. 0xFF)
+               (fromIntegral $ (word `shiftR` 16) .&. 0xFF)
+               (fromIntegral $ (word `shiftR` 24) .&. 0xFF)
+
+getRGBA :: SDL.Surface -> Int -> Int -> IO (Color4 Word8)
+getRGBA surf x y = liftM wordToPixel $ getPixel x y surf
+
+simpleStartup :: String -> (Int,Int) -> IO Surface
+simpleStartup name' (w,h) = do
+        SDL.init [SDL.InitEverything]
+        SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+        SDL.setCaption name' name'
+        SDL.getVideoSurface
+
+defaultReshape :: Int -> Int -> a -> IO a
+defaultReshape w h ret = do
+    let size = Size (fromIntegral w) (fromIntegral h)
+    viewport $=(Position 0 0, size)
+    _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+    return ret
+
+startPipeline :: (Int -> Int -> a -> IO a) -> (Event -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
+startPipeline reshapeH eventH displayH updateH ini = do
+    let pumpEvents' res = do
+        ev <- SDL.pollEvent
+        case ev of
+            Quit -> do
+                putStrLn "Exit event."
+                exitSuccess
+            SDL.NoEvent -> return res
+            VideoResize w h -> reshapeH w h res >>= pumpEvents'
+            _ -> eventH ev res >>= pumpEvents'
+    let runPipeline val = do
+            res <- pumpEvents' val >>= displayH
+            SDL.glSwapBuffers `seq` (updateH res) >>= runPipeline
+
+    -- TODO unhardcode this
+    reshapeH 640 480 ini >>= runPipeline
+
+setupTexturing :: TextureData -> UniformLocation -> Int -> IO ()
+setupTexturing (TextureData _ to) tu unit = do
+    texture Texture2D $= Enabled
+    activeTexture $= TextureUnit (fromIntegral unit)
+    textureBinding Texture2D $= Just to
+    uniform tu $= Index1 (fromIntegral unit::GLint)
diff --git a/Models.hs b/Models.hs
new file mode 100644
index 0000000..3f15288
--- /dev/null
+++ b/Models.hs
@@ -0,0 +1,88 @@
+module Models where
+
+import Graphics.Glyph.GeometryBuilder 
+import Graphics.Glyph.BufferBuilder
+
+import Control.Monad
+import Data.ByteString.Lazy
+
+import Graphics.Glyph.GLMath
+import Graphics.Glyph.ObjLoader
+
+square :: (Num b,IsModelBuilder b a) => b -> a ()
+square dist = do
+    plotVertex3   dist    dist  0
+    plotVertex3 (-dist)   dist  0
+    plotVertex3 (-dist) (-dist)  0
+    plotVertex3   dist  (-dist)  0
+
+getBS :: GeometryBuilder () -> ByteString
+getBS = buildSource
+
+getAsStr :: GeometryBuilder () -> String
+getAsStr = buildSourceAsString
+
+treeShader :: ByteString
+treeShader = buildSource tree
+
+triangle :: GeometryBuilder ()
+triangle =
+    generating Triangles $ do
+        projectionMatrixUniform "pjMatrix"
+        modelViewMatrixUniform "mvMatrix"
+        textureOutput "texposition"
+        normalOutput "normal"
+        positionOutput "frag_position"
+    
+        gVertex4E 1 0 0 0
+        gVertex4E 0 1 0 0
+        gVertex4E 0 0 1 0
+
+tree :: GeometryBuilder ()
+tree =
+    generating TriangleStrip $ do
+        projectionMatrixUniform "pjMatrix"
+        modelViewMatrixUniform "mvMatrix"
+        textureOutput "texposition"
+        normalOutput "normal"
+        positionOutput "frag_position"
+    
+        let r = 0.045
+        let h = 0.4
+    
+    
+        forM_ [0..6.4] $ \th -> do
+            let vertex x y z = do
+                gNormal3 x 0 z
+                gVertex4E x y z 0
+    
+            let c = r * cos th
+            let s = r * sin th
+    
+            let c2 = r * (cos $ th + 1.0)
+            let s2 = r * (sin $ th + 1.0)
+    
+            let texX = th / 6.4 / 2.0
+            let texX2 = (th+1.0) / 6.4 / 2.0
+    
+            let quads = trianglesFromQuads
+                    [(gTexture2 texX  0 >> vertex c 0 s),
+                    (gTexture2 texX  1 >> vertex c  h s),
+                    (gTexture2 texX2 1 >> vertex c2 h s2),
+                    (gTexture2 texX2 0 >> vertex c2 0 s2)]
+    
+            sequence_ quads
+    
+        forM_ [0..6.4] $ \th -> do
+            let vertex x y z = do
+                gNormal3 x 0 z
+                gVertex4E x y z 0
+    
+            let c = r * 4 * cos th
+            let s = r * 4 * sin th
+            let texX = th / 6.4 / 2.0 + 0.5
+    
+            gTexture2 texX 1
+            vertex 0 (h*2) 0
+            gTexture2 texX 0
+            vertex s (h/4) c
diff --git a/Resources.hs b/Resources.hs
new file mode 100644
index 0000000..bcc194a
--- /dev/null
+++ b/Resources.hs
@@ -0,0 +1,285 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Resources where
+
+import Graphics.UI.SDL as SDL 
+import Graphics.UI.SDL.Image as SDLImg
+
+import Graphics.Glyph.GLMath as V
+import Graphics.Glyph.GlyphObject
+import Graphics.Glyph.ObjLoader
+import Graphics.Glyph.GeometryBuilder as GB
+import Graphics.Glyph.Shaders
+import Graphics.SDL.SDLHelp
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Mat4
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL as GL
+
+import Control.Applicative
+import Control.Monad
+
+import Data.Angle
+import Data.Setters
+import Data.Maybe
+import Debug.Trace
+
+import System.Exit
+import System.FilePath
+
+import Models
+import Debug.Trace
+
+data CameraPosition = CameraPosition {
+    pEye :: Vec3 GLfloat,
+    pTh :: GLfloat,
+    pPh :: GLfloat
+} deriving Show
+
+data ObjectData = ObjectData Program
+
+data Resources = Resources {
+    rSurface :: SDL.Surface,
+
+    rPosition :: CameraPosition,
+    rDPosition :: CameraPosition,
+
+    pMatrix :: Mat4 GLfloat,
+    mvMatrix :: Mat4 GLfloat,
+
+    object :: GlyphObject (),
+    forest :: GlyphObject (),
+
+    speed :: Int,
+    time :: Int,
+    rSkyboxObject :: GlyphObject (UniformLocation,UniformLocation)
+}
+$(declareSetters ''Resources)
+
+buildMVMatrix :: CameraPosition -> Mat4 GLfloat
+buildMVMatrix (CameraPosition eye th ph) =
+    let up = if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0)
+            where ph' = (floor ph::Int) `mod` 360 in
+    let lookat = eye <+> (Vec3 $ toEuclidian (1,th,ph)) in
+        lookAtMatrix eye lookat up
+
+eventHandle :: SDL.Event -> Resources -> IO Resources
+eventHandle event res = do
+    let (CameraPosition eye th ph) = rDPosition res
+    let (CameraPosition peye pth pph) = rPosition res
+    case event of
+        KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess
+
+        KeyDown (Keysym SDLK_UP _ _) ->
+            return $ setRDPosition (CameraPosition eye th (ph+1)) res
+        KeyDown (Keysym SDLK_DOWN _ _) ->
+            return $ setRDPosition (CameraPosition eye th (ph-1)) res
+        KeyDown (Keysym SDLK_RIGHT _ _) ->
+            return $ setRDPosition (CameraPosition eye (th+1) ph) res
+        KeyDown (Keysym SDLK_LEFT _ _) ->
+            return $ setRDPosition (CameraPosition eye (th-1) ph) res
+
+        KeyUp (Keysym SDLK_UP _ _) ->
+            return $ setRDPosition (CameraPosition eye th (ph-1)) res
+        KeyUp (Keysym SDLK_DOWN _ _) ->
+            return $ setRDPosition (CameraPosition eye th (ph+1)) res
+        KeyUp (Keysym SDLK_RIGHT _ _) ->
+            return $ setRDPosition (CameraPosition eye (th-1) ph) res
+        KeyUp (Keysym SDLK_LEFT _ _) ->
+            return $ setRDPosition (CameraPosition eye (th+1) ph) res
+
+        MouseMotion _ _ x y -> do
+            return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res
+
+        KeyDown (Keysym SDLK_w _ _) ->
+            return $ setSpeed (speed res + 1) res
+        KeyDown (Keysym SDLK_s _ _) ->
+            return $ setSpeed (speed res - 1) res
+        KeyUp (Keysym SDLK_w _ _) ->
+            return $ setSpeed (speed res - 1) res
+        KeyUp (Keysym SDLK_s _ _) ->
+            return $ setSpeed (speed res + 1) res
+
+        KeyUp (Keysym SDLK_f _ _) -> do
+            ret <- reshape 1920 1080 res
+            SDL.toggleFullscreen $ rSurface ret
+            SDL.showCursor False
+            return ret
+        _ -> return res
+
+displayHandle :: Resources -> IO Resources
+displayHandle resources = do
+    let cameraPos@(CameraPosition _ th ph) = rPosition resources
+
+    clearColor $= Color4 1.0 0.0 0.0 1.0
+    clear [ColorBuffer, DepthBuffer]
+    SDL.flip $ rSurface resources
+    printErrors "Display"
+    depthFunc $= Nothing
+
+    let lightPos = Vec4( 100 * (cosine . Degrees . fromIntegral . time) resources + 50,
+                         100,
+                         100 * (sine . Degrees . fromIntegral . time) resources + 50, 1 )
+
+    cullFace $= Nothing
+    draw $ prepare (rSkyboxObject resources) $ \this -> do
+        let (matLoc,pmatLoc) = getResources this
+        uniform pmatLoc $= pMatrix resources
+        uniform matLoc $= buildMVMatrix (CameraPosition (Vec3 (0,0,0)) th ph)
+
+    vertexProgramPointSize $= Enabled
+    depthFunc $= Just Less
+    let l_mvMatrix = buildMVMatrix $ cameraPos
+    cullFace $= Just Front
+    draw $ prepare (object resources) $ \_ -> do
+        uniform (UniformLocation 5) $= l_mvMatrix
+        uniform (UniformLocation 4) $= pMatrix resources
+        uniform (UniformLocation 6) $= l_mvMatrix `glslMatMul` lightPos
+        return ()
+
+    cullFace $= Nothing
+    blend $= Enabled
+    blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)
+    draw $ prepare (forest resources) $ \_ -> do
+        uniform (UniformLocation 5) $= l_mvMatrix
+        uniform (UniformLocation 4) $= pMatrix resources
+        uniform (UniformLocation 7) $= l_mvMatrix `glslMatMul` lightPos
+        return ()
+
+    SDL.glSwapBuffers
+    return resources
+
+updateHandle :: Resources -> IO Resources
+updateHandle res = do
+   return $ setRPosition (rPosition res `cAdd` rDPosition res) $
+            setTime (time res + 1) res
+   where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
+           let fri = fromIntegral
+               x' = (fri $ speed res) `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) in
+           (CameraPosition (x <+> x') (y + y') (z + z'))
+
+reshape :: Int -> Int -> Resources -> IO Resources
+reshape w h res =
+    defaultReshape w h () >> do
+        let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 10000
+        return $ setPMatrix pMatrix' res
+
+loadProgramSafe' ::
+    (IsShaderSource a,
+     IsShaderSource b,
+     IsShaderSource c) => a -> b -> Maybe c -> IO Program
+loadProgramSafe' s1 s2 s3 = do
+    progMaybe <- loadProgramSafe s1 s2 s3
+    when (isNothing progMaybe) $ exitWith (ExitFailure 111)
+    return $ fromJust progMaybe
+
+buildTerrainObject :: BuilderM GLfloat b -> IO (GlyphObject ())
+buildTerrainObject builder = do
+    let terrainList = map ("terrain/"++)
+         [ "forest.png", "beach.png",
+           "oceanfloor.png", "grass.png",
+           "jungle.png", "mountains.png",
+           "tundra.png" ]
+    print terrainList
+    terrainProg <- loadProgramSafe' "shaders/basic.vert" "shaders/basic.frag" (Nothing::Maybe String)
+    lst <- forM (zip [0..7::Int] $ terrainList ++ repeat "height.png") $ \(idx,str) -> do
+            location <- get $ uniformLocation terrainProg $ "textures[" ++! idx ++ "]"
+            load str >>= textureFromSurface >>= return . (,) location
+
+    let (dx,dy) = (mapT2 $ (1/).fromIntegral) (mapT2 maximum (unzip $ map (textureSize.snd) lst));
+    dXlocation <- get $ uniformLocation terrainProg "dX"
+    dYlocation <- get $ uniformLocation terrainProg "dY"
+    putStrLn $ "(dx,dy)=" ++! (dx,dy)
+    newDefaultGlyphObjectWithClosure builder () $ \_ -> do
+                    currentProgram $= Just terrainProg
+                    forM_ (zip [0..] lst) $ \(i,(loc,td)) ->
+                        setupTexturing td loc i
+                    uniform dXlocation $= Index1 (dx::GLfloat)
+                    uniform dYlocation $= Index1 (dy::GLfloat)
+                    printErrors "terrainObjectClosure"
+
+buildForestObject :: BuilderM GLfloat b -> IO (GlyphObject ())
+buildForestObject builder = do
+    forestProg <- loadProgramSafe' 
+        "shaders/forest.vert" "shaders/forest.frag" (Nothing::Maybe String)
+
+    woodTexture <- load "textures/wood_low.png" >>= textureFromSurface
+    let (dx,dy) = (mapT2 $ (1/).fromIntegral) (textureSize woodTexture)
+    dXlocation <- get $ uniformLocation forestProg "dX"
+    dYlocation <- get $ uniformLocation forestProg "dY"
+
+    newDefaultGlyphObjectWithClosure builder () $ \_ -> do
+                currentProgram $= Just forestProg
+                setupTexturing woodTexture (UniformLocation 6) 0
+                uniform dXlocation $= (Index1 $ (dx::GLfloat))
+                uniform dYlocation $= (Index1 $ (dy::GLfloat))
+                printErrors "forestClosure"
+
+makeResources :: SDL.Surface -> BuilderM GLfloat b -> BuilderM GLfloat b -> IO Resources
+makeResources surf builder forestB = do
+    let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
+    Resources 
+        <$> pure surf
+        <*> do CameraPosition
+                <$> pure (Vec3 (10,10,2))
+                <*> pure 0
+                <*> pure 0
+        <*> do CameraPosition
+                <$> pure (Vec3 (0,0,0))
+                <*> pure 0
+                <*> pure 0
+        <*> pure pMatrix'
+        <*> pure pMatrix'
+        <*> buildTerrainObject builder
+        <*> buildForestObject forestB
+        <*> pure 0
+        <*> pure 0
+        <*> skyboxObject
+
+printErrors :: String -> IO ()
+printErrors ctx =
+    get errors >>= mapM_ (putStrLn . (("GL["++ctx++"]: ")++) . show)
+
+skyboxSides :: GLfloat -> BuilderM GLfloat ()
+skyboxSides dist = do
+    let q = trianglesFromQuads $
+                -- back
+                [(bTexture2(0,0),    bVertex3 (-dist,  dist, -dist)),
+                 (bTexture2(0.25,0), bVertex3 ( dist,  dist, -dist)),
+                 (bTexture2(0.25,1), bVertex3 ( dist, -dist, -dist)),
+                 (bTexture2(0,1),    bVertex3 (-dist, -dist, -dist))] ++
+                
+                -- front
+                [(bTexture2(0.75,0),    bVertex3 (-dist,  dist, dist)),
+                 (bTexture2(0.5,0),   bVertex3 ( dist,  dist, dist)),
+                 (bTexture2(0.5,1),   bVertex3 ( dist, -dist, dist)),
+                 (bTexture2(0.75,1),    bVertex3 (-dist, -dist, dist))] ++
+
+                -- right
+                [(bTexture2(0.75,1),    bVertex3 (-dist, -dist,  dist)),
+                 (bTexture2(0.75,0),   bVertex3 (-dist,  dist,  dist)),
+                 (bTexture2(1.0,0),   bVertex3 (-dist,  dist, -dist)),
+                 (bTexture2(1.0,1),    bVertex3 (-dist, -dist, -dist))] ++
+
+                -- left
+                [(bTexture2(0.5,1),    bVertex3 ( dist, -dist,  dist)),
+                 (bTexture2(0.5,0),    bVertex3 ( dist,  dist,  dist)),
+                 (bTexture2(0.25,0) ,    bVertex3 ( dist,  dist, -dist)),
+                 (bTexture2(0.25,1) ,    bVertex3 ( dist, -dist, -dist))]
+            in
+        mapM_ (uncurry (>>)) q
+skyboxObject :: IO (GlyphObject (UniformLocation,UniformLocation))
+skyboxObject = do
+    prog <- loadProgramSafe' "shaders/sky.vert" "shaders/sky.frag" (Nothing::Maybe String)
+    texLoc <- get $ uniformLocation prog "texture"
+    matLoc <- get $ uniformLocation prog "mvMatrix"
+    pmatLoc <- get $ uniformLocation prog "pjMatrix"
+    texture <- load "textures/skybox_sides.png" >>= textureFromSurface
+    newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do
+        currentProgram $= Just prog
+        setupTexturing texture texLoc 0
+        printErrors "Skybox"
+
+prepareSkybox :: Mat4 GLfloat -> Mat4 GLfloat -> GlyphObject (Mat4 GLfloat -> Mat4 GLfloat -> IO ()) -> IO ()
+prepareSkybox proj lookat obj = do
+    (getResources obj) proj lookat
+
diff --git a/TileShow.hs b/TileShow.hs
new file mode 100644
index 0000000..dd353dc
--- /dev/null
+++ b/TileShow.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module TileShow where
+import Language.Haskell.TH
+
+makeShow t = do
+  TyConI (DataD _ _ _ constructors _)  <-  reify t
+  -- Make `show` clause for one constructor:
+  --   show (A x1 x2) = "A "++show x1++" "++show x2
+  let showClause (NormalC name fields) = do
+        -- Name of constructor, i.e. "A". Will become string literal in generated code
+        let constructorName = [(head $ nameBase name)]
+        -- Generate function clause for one constructor
+        clause [conP name []]                                 -- (A x1 x2)
+               (normalB [| constructorName |]) []  -- "A "++show x1++" "++show x2
+  -- Make body for function `show`:
+  --   show (A x1 x2) = "A "++show x1++" "++show x2
+  --   show (B x1)    = "B "++show x1
+  --   show C         = "C"
+  showbody <- mapM showClause constructors
+  -- Generate template instance declaration and then replace
+  --   type name (T1) and function body (\x -> "text") with our data
+  d <- [d| instance Show String where
+             show _x = "text"
+       |]
+  let    [InstanceD [] (AppT showt (ConT _T1)) [FunD showf _text]] = d
+  return [InstanceD [] (AppT showt (ConT t  )) [FunD showf showbody]]