aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Data/ByteStringBuilder.hs15
-rw-r--r--Final.hs629
-rw-r--r--Graphics/Glyph/ArrayGenerator.hs41
-rw-r--r--Graphics/Glyph/BufferBuilder.hs466
-rw-r--r--Graphics/Glyph/ExtendedGL.hs11
-rw-r--r--Graphics/Glyph/ExtendedGL/Base.hs124
-rw-r--r--Graphics/Glyph/ExtendedGL/Framebuffers.hs137
-rw-r--r--Graphics/Glyph/GLMath.hs431
-rw-r--r--Graphics/Glyph/GeometryBuilder.hs249
-rw-r--r--Graphics/Glyph/GlyphObject.hs189
-rw-r--r--Graphics/Glyph/ObjLoader.hs166
-rw-r--r--Graphics/Glyph/Shaders.hs144
-rw-r--r--Graphics/Glyph/Textures.hs47
-rw-r--r--Graphics/Glyph/Util.hs265
-rw-r--r--Graphics/Rendering/HelpGL.hs12
-rw-r--r--Graphics/SDL/SDLHelp.hs203
-rw-r--r--Models.hs129
-rw-r--r--Resources.hs1407
18 files changed, 2494 insertions, 2171 deletions
diff --git a/Data/ByteStringBuilder.hs b/Data/ByteStringBuilder.hs
index 6f0222e..98b3db5 100644
--- a/Data/ByteStringBuilder.hs
+++ b/Data/ByteStringBuilder.hs
@@ -5,9 +5,10 @@ import Data.ByteString.Lazy.Char8 as BSLC
import Data.Word
data ByteStringBuilder a = ByteStringBuilder ByteString a
+
type Builder = ByteStringBuilder ()
-put :: ByteString -> Builder
+put :: ByteString -> Builder
put = flip ByteStringBuilder ()
putS :: String -> Builder
@@ -30,13 +31,13 @@ instance Functor ByteStringBuilder where
instance Applicative ByteStringBuilder where
(<*>) afn aa = do
- fn <- afn
- a <- aa
- return (fn a)
+ fn <- afn
+ a <- aa
+ return (fn a)
pure = return
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
+ ByteStringBuilder a _ >> ByteStringBuilder b c = ByteStringBuilder (a `append` b) c
+ a@(ByteStringBuilder _ b) >>= func = a >> func b
+ return = ByteStringBuilder BSL.empty
diff --git a/Final.hs b/Final.hs
index 2a58bbb..0a531d5 100644
--- a/Final.hs
+++ b/Final.hs
@@ -1,38 +1,30 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
module Main where
-import Text.Printf
-import Graphics.Rendering.OpenGL as GL
-import SDL.Image as SDLImg
-import SDL
-import Graphics.SDL.SDLHelp
-import Graphics.Glyph.Util
import Control.Monad
import Control.Monad.Writer
-
-import Graphics.Glyph.BufferBuilder
-
-import qualified Data.Map as Map
-import Data.Word
import Data.Array
import Data.Array.IO
-
-import Data.Sequence as Seq
-import Data.Sequence (Seq)
-import Prelude as P
-
import Data.Bits
-
+import qualified Data.Map as Map
+import Data.Sequence (Seq)
+import Data.Sequence as Seq
+import Data.Word
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL as GL
+import Graphics.SDL.SDLHelp
import Resources
-import System.Random
-
-import System.Environment
-import qualified SDL
+import SDL
import qualified SDL
-
+import SDL.Image as SDLImg
+import System.Environment
+import System.Random
+import Text.Printf
+import Prelude as P
{-
- This function builds an array of tile from the heightmap and
@@ -42,320 +34,357 @@ import qualified SDL
- w is the minimum width of the two images and h is the minimum
- height.
-}
-buildArray :: SDL.Surface -> SDL.Surface -> IO (Array (Int,Int) Tile)
+buildArray :: SDL.Surface -> SDL.Surface -> IO (Array (Int, Int) Tile)
buildArray terrain height = do
- bpp <- fromIntegral <$> (getSurfaceBytesPerPixel terrain) :: IO Int
- printf "Terrain BBP: %d\n" bpp
-
-
- (V2 (fromIntegral -> w) (fromIntegral -> h)) <- SDL.surfaceDimensions terrain
- {- Pick the minimum width and height between the two images -}
- let {- Function that returns a Tile for an x y coordinate -}
- conv x y =
- let terrainVal = fromIntegral $ getPixelUnsafe x y terrain
- {- The height is encoded as the sum of the color channels, to make life a litte
- - easier on the heightmap reader. -}
- sumit word =
- ((word `shiftR` 8) .&. 0xFF) +
- ((word `shiftR`16) .&. 0xFF) +
- ((word `shiftR`24) .&. 0xFF)
-
- {- The value of the hightmap at the coordinate. I will promise
- - the compmiler that my surfaces will not change. -}
- heightVal = (fromIntegral.sumit) (getPixelUnsafe x y height)
-
- {- The value of the terrain map at thata location -}
- terrainVal' = Map.findWithDefault Resources.Unknown terrainVal tileMap in
- Tile terrainVal' heightVal
-
- {- build the list of Tiles to jam into the array -}
- list = [conv x y | x <- [0..w-1], y <- [0..h-1]]
- in return $ listArray ((0,0),(w-1,h-1)) list
+ bpp <- fromIntegral <$> (getSurfaceBytesPerPixel terrain) :: IO Int
+ printf "Terrain BBP: %d\n" bpp
+
+ (V2 (fromIntegral -> w) (fromIntegral -> h)) <- SDL.surfaceDimensions terrain
+ {- Pick the minimum width and height between the two images -}
+ let {- Function that returns a Tile for an x y coordinate -}
+ conv x y =
+ let terrainVal = fromIntegral $ getPixelUnsafe x y terrain
+ {- The height is encoded as the sum of the color channels, to make life a litte
+ - easier on the heightmap reader. -}
+ sumit word =
+ ((word `shiftR` 8) .&. 0xFF)
+ + ((word `shiftR` 16) .&. 0xFF)
+ + ((word `shiftR` 24) .&. 0xFF)
+
+ {- The value of the hightmap at the coordinate. I will promise
+ - the compmiler that my surfaces will not change. -}
+ heightVal = (fromIntegral . sumit) (getPixelUnsafe x y height)
+
+ {- The value of the terrain map at thata location -}
+ terrainVal' = Map.findWithDefault Resources.Unknown terrainVal tileMap
+ in Tile terrainVal' heightVal
+
+ {- build the list of Tiles to jam into the array -}
+ list = [conv x y | x <- [0 .. w -1], y <- [0 .. h -1]]
+ in return $ listArray ((0, 0), (w -1, h -1)) list
{- This function takes the array generated in the function from above and
- creates a new array that colors in the array with locations of bodies
- of water and assigns an id to each of them. This allows for me to go
- back and assign heights for the bodies of water. -}
-colorArray :: Array (Int,Int) Tile -> IO (IOArray (Int,Int) Int)
+colorArray :: Array (Int, Int) Tile -> IO (IOArray (Int, Int) Int)
colorArray marr = do
-
- {- Very simple function that take splits a sequence
- - into a head and a tail -}
- let pollseq (Seq.viewl -> (head' :< tail')) = (head',tail')
- pollseq _ = undefined
-
- let bnd@(_,(w,h)) = bounds marr
- ret <- newArray bnd 0
-
- {- Boolean funcion. Returns true if the
- - tile at the position `place` is water
- - and has not yet been assigned an id -}
- let myfunction a_place = do
- val <- readArray ret a_place
- case marr ! a_place of
- (Tile Water _) -> return $ val==0
- _ -> return False
-
- {- Uses a queue method to flood fill bodies
- - of water and write that to an array -}
- let floodfill :: (Int,Int) -> ((Int,Int) -> IO Bool) -> Int -> IO ()
- floodfill start func' val = do
- let func t@(x,y) = if not (x <= w && x >= 0 && y <= h && y >= 0) then return False else func' t
- {- Just magic. Does a flood fill -}
- _ <- untilM2 (return . Seq.null) (Seq.singleton start) $ \queue -> do
- let (head',tail') = pollseq queue
- bool <- func head'
- if not bool then return tail' else do
- (_,tail2) <- untilM2 (liftM not . func . fst) (head',tail') $ \((x,y),queue') -> do
- (ret <!> (x,y)) $= val
- return ((x+1,y),queue' |> (x,y-1) |> (x,y+1))
- (_,tail3) <- untilM2 (liftM not . func . fst) (head',tail2) $ \((x,y),queue') -> do
- (ret <!> (x,y)) $= val
- return ((x-1,y), queue' |> (x,y-1) |> (x,y+1))
- return tail3
- return ()
- {- Iterates through all the points and does a flood fill on
- - them -}
- foldM_ (\val place -> do
+ {- Very simple function that take splits a sequence
+ - into a head and a tail -}
+ let pollseq (Seq.viewl -> (head' :< tail')) = (head', tail')
+ pollseq _ = undefined
+
+ let bnd@(_, (w, h)) = bounds marr
+ ret <- newArray bnd 0
+
+ {- Boolean funcion. Returns true if the
+ - tile at the position `place` is water
+ - and has not yet been assigned an id -}
+ let myfunction a_place = do
+ val <- readArray ret a_place
+ case marr ! a_place of
+ (Tile Water _) -> return $ val == 0
+ _ -> return False
+
+ {- Uses a queue method to flood fill bodies
+ - of water and write that to an array -}
+ let floodfill :: (Int, Int) -> ((Int, Int) -> IO Bool) -> Int -> IO ()
+ floodfill start func' val = do
+ let func t@(x, y) = if not (x <= w && x >= 0 && y <= h && y >= 0) then return False else func' t
+ {- Just magic. Does a flood fill -}
+ _ <- untilM2 (return . Seq.null) (Seq.singleton start) $ \queue -> do
+ let (head', tail') = pollseq queue
+ bool <- func head'
+ if not bool
+ then return tail'
+ else do
+ (_, tail2) <- untilM2 (liftM not . func . fst) (head', tail') $ \((x, y), queue') -> do
+ (ret <!> (x, y)) $= val
+ return ((x + 1, y), queue' |> (x, y -1) |> (x, y + 1))
+ (_, tail3) <- untilM2 (liftM not . func . fst) (head', tail2) $ \((x, y), queue') -> do
+ (ret <!> (x, y)) $= val
+ return ((x -1, y), queue' |> (x, y -1) |> (x, y + 1))
+ return tail3
+ return ()
+ {- Iterates through all the points and does a flood fill on
+ - them -}
+ foldM_
+ ( \val place -> do
bool <- myfunction place
- if bool then do
+ if bool
+ then do
floodfill place myfunction val
- return $ val+1
- else return val
- ) 1 [(x,y) | x <- [0..w], y <- [0..h]]
- return ret
+ return $ val + 1
+ else return val
+ )
+ 1
+ [(x, y) | x <- [0 .. w], y <- [0 .. h]]
+ return ret
{- This function takes the two arrays from the functions above and generates
- 2 things:
- A map of water bodies ids to elevations (to detect if you are under water
- A builder that will generate all of the quads for the water. -}
-getWaterQuads :: Array (Int,Int) Tile -> IOArray (Int,Int) Int -> IO ( Map.Map Int GLfloat, BuilderM GLfloat () )
+getWaterQuads :: Array (Int, Int) Tile -> IOArray (Int, Int) Int -> IO (Map.Map Int GLfloat, BuilderM GLfloat ())
getWaterQuads marr arr = do
- let (_,(w,h)) = bounds marr
-
- {- Iterates through the bodies of water and finds the lowest altitude
- - of the land surrounding the water. Returns a type of body id
- - to minx, miny, maxx, maxy and elevation -}
- let elevationCacheIO :: IO (Map.Map Int (Int,Int,Int,Int,Int))
- elevationCacheIO = do
- {- Tuple of functions that will be mapped with
- - the application operator ($) -}
- let tup = (min,max,max,min,min)
- foldM (\themap (x,y) -> do
- bodyID <- readArray arr (x,y)
- if bodyID == 0 then return themap else do
- let valid (aX,aY) = aX >= 0 && aX <= w && aY >= 0 && aY <= h
- let neighbors (aX,aY) = P.filter valid $ map (zipWithT2 (+) (aX,aY))
- [ (1,0),
- (0,1), (0,-1),
- (-1,0) ]
- let toelev aX =
- let tile = marr ! aX in
- (tileType tile == Water) ? 1000000000000 $ elevation tile
- let elev = minimum $ map toelev (neighbors (x,y))
- let newmap =
- Map.insertWith (zipWithT5 (P.$) . zipWithT5 (P.$) tup)
- bodyID (elev,x,y,x,y) themap
- return newmap
- ) (Map.empty::Map.Map Int (Int,Int,Int,Int,Int)) [(x,y) | x <- [0..w], y <- [0..h]]
-
- elevMap <- elevationCacheIO
-
- {- A map between body id and elevation. Get rid of the bounding quad box -}
- let elevMap2 = Map.map (\(elev,_,_,_,_) ->
- fromIntegral elev / 10) elevMap
-
- let dat = Map.toList elevMap
- {- Iterate through the map and draw the bounding quad
- - for the body of water -}
- return (elevMap2,sequence_ $ for dat $ \(_, (elev,maxx,maxy,minx,miny)) ->
- let mxx = fromIntegral maxx + 1
- mnx = fromIntegral minx - 1
- mxy = fromIntegral maxy + 1
- mny = fromIntegral miny - 1
- relev = fromIntegral elev / 10 in
- mapM_ bVertex3
- [(mxx,relev,mxy),
- (mxx,relev,mny),
- (mnx,relev,mny),
- (mnx,relev,mxy)])
-
-
-printArray :: Array (Int,Int) Tile -> IO ()
+ let (_, (w, h)) = bounds marr
+
+ {- Iterates through the bodies of water and finds the lowest altitude
+ - of the land surrounding the water. Returns a type of body id
+ - to minx, miny, maxx, maxy and elevation -}
+ let elevationCacheIO :: IO (Map.Map Int (Int, Int, Int, Int, Int))
+ elevationCacheIO = do
+ {- Tuple of functions that will be mapped with
+ - the application operator ($) -}
+ let tup = (min, max, max, min, min)
+ foldM
+ ( \themap (x, y) -> do
+ bodyID <- readArray arr (x, y)
+ if bodyID == 0
+ then return themap
+ else do
+ let valid (aX, aY) = aX >= 0 && aX <= w && aY >= 0 && aY <= h
+ let neighbors (aX, aY) =
+ P.filter valid $
+ map
+ (zipWithT2 (+) (aX, aY))
+ [ (1, 0),
+ (0, 1),
+ (0, -1),
+ (-1, 0)
+ ]
+ let toelev aX =
+ let tile = marr ! aX
+ in (tileType tile == Water) ? 1000000000000 $ elevation tile
+ let elev = minimum $ map toelev (neighbors (x, y))
+ let newmap =
+ Map.insertWith
+ (zipWithT5 (P.$) . zipWithT5 (P.$) tup)
+ bodyID
+ (elev, x, y, x, y)
+ themap
+ return newmap
+ )
+ (Map.empty :: Map.Map Int (Int, Int, Int, Int, Int))
+ [(x, y) | x <- [0 .. w], y <- [0 .. h]]
+
+ elevMap <- elevationCacheIO
+
+ {- A map between body id and elevation. Get rid of the bounding quad box -}
+ let elevMap2 =
+ Map.map
+ ( \(elev, _, _, _, _) ->
+ fromIntegral elev / 10
+ )
+ elevMap
+
+ let dat = Map.toList elevMap
+ {- Iterate through the map and draw the bounding quad
+ - for the body of water -}
+ return
+ ( elevMap2,
+ sequence_ $
+ for dat $ \(_, (elev, maxx, maxy, minx, miny)) ->
+ let mxx = fromIntegral maxx + 1
+ mnx = fromIntegral minx - 1
+ mxy = fromIntegral maxy + 1
+ mny = fromIntegral miny - 1
+ relev = fromIntegral elev / 10
+ in mapM_
+ bVertex3
+ [ (mxx, relev, mxy),
+ (mxx, relev, mny),
+ (mnx, relev, mny),
+ (mnx, relev, mxy)
+ ]
+ )
+
+printArray :: Array (Int, Int) Tile -> IO ()
printArray arr = do
- let (_,(w,h)) = bounds arr
- putStrLn $ "w=" ++! (w+1)
- putStrLn $ "h=" ++! (h+1)
- forM_ [0..h] $ \y -> do
- forM_ [0..w] $ \x -> do
- let lNext = arr ! (x,y)
- putStr $ show $ tileType lNext
- putStr " "
- forM_ [0..w] $ \x -> do
- let lNext = arr ! (x,y)
- putStr $ elevShow $ elevation lNext
- putStrLn ""
- where elevShow x =
- let len = P.length elevMap
- nx = x `div` 5 in
- if nx >= len then "=" else [elevMap !! nx]
- elevMap = "`.,-~*<:!;%&#@0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
-
-printShowArray :: (Show a) => IOArray (Int,Int) a -> IO ()
+ let (_, (w, h)) = bounds arr
+ putStrLn $ "w=" ++! (w + 1)
+ putStrLn $ "h=" ++! (h + 1)
+ forM_ [0 .. h] $ \y -> do
+ forM_ [0 .. w] $ \x -> do
+ let lNext = arr ! (x, y)
+ putStr $ show $ tileType lNext
+ putStr " "
+ forM_ [0 .. w] $ \x -> do
+ let lNext = arr ! (x, y)
+ putStr $ elevShow $ elevation lNext
+ putStrLn ""
+ where
+ elevShow x =
+ let len = P.length elevMap
+ nx = x `div` 5
+ in if nx >= len then "=" else [elevMap !! nx]
+ elevMap = "`.,-~*<:!;%&#@0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+
+printShowArray :: (Show a) => IOArray (Int, Int) a -> IO ()
printShowArray arr = do
- (_,(w,h)) <- getBounds arr
- putStrLn $ "w=" ++! (w+1)
- putStrLn $ "h=" ++! (h+1)
- forM_ [0..h] $ \y -> do
- forM_ [0..w] $ \x -> do
- lNext <- readArray arr (x,y)
- putStr $ show lNext ++ " "
- putStrLn ""
+ (_, (w, h)) <- getBounds arr
+ putStrLn $ "w=" ++! (w + 1)
+ putStrLn $ "h=" ++! (h + 1)
+ forM_ [0 .. h] $ \y -> do
+ forM_ [0 .. w] $ \x -> do
+ lNext <- readArray arr (x, y)
+ putStr $ show lNext ++ " "
+ putStrLn ""
{- The colors each tile type is mapped to
- as an array -}
-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)
-toColor Resources.Unknown = (0,0,0,0)
+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)
+toColor Resources.Unknown = (0, 0, 0, 0)
{- Map of color to TileType used for
- parsing the terrain map -}
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
+ 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
{- The function that generates the builder that will
- generate the VAO for the terrain based on the heightmap -}
-createBuilder :: Array (Int,Int) Tile -> BuilderM GLfloat ()
+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 $
- forM_ (trianglesFromQuads lst) $ \(x,y,z,_) -> do
- let f = fromIntegral
-
- {- Store the texture to use in the color -}
- let bUseTexture a = bColor4 (0,0,0,f a)
+ 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 $
+ forM_ (trianglesFromQuads lst) $ \(x, y, z, _) -> do
+ let f = fromIntegral
+
+ {- Store the texture to use in the color -}
+ let bUseTexture a = bColor4 (0, 0, 0, f a)
+
+ bUseTexture $ fromEnum (tileType $ arr ! (x, z))
+ bTexture2 (f x / 10.0, f z / 10.0)
+ bVertex3 (f x, y, f z)
- bUseTexture $ fromEnum (tileType $ arr ! (x,z))
- bTexture2 (f x / 10.0, f z / 10.0)
- bVertex3 (f x, y,f z)
-
{- Generates random locations for the trees inside of the terrain
- - spots where trees may exist
+ - spots where trees may exist
-
- A MonadPlusBuilder is a Monad used to build monad pluses; in this
- case a Sequence.
-}
-createLocations :: Array (Int,Int) Tile -> StdGen -> Int -> TileType -> Writer (Seq GLfloat) ()
+createLocations :: Array (Int, Int) Tile -> StdGen -> Int -> TileType -> Writer (Seq GLfloat) ()
createLocations arr gen density typ = 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
-
- {- Adds a random number of trees between 0 and density for the location -}
- let run rs (x',y') = do
- let (_:ntrees, t) = P.splitAt (head rs `mod` density + 1) rs
-
- when (isType x' y' typ) $
- {- Iterate and place n trees -}
- forM_ ntrees $ \rand ->
- let (a',b',c) = toTup rand
- (x,y) = (int x' + f a', int y' + f b') :: (GLfloat,GLfloat)
- [sx,sy,sz,rot,noise,shade] = (P.take 6 $ randomRs (0.0,1.0) $ mkStdGen c)
-
- {- Boiler for finding the correct elevation between vertices -}
- h1 = getElev (floor x) (floor y)
- h2 = getElev (floor x) (floor (y+1))
- h3 = getElev (floor (x+1)) (floor y)
- h4 = getElev (floor (x+1)) (floor (y+1))
- u = fpart x
- v = fpart y
- mixu1 = mix h3 h1 u
- mixu2 = mix h4 h2 u
- newh = mix mixu2 mixu1 v in
-
- {- Add to the sequence of elements. This
- - will be turned into a per-instance VAO -}
- tell $ Seq.fromList [
- -- translation
- x,newh-0.2,y,
- -- scale
- sx+0.5,sy+0.5,sz+0.5,
- -- rotation
- sin (rot*6.4), cos(rot*6.4),
- -- noise
- noise*6.4,
- shade / 2 + 0.75
- ]
-
- {- Return the tail of the randomly generated numbers -}
- return t
-
- foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]
-
- where isType x y t = tileType (arr ! (x,y)) == t
- f x = (fromIntegral x - 128) / 128 * (sqrt 2 / 2)
- toTup x = ( x .&. 0xFF ,
- (x `shiftR` 8) .&. 0xFF,
- (x `shiftR` 16) .&. 0xFF)
-
+ 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
+
+ {- Adds a random number of trees between 0 and density for the location -}
+ let run rs (x', y') = do
+ let (_ : ntrees, t) = P.splitAt (head rs `mod` density + 1) rs
+
+ when (isType x' y' typ) $
+ {- Iterate and place n trees -}
+ forM_ ntrees $ \rand ->
+ let (a', b', c) = toTup rand
+ (x, y) = (int x' + f a', int y' + f b') :: (GLfloat, GLfloat)
+ [sx, sy, sz, rot, noise, shade] = (P.take 6 $ randomRs (0.0, 1.0) $ mkStdGen c)
+
+ {- Boiler for finding the correct elevation between vertices -}
+ h1 = getElev (floor x) (floor y)
+ h2 = getElev (floor x) (floor (y + 1))
+ h3 = getElev (floor (x + 1)) (floor y)
+ h4 = getElev (floor (x + 1)) (floor (y + 1))
+ u = fpart x
+ v = fpart y
+ mixu1 = mix h3 h1 u
+ mixu2 = mix h4 h2 u
+ newh = mix mixu2 mixu1 v
+ in {- Add to the sequence of elements. This
+ - will be turned into a per-instance VAO -}
+ tell $
+ Seq.fromList
+ [ -- translation
+ x,
+ newh -0.2,
+ y,
+ -- scale
+ sx + 0.5,
+ sy + 0.5,
+ sz + 0.5,
+ -- rotation
+ sin (rot * 6.4),
+ cos (rot * 6.4),
+ -- noise
+ noise * 6.4,
+ shade / 2 + 0.75
+ ]
+
+ {- Return the tail of the randomly generated numbers -}
+ return t
+
+ foldM_ run (randoms gen) [(x, y) | x <- [1 .. w], y <- [1 .. h]]
+ where
+ isType x y t = tileType (arr ! (x, y)) == t
+ 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
- let doload str = sequence
- [ SDLImg.load $ "maps/"++str++"_terrain.png",
- SDLImg.load $ "maps/"++str++"_height.png" ]
- args <- getArgs
-
- {- Load the terrain and heightmaps from SDL. -}
- [terrain,height] <-
- case args of
- (ter:hei:_) -> sequence [SDLImg.load ter, SDLImg.load hei]
- (m:_) -> doload m
- _ -> sequence [SDLImg.load "maps/wonderland_terrain.png", SDLImg.load "maps/wonderland_height.png"]
-
- arr <- buildArray terrain height
- coloredArr <- colorArray arr
-
- window <- simpleStartup "Terralloc" (1280,1024)
- stgen <- newStdGen
- stgen2 <- newStdGen
-
- {- Create the tree locations. Desity of 7 for the forest, 2 for the jungle
- - since the jungle model is bigger -}
- let !forestLocations = execWriter $ createLocations arr stgen 7 Forest
- let !jungleLocations = execWriter $ createLocations arr stgen2 2 Jungle
-
- (mapping,water) <- getWaterQuads arr coloredArr
- coloredArr2 <- mapArray (\idx -> if idx == 0 then -1 else Map.findWithDefault (-1) idx mapping) coloredArr
-
- printShowArray coloredArr2
- printArray arr
-
- {- Kick off SDL with the callbacks defined in Resources -}
- makeResources window (createBuilder arr) forestLocations jungleLocations water arr coloredArr2
- >>= startPipeline reshape eventHandle displayHandle updateHandle;
+ let doload str =
+ sequence
+ [ SDLImg.load $ "maps/" ++ str ++ "_terrain.png",
+ SDLImg.load $ "maps/" ++ str ++ "_height.png"
+ ]
+ args <- getArgs
+
+ {- Load the terrain and heightmaps from SDL. -}
+ [terrain, height] <-
+ case args of
+ (ter : hei : _) -> sequence [SDLImg.load ter, SDLImg.load hei]
+ (m : _) -> doload m
+ _ -> sequence [SDLImg.load "maps/wonderland_terrain.png", SDLImg.load "maps/wonderland_height.png"]
+
+ arr <- buildArray terrain height
+ coloredArr <- colorArray arr
+
+ window <- simpleStartup "Terralloc" (1280, 1024)
+ stgen <- newStdGen
+ stgen2 <- newStdGen
+
+ {- Create the tree locations. Desity of 7 for the forest, 2 for the jungle
+ - since the jungle model is bigger -}
+ let !forestLocations = execWriter $ createLocations arr stgen 7 Forest
+ let !jungleLocations = execWriter $ createLocations arr stgen2 2 Jungle
+
+ (mapping, water) <- getWaterQuads arr coloredArr
+ coloredArr2 <- mapArray (\idx -> if idx == 0 then -1 else Map.findWithDefault (-1) idx mapping) coloredArr
+
+ printShowArray coloredArr2
+ printArray arr
+
+ {- Kick off SDL with the callbacks defined in Resources -}
+ makeResources window (createBuilder arr) forestLocations jungleLocations water arr coloredArr2
+ >>= startPipeline reshape eventHandle displayHandle updateHandle
diff --git a/Graphics/Glyph/ArrayGenerator.hs b/Graphics/Glyph/ArrayGenerator.hs
index 16fe41f..088ccc7 100644
--- a/Graphics/Glyph/ArrayGenerator.hs
+++ b/Graphics/Glyph/ArrayGenerator.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE UndecidableInstances #-}
-module Graphics.Glyph.ArrayGenerator where
-import qualified Data.Map as M
+module Graphics.Glyph.ArrayGenerator where
import Data.Array
+import qualified Data.Map as M
import Data.Maybe
data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b
@@ -13,33 +13,36 @@ instance (Ord ix) => Functor (ArrayTransaction ix a) where
instance (Ord ix) => Applicative (ArrayTransaction ix a) where
(<*>) afn aa = do
- fn <- afn
- a <- aa
- return (fn a)
+ fn <- afn
+ a <- aa
+ return (fn a)
pure = return
instance (Ord ix) => Monad (ArrayTransaction ix a) where
- return = ArrayBuilderM_ M.empty
- (ArrayBuilderM_ map1 val) >>= f =
- ArrayBuilderM_ (map1 `M.union` map2) val2
- where (ArrayBuilderM_ map2 val2) = f val
+ return = ArrayBuilderM_ M.empty
+ (ArrayBuilderM_ map1 val) >>= f =
+ ArrayBuilderM_ (map1 `M.union` map2) val2
+ where
+ (ArrayBuilderM_ map2 val2) = f val
class HasDefault a where
- theDefault :: a
+ theDefault :: a
instance (Num a) => HasDefault a where
- theDefault = 0
-instance (HasDefault a, HasDefault b) => HasDefault (a,b) where
- theDefault = (theDefault,theDefault)
-instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a,b,c) where
- theDefault = (theDefault,theDefault,theDefault)
+ theDefault = 0
+
+instance (HasDefault a, HasDefault b) => HasDefault (a, b) where
+ theDefault = (theDefault, theDefault)
+
+instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a, b, c) where
+ theDefault = (theDefault, theDefault, theDefault)
writeArray :: ix -> a -> ArrayTransaction ix a ()
writeArray index' val = ArrayBuilderM_ (M.singleton index' val) ()
-buildArray :: (Ix ix) => (ix,ix) -> e -> ArrayTransaction ix e () -> Array ix e
+buildArray :: (Ix ix) => (ix, ix) -> e -> ArrayTransaction ix e () -> Array ix e
buildArray bounds' def (ArrayBuilderM_ map' _) =
- listArray bounds' [maybeLookup map' bound | bound <- range bounds']
- where maybeLookup map_ key = fromMaybe def (M.lookup key map_)
-
+ listArray bounds' [maybeLookup map' bound | bound <- range bounds']
+ where
+ maybeLookup map_ key = fromMaybe def (M.lookup key map_)
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index b23f6ba..8a41f9e 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -1,25 +1,25 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
module Graphics.Glyph.BufferBuilder where
-import Graphics.Rendering.OpenGL
-import Foreign.Storable
-import Foreign.Ptr
-import Foreign.Marshal.Array
import Data.Array.Storable
import qualified Data.Foldable as Fold
-import Data.Sequence as Seq
import Data.Map as Map
-
-import Graphics.Glyph.Util
+import Data.Sequence as Seq
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
import Graphics.Glyph.GLMath
-
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL
import System.IO.Unsafe
import Unsafe.Coerce
-data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat, GLfloat, GLfloat) Int Int | End
+
bufferSize :: BufferBuilder3D -> Int
bufferSize End = 0
bufferSize (Plot _ _ l _) = l
@@ -31,78 +31,78 @@ nelem (Plot _ _ _ l) = l
sizeofGLfloat :: Int
sizeofGLfloat = 4
-simpleCube :: Num a => [(a,a,a)]
-simpleCube = trianglesFromQuads [
- (-1, 1,-1)
- , ( 1, 1,-1)
- , ( 1,-1,-1)
- , (-1,-1,-1)
-
- , (-1, 1, 1)
- , ( 1, 1, 1)
- , ( 1,-1, 1)
- , (-1,-1, 1)
-
- , (-1, 1, 1)
- , ( 1, 1, 1)
- , ( 1, 1,-1)
- , (-1, 1,-1)
-
- , (-1,-1, 1)
- , ( 1,-1, 1)
- , ( 1,-1,-1)
- , (-1,-1,-1)
-
- , (-1,-1, 1)
- , (-1, 1, 1)
- , (-1, 1,-1)
- , (-1,-1,-1)
-
- , ( 1,-1, 1)
- , ( 1, 1, 1)
- , ( 1, 1,-1)
- , ( 1,-1,-1)
+simpleCube :: Num a => [(a, a, a)]
+simpleCube =
+ trianglesFromQuads
+ [ (-1, 1, -1),
+ (1, 1, -1),
+ (1, -1, -1),
+ (-1, -1, -1),
+ (-1, 1, 1),
+ (1, 1, 1),
+ (1, -1, 1),
+ (-1, -1, 1),
+ (-1, 1, 1),
+ (1, 1, 1),
+ (1, 1, -1),
+ (-1, 1, -1),
+ (-1, -1, 1),
+ (1, -1, 1),
+ (1, -1, -1),
+ (-1, -1, -1),
+ (-1, -1, 1),
+ (-1, 1, 1),
+ (-1, 1, -1),
+ (-1, -1, -1),
+ (1, -1, 1),
+ (1, 1, 1),
+ (1, 1, -1),
+ (1, -1, -1)
]
class Monad a => IsModelBuilder b a where
- plotVertex3 :: b -> b -> b -> a ()
- plotNormal :: b -> b -> b -> a ()
- plotTexture :: b -> b ->a ()
+ 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
+
+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,
+ 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++"]"
+ show (CompiledBuild stride enabled n ptr nbytes) =
+ "[CompiledBuild stride=" ++! stride ++ " enabled" ++! enabled ++ " n=" ++! n ++ " ptr=" ++! ptr ++ " nbytes=" ++! nbytes ++ "]"
instance Functor (BuilderM t) where
fmap f b = b >>= (return . f)
@@ -115,206 +115,240 @@ instance Applicative (BuilderM t) where
return (fn a)
instance 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')
+ (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
+ b1@(BuilderM _ ret) >>= func = b1 >> func ret
- return = BuilderM (LeafBuilder Seq.empty)
+ return = BuilderM (LeafBuilder Seq.empty)
instance Functor Builder where
- fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
- fmap f (LeafBuilder seq') = (LeafBuilder (fmap f seq'))
+ 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'
+ 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'
+ 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 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) initial func =
- let (sequ,snow) = Fold.foldl' (\(seq', snowball) datum ->
- let (snow',lst) = func snowball datum in
- (seq' >< Seq.fromList lst,snow')) (Seq.empty,initial) seq1 in
- (snow,LeafBuilder sequ)
+ 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) initial func =
+ let (sequ, snow) =
+ Fold.foldl'
+ ( \(seq', snowball) datum ->
+ let (snow', lst) = func snowball datum
+ in (seq' >< Seq.fromList lst, snow')
+ )
+ (Seq.empty, initial)
+ seq1
+ in (snow, LeafBuilder sequ)
{- Add a vertex to the current builder -}
-bVertex3 :: (a,a,a) -> BuilderM a ()
+bVertex3 :: (a, a, a) -> BuilderM a ()
bVertex3 vert = BuilderM (LeafBuilder (Seq.singleton $ VertexLink vert)) ()
-bTexture2 :: (a,a) -> BuilderM a ()
+bTexture2 :: (a, a) -> BuilderM a ()
bTexture2 tex = BuilderM (LeafBuilder (Seq.singleton $ TextureLink tex)) ()
-bNormal3 :: (a,a,a) -> BuilderM a ()
+bNormal3 :: (a, a, a) -> BuilderM a ()
bNormal3 norm = BuilderM (LeafBuilder (Seq.singleton $ NormalLink norm)) ()
-bColor4 :: (a,a,a,a) -> BuilderM a ()
+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 (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 _ = []
- 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
+ tp3 True (a, b, c) = [a, b, c]
+ tp3 False _ = []
- 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 _ = []
+ 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
+ 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 -> Int -> Ptr b -> IO BufferObject
ptrToBuffer target len ptr = do
- -- len is length in bytes
- [buffer] <- genObjectNames 1
- bindBuffer target $= Just buffer
- bufferData target $= (fromIntegral len, ptr, StaticDraw)
- return buffer
+ -- 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
+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
+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
+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 len arr
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)
+ 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 :: (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)
-
+ 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 (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 :: (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
+ BuilderM
+ ( flip fmap builder $ \datum ->
+ case datum of
+ VertexLink tup -> VertexLink $ zipWithT3 (+) tup trans
+ _ -> datum
+ )
+ ret
diff --git a/Graphics/Glyph/ExtendedGL.hs b/Graphics/Glyph/ExtendedGL.hs
index a056c5b..4d77924 100644
--- a/Graphics/Glyph/ExtendedGL.hs
+++ b/Graphics/Glyph/ExtendedGL.hs
@@ -1,8 +1,7 @@
-module Graphics.Glyph.ExtendedGL
- (
- module All
- ) where
+module Graphics.Glyph.ExtendedGL
+ ( module All,
+ )
+where
-import Graphics.Glyph.ExtendedGL.Framebuffers as All hiding (framebufferBasicParameteri)
import Graphics.Glyph.ExtendedGL.Base as All
-
+import Graphics.Glyph.ExtendedGL.Framebuffers as All hiding (framebufferBasicParameteri)
diff --git a/Graphics/Glyph/ExtendedGL/Base.hs b/Graphics/Glyph/ExtendedGL/Base.hs
index 88566f4..9b50ddb 100644
--- a/Graphics/Glyph/ExtendedGL/Base.hs
+++ b/Graphics/Glyph/ExtendedGL/Base.hs
@@ -1,111 +1,117 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-module Graphics.Glyph.ExtendedGL.Base where
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
-import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.GL.Core43
-import Graphics.GL.Compatibility30
+module Graphics.Glyph.ExtendedGL.Base where
+import Control.Monad
+import Data.Proxy
+import Data.StateVar
+import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
-import Foreign.C.Types
-
+import Graphics.GL.Compatibility30
+import Graphics.GL.Core43
+import qualified Graphics.Rendering.OpenGL as GL
import System.IO.Unsafe
-import Control.Monad
-
-import Data.StateVar
import Unsafe.Coerce
-import Data.Proxy
-data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show,Enum)
+data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show, Enum)
class IsBindable a where
- bind :: a -> IO ()
+ bind :: a -> IO ()
+
class IsGLEnumMarshallable a where
- toGLEnum :: a -> GLenum
+ toGLEnum :: a -> GLenum
+
class IsGenerable a where
- generate :: IO a
+ generate :: IO a
+
class IsWrappedPrimitive t a where
- unwrap :: a -> t
- wrap :: t -> a
+ unwrap :: a -> t
+ wrap :: t -> a
+
class HasIntegerParam t a where
- parami :: t -> a -> SettableStateVar GLuint
+ parami :: t -> a -> SettableStateVar GLuint
+
class HasFloatParam t a where
- paramf :: t -> a -> SettableStateVar GLfloat
+ paramf :: t -> a -> SettableStateVar GLfloat
+
class HasParamOfType b t a where
- param :: t -> a -> SettableStateVar b
+ param :: t -> a -> SettableStateVar b
class IsPrimitiveModeMarshallable a where
- marshalPrimitiveMode :: a -> GLuint
+ marshalPrimitiveMode :: a -> GLuint
castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => Proxy t -> a -> b
castPrimitive _ x = wrap unw
- where
- unw :: t
- unw = unwrap x
+ where
+ unw :: t
+ unw = unwrap x
instance (IsWrappedPrimitive a a) where
- unwrap = id
- wrap = id
+ unwrap = id
+ wrap = id
+
instance (IsWrappedPrimitive GLenum a) => IsGLEnumMarshallable a where
- toGLEnum = unwrap
+ toGLEnum = unwrap
instance IsPrimitiveModeMarshallable ExPrimitiveMode where
- marshalPrimitiveMode x = case x of
- Points -> GL_POINTS
- Triangles -> GL_TRIANGLES
- Lines -> GL_LINES
- Patches -> GL_PATCHES
+ marshalPrimitiveMode x = case x of
+ Points -> GL_POINTS
+ Triangles -> GL_TRIANGLES
+ Lines -> GL_LINES
+ Patches -> GL_PATCHES
instance IsPrimitiveModeMarshallable GL.PrimitiveMode where
- marshalPrimitiveMode x = case x of
- GL.Points -> 0x0
- GL.Lines -> 0x1
- GL.LineLoop -> 0x2
- GL.LineStrip -> 0x3
- GL.Triangles -> 0x4
- GL.TriangleStrip -> 0x5
- GL.TriangleFan -> 0x6
- GL.Quads -> 0x7
- GL.QuadStrip -> 0x8
- GL.Polygon -> 0x9
+ marshalPrimitiveMode x = case x of
+ GL.Points -> 0x0
+ GL.Lines -> 0x1
+ GL.LineLoop -> 0x2
+ GL.LineStrip -> 0x3
+ GL.Triangles -> 0x4
+ GL.TriangleStrip -> 0x5
+ GL.TriangleFan -> 0x6
+ GL.Quads -> 0x7
+ GL.QuadStrip -> 0x8
+ GL.Polygon -> 0x9
instance IsPrimitiveModeMarshallable GLuint where
- marshalPrimitiveMode = id
+ marshalPrimitiveMode = id
vertexAttributeDivisor :: GL.AttribLocation -> SettableStateVar GLuint
vertexAttributeDivisor (GL.AttribLocation loc) =
- makeSettableStateVar $ \val ->
- glVertexAttribDivisor loc val
+ makeSettableStateVar $ \val ->
+ glVertexAttribDivisor loc val
{- Sets the number of vertices per patch
- for OpenGL -}
patchVertices :: (Integral a) => SettableStateVar a
-patchVertices =
- makeSettableStateVar $ \val ->
- glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val
+patchVertices =
+ makeSettableStateVar $ \val ->
+ glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val
{- Returns the maximum number of patches
- for a tessilation shader -}
maxPatchVertices :: IO CInt
maxPatchVertices =
- alloca $ \ptr -> do
- glGetIntegerv GL_MAX_PATCH_VERTICES ptr
- fromIntegral <$> peek ptr
+ alloca $ \ptr -> do
+ glGetIntegerv GL_MAX_PATCH_VERTICES ptr
+ fromIntegral <$> peek ptr
getGLVersion :: IO String
getGLVersion =
- let lift2 (a,b) = do
- x <- a ; y <- b ; return (x,y)
- in
- alloca $ \ptr1 -> alloca $ \ptr2 -> do
+ let lift2 (a, b) = do
+ x <- a
+ y <- b
+ return (x, y)
+ in alloca $ \ptr1 -> alloca $ \ptr2 -> do
glGetIntegerv GL_MAJOR_VERSION ptr1
glGetIntegerv GL_MINOR_VERSION ptr2
- (v1,v2) <- lift2 (peek ptr1, peek ptr2)
+ (v1, v2) <- lift2 (peek ptr1, peek ptr2)
return ("OpenGL " ++ show v1 ++ "." ++ show v2)
coerced :: a
-coerced = unsafeCoerce (0::Int)
+coerced = unsafeCoerce (0 :: Int)
diff --git a/Graphics/Glyph/ExtendedGL/Framebuffers.hs b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
index a6c2891..1de7781 100644
--- a/Graphics/Glyph/ExtendedGL/Framebuffers.hs
+++ b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
@@ -1,109 +1,120 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
module Graphics.Glyph.ExtendedGL.Framebuffers where
-import Graphics.GL.Compatibility30
-import Graphics.GL.Core43
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.Glyph.ExtendedGL.Base
-
+import Control.Monad
+import Data.StateVar
+import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
-import Foreign.C.Types
-
-import Data.StateVar
-import Control.Monad
-
+import Graphics.GL.Compatibility30
+import Graphics.GL.Core43
+import Graphics.Glyph.ExtendedGL.Base
+import qualified Graphics.Rendering.OpenGL as GL
import Unsafe.Coerce
-
-class (
- HasParamOfType GLuint FramebufferParameter a,
+class
+ ( HasParamOfType GLuint FramebufferParameter a,
HasIntegerParam GLenum a,
IsGenerable a,
- IsBindable a, IsWrappedPrimitive GLuint a) => IsFramebuffer a where
-
- -- this function MUST discard the argument
- getType :: a -> GLenum
+ IsBindable a,
+ IsWrappedPrimitive GLuint a
+ ) =>
+ IsFramebuffer a
+ where
+ -- this function MUST discard the argument
+ getType :: a -> GLenum
framebufferBasicParameteri :: (IsFramebuffer a) => GLenum -> a -> GLenum -> SettableStateVar GLuint
framebufferBasicParameteri typ fb enum =
- makeSettableStateVar (\value -> do
+ makeSettableStateVar
+ ( \value -> do
bind fb
- glFramebufferParameteri typ enum $ fromIntegral value)
+ glFramebufferParameteri typ enum $ fromIntegral value
+ )
data Renderbuffer = Renderbuffer GLuint
+
instance IsWrappedPrimitive GLuint Renderbuffer where
- unwrap (Renderbuffer x) = x
+ unwrap (Renderbuffer x) = x
+
instance IsGenerable Renderbuffer where
- generate = alloca $ \ptr -> do
- glGenRenderbuffers 1 ptr
- liftM Renderbuffer $ peek ptr
+ generate = alloca $ \ptr -> do
+ glGenRenderbuffers 1 ptr
+ liftM Renderbuffer $ peek ptr
+
instance IsBindable Renderbuffer where
- bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap
+ bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap
+
+data RenderbufferArgument
+ = DepthAttachment
-data RenderbufferArgument =
- DepthAttachment
instance IsWrappedPrimitive GLenum RenderbufferArgument where
- unwrap DepthAttachment = GL_DEPTH_ATTACHMENT
+ unwrap DepthAttachment = GL_DEPTH_ATTACHMENT
renderBufferStorageRaw :: (IsGLEnumMarshallable a, IsGLEnumMarshallable b) => a -> b -> Int -> Int -> IO ()
-renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ)
- (toGLEnum enum) (fromIntegral w) (fromIntegral h)
-renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a,Int,Int)
-renderBufferStorage buffer = makeSettableStateVar $ \(en,w,h) -> do
- bind buffer
- renderBufferStorageRaw GL_RENDERBUFFER en w h
-
-frameBufferRenderBuffer :: forall a b. (IsFramebuffer a,IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a
+renderBufferStorageRaw typ enum w h =
+ glRenderbufferStorage
+ (toGLEnum typ)
+ (toGLEnum enum)
+ (fromIntegral w)
+ (fromIntegral h)
+
+renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a, Int, Int)
+renderBufferStorage buffer = makeSettableStateVar $ \(en, w, h) -> do
+ bind buffer
+ renderBufferStorageRaw GL_RENDERBUFFER en w h
+
+frameBufferRenderBuffer :: forall a b. (IsFramebuffer a, IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a
frameBufferRenderBuffer rb e = do
- let enum :: GLenum
- enum = getType test
- unw :: GLuint
- unw = unwrap rb
- bind rb
- glFramebufferRenderbuffer enum (toGLEnum e) GL_RENDERBUFFER (unwrap rb)
- return $ wrap unw
- where
- test :: a
- test = coerced
+ let enum :: GLenum
+ enum = getType test
+ unw :: GLuint
+ unw = unwrap rb
+ bind rb
+ glFramebufferRenderbuffer enum (toGLEnum e) GL_RENDERBUFFER (unwrap rb)
+ return $ wrap unw
+ where
+ test :: a
+ test = coerced
data DrawFramebuffer = DrawFramebuffer GLuint
+
data FramebufferParameter = DefaultWidth | DefaultHeight
instance IsWrappedPrimitive GLenum FramebufferParameter where
- unwrap p = case p of
- DefaultWidth -> GL_FRAMEBUFFER_DEFAULT_WIDTH
- DefaultHeight -> GL_FRAMEBUFFER_DEFAULT_HEIGHT
- wrap x | x == GL_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth
- | x == GL_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight
- | otherwise = undefined
+ unwrap p = case p of
+ DefaultWidth -> GL_FRAMEBUFFER_DEFAULT_WIDTH
+ DefaultHeight -> GL_FRAMEBUFFER_DEFAULT_HEIGHT
+ wrap x
+ | x == GL_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth
+ | x == GL_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight
+ | otherwise = undefined
instance HasIntegerParam GLenum DrawFramebuffer where
- parami p fb = framebufferBasicParameteri GL_DRAW_FRAMEBUFFER fb p
+ parami p fb = framebufferBasicParameteri GL_DRAW_FRAMEBUFFER fb p
{- Has parameters of type GLuint which are acessable by the data FramebufferParameter for
- the type DrawFramebuffer -}
instance HasParamOfType GLuint FramebufferParameter DrawFramebuffer where
- param = parami . toGLEnum
+ param = parami . toGLEnum
instance IsGenerable DrawFramebuffer where
- generate = alloca $ \ptr -> do
- glGenFramebuffers 1 ptr
- liftM DrawFramebuffer $ peek ptr
+ generate = alloca $ \ptr -> do
+ glGenFramebuffers 1 ptr
+ liftM DrawFramebuffer $ peek ptr
instance IsBindable DrawFramebuffer where
- bind (DrawFramebuffer fb) = glBindFramebuffer GL_DRAW_FRAMEBUFFER fb
+ bind (DrawFramebuffer fb) = glBindFramebuffer GL_DRAW_FRAMEBUFFER fb
instance IsWrappedPrimitive GLuint DrawFramebuffer where
- unwrap (DrawFramebuffer fb) = fb
- wrap = DrawFramebuffer
+ unwrap (DrawFramebuffer fb) = fb
+ wrap = DrawFramebuffer
instance IsFramebuffer DrawFramebuffer where
- getType _ = GL_DRAW_FRAMEBUFFER
+ getType _ = GL_DRAW_FRAMEBUFFER
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
index ac3e93a..7614cf7 100644
--- a/Graphics/Glyph/GLMath.hs
+++ b/Graphics/Glyph/GLMath.hs
@@ -1,44 +1,51 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
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 Data.Maybe
import Debug.Trace
+import Graphics.Glyph.Mat4
+import Graphics.Rendering.OpenGL (GLfloat, Uniform, UniformComponent, Vertex3 (..), uniform)
+import qualified Graphics.Rendering.OpenGL as GL
+
+data Vec2 a = Vec2 (a, a) deriving (Show, Eq)
+
+data Vec3 a = Vec3 (a, a, a) deriving (Show, Eq)
-data Vec2 a = Vec2 (a,a) deriving (Show,Eq)
-data Vec3 a = Vec3 (a,a,a) deriving (Show,Eq)
-data Vec4 a = Vec4 (a,a,a,a) deriving (Show,Eq)
+data Vec4 a = Vec4 (a, a, a, a) deriving (Show, Eq)
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)
- uniformv _ = undefined
+ 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)
+ uniformv _ = undefined
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)
- uniformv _ = undefined
+ 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)
+ uniformv _ = undefined
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
-
+ (<+>) :: 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
@@ -47,168 +54,294 @@ class (Floating flT) => Vector flT b where
(|||) = 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)
+ (<+>) (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)
+ (<+>) (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)
+ (<+>) (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 )
+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 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
- Matrix4 (sx, ux, -fx, 0,
- sy, uy, -fy, 0,
- sz, uz, -fz, 0,
- -(s<.>e) , -(u'<.>e), f<.>e, 1 )
+ 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 Matrix4
+ ( sx,
+ ux,
+ - fx,
+ 0,
+ sy,
+ uy,
+ - fy,
+ 0,
+ sz,
+ uz,
+ - fz,
+ 0,
+ - (s <.> e),
+ - (u' <.> e),
+ f <.> e,
+ 1
+ )
orthoMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
orthoMatrix top bot right left near far =
- Matrix4 (2 / (right-left), 0, 0, - (right + left) / (right - left),
- 0, 2 / (top-bot), 0, - (top+bot) / (top-bot),
- 0, 0, -2 / (far-near), - (far+near) / (far - near),
- 0, 0, 0, 1)
+ Matrix4
+ ( 2 / (right - left),
+ 0,
+ 0,
+ - (right + left) / (right - left),
+ 0,
+ 2 / (top - bot),
+ 0,
+ - (top + bot) / (top - bot),
+ 0,
+ 0,
+ -2 / (far - near),
+ - (far + near) / (far - near),
+ 0,
+ 0,
+ 0,
+ 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) $
- Matrix4 (res00, 0, 0, 0,
- 0, res11, 0, 0,
- 0, 0, res22, res23,
- 0, 0, res32, 0)
+ 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) $
+ Matrix4
+ ( 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
+ 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 )
-
-
+ 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
+ vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
+ mat -*| tmp = glslMatMul mat tmp
glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
-glslMatMul (Matrix4 (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 )
+glslMatMul
+ ( Matrix4
+ ( 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
+ )
glslModelViewToNormalMatrix :: Mat4 GLfloat -> Mat3 GLfloat
-glslModelViewToNormalMatrix = fromJust.inverse.transpose.trunc4
+glslModelViewToNormalMatrix = fromJust . inverse . transpose . trunc4
(==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
(==>) = glslMatTranslate
+
glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
glslMatTranslate
- mat@(Matrix4 (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
- Matrix4 (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30+v0,m31+v1,m32+v2,m33+v3)
-
+ mat@( Matrix4
+ ( 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 Matrix4
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30 + v0,
+ m31 + v1,
+ m32 + v2,
+ m33 + v3
+ )
+
rotationMatrix :: GLfloat -> Vec3 GLfloat -> Mat3 GLfloat
-rotationMatrix ang (Vec3 (u,v,w)) =
- let l = (u*u + v*v + w*w)
- u2 = u*u
- v2 = v*v
- w2 = w*w in
- Matrix3 (
- (u2 + (v2 + w2) * cos(ang)) / l,
- (u * v * (1 - cos(ang)) - w * sqrt(l) * sin(ang)) / l,
- (u * w * (1 - cos(ang)) + v * sqrt(l) * sin(ang)) / l,
-
- (u * v * (1 - cos(ang)) + w * sqrt(l) * sin(ang)) / l,
- (v2 + (u2 + w2) * cos(ang)) / l,
- (v * w * (1 - cos(ang)) - u * sqrt(l) * sin(ang)) / l,
-
- (u * w * (1 - cos(ang)) - v * sqrt(l) * sin(ang)) / l,
- (v * w * (1 - cos(ang)) + u * sqrt(l) * sin(ang)) / l,
- (w2 + (u2 + v2) * cos(ang)) / l
+rotationMatrix ang (Vec3 (u, v, w)) =
+ let l = (u * u + v * v + w * w)
+ u2 = u * u
+ v2 = v * v
+ w2 = w * w
+ in Matrix3
+ ( (u2 + (v2 + w2) * cos (ang)) / l,
+ (u * v * (1 - cos (ang)) - w * sqrt (l) * sin (ang)) / l,
+ (u * w * (1 - cos (ang)) + v * sqrt (l) * sin (ang)) / l,
+ (u * v * (1 - cos (ang)) + w * sqrt (l) * sin (ang)) / l,
+ (v2 + (u2 + w2) * cos (ang)) / l,
+ (v * w * (1 - cos (ang)) - u * sqrt (l) * sin (ang)) / l,
+ (u * w * (1 - cos (ang)) - v * sqrt (l) * sin (ang)) / l,
+ (v * w * (1 - cos (ang)) + u * sqrt (l) * sin (ang)) / l,
+ (w2 + (u2 + v2) * cos (ang)) / l
)
zRotationMatrix :: GLfloat -> Mat3 GLfloat
-zRotationMatrix ang = rotationMatrix ang (Vec3 (0,0,1))
+zRotationMatrix ang = rotationMatrix ang (Vec3 (0, 0, 1))
maybeNormalize :: (Vector f a, Eq f) => a f -> a f
maybeNormalize x = if norm x == 0 then x else normalize x
coordinateConvert :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat
coordinateConvert forward up' vector =
- if vector == Vec3 (0,0,0) then vector else
- let right = forward × up'
- up = right × forward in
- case (normalize forward, normalize up, normalize right, vector) of
- (za,ya,xa,Vec3 (x,y,z)) -> (x `vScale` xa) <+> (y `vScale` ya) <+> (z `vScale` za)
-
+ if vector == Vec3 (0, 0, 0)
+ then vector
+ else
+ let right = forward × up'
+ up = right × forward
+ in case (normalize forward, normalize up, normalize right, vector) of
+ (za, ya, xa, Vec3 (x, y, z)) -> (x `vScale` xa) <+> (y `vScale` ya) <+> (z `vScale` za)
+
rotateFrom :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat
rotateFrom vector relative newRelative =
- if vector == Vec3 (0,0,0) then vector else
- case (normalize relative, normalize newRelative) of
- (r', n') ->
- if r' == n' then vector else
- let axis = r' × n'
- ang = acos $ r' `vDot` n' in
- rotationMatrix ang axis -*| vector
-
+ if vector == Vec3 (0, 0, 0)
+ then vector
+ else case (normalize relative, normalize newRelative) of
+ (r', n') ->
+ if r' == n'
+ then vector
+ else
+ let axis = r' × n'
+ ang = acos $ r' `vDot` n'
+ in rotationMatrix ang axis -*| vector
diff --git a/Graphics/Glyph/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs
index 53c6681..0b87490 100644
--- a/Graphics/Glyph/GeometryBuilder.hs
+++ b/Graphics/Glyph/GeometryBuilder.hs
@@ -1,148 +1,156 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-module Graphics.Glyph.GeometryBuilder where
-
-import Data.Sequence as Seq
-import Data.Maybe
+{-# LANGUAGE TemplateHaskell #-}
-import Graphics.Glyph.Util
-import Graphics.Glyph.BufferBuilder
+module Graphics.Glyph.GeometryBuilder where
-import Data.ByteStringBuilder
import Data.ByteString.Lazy
import Data.ByteString.Lazy.Char8 as BSLC
+import Data.ByteStringBuilder
import Data.Foldable as Fold
-
+import Data.Maybe
+import Data.Sequence as Seq
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
import Text.Printf
data OutType = TriangleStrip | Triangles
+
instance Show OutType where
- show TriangleStrip = "triangle_strip"
- show Triangles = "triangle_strip"
+ 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),
-
+ 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
-}
+ }
generating :: OutType -> GeometryBuilder () -> GeometryBuilder ()
-generating TriangleStrip builder = builder { gOutType = Just TriangleStrip }
+generating TriangleStrip builder = builder {gOutType = Just TriangleStrip}
generating Triangles builder = do
- let (nSeq,_) =
- Fold.foldl' (\(tSeq,cnt) datum ->
- case datum of
+ let (nSeq, _) =
+ Fold.foldl'
+ ( \(tSeq, cnt) datum ->
+ case datum of
EmitVertex ->
- if cnt == (2::Int) then (tSeq |> datum |> EndPrimitive, 0)
+ if cnt == (2 :: Int)
+ then (tSeq |> datum |> EndPrimitive, 0)
else (tSeq |> datum, cnt + 1)
- _ -> (tSeq |> datum,cnt)
- ) (Seq.empty, 0) (gList builder)
+ _ -> (tSeq |> datum, cnt)
+ )
+ (Seq.empty, 0)
+ (gList builder)
- builder {
- gOutType = Just Triangles,
+ builder
+ { gOutType = Just Triangles,
gList = nSeq
}
projectionMatrixUniform :: String -> GeometryBuilder ()
-projectionMatrixUniform str = (return ()) { pjMatrixUniform = (Just str) }
+projectionMatrixUniform str = (return ()) {pjMatrixUniform = (Just str)}
modelViewMatrixUniform :: String -> GeometryBuilder ()
-modelViewMatrixUniform str = (return ()) { mvMatrixUniform = (Just str) }
+modelViewMatrixUniform str = (return ()) {mvMatrixUniform = (Just str)}
maxVerticies :: Int -> GeometryBuilder ()
-maxVerticies i = (return ()) { maxVerts = (Just i) }
+maxVerticies i = (return ()) {maxVerts = (Just i)}
textureOutput :: String -> GeometryBuilder ()
-textureOutput str = (return ()) { textureOut = (Just str) }
+textureOutput str = (return ()) {textureOut = (Just str)}
normalOutput :: String -> GeometryBuilder ()
-normalOutput str = (return ()) { normalOut = (Just str) }
+normalOutput str = (return ()) {normalOut = (Just str)}
positionOutput :: String -> GeometryBuilder ()
-positionOutput str = (return ()) { positionOut = (Just str) }
+positionOutput str = (return ()) {positionOut = (Just str)}
gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder ()
-gVertex4 x y z w = (return ()) { gList = Seq.singleton $ Vertex x y z w }
+gVertex4 x y z w = (return ()) {gList = Seq.singleton $ Vertex x y z w}
gNormal3 :: Float -> Float -> Float -> GeometryBuilder ()
-gNormal3 x y z = (return ()) { gList = (Seq.singleton $ Normal x y z) }
+gNormal3 x y z = (return ()) {gList = (Seq.singleton $ Normal x y z)}
gTexture2 :: Float -> Float -> GeometryBuilder ()
-gTexture2 x y = (return ()) { gList = (Seq.singleton $ Texture x y) }
+gTexture2 x y = (return ()) {gList = (Seq.singleton $ Texture x y)}
gEmitVertex :: GeometryBuilder ()
-gEmitVertex = (return ()) { gList = (Seq.singleton $ EmitVertex) }
+gEmitVertex = (return ()) {gList = (Seq.singleton $ EmitVertex)}
gEndPrimitive :: GeometryBuilder ()
-gEndPrimitive = (return ()) { gList = Seq.singleton $ EndPrimitive }
+gEndPrimitive = (return ()) {gList = Seq.singleton $ EndPrimitive}
gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder ()
gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex
@@ -152,38 +160,39 @@ instance Functor GeometryBuilder where
instance Applicative GeometryBuilder where
(<*>) afn aa = do
- fn <- afn
- a <- aa
- return (fn a)
+ fn <- afn
+ a <- aa
+ return (fn a)
pure = return
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
-
+ 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
instance IsModelBuilder Float GeometryBuilder where
- plotVertex3 x y z = gVertex4E x y z 0
- plotNormal = gNormal3
- plotTexture = gTexture2
-
+ 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
index db7b47c..a9f5c60 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -1,10 +1,10 @@
-module Graphics.Glyph.GlyphObject (
- GlyphObject,
+module Graphics.Glyph.GlyphObject
+ ( GlyphObject,
getBufferObject,
getCompiledData,
getVertexAttribute,
getNormalAttribute,
- getColorAttribute ,
+ getColorAttribute,
getTextureAttribute,
getResources,
getSetupRoutine,
@@ -14,39 +14,44 @@ module Graphics.Glyph.GlyphObject (
setCompiledData,
setVertexAttribute,
setNormalAttribute,
- setColorAttribute ,
+ setColorAttribute,
setTextureAttribute,
setResources,
setSetupRoutine,
setTeardownRoutine,
setPrimitiveMode,
- prepare, teardown,
- Drawable, draw, newGlyphObject,
+ prepare,
+ teardown,
+ Drawable,
+ draw,
+ newGlyphObject,
newDefaultGlyphObject,
startClosure,
newDefaultGlyphObjectWithClosure,
- drawInstances, numInstances, setNumInstances
-) where
+ drawInstances,
+ numInstances,
+ setNumInstances,
+ )
+where
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL as GL
-import Graphics.Glyph.ExtendedGL as Ex
-
-import Control.Monad
-import Control.Applicative
-import Data.Maybe
class Drawable a where
- -- mvMat -> pMat -> obj -> IO ()
- draw :: a -> IO ()
+ -- mvMat -> pMat -> obj -> IO ()
+ draw :: a -> IO ()
-data GlyphObject a = GlyphObject {
- bufferObject :: BufferObject, -- buffer
+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
+ colorAttribute :: (Maybe AttribLocation), -- color attrib
textureAttribute :: (Maybe AttribLocation), -- texture attrib
resources :: a, -- Resources
setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
@@ -54,7 +59,7 @@ data GlyphObject a = GlyphObject {
teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
primitiveMode :: ExPrimitiveMode,
numInstances :: Int
-}
+ }
getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject
@@ -68,8 +73,8 @@ getVertexAttribute = vertexAttribute
getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation)
getNormalAttribute = normalAttribute
-getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
-getColorAttribute = colorAttribute
+getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getColorAttribute = colorAttribute
getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation)
getTextureAttribute = textureAttribute
@@ -122,91 +127,97 @@ setPrimitiveMode o a = o {primitiveMode = a}
setNumInstances :: GlyphObject a -> Int -> GlyphObject a
setNumInstances o a = o {numInstances = a}
-
-newGlyphObject :: BuilderM GLfloat x ->
- AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- a ->
- Maybe (GlyphObject a -> IO ()) ->
- Maybe (GlyphObject a -> IO ()) ->
- ExPrimitiveMode ->
- IO (GlyphObject a)
-
+newGlyphObject ::
+ BuilderM GLfloat x ->
+ AttribLocation ->
+ Maybe AttribLocation ->
+ Maybe AttribLocation ->
+ Maybe AttribLocation ->
+ a ->
+ Maybe (GlyphObject a -> IO ()) ->
+ Maybe (GlyphObject a -> IO ()) ->
+ ExPrimitiveMode ->
+ 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 1
+ compiled <- compilingBuilder builder
+ buffer <- createBufferObject ArrayBuffer compiled
+ return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode 1
-prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
prepare a b = setSetupRoutine2 a (Just b)
-startClosure :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+startClosure :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
startClosure a b = setSetupRoutine a (Just b)
-teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
teardown a b = setTeardownRoutine a (Just b)
instance Drawable (GlyphObject a) where
- draw = drawInstances <..> numInstances
+ draw = drawInstances <..> numInstances
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
-
- let p' = case p of
- Ex.Points -> GL.Points
- Ex.Lines -> GL.Lines
- Ex.Triangles -> GL.Triangles
- Ex.Patches -> GL.Patches
-
- 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
+ {- 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
+
+ let p' = case p of
+ Ex.Points -> GL.Points
+ Ex.Lines -> GL.Lines
+ Ex.Triangles -> GL.Triangles
+ Ex.Patches -> GL.Patches
+
+ 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 n) =
- "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
- " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++" instances="++!n++"]"
+ show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ _ p n) =
+ "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr
+ ++ " normalAttr=" ++! nAttr
+ ++ " colorAttr=" ++! cAttr
+ ++ " textureAttr=" ++! tAttr
+ ++ " res=" ++! res
+ ++ " PrimitiveMode=" ++! p
+ ++ " instances=" ++! n
+ ++ "]"
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
- Ex.Triangles -- primitive
+ newGlyphObject
+ builder
+ (AttribLocation 0) -- vertex
+ (Just $ AttribLocation 1) -- normal
+ (Just $ AttribLocation 2) -- color
+ (Just $ AttribLocation 3) -- texture
+ resources
+ Nothing -- setup
+ Nothing -- teardown
+ Ex.Triangles -- primitive
newDefaultGlyphObjectWithClosure :: BuilderM GLfloat x -> a -> (GlyphObject a -> IO ()) -> IO (GlyphObject a)
newDefaultGlyphObjectWithClosure builder res func =
- liftM (flip startClosure func) $ newDefaultGlyphObject builder res
-
-
+ liftM (flip startClosure func) $ newDefaultGlyphObject builder res
diff --git a/Graphics/Glyph/ObjLoader.hs b/Graphics/Glyph/ObjLoader.hs
index b392a26..9acaf48 100644
--- a/Graphics/Glyph/ObjLoader.hs
+++ b/Graphics/Glyph/ObjLoader.hs
@@ -1,37 +1,36 @@
module Graphics.Glyph.ObjLoader where
-import Graphics.Glyph.BufferBuilder
-import Graphics.Glyph.Util
-import Debug.Trace
-
-import Data.List.Split
import Control.Monad
-import Data.Either
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
+import Data.Either
+import Data.List.Split
+import qualified Data.Map as M
+import Debug.Trace
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
+import System.IO
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
+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
+foldl2 a b c = foldl c a b
isNop :: ObjectStatement a -> Bool
-isNop x = case x of
- Nop -> True
- _ -> False
+isNop x = case x of
+ Nop -> True
+ _ -> False
isVertex :: ObjectStatement a -> Bool
isVertex (VertexStatement _) = True
@@ -47,77 +46,80 @@ 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 ->
+ 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
- (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 ()
-
+ (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 splitOn "/" 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) )
-
+ let contents :: [L.ByteString]; contents = C.split '\n' _contents
+ in let mys2n str = case str of
+ "" -> -1
+ _ -> read str
+ in let s2t s = case splitOn "/" 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)
+ liftM (loadObjFromBytestring . _filter) (L.hGetContents handle)
loadObjFile :: (Read b) => FilePath -> IO ([String], ObjectFile b)
loadObjFile = loadObjFileWithFilter id
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
index 6b3ddde..b87129c 100644
--- a/Graphics/Glyph/Shaders.hs
+++ b/Graphics/Glyph/Shaders.hs
@@ -1,12 +1,12 @@
module Graphics.Glyph.Shaders where
-import Graphics.Rendering.OpenGL
+import Control.Monad
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 Data.Maybe
import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL
{- Load a shader from a file giving the type of the shader
- to load.
@@ -15,41 +15,41 @@ import Graphics.Glyph.Util
- and Just if the shader did compile
-}
class IsShaderSource a where
- loadShader :: ShaderType -> a -> IO (String, Maybe Shader)
+ loadShader :: ShaderType -> a -> IO (String, Maybe Shader)
instance IsShaderSource FilePath where
- loadShader typ path = loadShaderBS path typ =<< BS.readFile path
+ loadShader typ path = loadShaderBS path typ =<< BS.readFile path
instance IsShaderSource BS.ByteString where
- loadShader = loadShaderBS "Inlined"
+ loadShader = loadShaderBS "Inlined"
instance IsShaderSource BSL.ByteString where
- loadShader typ = loadShader typ . toStrict
- where toStrict = BS.concat . BSL.toChunks
+ loadShader typ = loadShader typ . toStrict
+ where
+ toStrict = BS.concat . BSL.toChunks
noShader :: Maybe String
noShader = Nothing
loadShaderBS :: String -> ShaderType -> BS.ByteString -> IO (String, Maybe Shader)
loadShaderBS ctx typ src = do
- shader <- createShader typ
- shaderSourceBS shader $= src
- compileShader shader
-
- ok <- get (compileStatus shader)
- infoLog <- get (shaderInfoLog shader)
+ shader <- createShader typ
+ shaderSourceBS shader $= src
+ compileShader shader
- unless ok $
- deleteObjectNames [shader]
+ ok <- get (compileStatus shader)
+ infoLog <- get (shaderInfoLog shader)
- if not ok then
- return ( unlines $ map ((ctx ++ " " ++ show typ ++ ": ")++) $ lines infoLog, Nothing )
- else return ( infoLog, Just shader );
+ unless ok $
+ deleteObjectNames [shader]
+ if not ok
+ then return (unlines $ map ((ctx ++ " " ++ show typ ++ ": ") ++) $ lines infoLog, Nothing)
+ else return (infoLog, Just shader)
{- Load multiple shaders -}
-loadShaders :: (IsShaderSource a) => [(ShaderType,a)] -> IO [(String, Maybe Shader)]
-loadShaders = mapM ( uncurry loadShader )
+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 -}
@@ -59,60 +59,72 @@ 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
+ p <- createProgram
+ mapM_ (attachShader p) shaders
+ linkProgram p
- ok <- get $ linkStatus p
- info <- get $ programInfoLog p
+ ok <- get $ linkStatus p
+ info <- get $ programInfoLog p
- unless ok $
- deleteObjectNames [p]
+ unless ok $
+ deleteObjectNames [p]
- return ( info, not ok ? Nothing $ Just 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
-
-
-getUniformLocationsSafe :: Program -> [String] -> IO [ Maybe UniformLocation ]
+createShaderProgramSafe :: [(String, Maybe Shader)] -> IO (String, Maybe Program)
+createShaderProgramSafe shaders =
+ not (List.all (isJust . snd) shaders)
+ ? return (concatMap fst shaders, Nothing)
+ $ createShaderProgram $ workingShaders shaders
+
+getUniformLocationsSafe :: Program -> [String] -> IO [Maybe UniformLocation]
getUniformLocationsSafe prog uniforms =
- forM uniforms $ \uniform -> do
- tmp <- get $ uniformLocation prog uniform
- case tmp of
- UniformLocation (-1) -> return $ Nothing
- _ -> return $Just tmp
+ forM uniforms $ \uniform -> do
+ tmp <- get $ uniformLocation prog uniform
+ case tmp of
+ UniformLocation (-1) -> return $ Nothing
+ _ -> return $ Just tmp
loadProgramFullSafe ::
- (IsShaderSource tc,
- IsShaderSource te,
- IsShaderSource g,
- IsShaderSource v,
- IsShaderSource f) => Maybe (tc,te) -> Maybe g -> v -> f -> IO (Maybe Program)
+ ( IsShaderSource tc,
+ IsShaderSource te,
+ IsShaderSource g,
+ IsShaderSource v,
+ IsShaderSource f
+ ) =>
+ Maybe (tc, te) ->
+ Maybe g ->
+ v ->
+ f ->
+ IO (Maybe Program)
loadProgramFullSafe tess geometry vert frag = do
- let (ts1,ts2) = distribMaybe tess
- shaders <- sequence $ catMaybes [
- Just $ loadShader VertexShader vert,
- Just $ loadShader FragmentShader frag,
- liftM (loadShader GeometryShader) geometry,
- liftM (loadShader TessControlShader) ts1,
- liftM (loadShader TessEvaluationShader) ts2]
- (linklog,maybeProg) <- createShaderProgramSafe shaders
- if isNothing maybeProg then do
- putStrLn "Failed to link program"
- putStrLn linklog
- return Nothing
- else return maybeProg
-
+ let (ts1, ts2) = distribMaybe tess
+ shaders <-
+ sequence $
+ catMaybes
+ [ Just $ loadShader VertexShader vert,
+ Just $ loadShader FragmentShader frag,
+ liftM (loadShader GeometryShader) geometry,
+ liftM (loadShader TessControlShader) ts1,
+ liftM (loadShader TessEvaluationShader) ts2
+ ]
+ (linklog, maybeProg) <- createShaderProgramSafe shaders
+ if isNothing maybeProg
+ then do
+ putStrLn "Failed to link program"
+ putStrLn linklog
+ return Nothing
+ else return maybeProg
loadProgramSafe ::
- (IsShaderSource a,
- IsShaderSource b,
- IsShaderSource c) =>
- a -> b -> Maybe c -> IO (Maybe Program)
-loadProgramSafe vert frag geom = loadProgramFullSafe (Nothing::Maybe(String,String)) geom vert frag
+ ( IsShaderSource a,
+ IsShaderSource b,
+ IsShaderSource c
+ ) =>
+ a ->
+ b ->
+ Maybe c ->
+ IO (Maybe Program)
+loadProgramSafe vert frag geom = loadProgramFullSafe (Nothing :: Maybe (String, String)) geom vert frag
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
index ec3e12f..538c87a 100644
--- a/Graphics/Glyph/Textures.hs
+++ b/Graphics/Glyph/Textures.hs
@@ -6,33 +6,40 @@ import Data.Word
import Graphics.GL.Compatibility30
import Graphics.Rendering.OpenGL
-data Pixels =
- PixelsRGB (Int,Int) (StorableArray Int Word8) |
- PixelsRGBA (Int,Int) (StorableArray Int Word8)
+data Pixels
+ = PixelsRGB (Int, Int) (StorableArray Int Word8)
+ | PixelsRGBA (Int, Int) (StorableArray Int Word8)
pixelsArray :: Pixels -> StorableArray Int Word8
-pixelsArray (PixelsRGB _ a) = a
+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))
+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)
+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
-
-
+ 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
index 90640a4..79fd5c6 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -3,21 +3,17 @@
module Graphics.Glyph.Util where
+import Control.Exception
+import Control.Monad
import Data.Angle
-import Graphics.Rendering.OpenGL
-import Data.Maybe
+import Data.Array.MArray
import Data.Char
import Data.Either
-
-import Control.Exception
-import Control.Monad
-
import Data.Foldable as Fold
-
-import Foreign.Ptr
+import Data.Maybe
import Foreign.Marshal.Alloc
-
-import Data.Array.MArray
+import Foreign.Ptr
+import Graphics.Rendering.OpenGL
if' :: Bool -> a -> a -> a
if' True a _ = a
@@ -30,31 +26,31 @@ flipIf :: a -> a -> Bool -> a
flipIf a b c = if c then a else b
int :: (Integral a, Num b) => a -> b
-int = fromIntegral
+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
+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
+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
+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
+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
+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
+const2 = const . const
const3 :: a -> b -> c -> d -> a
-const3 = const2.const
+const3 = const2 . const
const4 :: a -> b -> c -> d -> e -> a
-const4 = const3.const
+const4 = const3 . const
gsin :: (Floating a) => a -> a
gsin = sine . Degrees
@@ -63,76 +59,76 @@ 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
- )
+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 :: (a -> b) -> (a, a) -> (b, b)
mapT2 f (a, b) = (f a, f b)
-mapT3 :: (a -> b) -> (a,a,a) -> (b,b,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 :: (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 :: (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 :: (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 :: (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
+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
+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
+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
+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)
+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)
+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)
+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)
+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)
+expand3 :: a -> (a, a, a)
+expand3 t = (t, t, t)
-expand4 :: a -> (a,a,a,a)
-expand4 t = (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)
+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)
+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 :: (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 :: (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 :: (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)
-zipWithT5 :: (a -> b -> c) -> (a,a,a,a,a) -> (b,b,b,b,b) -> (c,c,c,c,c)
+zipWithT5 :: (a -> b -> c) -> (a, a, a, a, a) -> (b, b, b, b, b) -> (c, c, c, c, c)
zipWithT5 fu (a, b, c, d, i) (e, f, g, h, j) = (fu a e, fu b f, fu c g, fu d h, fu i j)
toFloating :: (Real a, Floating b) => a -> b
@@ -142,26 +138,25 @@ toFloating = fromRational . toRational
(!!%) lst idx = lst !! (idx `mod` length lst)
(++!) :: (Show a) => String -> a -> String
-(++!) str = (str++) . show
+(++!) str = (str ++) . show
-clamp :: (Ord a) => a -> (a, a) -> a
+clamp :: (Ord a) => a -> (a, a) -> a
clamp var (low, high) = min (max var low) high
-floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble
+floatVertex :: (GLfloat, GLfloat, GLfloat) -> Vertex3 GLdouble
floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)
-floatVector :: (GLfloat,GLfloat,GLfloat) -> Vector3 GLdouble
+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)
+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
@@ -178,18 +173,17 @@ mapWith _ s [] = ([],s)
{- Instance where a monad can deconstruct
- when the operation has failed -}
class (Monad m) => MonadHasFailure m where
- isFail :: m a -> Bool
+ isFail :: m a -> Bool
instance MonadHasFailure Maybe where
- isFail = isNothing
+ isFail = isNothing
instance MonadHasFailure [] where
- isFail = null
+ isFail = null
instance MonadHasFailure (Either a) where
- isFail (Left _) = True
- isFail _ = False
-
+ isFail (Left _) = True
+ isFail _ = False
{- A way of chaining together commands such
- that the first function in the chain that
@@ -202,49 +196,52 @@ instance MonadHasFailure (Either a) where
-}
(>|>) :: (MonadHasFailure m) => (a -> m c) -> (a -> m c) -> a -> m c
(>|>) f1 f2 a =
- let res = f1 a in
- isFail res ? f2 a $ res
+ 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
+ | 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
+ 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
+ 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
- if' (func start)
- (untilM_ func routine)
- (return start)
+ start <- routine
+ if'
+ (func start)
+ (untilM_ func routine)
+ (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
- if' (func start)
- (untilM' func routine (lst ++ [start]))
- (return lst)
+ untilM' func' routine' []
+ where
+ untilM' func routine lst = do
+ start <- routine
+ if'
+ (func start)
+ (untilM' func routine (lst ++ [start]))
+ (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 (x1 : x2 : xs) next func = dFold (x2 : xs) (func x1 x2 next) func
dFold _ next _ = next
(!>>) :: a -> (a -> b) -> b
@@ -259,17 +256,19 @@ dFold _ next _ = next
(<..>) :: (b -> a -> c) -> (a -> b) -> a -> c
(<..>) f1 f2 a = f1 (f2 a) a
-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"
+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
+ 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
@@ -278,7 +277,7 @@ maybeDefaultM :: (Monad m) => Maybe a -> (a -> m ()) -> m () -> m ()
maybeDefaultM Nothing _ a = a
maybeDefaultM (Just a) b _ = b a
-data MonadPlusBuilder a b = MonadPlusBuilder a b
+data MonadPlusBuilder a b = MonadPlusBuilder a b
plusM :: a -> MonadPlusBuilder a ()
plusM a = MonadPlusBuilder a ()
@@ -287,7 +286,7 @@ runMonadPlusBuilder :: MonadPlusBuilder a b -> a
runMonadPlusBuilder (MonadPlusBuilder !a _) = a
instance (MonadPlus a) => Functor (MonadPlusBuilder (a b)) where
- fmap f b = b >>= return . f
+ fmap f b = b >>= return . f
instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where
(<*>) afn aa = do
@@ -297,28 +296,29 @@ instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where
pure = return
instance (MonadPlus a) => Monad (MonadPlusBuilder (a b)) where
- return = MonadPlusBuilder mzero
- MonadPlusBuilder a1 _ >> MonadPlusBuilder a2 b = MonadPlusBuilder (a1 `mplus` a2) b
- builder@(MonadPlusBuilder _ b) >>= f = builder >> f b
+ return = MonadPlusBuilder mzero
+ MonadPlusBuilder a1 _ >> MonadPlusBuilder a2 b = MonadPlusBuilder (a1 `mplus` a2) b
+ builder@(MonadPlusBuilder _ b) >>= f = builder >> f b
untilM2 :: (Monad m) => (a -> m Bool) -> a -> (a -> m a) -> m a
untilM2 cond ini bod = do
- bool <- cond ini
- if bool then return ini
- else bod ini >>= \newini -> untilM2 cond newini bod
+ bool <- cond ini
+ if bool
+ then return ini
+ else bod ini >>= \newini -> untilM2 cond newini bod
(<!>) :: (MArray a e IO, Ix i) => a i e -> i -> StateVar e
-(<!>) arr idx =
- let setter = writeArray arr idx
- getter = readArray arr idx in
- makeStateVar getter setter
+(<!>) arr idx =
+ let setter = writeArray arr idx
+ getter = readArray arr idx
+ in makeStateVar getter setter
for :: [a] -> (a -> b) -> [b]
for = flip map
-distribMaybe :: Maybe (a,b) -> (Maybe a, Maybe b)
-distribMaybe Nothing = (Nothing,Nothing)
-distribMaybe (Just (a,b)) = (Just a, Just b)
+distribMaybe :: Maybe (a, b) -> (Maybe a, Maybe b)
+distribMaybe Nothing = (Nothing, Nothing)
+distribMaybe (Just (a, b)) = (Just a, Just b)
whenM :: IO Bool -> IO () -> IO ()
whenM b = (>>=) b . flip when
@@ -327,7 +327,7 @@ mix :: (Floating a) => a -> a -> a -> a
mix a b c = a * c + b * (1 - c)
fpart :: (RealFrac a) => a -> a
-fpart x = x - (fromIntegral (floor x::Int))
+fpart x = x - (fromIntegral (floor x :: Int))
ifNaN :: (RealFloat a) => a -> a -> a
ifNaN reg def = if' (isNaN reg) def reg
@@ -336,11 +336,12 @@ everyN :: Int -> [a] -> [a]
everyN _ [] = []
everyN n (x : xs) = x : (everyN n $ drop n xs)
-chunkList :: [a] -> [(a,a)]
+chunkList :: [a] -> [(a, a)]
chunkList l = zip [x | x <- everyN 1 l] [x | x <- everyN 1 (tail l)]
-chunkList3 :: [a] -> [(a,a,a)]
-chunkList3 l = zip3
+chunkList3 :: [a] -> [(a, a, a)]
+chunkList3 l =
+ zip3
[x | x <- everyN 2 l]
[x | x <- everyN 2 (tail l)]
[x | x <- everyN 2 (tail $ tail l)]
diff --git a/Graphics/Rendering/HelpGL.hs b/Graphics/Rendering/HelpGL.hs
index 938147e..201c3a6 100644
--- a/Graphics/Rendering/HelpGL.hs
+++ b/Graphics/Rendering/HelpGL.hs
@@ -1,16 +1,12 @@
-module Graphics.Rendering.HelpGL
-( emptyRGBATexture )
-where
-
-import Graphics.Rendering.OpenGL as GL
-import Foreign.Ptr
+module Graphics.Rendering.HelpGL (emptyRGBATexture) where
import Foreign.Marshal.Array
+import Foreign.Ptr
+import Graphics.Rendering.OpenGL as GL
(?) :: (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)
+ 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
index 72159d1..40ce820 100644
--- a/Graphics/SDL/SDLHelp.hs
+++ b/Graphics/SDL/SDLHelp.hs
@@ -1,34 +1,37 @@
-{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns, RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+
module Graphics.SDL.SDLHelp where
-import Data.Word
import Control.Monad
-import Graphics.Glyph.Util
-
-import SDL as SDL
-import SDL.Video.Renderer (SurfacePixelFormat(..))
-
+import Data.Bits
+import Data.Word
+import Foreign.Ptr
+import Foreign.Storable
import Graphics.GL.Compatibility30
+import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL as GL
-
-import Foreign.Storable
-import Foreign.Ptr
-import Data.Bits
-
-import System.IO.Unsafe
-import System.Endian
-import System.Exit
+import SDL as SDL
import SDL.Raw (getSurfaceColorMod)
import qualified SDL.Raw.Types
+import SDL.Video.Renderer (SurfacePixelFormat (..))
+import System.Endian
+import System.Exit
+import System.IO.Unsafe
-data TextureData = TextureData {
- textureSize :: (Int,Int),
- textureObject :: TextureObject } deriving Show
-
-data TextureData3D = TextureData3D {
- textureSize3D :: (Int,Int,Int),
- textureObject3D :: TextureObject } deriving Show
+data TextureData = TextureData
+ { textureSize :: (Int, Int),
+ textureObject :: TextureObject
+ }
+ deriving (Show)
+data TextureData3D = TextureData3D
+ { textureSize3D :: (Int, Int, Int),
+ textureObject3D :: TextureObject
+ }
+ deriving (Show)
bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
bindSurfaceToTexture surf to = do
@@ -43,74 +46,76 @@ bindSurfaceToTexture surf to = do
fi :: (Integral a, Integral b) => a -> b
fi = fromIntegral
-textureFromPointer3D :: Ptr Word8 -> (Int,Int,Int) -> TextureObject -> IO TextureData3D
-textureFromPointer3D ptr (w,h,d) to = do
- textureBinding Texture3D $= Just to
- glTexImage3D GL_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 GL_RGB GL_UNSIGNED_BYTE ptr
- return $ TextureData3D (w,h,d) to
- where f = fromIntegral
+textureFromPointer3D :: Ptr Word8 -> (Int, Int, Int) -> TextureObject -> IO TextureData3D
+textureFromPointer3D ptr (w, h, d) to = do
+ textureBinding Texture3D $= Just to
+ glTexImage3D GL_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 GL_RGB GL_UNSIGNED_BYTE ptr
+ return $ TextureData3D (w, h, d) to
+ where
+ f = fromIntegral
textureFromSurface :: SDL.Surface -> IO TextureData
textureFromSurface surf = makeTexture >>= (bindSurfaceToTexture surf >=> return)
makeTexture3D :: IO TextureObject
makeTexture3D = do
- texobj <- liftM head $ genObjectNames 1
- textureBinding Texture3D $= Just texobj
- textureFilter Texture3D $= ((Linear', Nothing), Linear')
- return texobj
+ texobj <- liftM head $ genObjectNames 1
+ textureBinding Texture3D $= Just texobj
+ textureFilter Texture3D $= ((Linear', Nothing), Linear')
+ return texobj
makeTexture :: IO TextureObject
makeTexture = do
- texobj <- liftM head $ genObjectNames 1
- textureBinding Texture2D $= Just texobj
- textureFilter Texture2D $= ((Linear', Nothing), Linear')
- return texobj
+ 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 <- fromIntegral <$> getSurfaceBytesPerPixel surf
- ptr <- (surfacePixels surf >>= return.castPtr) :: IO (Ptr Word8)
- (V2 w h) <- SDL.surfaceDimensions surf
- let newPtr = ptr `plusPtr` (y * bpp * fromIntegral w) `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
+ bpp <- fromIntegral <$> getSurfaceBytesPerPixel surf
+ ptr <- (surfacePixels surf >>= return . castPtr) :: IO (Ptr Word8)
+ (V2 w h) <- SDL.surfaceDimensions surf
+ let newPtr = ptr `plusPtr` (y * bpp * fromIntegral w) `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
+ 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)
+ 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 SDL.Window
-simpleStartup name' (w,h) = do
+simpleStartup :: String -> (Int, Int) -> IO SDL.Window
+simpleStartup name' (w, h) = do
SDL.initialize [SDL.InitVideo]
SDL.HintRenderScaleQuality $= SDL.ScaleLinear
renderQuality <- SDL.get SDL.HintRenderScaleQuality
@@ -131,47 +136,51 @@ simpleStartup name' (w,h) = do
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
+ 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 :: forall a. (Int -> Int -> a -> IO a) -> (SDL.EventPayload -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
startPipeline reshapeH eventH displayH updateH ini = do
- let pumpEvents' res = do
- evs <- SDL.pollEvents
- foldM (\res (SDL.eventPayload -> ev) -> case ev of
- SDL.QuitEvent -> exitSuccess >> return res
- _ -> eventH ev res) res evs
- -- 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'
- runPipeline val = do
- res <- pumpEvents' val >>= displayH
- updateH res >>= runPipeline
-
- -- -- TODO unhardcode this
- reshapeH 1920 1080 ini >>= runPipeline
+ let pumpEvents' res = do
+ evs <- SDL.pollEvents
+ foldM
+ ( \res (SDL.eventPayload -> ev) -> case ev of
+ SDL.QuitEvent -> exitSuccess >> return res
+ _ -> eventH ev res
+ )
+ res
+ evs
+ -- 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'
+ runPipeline val = do
+ res <- pumpEvents' val >>= displayH
+ updateH res >>= runPipeline
+
+ -- -- TODO unhardcode this
+ reshapeH 1920 1080 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)
+ texture Texture2D $= Enabled
+ activeTexture $= TextureUnit (fromIntegral unit)
+ textureBinding Texture2D $= Just to
+ uniform tu $= Index1 (fromIntegral unit :: GLint)
setupTexturing3D :: TextureData3D -> UniformLocation -> Int -> IO ()
setupTexturing3D (TextureData3D _ to) tu unit = do
- texture Texture3D $= Enabled
- activeTexture $= TextureUnit (fromIntegral unit)
- textureBinding Texture3D $= Just to
- uniform tu $= Index1 (fromIntegral unit::GLint)
+ texture Texture3D $= Enabled
+ activeTexture $= TextureUnit (fromIntegral unit)
+ textureBinding Texture3D $= Just to
+ uniform tu $= Index1 (fromIntegral unit :: GLint)
getSurfaceBytesPerPixel :: SDL.Surface -> IO Word8
getSurfaceBytesPerPixel (SDL.Surface ptr _) = do
- SDL.Raw.Types.pixelFormatBytesPerPixel <$>
- (peek . SDL.Raw.Types.surfaceFormat =<< peek ptr)
+ SDL.Raw.Types.pixelFormatBytesPerPixel
+ <$> (peek . SDL.Raw.Types.surfaceFormat =<< peek ptr)
diff --git a/Models.hs b/Models.hs
index 3d154e6..fac49be 100644
--- a/Models.hs
+++ b/Models.hs
@@ -1,20 +1,18 @@
module Models where
-import Graphics.Glyph.GeometryBuilder
-import Graphics.Glyph.BufferBuilder
-
import Control.Monad
import Data.ByteString.Lazy
-
+import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.GLMath
+import Graphics.Glyph.GeometryBuilder
import Graphics.Glyph.ObjLoader
-square :: (Num b,IsModelBuilder b a) => b -> a ()
+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
+ plotVertex3 dist dist 0
+ plotVertex3 (- dist) dist 0
+ plotVertex3 (- dist) (- dist) 0
+ plotVertex3 dist (- dist) 0
getBS :: GeometryBuilder () -> ByteString
getBS = buildSource
@@ -27,62 +25,63 @@ 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
+ 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
+ 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
index ce38b21..da5040e 100644
--- a/Resources.hs
+++ b/Resources.hs
@@ -1,580 +1,612 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
-module Resources where
-import qualified SDL
-import qualified SDL.Image
+module Resources where
-import Foreign.Storable
-import Foreign.Ptr
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad
+import Data.Angle
+import Data.Array
+import qualified Data.Array.IO as ArrIO
+import qualified Data.Foldable as Fold
+import Data.Function
+import Data.Maybe
+import qualified Data.Sequence as Seq
+import qualified Data.StateVar as SV
+import Data.Time.Clock.POSIX
+import Debug.Trace
import Foreign.Marshal.Array
-
+import Foreign.Ptr
+import Foreign.Storable
+import Graphics.GL.Compatibility30
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Glyph.GLMath as V
import Graphics.Glyph.GlyphObject
+import Graphics.Glyph.Mat4
import Graphics.Glyph.ObjLoader
import Graphics.Glyph.Shaders
-import Graphics.SDL.SDLHelp
-import Graphics.Glyph.BufferBuilder
-import Graphics.Glyph.Mat4
import Graphics.Glyph.Util
-import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Rendering.OpenGL as GL
-import Graphics.GL.Compatibility30
-
-import Control.Applicative
-import Control.Monad
-
-import Data.Angle
-import Data.Function
-import qualified Data.Sequence as Seq
-import qualified Data.Foldable as Fold
-import Data.Maybe
-import Debug.Trace
-
+import Graphics.SDL.SDLHelp
+import qualified SDL
+import qualified SDL.Image
import System.Exit
-import qualified Data.Array.IO as ArrIO
-
-import Data.Array
-import qualified Data.StateVar as SV
-import Data.Time.Clock.POSIX
-import Control.Concurrent
-import Text.Printf
import System.IO
import System.Random hiding (uniform)
-import qualified SDL
+import Text.Printf
{- Types of terrain which are possible -}
-data TileType = Forest | Beach | Water | Grass | Jungle | Mountains |
- Tundra | Unknown deriving (Enum,Eq)
+data TileType
+ = Forest
+ | Beach
+ | Water
+ | Grass
+ | Jungle
+ | Mountains
+ | Tundra
+ | Unknown
+ deriving (Enum, Eq)
+
instance Show TileType where
- show = \case
- Forest -> "F"
- Beach -> "B"
- Water -> "W"
- Grass -> "G"
- Jungle -> "J"
- Mountains -> "M"
- Tundra -> "T"
- Unknown -> "?"
+ show = \case
+ Forest -> "F"
+ Beach -> "B"
+ Water -> "W"
+ Grass -> "G"
+ Jungle -> "J"
+ Mountains -> "M"
+ Tundra -> "T"
+ Unknown -> "?"
{- A tile has 2 things, a type and
- elevation, however, the term tile is
- a litte misleading, it is really a point. -}
-data Tile = Tile {
- tileType :: TileType,
+data Tile = Tile
+ { tileType :: TileType,
elevation :: Int
-} deriving Show
+ }
+ deriving (Show)
{- Position of the camera as described by
- polar coordinates -}
-data CameraPosition = CameraPosition {
- pEye :: Vec3 GLfloat,
+data CameraPosition = CameraPosition
+ { pEye :: Vec3 GLfloat,
pTh :: GLfloat,
pPh :: GLfloat
-} deriving Show
+ }
+ deriving (Show)
{- The central data type for rendering
- the scene. Contains the 'global' information -}
-data Resources = Resources {
- rWindow :: SDL.Window,
-
+data Resources = Resources
+ { rWindow :: SDL.Window,
rPosition :: CameraPosition,
rDPosition :: CameraPosition,
-
pMatrix :: Mat4 GLfloat,
mvMatrix :: Mat4 GLfloat,
-
routines :: [ResourcesClosure -> IO ()],
-
timeSpeed :: Int,
time :: Int,
-
- heightMap :: Array (Int,Int) Tile,
+ heightMap :: Array (Int, Int) Tile,
positionUpdate :: (Resources -> IO Resources),
-
{- Smaller if in first person -}
speedFactor :: GLfloat,
{- Higher if shift is held -}
speedMultiplier :: GLfloat,
{- Direction -}
speedDirection :: Vec3 GLfloat,
-
dDown :: GLfloat,
- waterArray :: ArrIO.IOArray (Int,Int) GLfloat,
+ waterArray :: ArrIO.IOArray (Int, Int) GLfloat,
headBob :: GLfloat,
mode :: CameraMode,
threadDiff :: Double
-}
+ }
setHeadBob :: GLfloat -> Resources -> Resources
-setHeadBob f r = r { headBob = f }
+setHeadBob f r = r {headBob = f}
setThreadDiff :: Double -> Resources -> Resources
-setThreadDiff f r = r { threadDiff = f }
+setThreadDiff f r = r {threadDiff = f}
setRSurface :: SDL.Window -> Resources -> Resources
-setRSurface x r = r { rWindow = x }
+setRSurface x r = r {rWindow = x}
setRPosition :: CameraPosition -> Resources -> Resources
-setRPosition x r = r { rPosition = x }
+setRPosition x r = r {rPosition = x}
setRDPosition :: CameraPosition -> Resources -> Resources
-setRDPosition x r = r { rDPosition = x }
+setRDPosition x r = r {rDPosition = x}
setPMatrix :: Mat4 GLfloat -> Resources -> Resources
-setPMatrix x r = r { pMatrix = x }
+setPMatrix x r = r {pMatrix = x}
setMvMatrix :: Mat4 GLfloat -> Resources -> Resources
-setMvMatrix x r = r { mvMatrix = x }
+setMvMatrix x r = r {mvMatrix = x}
setRoutines :: [ResourcesClosure -> IO ()] -> Resources -> Resources
-setRoutines x r = r { routines = x }
+setRoutines x r = r {routines = x}
setSpeedDirection :: Vec3 GLfloat -> Resources -> Resources
-setSpeedDirection x r = r { speedDirection = x }
+setSpeedDirection x r = r {speedDirection = x}
setTimeSpeed :: Int -> Resources -> Resources
-setTimeSpeed x r = r { timeSpeed = x }
+setTimeSpeed x r = r {timeSpeed = x}
setTime :: Int -> Resources -> Resources
-setTime x r = r { time = x }
+setTime x r = r {time = x}
-setHeightMap :: Array (Int,Int) Tile -> Resources -> Resources
-setHeightMap x r = r { heightMap = x }
+setHeightMap :: Array (Int, Int) Tile -> Resources -> Resources
+setHeightMap x r = r {heightMap = x}
setPositionUpdate :: (Resources -> IO Resources) -> Resources -> Resources
-setPositionUpdate x r = r { positionUpdate = x }
+setPositionUpdate x r = r {positionUpdate = x}
setSpeedFactor :: GLfloat -> Resources -> Resources
-setSpeedFactor x r = r { speedFactor = x }
+setSpeedFactor x r = r {speedFactor = x}
setDDown :: GLfloat -> Resources -> Resources
-setDDown x r = r { dDown = x }
+setDDown x r = r {dDown = x}
-setWaterArray :: ArrIO.IOArray (Int,Int) GLfloat -> Resources -> Resources
-setWaterArray x r = r { waterArray = x }
+setWaterArray :: ArrIO.IOArray (Int, Int) GLfloat -> Resources -> Resources
+setWaterArray x r = r {waterArray = x}
getSpeed :: Resources -> GLfloat
-getSpeed res =speedFactor res * speedMultiplier res * norm (speedDirection res)
+getSpeed res = speedFactor res * speedMultiplier res * norm (speedDirection res)
cameraForward :: CameraPosition -> Vec3 GLfloat
-cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1,th,ph)
+cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1, th, ph)
cameraUp :: CameraPosition -> Vec3 GLfloat
-cameraUp (CameraPosition _ _ ph) =
- if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0)
- where ph' = (floor ph::Int) `mod` 360
+cameraUp (CameraPosition _ _ ph) =
+ if ph' >= 90 && ph' < 270 then Vec3 (0, -1, 0) else Vec3 (0, 1, 0)
+ where
+ ph' = (floor ph :: Int) `mod` 360
cameraRight :: CameraPosition -> Vec3 GLfloat
cameraRight cam = cameraUp cam × cameraForward cam
-
getVelocity :: Resources -> Vec3 GLfloat
getVelocity res =
- let dir = speedDirection res
- camdir = cameraForward $ rPosition res
- truedir = coordinateConvert camdir (Vec3 (0,1,0)) dir in
- getSpeed res `vScale` maybeNormalize truedir
+ let dir = speedDirection res
+ camdir = cameraForward $ rPosition res
+ truedir = coordinateConvert camdir (Vec3 (0, 1, 0)) dir
+ in getSpeed res `vScale` maybeNormalize truedir
-data CameraMode = Oracle | FirstPerson deriving Eq
+data CameraMode = Oracle | FirstPerson deriving (Eq)
{- Central data type for rendering each frame -}
-data ResourcesClosure = ResourcesClosure {
- rcMVMatrix :: Mat4 GLfloat
- , rcPMatrix :: Mat4 GLfloat
- , rcLightPos :: Vec4 GLfloat
- , rcTime :: GLfloat
- , rcNormalMatrix :: Mat3 GLfloat
- , rcGlobalAmbient :: Vec4 GLfloat
- , rcCameraPos :: CameraPosition
- , rcCameraLocation :: Vec3 GLfloat
- , rcResources :: Resources
-}
+data ResourcesClosure = ResourcesClosure
+ { rcMVMatrix :: Mat4 GLfloat,
+ rcPMatrix :: Mat4 GLfloat,
+ rcLightPos :: Vec4 GLfloat,
+ rcTime :: GLfloat,
+ rcNormalMatrix :: Mat3 GLfloat,
+ rcGlobalAmbient :: Vec4 GLfloat,
+ rcCameraPos :: CameraPosition,
+ rcCameraLocation :: Vec3 GLfloat,
+ rcResources :: Resources
+ }
{- A function that makes the resources data first
- person -}
firstPerson :: Resources -> IO Resources
firstPerson res =
- let camera@(CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition res
- (_,(w,h)) = bounds $ heightMap res
- (!!!) arr (x',y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x',y'))
- h1 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor y) )
- h2 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor (y+1)) )
- h3 = ((/10.0).fromIntegral) (heightMap res !!! (floor (x+1), floor y) )
- h4 = ((/10.0).fromIntegral) (heightMap res !!! (floor (x+1), floor (y+1)))
- u = x - (int $ (floor x::Int))
- v = y - (int $ (floor y::Int))
- mixu1 = mix h3 h1 u
- mixu2 = mix h4 h2 u
- newh = mix mixu2 mixu1 v
- droph = curh - dDown res
- speed = getSpeed res
- jitter = (max 0 $ speed - 0.029) ** 0.1 / 2
- dy = sin (headBob res*2) * jitter
- dx = realToFrac $ cos (headBob res) * jitter
- in do
- return $ ((setHeadBob.(+ jitter)) <..> headBob) $
- if (newh+0.3 > droph) then
- setSpeedFactor 0.03 $
- setRPosition (CameraPosition (Vec3 (x,newh+0.2,y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $
+ let camera@(CameraPosition (Vec3 (x, curh, y)) th ph) = rPosition res
+ (_, (w, h)) = bounds $ heightMap res
+ (!!!) arr (x', y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x', y'))
+ h1 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor x, floor y))
+ h2 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor x, floor (y + 1)))
+ h3 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor (x + 1), floor y))
+ h4 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor (x + 1), floor (y + 1)))
+ u = x - (int $ (floor x :: Int))
+ v = y - (int $ (floor y :: Int))
+ mixu1 = mix h3 h1 u
+ mixu2 = mix h4 h2 u
+ newh = mix mixu2 mixu1 v
+ droph = curh - dDown res
+ speed = getSpeed res
+ jitter = (max 0 $ speed - 0.029) ** 0.1 / 2
+ dy = sin (headBob res * 2) * jitter
+ dx = realToFrac $ cos (headBob res) * jitter
+ in do
+ return $
+ ((setHeadBob . (+ jitter)) <..> headBob) $
+ if (newh + 0.3 > droph)
+ then
+ setSpeedFactor 0.03 $
+ setRPosition (CameraPosition (Vec3 (x, newh + 0.2, y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $
setDDown 0 res
- else
+ else
setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $
- setDDown (dDown res + 0.03) res
+ setDDown (dDown res + 0.03) res
{- A function which will explode if a uniform
- does not exist for the shader given, otherwis,
- it will return a list of uniform locations -}
getUniformsSafe :: Program -> [String] -> IO [UniformLocation]
getUniformsSafe prog uniforms =
- forM uniforms $ \a_uniform -> do
- tmp <- get $ uniformLocation prog a_uniform
- case tmp of
- UniformLocation (-1) -> do
- putStrLn $ "No uniform with name: "++a_uniform
- exitWith (ExitFailure 112)
- _ -> return tmp
+ forM uniforms $ \a_uniform -> do
+ tmp <- get $ uniformLocation prog a_uniform
+ case tmp of
+ UniformLocation (-1) -> do
+ putStrLn $ "No uniform with name: " ++ a_uniform
+ exitWith (ExitFailure 112)
+ _ -> return tmp
{- Builds an model view matrix given the
- camera position of the scene -}
buildMVMatrix :: CameraPosition -> Mat4 GLfloat
buildMVMatrix camera@(CameraPosition eye _ _) =
- let lookat = eye <+> cameraForward camera in
- lookAtMatrix eye lookat (cameraUp camera)
+ let lookat = eye <+> cameraForward camera
+ in lookAtMatrix eye lookat (cameraUp camera)
{- Called after each frame to crunch throught the
- events -}
eventHandle :: SDL.EventPayload -> Resources -> IO Resources
eventHandle event = case event of
- SDL.KeyboardEvent e ->
- case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
- (SDL.Pressed, SDL.ScancodeW) -> setPh 2
- (SDL.Released, SDL.ScancodeW) -> setPh 0
- (SDL.Pressed, SDL.ScancodeA) -> setTh (-2)
- (SDL.Released, SDL.ScancodeA) -> setTh 0
- (SDL.Pressed, SDL.ScancodeS) -> setPh (-2)
- (SDL.Released, SDL.ScancodeS) -> setPh 0
- (SDL.Pressed, SDL.ScancodeD) -> setTh 2
- (SDL.Released, SDL.ScancodeD) -> setTh 0
- (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1))
- (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0))
- (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1))
- (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0))
-
- -- Pressing the 'q' enters first-person-mode
- (SDL.Pressed, SDL.ScancodeQ) -> return . appAll
- [setPositionUpdate firstPerson,
- setSpeedFactor 0.1,
- \res -> res { dDown = negate $ (\(Vec3 (_,y,_)) -> y) $ resourcesVelocity res}]
-
- (SDL.Pressed, SDL.ScancodeE) -> return . appAll
- [setPositionUpdate return,
- setSpeedFactor 1,
- \res -> res { dDown = 0 }]
-
- (SDL.Pressed, SDL.ScancodeSpace) -> return . appAll
- [setSpeedFactor 0.05,
- \res -> res { dDown = -0.2 }]
-
- (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 4 }
-
- (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 1 }
-
- -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
- -- return $ setSpeedMultiplier 4 res
-
- -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
- -- return $ setSpeedMultiplier 1 res
- -- KeyUp (Keysym SDLK_e _ _) ->
- -- return $
- -- setPositionUpdate return $
- -- setSpeedFactor 1 $
- -- if speed res > 0 then setSpeed 1 res else res
-
- _ -> return
- _ -> return
-
- where
- appAll :: [a -> a] -> a -> a
- appAll (f:fs) a = appAll fs (f a)
- appAll [] a = a
-
- setPh i res =
- let (CameraPosition eye th ph) = rDPosition res in
- return $ setRDPosition (CameraPosition eye th i) res
- setTh i res =
- let (CameraPosition eye th ph) = rDPosition res in
- return $ setRDPosition (CameraPosition eye i ph) res
+ SDL.KeyboardEvent e ->
+ case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
+ (SDL.Pressed, SDL.ScancodeW) -> setPh 2
+ (SDL.Released, SDL.ScancodeW) -> setPh 0
+ (SDL.Pressed, SDL.ScancodeA) -> setTh (-2)
+ (SDL.Released, SDL.ScancodeA) -> setTh 0
+ (SDL.Pressed, SDL.ScancodeS) -> setPh (-2)
+ (SDL.Released, SDL.ScancodeS) -> setPh 0
+ (SDL.Pressed, SDL.ScancodeD) -> setTh 2
+ (SDL.Released, SDL.ScancodeD) -> setTh 0
+ (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1))
+ (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0))
+ (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1))
+ (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0))
+ -- Pressing the 'q' enters first-person-mode
+ (SDL.Pressed, SDL.ScancodeQ) ->
+ return
+ . appAll
+ [ setPositionUpdate firstPerson,
+ setSpeedFactor 0.1,
+ \res -> res {dDown = negate $ (\(Vec3 (_, y, _)) -> y) $ resourcesVelocity res}
+ ]
+ (SDL.Pressed, SDL.ScancodeE) ->
+ return
+ . appAll
+ [ setPositionUpdate return,
+ setSpeedFactor 1,
+ \res -> res {dDown = 0}
+ ]
+ (SDL.Pressed, SDL.ScancodeSpace) ->
+ return
+ . appAll
+ [ setSpeedFactor 0.05,
+ \res -> res {dDown = -0.2}
+ ]
+ (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res {speedMultiplier = 4}
+ (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res {speedMultiplier = 1}
+ -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ setSpeedMultiplier 4 res
+
+ -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ setSpeedMultiplier 1 res
+ -- KeyUp (Keysym SDLK_e _ _) ->
+ -- return $
+ -- setPositionUpdate return $
+ -- setSpeedFactor 1 $
+ -- if speed res > 0 then setSpeed 1 res else res
+
+ _ -> return
+ _ -> return
+ where
+ appAll :: [a -> a] -> a -> a
+ appAll (f : fs) a = appAll fs (f a)
+ appAll [] a = a
+
+ setPh i res =
+ let (CameraPosition eye th ph) = rDPosition res
+ in return $ setRDPosition (CameraPosition eye th i) res
+ setTh i res =
+ let (CameraPosition eye th ph) = rDPosition res
+ in return $ setRDPosition (CameraPosition eye i ph) res
-- 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_EQUALS _ _) ->
- -- return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
- -- KeyDown (Keysym SDLK_MINUS _ _) ->
- -- return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res
-
- -- 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 + speedFactor res) res
- -- KeyDown (Keysym SDLK_s _ _) ->
- -- return $ setSpeed (speed res - speedFactor res) res
- -- KeyUp (Keysym SDLK_w _ _) ->
- -- return $ setSpeed 0 res
- -- KeyUp (Keysym SDLK_s _ _) ->
- -- return $ setSpeed 0 res
-
- -- KeyUp (Keysym SDLK_q _ _) ->
- -- let getY (Vec3 (_,y,_)) = y in
- -- return $
- -- setPositionUpdate firstPerson $
- -- setSpeedFactor 0.1 $
- -- (setDDown <..> (negate . getY . resourcesVelocity)) res
- -- KeyUp (Keysym SDLK_e _ _) ->
- -- return $
- -- setPositionUpdate return $
- -- setSpeedFactor 1 $
- -- if speed res > 0 then setSpeed 1 res else res
-
- -- KeyUp (Keysym SDLK_f _ _) -> do
- -- ret <- reshape 1920 1080 res
- -- SDL.toggleFullscreen $ rSurface ret
- -- SDL.showCursor False
- -- SDL.grabInput True
- -- return ret
- -- KeyUp (Keysym SDLK_g _ _) -> do
- -- SDL.showCursor False
- -- SDL.grabInput True
- -- return res
-
- -- KeyDown (Keysym SDLK_SPACE _ _) -> do
- -- return $ setDDown (-0.3) 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 $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
- -- KeyDown (Keysym SDLK_s _ _) ->
- -- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
- -- KeyDown (Keysym SDLK_d _ _) ->
- -- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
- -- KeyDown (Keysym SDLK_a _ _) ->
- -- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
-
- -- KeyUp (Keysym SDLK_w _ _) ->
- -- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
- -- KeyUp (Keysym SDLK_s _ _) ->
- -- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
- -- KeyUp (Keysym SDLK_d _ _) ->
- -- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
- -- KeyUp (Keysym SDLK_a _ _) ->
- -- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
-
- -- KeyUp (Keysym SDLK_q _ _) ->
- -- let getY (Vec3 (_,y,_)) = y in
- -- return $
- -- setPositionUpdate firstPerson $
- -- setMode FirstPerson $
- -- (setDDown <..> (negate . getY . resourcesVelocity)) res
- -- KeyUp (Keysym SDLK_e _ _) ->
- -- return $
- -- setPositionUpdate return $
- -- setSpeedFactor 1 $
- -- setMode Oracle res
-
- -- KeyUp (Keysym SDLK_f _ _) -> do
- -- ret <- reshape 1920 1080 res
- -- SDL.toggleFullscreen $ rSurface ret
- -- SDL.showCursor False
- -- SDL.grabInput True
- -- return ret
- -- KeyUp (Keysym SDLK_c _ _) -> do
- -- SDL.showCursor True
- -- SDL.grabInput False
- -- return res
- -- KeyUp (Keysym SDLK_g _ _) -> do
- -- SDL.showCursor False
- -- SDL.grabInput True
- -- return res
-
- -- KeyDown (Keysym SDLK_SPACE _ _) -> do
- -- return $
- -- setDDown (-0.2) $
- -- setSpeedFactor 0.05 res
-
- -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
- -- return $ setSpeedMultiplier 4 res
-
- -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
- -- return $ setSpeedMultiplier 1 res
-
- -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
- -- return $ (setSpeed <..> ((*3) . speed)) res
- -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
- -- return $ (setSpeed <..> ((/3) . speed)) res
-
- -- _ -> return res
+-- 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_EQUALS _ _) ->
+-- return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
+-- KeyDown (Keysym SDLK_MINUS _ _) ->
+-- return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res
+
+-- 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 + speedFactor res) res
+-- KeyDown (Keysym SDLK_s _ _) ->
+-- return $ setSpeed (speed res - speedFactor res) res
+-- KeyUp (Keysym SDLK_w _ _) ->
+-- return $ setSpeed 0 res
+-- KeyUp (Keysym SDLK_s _ _) ->
+-- return $ setSpeed 0 res
+
+-- KeyUp (Keysym SDLK_q _ _) ->
+-- let getY (Vec3 (_,y,_)) = y in
+-- return $
+-- setPositionUpdate firstPerson $
+-- setSpeedFactor 0.1 $
+-- (setDDown <..> (negate . getY . resourcesVelocity)) res
+-- KeyUp (Keysym SDLK_e _ _) ->
+-- return $
+-- setPositionUpdate return $
+-- setSpeedFactor 1 $
+-- if speed res > 0 then setSpeed 1 res else res
+
+-- KeyUp (Keysym SDLK_f _ _) -> do
+-- ret <- reshape 1920 1080 res
+-- SDL.toggleFullscreen $ rSurface ret
+-- SDL.showCursor False
+-- SDL.grabInput True
+-- return ret
+-- KeyUp (Keysym SDLK_g _ _) -> do
+-- SDL.showCursor False
+-- SDL.grabInput True
+-- return res
+
+-- KeyDown (Keysym SDLK_SPACE _ _) -> do
+-- return $ setDDown (-0.3) 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 $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
+-- KeyDown (Keysym SDLK_s _ _) ->
+-- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
+-- KeyDown (Keysym SDLK_d _ _) ->
+-- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
+-- KeyDown (Keysym SDLK_a _ _) ->
+-- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
+
+-- KeyUp (Keysym SDLK_w _ _) ->
+-- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
+-- KeyUp (Keysym SDLK_s _ _) ->
+-- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
+-- KeyUp (Keysym SDLK_d _ _) ->
+-- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
+-- KeyUp (Keysym SDLK_a _ _) ->
+-- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
+
+-- KeyUp (Keysym SDLK_q _ _) ->
+-- let getY (Vec3 (_,y,_)) = y in
+-- return $
+-- setPositionUpdate firstPerson $
+-- setMode FirstPerson $
+-- (setDDown <..> (negate . getY . resourcesVelocity)) res
+-- KeyUp (Keysym SDLK_e _ _) ->
+-- return $
+-- setPositionUpdate return $
+-- setSpeedFactor 1 $
+-- setMode Oracle res
+
+-- KeyUp (Keysym SDLK_f _ _) -> do
+-- ret <- reshape 1920 1080 res
+-- SDL.toggleFullscreen $ rSurface ret
+-- SDL.showCursor False
+-- SDL.grabInput True
+-- return ret
+-- KeyUp (Keysym SDLK_c _ _) -> do
+-- SDL.showCursor True
+-- SDL.grabInput False
+-- return res
+-- KeyUp (Keysym SDLK_g _ _) -> do
+-- SDL.showCursor False
+-- SDL.grabInput True
+-- return res
+
+-- KeyDown (Keysym SDLK_SPACE _ _) -> do
+-- return $
+-- setDDown (-0.2) $
+-- setSpeedFactor 0.05 res
+
+-- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
+-- return $ setSpeedMultiplier 4 res
+
+-- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
+-- return $ setSpeedMultiplier 1 res
+
+-- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
+-- return $ (setSpeed <..> ((*3) . speed)) res
+-- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
+-- return $ (setSpeed <..> ((/3) . speed)) res
+
+-- _ -> return res
{- Callback for the display -}
displayHandle :: Resources -> IO Resources
displayHandle resources = do
- time1 <- getPOSIXTime
- let cameraPos@(CameraPosition loc _ _) = rPosition resources
- let lighty = ((/10) . fromIntegral . time) resources
- let logist c = (1 / (1 + 2.71828**(-c*x))) * 0.9 + 0.1
- where x = sine $ Degrees (lighty)
- let globalAmbient::(GLfloat,GLfloat,GLfloat,GLfloat)
- globalAmbient = ( logist 2+0.1, logist 10, (logist 15) + 0.1,(sine.Degrees) lighty)
- let lightPos = Vec4( 50,
- 1000000 * (sine.Degrees $ lighty),
- -1000000 * (cosine.Degrees . (/10) . fromIntegral . time) resources,
- 1 )
- let l_mvMatrix = buildMVMatrix $ cameraPos
- let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix
-
- clearColor $= Color4 0 0 0 0
- clear [ColorBuffer, DepthBuffer]
- printErrors "Display"
-
-
- let rc = ResourcesClosure l_mvMatrix
- (pMatrix resources)
- (l_mvMatrix `glslMatMul` lightPos)
- (fromIntegral $ time resources)
- (normalMatrix)
- (Vec4 globalAmbient)
- cameraPos
- loc
- resources
-
- in mapM_ (Prelude.$rc) $ routines resources
-
- SDL.glSwapWindow (rWindow resources)
- time2 <- getPOSIXTime
-
- let diff = threadDiff resources - (realToFrac $ time2 - time1)
- when (diff > 0) (threadDelay $ round $ diff * 1000000)
- time3 <- getPOSIXTime
- let fps = realToFrac $ 1 / (time3 - time1) :: Double
-
- putStr $ printf "FPS: %.2f\r" fps
-
- return $
- if' (fps < 30)
- ((setThreadDiff.(subtract 0.0001)) <..> threadDiff)
- ((setThreadDiff.(+0.0001)) <..> threadDiff) resources
+ time1 <- getPOSIXTime
+ let cameraPos@(CameraPosition loc _ _) = rPosition resources
+ let lighty = ((/ 10) . fromIntegral . time) resources
+ let logist c = (1 / (1 + 2.71828 ** (- c * x))) * 0.9 + 0.1
+ where
+ x = sine $ Degrees (lighty)
+ let globalAmbient :: (GLfloat, GLfloat, GLfloat, GLfloat)
+ globalAmbient = (logist 2 + 0.1, logist 10, (logist 15) + 0.1, (sine . Degrees) lighty)
+ let lightPos =
+ Vec4
+ ( 50,
+ 1000000 * (sine . Degrees $ lighty),
+ -1000000 * (cosine . Degrees . (/ 10) . fromIntegral . time) resources,
+ 1
+ )
+ let l_mvMatrix = buildMVMatrix $ cameraPos
+ let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix
+
+ clearColor $= Color4 0 0 0 0
+ clear [ColorBuffer, DepthBuffer]
+ printErrors "Display"
+
+ let rc =
+ ResourcesClosure
+ l_mvMatrix
+ (pMatrix resources)
+ (l_mvMatrix `glslMatMul` lightPos)
+ (fromIntegral $ time resources)
+ (normalMatrix)
+ (Vec4 globalAmbient)
+ cameraPos
+ loc
+ resources
+ in mapM_ (Prelude.$ rc) $ routines resources
+
+ SDL.glSwapWindow (rWindow resources)
+ time2 <- getPOSIXTime
+
+ let diff = threadDiff resources - (realToFrac $ time2 - time1)
+ when (diff > 0) (threadDelay $ round $ diff * 1000000)
+ time3 <- getPOSIXTime
+ let fps = realToFrac $ 1 / (time3 - time1) :: Double
+
+ putStr $ printf "FPS: %.2f\r" fps
+
+ return $
+ if'
+ (fps < 30)
+ ((setThreadDiff . (subtract 0.0001)) <..> threadDiff)
+ ((setThreadDiff . (+ 0.0001)) <..> threadDiff)
+ resources
cameraToEuclidian :: CameraPosition -> Vec3 GLfloat
-cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1,ph,th)
+cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1, ph, th)
resourcesVelocity :: Resources -> Vec3 GLfloat
resourcesVelocity res = getSpeed res `vScale` cameraToEuclidian (rPosition res)
resourcesUnderWater :: Resources -> IO Bool
resourcesUnderWater res = do
- let (CameraPosition (Vec3 (x,ch,y)) _ _) = rPosition res
- (_,(w,h)) <- ArrIO.getBounds $ waterArray res
- if x < 0 || y < 0 || x > int w || y > int h then return False else do
- height <- ArrIO.readArray (waterArray res) (floor x, floor y)
- return (height > ch && height >= 0)
+ let (CameraPosition (Vec3 (x, ch, y)) _ _) = rPosition res
+ (_, (w, h)) <- ArrIO.getBounds $ waterArray res
+ if x < 0 || y < 0 || x > int w || y > int h
+ then return False
+ else do
+ height <- ArrIO.readArray (waterArray res) (floor x, floor y)
+ return (height > ch && height >= 0)
updateHandle :: Resources -> IO Resources
updateHandle res = do
- (positionUpdate res) $ setRPosition (rPosition res `cAdd` rDPosition res) $
- let new = ((+) `on` (Prelude.$ res)) timeSpeed time in
- setTime new res
- where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
- let x' = getVelocity res in
- CameraPosition (x <+> x') (y + y') (z + z')
+ (positionUpdate res) $
+ setRPosition (rPosition res `cAdd` rDPosition res) $
+ let new = ((+) `on` (Prelude.$ res)) timeSpeed time
+ in setTime new res
+ where
+ (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
+ let x' = getVelocity res
+ 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
+ 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
+ ( 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
-
-loadProgramFullSafe' ::
- (IsShaderSource tc, IsShaderSource te,
- IsShaderSource g, IsShaderSource v,
- IsShaderSource f) => Maybe (tc, te) -> Maybe g -> v -> f -> IO Program
+ progMaybe <- loadProgramSafe s1 s2 s3
+ when (isNothing progMaybe) $ exitWith (ExitFailure 111)
+ return $ fromJust progMaybe
+
+loadProgramFullSafe' ::
+ ( IsShaderSource tc,
+ IsShaderSource te,
+ IsShaderSource g,
+ IsShaderSource v,
+ IsShaderSource f
+ ) =>
+ Maybe (tc, te) ->
+ Maybe g ->
+ v ->
+ f ->
+ IO Program
loadProgramFullSafe' a b c d = do
- progMaybe <- loadProgramFullSafe a b c d
- when (isNothing progMaybe) $ exitWith (ExitFailure 111)
- return $ fromJust progMaybe
+ progMaybe <- loadProgramFullSafe a b c d
+ when (isNothing progMaybe) $ exitWith (ExitFailure 111)
+ return $ fromJust progMaybe
buildTerrainObject :: BuilderM GLfloat b -> IO (ResourcesClosure -> IO ())
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 "terrain/unknown.png") $ \(idx,str) -> do
- location <- get $ uniformLocation terrainProg $ "textures[" ++! idx ++ "]"
- SDL.Image.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)
- obj <- 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"
-
- [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU, fogU]
- <- getUniformsSafe terrainProg ["lightPos","globalAmbient","pjMatrix","mvMatrix","normalMatrix","fog"]
- return $ \rc -> do
- draw $ prepare obj $ \_ -> do
- cullFace $= Just Front
- uniform mvMatrixU $= rcMVMatrix rc
- uniform pjMatrixU $= rcPMatrix rc
- uniform lightposU $= rcLightPos rc
- uniform normalMatrixU $= rcNormalMatrix rc
- uniform globalAmbientU $= rcGlobalAmbient rc
- bool <- (resourcesUnderWater $ rcResources rc)
- if bool then
- uniform fogU $= Index1 (0.9::GLfloat) else
- uniform fogU $= Index1 (0.0::GLfloat)
+ 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 "terrain/unknown.png") $ \(idx, str) -> do
+ location <- get $ uniformLocation terrainProg $ "textures[" ++! idx ++ "]"
+ SDL.Image.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)
+ obj <- 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"
+
+ [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU, fogU] <-
+ getUniformsSafe terrainProg ["lightPos", "globalAmbient", "pjMatrix", "mvMatrix", "normalMatrix", "fog"]
+ return $ \rc -> do
+ draw $
+ prepare obj $ \_ -> do
+ cullFace $= Just Front
+ uniform mvMatrixU $= rcMVMatrix rc
+ uniform pjMatrixU $= rcPMatrix rc
+ uniform lightposU $= rcLightPos rc
+ uniform normalMatrixU $= rcNormalMatrix rc
+ uniform globalAmbientU $= rcGlobalAmbient rc
+ bool <- (resourcesUnderWater $ rcResources rc)
+ if bool
+ then uniform fogU $= Index1 (0.9 :: GLfloat)
+ else uniform fogU $= Index1 (0.0 :: GLfloat)
-- cloudProgram :: IO (ResourcesClosure -> IO ())
-- cloudProgram = do
@@ -583,13 +615,13 @@ buildTerrainObject builder = do
-- bColor4 (x,y,z,0)
-- bVertex3 (x,y+20,z)
-- program <- loadProgramSafe' "shaders/clouds.vert" "shaders/clouds.frag" noShader
---
+--
-- stgen <- newStdGen
-- array3D <- SA.newListArray ((0,0,0,0),(3,64,64,64)) (map (fromIntegral . (`mod`256)) $ (randoms stgen::[Int]))
---
+--
-- SA.withStorableArray array3D $ \ptr3D -> do
-- density <- makeTexture3D >>= textureFromPointer3D ptr3D (64,64,64)
---
+--
-- obj' <- newDefaultGlyphObjectWithClosure builder () $ \_ -> do
-- currentProgram $= Just program
-- [mvMatU, pMatU, densityU, globalAmbientU,lightposU] <- mapM (get . uniformLocation program)
@@ -602,93 +634,102 @@ buildTerrainObject builder = do
-- uniform globalAmbientU $= rcGlobalAmbient rc
-- uniform lightposU $= rcLightPos rc
-- setupTexturing3D density densityU 0
-
-buildSnowVal :: Array (Int,Int) Tile -> StdGen -> BuilderM GLfloat ()
+
+buildSnowVal :: Array (Int, Int) Tile -> StdGen -> BuilderM GLfloat ()
buildSnowVal arr gen =
- let (_,(w,h)) = bounds arr
- run :: [Int] -> (Int,Int) -> BuilderM GLfloat [Int]
- run rs (x,y) = do
- let (seed:npart:t) = rs
- nStdGen = mkStdGen seed
- height = elevation (arr ! (x,y))
- when (tileType (arr ! (x,y)) == Tundra) $
- forM_ (take (npart`mod`50) $ chunkList3 $ randomRs (0::GLfloat,1) nStdGen ) $ \(a,b,c) -> do
- let (x',y') = (int x + a, int y + b)
- bVertex3 (x',c*100,y')
- bColor4 (int $ height `div` 10,1, 0, 0)
-
- return t
- in
-
- foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]
-
-buildSnowObject :: Array (Int,Int) Tile -> StdGen -> IO (ResourcesClosure -> IO ())
+ let (_, (w, h)) = bounds arr
+ run :: [Int] -> (Int, Int) -> BuilderM GLfloat [Int]
+ run rs (x, y) = do
+ let (seed : npart : t) = rs
+ nStdGen = mkStdGen seed
+ height = elevation (arr ! (x, y))
+ when (tileType (arr ! (x, y)) == Tundra) $
+ forM_ (take (npart `mod` 50) $ chunkList3 $ randomRs (0 :: GLfloat, 1) nStdGen) $ \(a, b, c) -> do
+ let (x', y') = (int x + a, int y + b)
+ bVertex3 (x', c * 100, y')
+ bColor4 (int $ height `div` 10, 1, 0, 0)
+
+ return t
+ in foldM_ run (randoms gen) [(x, y) | x <- [1 .. w], y <- [1 .. h]]
+
+buildSnowObject :: Array (Int, Int) Tile -> StdGen -> IO (ResourcesClosure -> IO ())
buildSnowObject arr gen = do
- snowProgram <- loadProgramSafe' "shaders/snow.vert" "shaders/snow.frag" (Just "shaders/snow.geom")
- obj <-
- liftM (flip setPrimitiveMode Ex.Points) $
- newDefaultGlyphObjectWithClosure (buildSnowVal arr gen) () $ \_ -> do
- currentProgram $= Just snowProgram
-
- [globalAmbientU,pjMatrixU,mvMatrixU,timeU] <-
- getUniformsSafe snowProgram ["globalAmbient","pjMatrix","mvMatrix","time"]
- return $ \rc -> do
- draw $ (prepare obj) $ \_ -> do
- uniform mvMatrixU $= rcMVMatrix rc
- uniform pjMatrixU $= rcPMatrix rc
- uniform timeU $= (Index1 $ (rcTime rc/75))
- uniform globalAmbientU $= rcGlobalAmbient rc
+ snowProgram <- loadProgramSafe' "shaders/snow.vert" "shaders/snow.frag" (Just "shaders/snow.geom")
+ obj <-
+ liftM (flip setPrimitiveMode Ex.Points) $
+ newDefaultGlyphObjectWithClosure (buildSnowVal arr gen) () $ \_ -> do
+ currentProgram $= Just snowProgram
+
+ [globalAmbientU, pjMatrixU, mvMatrixU, timeU] <-
+ getUniformsSafe snowProgram ["globalAmbient", "pjMatrix", "mvMatrix", "time"]
+ return $ \rc -> do
+ draw $
+ (prepare obj) $ \_ -> do
+ uniform mvMatrixU $= rcMVMatrix rc
+ uniform pjMatrixU $= rcPMatrix rc
+ uniform timeU $= (Index1 $ (rcTime rc / 75))
+ uniform globalAmbientU $= rcGlobalAmbient rc
buildForestObject :: Seq.Seq GLfloat -> String -> String -> IO (ResourcesClosure -> IO ())
buildForestObject a_seq obj tex =
- if Seq.null a_seq then return ((const.return) ()) else do
- let bufferIO :: IO BufferObject
- bufferIO = (newArray . Fold.toList) a_seq >>= ptrToBuffer ArrayBuffer (Seq.length a_seq * 4)
-
- !buffer <- bufferIO
- (log',file) <- loadObjFile obj :: IO ([String],ObjectFile GLfloat)
- mapM_ putStrLn log'
- let !treeF = trace "build tree" $ (basicBuildObject file :: BuilderM GLfloat ())
-
- forestProg <- loadProgramSafe'
- "shaders/forest.vert" "shaders/forest.frag" noShader
-
- woodTexture <- SDL.Image.load tex >>= textureFromSurface
- let (dx,dy) = (mapT2 $ (1/).fromIntegral) (textureSize woodTexture)
- dXlocation <- get $ uniformLocation forestProg "dX"
- dYlocation <- get $ uniformLocation forestProg "dY"
-
- [textureU,lightU,globalAmbientU,pjMatrixU,mvMatrixU,timeU,normalMatrixU] <-
- getUniformsSafe forestProg ["texture","light","globalAmbient","pjMatrix","mvMatrix","time","normalMatrix"]
-
- obj' <- newDefaultGlyphObjectWithClosure treeF () $ \_ -> do
- currentProgram $= Just forestProg
- setupTexturing woodTexture textureU 0
- uniform dXlocation $= (Index1 $ (dx::GLfloat))
- uniform dYlocation $= (Index1 $ (dy::GLfloat))
-
- bindBuffer ArrayBuffer $= Just buffer
-
- let declareAttr location nelem' offset = do
- vertexAttribPointer location $=
- (ToFloat, VertexArrayDescriptor
- nelem' Float (fromIntegral $ (3+3+2+1+1)*sizeOf (0::GLfloat))
- (wordPtrToPtr offset))
- vertexAttribArray location $= Enabled
- vertexAttributeDivisor location SV.$= 1
-
- declareAttr (AttribLocation 10) 3 0
- declareAttr (AttribLocation 11) 3 (3*4)
- declareAttr (AttribLocation 12) 2 (6*4)
- declareAttr (AttribLocation 13) 1 (8*4)
- declareAttr (AttribLocation 14) 1 (9*4)
-
- printErrors "forestClosure"
- putStrLn $ "N trees = " ++! (Seq.length a_seq `div` 3)
- let obj'' = setNumInstances obj' (Seq.length a_seq `div` 3)
-
- return $ \rc -> do
- draw $ (prepare obj'') $ \_ -> do
+ if Seq.null a_seq
+ then return ((const . return) ())
+ else do
+ let bufferIO :: IO BufferObject
+ bufferIO = (newArray . Fold.toList) a_seq >>= ptrToBuffer ArrayBuffer (Seq.length a_seq * 4)
+
+ !buffer <- bufferIO
+ (log', file) <- loadObjFile obj :: IO ([String], ObjectFile GLfloat)
+ mapM_ putStrLn log'
+ let !treeF = trace "build tree" $ (basicBuildObject file :: BuilderM GLfloat ())
+
+ forestProg <-
+ loadProgramSafe'
+ "shaders/forest.vert"
+ "shaders/forest.frag"
+ noShader
+
+ woodTexture <- SDL.Image.load tex >>= textureFromSurface
+ let (dx, dy) = (mapT2 $ (1 /) . fromIntegral) (textureSize woodTexture)
+ dXlocation <- get $ uniformLocation forestProg "dX"
+ dYlocation <- get $ uniformLocation forestProg "dY"
+
+ [textureU, lightU, globalAmbientU, pjMatrixU, mvMatrixU, timeU, normalMatrixU] <-
+ getUniformsSafe forestProg ["texture", "light", "globalAmbient", "pjMatrix", "mvMatrix", "time", "normalMatrix"]
+
+ obj' <- newDefaultGlyphObjectWithClosure treeF () $ \_ -> do
+ currentProgram $= Just forestProg
+ setupTexturing woodTexture textureU 0
+ uniform dXlocation $= (Index1 $ (dx :: GLfloat))
+ uniform dYlocation $= (Index1 $ (dy :: GLfloat))
+
+ bindBuffer ArrayBuffer $= Just buffer
+
+ let declareAttr location nelem' offset = do
+ vertexAttribPointer location
+ $= ( ToFloat,
+ VertexArrayDescriptor
+ nelem'
+ Float
+ (fromIntegral $ (3 + 3 + 2 + 1 + 1) * sizeOf (0 :: GLfloat))
+ (wordPtrToPtr offset)
+ )
+ vertexAttribArray location $= Enabled
+ vertexAttributeDivisor location SV.$= 1
+
+ declareAttr (AttribLocation 10) 3 0
+ declareAttr (AttribLocation 11) 3 (3 * 4)
+ declareAttr (AttribLocation 12) 2 (6 * 4)
+ declareAttr (AttribLocation 13) 1 (8 * 4)
+ declareAttr (AttribLocation 14) 1 (9 * 4)
+
+ printErrors "forestClosure"
+ putStrLn $ "N trees = " ++! (Seq.length a_seq `div` 3)
+ let obj'' = setNumInstances obj' (Seq.length a_seq `div` 3)
+
+ return $ \rc -> do
+ draw $
+ (prepare obj'') $ \_ -> do
uniform mvMatrixU $= rcMVMatrix rc
uniform pjMatrixU $= rcPMatrix rc
uniform lightU $= rcLightPos rc
@@ -698,185 +739,205 @@ buildForestObject a_seq obj tex =
buildWaterObject :: BuilderM GLfloat a -> IO (ResourcesClosure -> IO ())
buildWaterObject builder = do
- waterProg <- loadProgramFullSafe'
- (Just ("shaders/water.tcs","shaders/water.tes"))
- noShader "shaders/water.vert" "shaders/water.frag"
- waterTexture <- SDL.Image.load "textures/water.jpg" >>= textureFromSurface
- skyTexture <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
- skyNightTexture <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
- location <- get (uniformLocation waterProg "texture")
- skyLocation <- get (uniformLocation waterProg "skytex")
- skyNightLocation <- get (uniformLocation waterProg "skynight")
- obj <- (liftM (flip setPrimitiveMode Ex.Patches) $ newDefaultGlyphObjectWithClosure builder () $ \_ -> do
- currentProgram $= Just waterProg
- setupTexturing waterTexture location 0
- setupTexturing skyTexture skyLocation 1
- setupTexturing skyNightTexture skyNightLocation 2
- )
- [fogU] <- getUniformsSafe waterProg ["fog"]
- return $ \rc -> do
- draw $ prepare obj $ \_ -> do
- cullFace $= Nothing
- GL.patchVertices $= 4
- uniform (UniformLocation 4) $= rcPMatrix rc
- uniform (UniformLocation 5) $= rcMVMatrix rc
- uniform (UniformLocation 7) $= rcNormalMatrix rc
- uniform (UniformLocation 8) $= rcLightPos rc
- uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0);
- uniform (UniformLocation 10) $= rcGlobalAmbient rc
- bool <- (resourcesUnderWater $ rcResources rc)
- if bool then
- uniform fogU $= Index1 (0.9::GLfloat) else
- uniform fogU $= Index1 (0.0::GLfloat)
-
-
-makeResources :: SDL.Window -> BuilderM GLfloat b ->
- Seq.Seq GLfloat -> Seq.Seq GLfloat ->
- BuilderM GLfloat a -> Array (Int,Int) Tile ->
- ArrIO.IOArray (Int,Int) GLfloat -> IO Resources
+ waterProg <-
+ loadProgramFullSafe'
+ (Just ("shaders/water.tcs", "shaders/water.tes"))
+ noShader
+ "shaders/water.vert"
+ "shaders/water.frag"
+ waterTexture <- SDL.Image.load "textures/water.jpg" >>= textureFromSurface
+ skyTexture <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
+ skyNightTexture <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
+ location <- get (uniformLocation waterProg "texture")
+ skyLocation <- get (uniformLocation waterProg "skytex")
+ skyNightLocation <- get (uniformLocation waterProg "skynight")
+ obj <-
+ ( liftM (flip setPrimitiveMode Ex.Patches) $
+ newDefaultGlyphObjectWithClosure builder () $ \_ -> do
+ currentProgram $= Just waterProg
+ setupTexturing waterTexture location 0
+ setupTexturing skyTexture skyLocation 1
+ setupTexturing skyNightTexture skyNightLocation 2
+ )
+ [fogU] <- getUniformsSafe waterProg ["fog"]
+ return $ \rc -> do
+ draw $
+ prepare obj $ \_ -> do
+ cullFace $= Nothing
+ GL.patchVertices $= 4
+ uniform (UniformLocation 4) $= rcPMatrix rc
+ uniform (UniformLocation 5) $= rcMVMatrix rc
+ uniform (UniformLocation 7) $= rcNormalMatrix rc
+ uniform (UniformLocation 8) $= rcLightPos rc
+ uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0)
+ uniform (UniformLocation 10) $= rcGlobalAmbient rc
+ bool <- (resourcesUnderWater $ rcResources rc)
+ if bool
+ then uniform fogU $= Index1 (0.9 :: GLfloat)
+ else uniform fogU $= Index1 (0.0 :: GLfloat)
+
+makeResources ::
+ SDL.Window ->
+ BuilderM GLfloat b ->
+ Seq.Seq GLfloat ->
+ Seq.Seq GLfloat ->
+ BuilderM GLfloat a ->
+ Array (Int, Int) Tile ->
+ ArrIO.IOArray (Int, Int) GLfloat ->
+ IO Resources
makeResources window builder forestB jungleB water arr waterarr = do
- hSetBuffering stdout NoBuffering
- let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
-
- stdgen <- newStdGen
- let l_routines = sequence [
- skyboxObject,
- (return $ \_ -> do
+ hSetBuffering stdout NoBuffering
+ let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
+
+ stdgen <- newStdGen
+ let l_routines =
+ sequence
+ [ skyboxObject,
+ ( return $ \_ -> do
vertexProgramPointSize $= Enabled
- depthFunc $= Just Less),
+ depthFunc $= Just Less
+ ),
buildTerrainObject builder,
- (return $ \_-> do
+ ( return $ \_ -> do
blend $= Disabled
cullFace $= Just Back
- blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)),
+ blendFunc $= (GL.SrcAlpha, OneMinusSrcAlpha)
+ ),
buildWaterObject water,
buildForestObject forestB "tree.obj" "textures/wood_low.png",
buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png"
-- buildSnowObject arr stdgen
-- cloudProgram
- ]
- Resources
- <$> pure window
- <*> do CameraPosition
- <$> pure (Vec3 (10,10,-10))
- <*> pure 0
- <*> pure 0
- <*> do CameraPosition
- <$> pure (Vec3 (0,0,0))
- <*> pure 0
- <*> pure 0
- <*> pure pMatrix'
- <*> pure pMatrix'
- <*> l_routines
- <*> pure 1
+ ]
+ Resources
+ <$> pure window
+ <*> do
+ CameraPosition
+ <$> pure (Vec3 (10, 10, -10))
<*> pure 0
- <*> pure arr
- <*> pure return
- <*> pure 1
- <*> pure 1
- <*> pure (Vec3 (0,0,0))
<*> pure 0
- <*> pure waterarr
+ <*> do
+ CameraPosition
+ <$> pure (Vec3 (0, 0, 0))
<*> pure 0
- <*> pure Oracle
- <*> pure 0.033
+ <*> pure 0
+ <*> pure pMatrix'
+ <*> pure pMatrix'
+ <*> l_routines
+ <*> pure 1
+ <*> pure 0
+ <*> pure arr
+ <*> pure return
+ <*> pure 1
+ <*> pure 1
+ <*> pure (Vec3 (0, 0, 0))
+ <*> pure 0
+ <*> pure waterarr
+ <*> pure 0
+ <*> pure Oracle
+ <*> pure 0.033
printErrors :: String -> IO ()
printErrors ctx =
- get errors >>= mapM_ (putStrLn . (("GL["++ctx++"]: ")++) . show)
+ 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
+ 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
+
skyboxTop :: GLfloat -> BuilderM GLfloat ()
skyboxTop dist = do
- mapM_ (uncurry (>>)) $
- trianglesFromQuads
- [(bTexture2(1,0), bVertex3 ( -dist, dist, dist)),
- (bTexture2(1,1), bVertex3 ( dist, dist, dist)),
- (bTexture2(0,1), bVertex3 ( dist, dist, -dist)),
- (bTexture2(0,0), bVertex3 ( -dist, dist, -dist))]
+ mapM_ (uncurry (>>)) $
+ trianglesFromQuads
+ [ (bTexture2 (1, 0), bVertex3 (- dist, dist, dist)),
+ (bTexture2 (1, 1), bVertex3 (dist, dist, dist)),
+ (bTexture2 (0, 1), bVertex3 (dist, dist, - dist)),
+ (bTexture2 (0, 0), bVertex3 (- dist, dist, - dist))
+ ]
skyboxObject :: IO (ResourcesClosure -> IO ())
skyboxObject = do
- prog <- loadProgramSafe' "shaders/sky.vert" "shaders/sky.frag" (Nothing::Maybe String)
- texLoc <- get $ uniformLocation prog "texture"
- texLocNight <- get $ uniformLocation prog "night_tex"
- matLoc <- get $ uniformLocation prog "mvMatrix"
- pmatLoc <- get $ uniformLocation prog "pjMatrix"
-
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
- l_texture <- SDL.Image.load "textures/skybox_sides.png" >>= textureFromSurface
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
- l_texture2 <- SDL.Image.load "textures/skybox_sides_night.png" >>= textureFromSurface
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
- l_textureTop <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
- glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
- l_textureTopNight <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
-
- [lightposU,multU] <- mapM (get . uniformLocation prog)
- ["lightpos","mult"]
- topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do
- setupTexturing l_textureTop texLoc 2
- setupTexturing l_textureTopNight texLocNight 3
-
- obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do
- currentProgram $= Just prog
- setupTexturing l_texture texLoc 0
- setupTexturing l_texture2 texLocNight 1
- printErrors "Skybox"
-
- let obj' = teardown obj $ \_ -> do
- draw topObj
-
- return $ \rc -> do
- depthFunc $= Nothing
- cullFace $= Nothing
- draw $ prepare obj' $ \this -> do
- let (l_matLoc,l_pmatLoc) = getResources this
- let (CameraPosition _ th ph) = rcCameraPos rc
- uniform lightposU $= rcLightPos rc
- uniform l_pmatLoc $= rcPMatrix rc
- uniform l_matLoc $= buildMVMatrix (CameraPosition (Vec3 (0,0,0)) th ph)
- uniform (UniformLocation 1) $= rcGlobalAmbient rc
- bool <- (resourcesUnderWater $ rcResources rc)
- if bool then
- uniform multU $= Index1 (0.0::GLfloat) else
- uniform multU $= Index1 (1.0::GLfloat)
-
-
+ prog <- loadProgramSafe' "shaders/sky.vert" "shaders/sky.frag" (Nothing :: Maybe String)
+ texLoc <- get $ uniformLocation prog "texture"
+ texLocNight <- get $ uniformLocation prog "night_tex"
+ matLoc <- get $ uniformLocation prog "mvMatrix"
+ pmatLoc <- get $ uniformLocation prog "pjMatrix"
+
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_texture <- SDL.Image.load "textures/skybox_sides.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_texture2 <- SDL.Image.load "textures/skybox_sides_night.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_textureTop <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_textureTopNight <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
+
+ [lightposU, multU] <-
+ mapM
+ (get . uniformLocation prog)
+ ["lightpos", "mult"]
+ topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do
+ setupTexturing l_textureTop texLoc 2
+ setupTexturing l_textureTopNight texLocNight 3
+
+ obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc, pmatLoc) $ \_ -> do
+ currentProgram $= Just prog
+ setupTexturing l_texture texLoc 0
+ setupTexturing l_texture2 texLocNight 1
+ printErrors "Skybox"
+
+ let obj' = teardown obj $ \_ -> do
+ draw topObj
+
+ return $ \rc -> do
+ depthFunc $= Nothing
+ cullFace $= Nothing
+ draw $
+ prepare obj' $ \this -> do
+ let (l_matLoc, l_pmatLoc) = getResources this
+ let (CameraPosition _ th ph) = rcCameraPos rc
+ uniform lightposU $= rcLightPos rc
+ uniform l_pmatLoc $= rcPMatrix rc
+ uniform l_matLoc $= buildMVMatrix (CameraPosition (Vec3 (0, 0, 0)) th ph)
+ uniform (UniformLocation 1) $= rcGlobalAmbient rc
+ bool <- (resourcesUnderWater $ rcResources rc)
+ if bool
+ then uniform multU $= Index1 (0.0 :: GLfloat)
+ else uniform multU $= Index1 (1.0 :: GLfloat)
prepareSkybox :: Mat4 GLfloat -> Mat4 GLfloat -> GlyphObject (Mat4 GLfloat -> Mat4 GLfloat -> IO ()) -> IO ()
prepareSkybox proj lookat obj = do
- (getResources obj) proj lookat
-
+ (getResources obj) proj lookat
generated by cgit (git 2.34.1) at 2025-04-28 11:00:59 +0000