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)