From d70a491c93e061a5e196a1a27191c6e884ffd9d2 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Tue, 29 Dec 2020 01:37:41 +0000 Subject: Format with ormolu --- src/Vivant.hs | 435 +++++++++++++++++++++++++---------------------- src/Vivant/Noise.hs | 459 ++++++++++++++++++++++++++++++++++++++++---------- src/Vivant/Shader.hs | 82 ++++----- src/Vivant/Texture.hs | 23 ++- 4 files changed, 656 insertions(+), 343 deletions(-) diff --git a/src/Vivant.hs b/src/Vivant.hs index 4a93b62..19548ce 100644 --- a/src/Vivant.hs +++ b/src/Vivant.hs @@ -14,137 +14,146 @@ module Main where -import Control.Lens ((.~), (^.)) -import Control.Monad -import Data.Fixed (mod') -import Data.Function ((&)) -import Data.Int (Int32) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word (Word32) -import Foreign.C.Types -import Foreign.Marshal.Alloc (free, malloc) -import Foreign.Ptr -import Foreign.Storable (poke, sizeOf) -import Linear -import SDL (($=)) -import SDL.Raw.Enum as SDL -import SDL.Raw.Video as SDL (glSetAttribute) -import SDL.Time (ticks) -import SDL.Vect -import System.Exit (exitFailure) -import System.IO - -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as V -import qualified Graphics.GL.Functions as GL (glUniformMatrix4fv) -import qualified Graphics.Rendering.OpenGL as GL +import Control.Lens ((.~), (^.)) +import Control.Monad +import qualified Data.ByteString as BS +import Data.Fixed (mod') +import Data.Function ((&)) +import Data.Int (Int32) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector.Storable as V +import Data.Word (Word32) +import Foreign.C.Types +import Foreign.Marshal.Alloc (free, malloc) +import Foreign.Ptr +import Foreign.Storable (poke, sizeOf) +import qualified Graphics.GL.Functions as GL (glUniformMatrix4fv) +import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL.GL.Shaders.Uniform as GL (UniformLocation (..)) +import Linear +import Paths_vivant (getDataDir) +import SDL (($=)) import qualified SDL - -import Paths_vivant (getDataDir) -import Vivant.Shader (createProgram) +import SDL.Raw.Enum as SDL +import SDL.Raw.Video as SDL (glSetAttribute) +import SDL.Time (ticks) +import SDL.Vect +import System.Exit (exitFailure) +import System.IO +import Vivant.Shader (createProgram) screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) data Camera = Camera - { cameraPos :: V3 Float - , cameraUp :: V3 Float - , cameraFront :: V3 Float - , cameraSpeed :: Float - , cameraPitch :: Float - , cameraYaw :: Float - } deriving (Show) + { cameraPos :: V3 Float, + cameraUp :: V3 Float, + cameraFront :: V3 Float, + cameraSpeed :: Float, + cameraPitch :: Float, + cameraYaw :: Float + } + deriving (Show) initialCamera :: Camera -initialCamera = Camera - { cameraPos = V3 0 0 10 - , cameraUp = V3 0 1 0 - , cameraFront = V3 0 0 (-1) - , cameraSpeed = 0.05 - , cameraPitch = 0 - , cameraYaw = (-90) - } +initialCamera = + Camera + { cameraPos = V3 0 0 10, + cameraUp = V3 0 1 0, + cameraFront = V3 0 0 (-1), + cameraSpeed = 0.05, + cameraPitch = 0, + cameraYaw = (-90) + } data Game = Game - { gameProgram :: Maybe (GL.Program) - , gameVao :: Maybe (GL.VertexArrayObject) - , gameModelP :: Ptr (M44 Float) - , gameViewP :: Ptr (M44 Float) - , gameProjectionP :: Ptr (M44 Float) - , gameCamera :: Camera - } deriving (Show) + { gameProgram :: Maybe (GL.Program), + gameVao :: Maybe (GL.VertexArrayObject), + gameModelP :: Ptr (M44 Float), + gameViewP :: Ptr (M44 Float), + gameProjectionP :: Ptr (M44 Float), + gameCamera :: Camera + } + deriving (Show) initialGameState :: Game -initialGameState = Game - { gameProgram = Nothing - , gameVao = Nothing - , gameModelP = nullPtr - , gameViewP = nullPtr - , gameProjectionP = nullPtr - , gameCamera = initialCamera - } +initialGameState = + Game + { gameProgram = Nothing, + gameVao = Nothing, + gameModelP = nullPtr, + gameViewP = nullPtr, + gameProjectionP = nullPtr, + gameCamera = initialCamera + } data MouseInputs = MouseInputs - { mousePosition :: Point V2 Int32 - , mouseRelative :: V2 Int32 - , mousePositionOld :: Maybe (V2 Int32) - } deriving (Show) + { mousePosition :: Point V2 Int32, + mouseRelative :: V2 Int32, + mousePositionOld :: Maybe (V2 Int32) + } + deriving (Show) initialMouse :: MouseInputs -initialMouse = MouseInputs - { mousePosition = P (V2 400 300) - , mouseRelative = V2 0 0 - , mousePositionOld = Nothing - } +initialMouse = + MouseInputs + { mousePosition = P (V2 400 300), + mouseRelative = V2 0 0, + mousePositionOld = Nothing + } main :: IO () main = do - SDL.initialize [SDL.InitVideo] - SDL.HintRenderScaleQuality $= SDL.ScaleLinear - do renderQuality <- SDL.get SDL.HintRenderScaleQuality - when (renderQuality /= SDL.ScaleLinear) $ - putStrLn "Warning: Linear texture filtering not enabled!" + SDL.initialize [SDL.InitVideo] + SDL.HintRenderScaleQuality $= SDL.ScaleLinear + do + renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + putStrLn "Warning: Linear texture filtering not enabled!" - window <- - SDL.createWindow - "SDL / OpenGL Example" - SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight, - SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL} + window <- + SDL.createWindow + "SDL / OpenGL Example" + SDL.defaultWindow + { SDL.windowInitialSize = V2 screenWidth screenHeight, + SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + } - SDL.glSetAttribute SDL_GL_CONTEXT_PROFILE_MASK SDL_GL_CONTEXT_PROFILE_CORE - SDL.glSetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 3 - SDL.glSetAttribute SDL_GL_CONTEXT_MINOR_VERSION 2 + SDL.glSetAttribute SDL_GL_CONTEXT_PROFILE_MASK SDL_GL_CONTEXT_PROFILE_CORE + SDL.glSetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 3 + SDL.glSetAttribute SDL_GL_CONTEXT_MINOR_VERSION 2 - SDL.glSetAttribute SDL_GL_DOUBLEBUFFER 1 - SDL.glSetAttribute SDL_GL_DEPTH_SIZE 24 + SDL.glSetAttribute SDL_GL_DOUBLEBUFFER 1 + SDL.glSetAttribute SDL_GL_DEPTH_SIZE 24 - SDL.showWindow window + SDL.showWindow window - _ <- SDL.glCreateContext window + _ <- SDL.glCreateContext window - GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) - game <- initResources + game <- initResources - let loop key mouse = do - (keys', mouse') <- parseEvents key mouse + let loop key mouse = do + (keys', mouse') <- parseEvents key mouse - draw game - SDL.glSwapWindow window + draw game + SDL.glSwapWindow window - unless (Set.member escapeKey keys') (loop keys' mouse') + unless (Set.member escapeKey keys') (loop keys' mouse') - loop Set.empty initialMouse + loop Set.empty initialMouse - mapM_ free [ gameModelP game - , gameViewP game - , gameProjectionP game - ] + mapM_ + free + [ gameModelP game, + gameViewP game, + gameProjectionP game + ] - SDL.destroyWindow window - SDL.quit + SDL.destroyWindow window + SDL.quit noKeyModifier :: SDL.KeyModifier noKeyModifier = SDL.KeyModifier False False False False False False False False False False False @@ -154,86 +163,100 @@ escapeKey = SDL.Keysym SDL.ScancodeEscape SDL.KeycodeEscape noKeyModifier parseEvents :: Set SDL.Keysym -> MouseInputs -> IO (Set SDL.Keysym, MouseInputs) parseEvents keys mouse = do - events <- SDL.pollEvents - return $ foldr handleEvents (keys, mouse) (fmap SDL.eventPayload events) + events <- SDL.pollEvents + return $ foldr handleEvents (keys, mouse) (fmap SDL.eventPayload events) -handleEvents - :: SDL.EventPayload - -> (Set SDL.Keysym, MouseInputs) -> (Set SDL.Keysym, MouseInputs) +handleEvents :: + SDL.EventPayload -> + (Set SDL.Keysym, MouseInputs) -> + (Set SDL.Keysym, MouseInputs) handleEvents event (k, m) = - case event of - SDL.KeyboardEvent (SDL.KeyboardEventData { SDL.keyboardEventKeyMotion = e - , SDL.keyboardEventKeysym = k'}) -> + case event of + SDL.KeyboardEvent + ( SDL.KeyboardEventData + { SDL.keyboardEventKeyMotion = e, + SDL.keyboardEventKeysym = k' + } + ) -> ((if e == SDL.Released then Set.delete else Set.insert) k' k, m) - - SDL.MouseMotionEvent (SDL.MouseMotionEventData { SDL.mouseMotionEventPos = pos - , SDL.mouseMotionEventRelMotion = vel - }) -> + SDL.MouseMotionEvent + ( SDL.MouseMotionEventData + { SDL.mouseMotionEventPos = pos, + SDL.mouseMotionEventRelMotion = vel + } + ) -> (k, MouseInputs pos vel Nothing) - - SDL.QuitEvent{} -> - (Set.insert escapeKey k, m) - - _ -> (k, m) - + SDL.QuitEvent {} -> + (Set.insert escapeKey k, m) + _ -> (k, m) updateMouse :: MouseInputs -> Game -> Game updateMouse mouse game = - game { gameCamera = (gameCamera game) - { cameraFront = front - , cameraPitch = pitchDegrees - , cameraYaw = yawDegrees - } - } + game + { gameCamera = + (gameCamera game) + { cameraFront = front, + cameraPitch = pitchDegrees, + cameraYaw = yawDegrees + } + } where camera = gameCamera game front = normalize $ V3 (cos pitch * cos yaw) (sin pitch) (cos pitch * sin yaw) pitch = toRadians pitchDegrees - yaw = toRadians yawDegrees + yaw = toRadians yawDegrees pitchDegrees = min 89 . max (-89) $ cameraPitch camera + negate dy - yawDegrees = (`mod'` 360) $ cameraYaw camera + dx + yawDegrees = (`mod'` 360) $ cameraYaw camera + dx sensitivity = 0.05 - V2 dx dy = (* sensitivity) . fromIntegral <$> - if P (mouseRelative mouse) == mousePosition mouse - then V2 0 0 - else mouseRelative mouse + V2 dx dy = + (* sensitivity) . fromIntegral + <$> if P (mouseRelative mouse) == mousePosition mouse + then V2 0 0 + else mouseRelative mouse setVertexAttribute :: GL.Program -> String -> Int -> Int -> Int -> IO () setVertexAttribute program name vertices stride offset = do - let floatSize = sizeOf (1.0 :: Float) - attrib <- GL.get $ GL.attribLocation program name - GL.vertexAttribPointer attrib $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float - (fromIntegral $ stride * floatSize) - (plusPtr nullPtr (offset * floatSize))) - GL.vertexAttribArray attrib $= GL.Enabled + let floatSize = sizeOf (1.0 :: Float) + attrib <- GL.get $ GL.attribLocation program name + GL.vertexAttribPointer attrib + $= ( GL.ToFloat, + GL.VertexArrayDescriptor + 2 + GL.Float + (fromIntegral $ stride * floatSize) + (plusPtr nullPtr (offset * floatSize)) + ) + GL.vertexAttribArray attrib $= GL.Enabled getUniformLocation :: GL.UniformLocation -> GL.GLint getUniformLocation (GL.UniformLocation i) = i initResources :: IO Game initResources = do - vao <- GL.genObjectName - GL.bindVertexArrayObject $= Just vao + vao <- GL.genObjectName + GL.bindVertexArrayObject $= Just vao - vbo <- GL.genObjectName - GL.bindBuffer GL.ArrayBuffer $= Just vbo - V.unsafeWith vertices $ \ptr -> - GL.bufferData GL.ArrayBuffer $= (vectorSize vertices, castPtr ptr, GL.StaticDraw) + vbo <- GL.genObjectName + GL.bindBuffer GL.ArrayBuffer $= Just vbo + V.unsafeWith vertices $ \ptr -> + GL.bufferData GL.ArrayBuffer $= (vectorSize vertices, castPtr ptr, GL.StaticDraw) - prog <- createProgram + prog <- createProgram - setVertexAttribute prog "position" 2 0 0 + setVertexAttribute prog "position" 2 0 0 - modelP <- malloc - viewP <- malloc - projectionP <- malloc + modelP <- malloc + viewP <- malloc + projectionP <- malloc - return $ initialGameState { gameProgram = Just prog - , gameVao = Just vao - , gameModelP = modelP - , gameViewP = viewP - , gameProjectionP = projectionP - } + return $ + initialGameState + { gameProgram = Just prog, + gameVao = Just vao, + gameModelP = modelP, + gameViewP = viewP, + gameProjectionP = projectionP + } -- | Convert degrees to radians toRadians :: Float -> Float @@ -244,68 +267,82 @@ scaledMat n = ((n * identity) & _w . _w .~ 1) draw :: Game -> IO () draw game@(Game {gameProgram = Just p, gameVao = Just v}) = do - tick <- ticks - GL.clearColor $= GL.Color4 1 1 1 1 - GL.clear [GL.ColorBuffer, GL.DepthBuffer] + tick <- ticks + GL.clearColor $= GL.Color4 1 1 1 1 + GL.clear [GL.ColorBuffer, GL.DepthBuffer] - GL.currentProgram $= gameProgram game - GL.bindVertexArrayObject $= gameVao game + GL.currentProgram $= gameProgram game + GL.bindVertexArrayObject $= gameVao game - model <- getUniformLocation <$> GL.uniformLocation p "model" - view <- getUniformLocation <$> GL.uniformLocation p "view" - projection <- getUniformLocation <$> GL.uniformLocation p "projection" + model <- getUniformLocation <$> GL.uniformLocation p "model" + view <- getUniformLocation <$> GL.uniformLocation p "view" + projection <- getUniformLocation <$> GL.uniformLocation p "projection" - let camera = gameCamera game - cameraPosition = cameraPos camera - targetPosition = cameraPosition ^+^ cameraFront camera - viewMatrix = lookAt cameraPosition targetPosition (cameraUp camera) - projectionMatrix = perspective (toRadians 45) (640/480) 0.1 100 + let camera = gameCamera game + cameraPosition = cameraPos camera + targetPosition = cameraPosition ^+^ cameraFront camera + viewMatrix = lookAt cameraPosition targetPosition (cameraUp camera) + projectionMatrix = perspective (toRadians 45) (640 / 480) 0.1 100 - poke (gameViewP game) viewMatrix - poke (gameProjectionP game) projectionMatrix + poke (gameViewP game) viewMatrix + poke (gameProjectionP game) projectionMatrix - GL.glUniformMatrix4fv view 1 1 (castPtr (gameViewP game)) - GL.glUniformMatrix4fv projection 1 1 (castPtr (gameProjectionP game)) + GL.glUniformMatrix4fv view 1 1 (castPtr (gameViewP game)) + GL.glUniformMatrix4fv projection 1 1 (castPtr (gameProjectionP game)) - ourColorLoc <- GL.uniformLocation p "ourColour" - GL.uniform ourColorLoc $= (GL.Vector4 (1::Float) (sin (fromIntegral tick / 500) / 2 + 0.5) 1 1) + ourColorLoc <- GL.uniformLocation p "ourColour" + GL.uniform ourColorLoc $= (GL.Vector4 (1 :: Float) (sin (fromIntegral tick / 500) / 2 + 0.5) 1 1) - forM_ locs $ \l -> do - let modelMatrix = mkTransformation (axisAngle (V3 1 0 0) 0) l - poke (gameModelP game) modelMatrix - GL.glUniformMatrix4fv model 1 1 (castPtr (gameModelP game)) - GL.drawArrays GL.Triangles 0 6 + forM_ locs $ \l -> do + let modelMatrix = mkTransformation (axisAngle (V3 1 0 0) 0) l + poke (gameModelP game) modelMatrix + GL.glUniformMatrix4fv model 1 1 (castPtr (gameModelP game)) + GL.drawArrays GL.Triangles 0 6 - GL.bindVertexArrayObject $= Nothing - return () + GL.bindVertexArrayObject $= Nothing + return () vectorSize :: (Num b, V.Storable a) => V.Vector a -> b vectorSize array = fromIntegral $ V.length array * sizeOf (1.0 :: Float) vertices :: V.Vector Float -vertices = V.fromList [ 0.5, -0.5 - , -0.5, -0.5 - , 0.5, 0.5 - , -0.5, 0.5 - , -0.5, -0.5 - , 0.5, 0.5 - ] +vertices = + V.fromList + [ 0.5, + -0.5, + -0.5, + -0.5, + 0.5, + 0.5, + -0.5, + 0.5, + -0.5, + -0.5, + 0.5, + 0.5 + ] locs :: [V3 Float] -locs = [ V3 0 0 0 - , V3 1 0 0 - , V3 2 0 0 - , V3 3 0 0 - , V3 4 0 0 - , V3 0 1 0 - , V3 1 1 0 - , V3 2 1 0 - , V3 3 1 0 - , V3 4 1 0 - ] +locs = + [ V3 0 0 0, + V3 1 0 0, + V3 2 0 0, + V3 3 0 0, + V3 4 0 0, + V3 0 1 0, + V3 1 1 0, + V3 2 1 0, + V3 3 1 0, + V3 4 1 0 + ] texCoords :: V.Vector Float -texCoords = V.fromList [ 0, 0 - , 1, 0 - , 0.5, 1 - ] +texCoords = + V.fromList + [ 0, + 0, + 1, + 0, + 0.5, + 1 + ] diff --git a/src/Vivant/Noise.hs b/src/Vivant/Noise.hs index 131ffce..32cd08e 100644 --- a/src/Vivant/Noise.hs +++ b/src/Vivant/Noise.hs @@ -1,61 +1,69 @@ {-# LANGUAGE BangPatterns #-} -module Vivant.Noise - (Permutation(..), perlin3, permutation, mkPermutation) -where - -import Control.Arrow -import Data.Bits -import Data.Vector.Unboxed ((!)) -import Data.Word -import System.Environment (getArgs) - -import qualified Codec.Picture as P -import qualified Data.ByteString as B +module Vivant.Noise (Permutation (..), perlin3, permutation, mkPermutation) where + +import qualified Codec.Picture as P +import Control.Arrow +import Data.Bits +import qualified Data.ByteString as B +import Data.Vector.Unboxed ((!)) import qualified Data.Vector.Unboxed as V +import Data.Word +import System.Environment (getArgs) perlin3 :: (Ord a, Num a, RealFrac a, V.Unbox a) => Permutation -> (a, a, a) -> a -perlin3 p (!x', !y', !z') - = let (!xX, !x) = actuallyProperFraction x' - (!yY, !y) = actuallyProperFraction y' - (!zZ, !z) = actuallyProperFraction z' - - !u = fade x - !v = fade y - !w = fade z - - !h = xX - !a = next p h + yY - !b = next p (h+1) + yY - !aa = next p a + zZ - !ab = next p (a+1) + zZ - !ba = next p b + zZ - !bb = next p (b+1) + zZ - !aaa = next p aa - !aab = next p (aa+1) - !aba = next p ab - !abb = next p (ab+1) - !baa = next p ba - !bab = next p (ba+1) - !bba = next p bb - !bbb = next p (bb+1) - - in - lerp w - (lerp v - (lerp u - (grad aaa (x, y, z)) - (grad baa (x-1, y, z))) - (lerp u - (grad aba (x, y-1, z)) - (grad bba (x-1, y-1, z)))) - (lerp v - (lerp u - (grad aab (x, y, z-1)) - (grad bab (x-1, y, z-1))) - (lerp u - (grad abb (x, y-1, z-1)) - (grad bbb (x-1, y-1, z-1)))) +perlin3 p (!x', !y', !z') = + let (!xX, !x) = actuallyProperFraction x' + (!yY, !y) = actuallyProperFraction y' + (!zZ, !z) = actuallyProperFraction z' + + !u = fade x + !v = fade y + !w = fade z + + !h = xX + !a = next p h + yY + !b = next p (h + 1) + yY + !aa = next p a + zZ + !ab = next p (a + 1) + zZ + !ba = next p b + zZ + !bb = next p (b + 1) + zZ + !aaa = next p aa + !aab = next p (aa + 1) + !aba = next p ab + !abb = next p (ab + 1) + !baa = next p ba + !bab = next p (ba + 1) + !bba = next p bb + !bbb = next p (bb + 1) + in lerp + w + ( lerp + v + ( lerp + u + (grad aaa (x, y, z)) + (grad baa (x -1, y, z)) + ) + ( lerp + u + (grad aba (x, y -1, z)) + (grad bba (x -1, y -1, z)) + ) + ) + ( lerp + v + ( lerp + u + (grad aab (x, y, z -1)) + (grad bab (x -1, y, z -1)) + ) + ( lerp + u + (grad abb (x, y -1, z -1)) + (grad bbb (x -1, y -1, z -1)) + ) + ) fade :: (Ord a, Num a) => a -> a fade !t | 0 <= t, t <= 1 = t * t * t * (t * (t * 6 - 15) + 10) @@ -66,11 +74,24 @@ lerp !t !a !b | 0 <= t, t <= 1 = a + t * (b - a) grad :: (Bits hash, Integral hash, Num a, V.Unbox a) => hash -> (a, a, a) -> a grad !hash (!x, !y, !z) = dot3 (vks `V.unsafeIndex` fromIntegral (hash .&. 15)) (x, y, z) where - vks = V.fromList - [ (1,1,0), (-1,1,0), (1,-1,0), (-1,-1,0) - , (1,0,1), (-1,0,1), (1,0,-1), (-1,0,-1) - , (0,1,1), (0,-1,1), (0,1,-1), (0,-1,-1) - , (1,1,0), (-1,1,0), (0,-1,1), (0,-1,-1) + vks = + V.fromList + [ (1, 1, 0), + (-1, 1, 0), + (1, -1, 0), + (-1, -1, 0), + (1, 0, 1), + (-1, 0, 1), + (1, 0, -1), + (-1, 0, -1), + (0, 1, 1), + (0, -1, 1), + (0, 1, -1), + (0, -1, -1), + (1, 1, 0), + (-1, 1, 0), + (0, -1, 1), + (0, -1, -1) ] dot3 :: Num a => (a, a, a) -> (a, a, a) -> a @@ -78,55 +99,311 @@ dot3 (!x0, !y0, !z0) (!x1, !y1, !z1) = x0 * x1 + y0 * y1 + z0 * z1 -- Unlike `properFraction`, `actuallyProperFraction` rounds as intended. actuallyProperFraction :: (RealFrac a, Integral b) => a -> (b, a) -actuallyProperFraction x - = let (ipart, fpart) = properFraction x - r = if x >= 0 then (ipart, fpart) - else (ipart-1, 1+fpart) - in r +actuallyProperFraction x = + let (ipart, fpart) = properFraction x + r = + if x >= 0 + then (ipart, fpart) + else (ipart -1, 1 + fpart) + in r newtype Permutation = Permutation (V.Vector Word8) mkPermutation :: [Word8] -> Permutation mkPermutation xs - | length xs >= 256 - = Permutation . V.fromList $ xs + | length xs >= 256 = + Permutation . V.fromList $ xs permutation :: Permutation -permutation = mkPermutation - [151,160,137,91,90,15, - 131,13,201,95,96,53,194,233,7,225,140,36,103,30,69,142,8,99,37,240,21,10,23, - 190, 6,148,247,120,234,75,0,26,197,62,94,252,219,203,117,35,11,32,57,177,33, - 88,237,149,56,87,174,20,125,136,171,168, 68,175,74,165,71,134,139,48,27,166, - 77,146,158,231,83,111,229,122,60,211,133,230,220,105,92,41,55,46,245,40,244, - 102,143,54, 65,25,63,161, 1,216,80,73,209,76,132,187,208, 89,18,169,200,196, - 135,130,116,188,159,86,164,100,109,198,173,186, 3,64,52,217,226,250,124,123, - 5,202,38,147,118,126,255,82,85,212,207,206,59,227,47,16,58,17,182,189,28,42, - 223,183,170,213,119,248,152, 2,44,154,163, 70,221,153,101,155,167, 43,172,9, - 129,22,39,253, 19,98,108,110,79,113,224,232,178,185, 112,104,218,246,97,228, - 251,34,242,193,238,210,144,12,191,179,162,241, 81,51,145,235,249,14,239,107, - 49,192,214, 31,181,199,106,157,184, 84,204,176,115,121,50,45,127, 4,150,254, - 138,236,205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,61,156,180 - ] +permutation = + mkPermutation + [ 151, + 160, + 137, + 91, + 90, + 15, + 131, + 13, + 201, + 95, + 96, + 53, + 194, + 233, + 7, + 225, + 140, + 36, + 103, + 30, + 69, + 142, + 8, + 99, + 37, + 240, + 21, + 10, + 23, + 190, + 6, + 148, + 247, + 120, + 234, + 75, + 0, + 26, + 197, + 62, + 94, + 252, + 219, + 203, + 117, + 35, + 11, + 32, + 57, + 177, + 33, + 88, + 237, + 149, + 56, + 87, + 174, + 20, + 125, + 136, + 171, + 168, + 68, + 175, + 74, + 165, + 71, + 134, + 139, + 48, + 27, + 166, + 77, + 146, + 158, + 231, + 83, + 111, + 229, + 122, + 60, + 211, + 133, + 230, + 220, + 105, + 92, + 41, + 55, + 46, + 245, + 40, + 244, + 102, + 143, + 54, + 65, + 25, + 63, + 161, + 1, + 216, + 80, + 73, + 209, + 76, + 132, + 187, + 208, + 89, + 18, + 169, + 200, + 196, + 135, + 130, + 116, + 188, + 159, + 86, + 164, + 100, + 109, + 198, + 173, + 186, + 3, + 64, + 52, + 217, + 226, + 250, + 124, + 123, + 5, + 202, + 38, + 147, + 118, + 126, + 255, + 82, + 85, + 212, + 207, + 206, + 59, + 227, + 47, + 16, + 58, + 17, + 182, + 189, + 28, + 42, + 223, + 183, + 170, + 213, + 119, + 248, + 152, + 2, + 44, + 154, + 163, + 70, + 221, + 153, + 101, + 155, + 167, + 43, + 172, + 9, + 129, + 22, + 39, + 253, + 19, + 98, + 108, + 110, + 79, + 113, + 224, + 232, + 178, + 185, + 112, + 104, + 218, + 246, + 97, + 228, + 251, + 34, + 242, + 193, + 238, + 210, + 144, + 12, + 191, + 179, + 162, + 241, + 81, + 51, + 145, + 235, + 249, + 14, + 239, + 107, + 49, + 192, + 214, + 31, + 181, + 199, + 106, + 157, + 184, + 84, + 204, + 176, + 115, + 121, + 50, + 45, + 127, + 4, + 150, + 254, + 138, + 236, + 205, + 93, + 222, + 114, + 67, + 29, + 24, + 72, + 243, + 141, + 128, + 195, + 78, + 66, + 215, + 61, + 156, + 180 + ] doubleToByte :: Double -> Word8 doubleToByte f = fromIntegral (truncate f :: Int) next :: Permutation -> Int -> Int -next (Permutation !v) !idx' - = fromIntegral $ v `V.unsafeIndex` (fromIntegral idx' .&. 0xFF) +next (Permutation !v) !idx' = + fromIntegral $ v `V.unsafeIndex` (fromIntegral idx' .&. 0xFF) main = do - [target, n] <- getArgs - let image = P.generateImage (pixelRenderer n) 64 64 - P.writePng target image + [target, n] <- getArgs + let image = P.generateImage (pixelRenderer n) 64 64 + P.writePng target image where pixelRenderer, pixelRenderer' :: String -> Int -> Int -> Word8 - pixelRenderer !n !x !y - = doubleToByte $ ((perlin3 permutation ((fromIntegral x - 32) / 4, - (fromIntegral y - 32) / 4, read n :: Double))+1)/2 * 128 + pixelRenderer !n !x !y = + doubleToByte $ + ( ( perlin3 + permutation + ( (fromIntegral x - 32) / 4, + (fromIntegral y - 32) / 4, + read n :: Double + ) + ) + + 1 + ) + / 2 + * 128 - pixelRenderer' !n x y - = (\w -> doubleToByte $ ((w+1)/2 * 128)) -- w should be in [-1,+1] + pixelRenderer' !n x y = + (\w -> doubleToByte $ ((w + 1) / 2 * 128)) -- w should be in [-1,+1] . perlin3 permutation - . (\(x,y,z) -> ((x-256)/32, (y-256)/32, (z-256)/32)) + . (\(x, y, z) -> ((x -256) / 32, (y -256) / 32, (z -256) / 32)) $ (fromIntegral x, fromIntegral y, 0 :: Double) diff --git a/src/Vivant/Shader.hs b/src/Vivant/Shader.hs index c2df314..aa884c6 100644 --- a/src/Vivant/Shader.hs +++ b/src/Vivant/Shader.hs @@ -1,50 +1,50 @@ module Vivant.Shader (createProgram) where -import Control.Monad (unless) -import qualified Data.ByteString as BS +import Control.Monad (unless) +import qualified Data.ByteString as BS import qualified Graphics.Rendering.OpenGL as GL -import Paths_vivant (getDataDir) -import SDL (($=)) -import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr) +import Paths_vivant (getDataDir) +import SDL (($=)) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) createProgram :: IO GL.Program createProgram = do - datadir <- getDataDir - -- compile vertex shader - vs <- GL.createShader GL.VertexShader - vsSource <- BS.readFile $ datadir <> "/shaders/triangle.vert" - GL.shaderSourceBS vs $= vsSource - GL.compileShader vs - vsOK <- GL.get $ GL.compileStatus vs - unless vsOK $ do - log <- GL.shaderInfoLog vs - hPutStrLn stderr ("Error in vertex shader\n" <> log) - exitFailure + datadir <- getDataDir + -- compile vertex shader + vs <- GL.createShader GL.VertexShader + vsSource <- BS.readFile $ datadir <> "/shaders/triangle.vert" + GL.shaderSourceBS vs $= vsSource + GL.compileShader vs + vsOK <- GL.get $ GL.compileStatus vs + unless vsOK $ do + log <- GL.shaderInfoLog vs + hPutStrLn stderr ("Error in vertex shader\n" <> log) + exitFailure - -- Do it again for the fragment shader - fs <- GL.createShader GL.FragmentShader - fsSource <- BS.readFile $ datadir <> "/shaders/triangle.frag" - GL.shaderSourceBS fs $= fsSource - GL.compileShader fs - fsOK <- GL.get $ GL.compileStatus fs - unless fsOK $ do - log <- GL.shaderInfoLog fs - hPutStrLn stderr ("Error in fragment shader\n" <> log) - exitFailure + -- Do it again for the fragment shader + fs <- GL.createShader GL.FragmentShader + fsSource <- BS.readFile $ datadir <> "/shaders/triangle.frag" + GL.shaderSourceBS fs $= fsSource + GL.compileShader fs + fsOK <- GL.get $ GL.compileStatus fs + unless fsOK $ do + log <- GL.shaderInfoLog fs + hPutStrLn stderr ("Error in fragment shader\n" <> log) + exitFailure - program <- GL.createProgram - GL.attachShader program vs - GL.attachShader program fs - GL.linkProgram program - linkOK <- GL.get $ GL.linkStatus program - GL.validateProgram program - status <- GL.get $ GL.validateStatus program - unless (linkOK && status) $ do - hPutStrLn stderr "GL.linkProgram error" - plog <- GL.get $ GL.programInfoLog program - putStrLn plog - exitFailure - GL.currentProgram $= Just program + program <- GL.createProgram + GL.attachShader program vs + GL.attachShader program fs + GL.linkProgram program + linkOK <- GL.get $ GL.linkStatus program + GL.validateProgram program + status <- GL.get $ GL.validateStatus program + unless (linkOK && status) $ do + hPutStrLn stderr "GL.linkProgram error" + plog <- GL.get $ GL.programInfoLog program + putStrLn plog + exitFailure + GL.currentProgram $= Just program - return program + return program diff --git a/src/Vivant/Texture.hs b/src/Vivant/Texture.hs index dceba80..d81a28a 100644 --- a/src/Vivant/Texture.hs +++ b/src/Vivant/Texture.hs @@ -1,19 +1,18 @@ module Vivant.Texture (initTexture, loadTexture) where -import Codec.Picture.Jpg (decodeJpeg) -import Codec.Picture.Types (convertImage) -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as V +import Codec.Picture.Jpg (decodeJpeg) +import Codec.Picture.Types (convertImage) +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as V import qualified Graphics.Rendering.OpenGL as GL - -import Paths_vivant (getDataDir) +import Paths_vivant (getDataDir) initTexture = do - GL.textureWrapMode GL.Texture2D GL.S $= (GL.Mirrored, GL.Repeat) - GL.textureWrapMode GL.Texture2D GL.T $= (GL.Mirrored, GL.Repeat) - GL.textureBorderColor GL.Texture2D $= GL.Color4 1 1 1 1 - GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Linear') + GL.textureWrapMode GL.Texture2D GL.S $= (GL.Mirrored, GL.Repeat) + GL.textureWrapMode GL.Texture2D GL.T $= (GL.Mirrored, GL.Repeat) + GL.textureBorderColor GL.Texture2D $= GL.Color4 1 1 1 1 + GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Linear') loadTexture = do - image <- BS.readFile $ datadir <> "/assets/wall.jpg" - convertImage $ decodeJpeg image + image <- BS.readFile $ datadir <> "/assets/wall.jpg" + convertImage $ decodeJpeg image -- cgit