From ba59711a51b4fee34009b1fe6afdce9ef8e60ae0 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 3 Dec 2022 17:37:59 -0700 Subject: run ormolu formatter --- Data/ByteStringBuilder.hs | 15 +- Final.hs | 629 +++++++------ Graphics/Glyph/ArrayGenerator.hs | 41 +- Graphics/Glyph/BufferBuilder.hs | 466 +++++----- Graphics/Glyph/ExtendedGL.hs | 11 +- Graphics/Glyph/ExtendedGL/Base.hs | 124 +-- Graphics/Glyph/ExtendedGL/Framebuffers.hs | 137 +-- Graphics/Glyph/GLMath.hs | 431 ++++++--- Graphics/Glyph/GeometryBuilder.hs | 249 ++--- Graphics/Glyph/GlyphObject.hs | 189 ++-- Graphics/Glyph/ObjLoader.hs | 166 ++-- Graphics/Glyph/Shaders.hs | 144 +-- Graphics/Glyph/Textures.hs | 47 +- Graphics/Glyph/Util.hs | 265 +++--- Graphics/Rendering/HelpGL.hs | 12 +- Graphics/SDL/SDLHelp.hs | 203 +++-- Models.hs | 129 ++- Resources.hs | 1407 +++++++++++++++-------------- 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_FRAMEBUFFE