Skip to content

Commit

Permalink
Improving ColourMult code
Browse files Browse the repository at this point in the history
  • Loading branch information
@rumblesan
rumblesan committed Aug 6, 2021
1 parent bf8da88 commit bccd1f1
Show file tree
Hide file tree
Showing 3 changed files with 83 additions and 40 deletions.
2 changes: 1 addition & 1 deletion improviz.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ font:
assetsDirectory: "./assets"
textureDirectories:
- "./textures"
# - "./hellocatfood/gifs"
- "./hellocatfood/gifs"
geometryDirectories:
- "./geometries"
# - "./hellocatfood/geometries"
Expand Down
77 changes: 38 additions & 39 deletions src/Gfx/Commands.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,33 +18,33 @@ module Gfx.Commands
, renderCode
, renderCodeToBuffer
)
where
where

import Foreign.Ptr ( castPtr )
import Foreign.Marshal.Utils ( with
, fromBool
, fromBool
)
import Control.Monad.Trans ( liftIO )
import Control.Monad.State.Strict ( modify' )
import Lens.Simple ( use
, assign
, view
, assign
, view
)
import qualified Data.Map.Strict as M

import Linear.Matrix ( M44
, (!*!)
, (!*!)
)

import Language.Ast (Value(..))
import qualified Graphics.GL as GLRaw
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL ( ($=)
, GLfloat
, TextureUnit(..)
, TextureTarget2D(Texture2D)
, UniformLocation(..)
, currentProgram
, GLfloat
, TextureUnit(..)
, TextureTarget2D(Texture2D)
, UniformLocation(..)
, currentProgram
)
import Graphics.Rendering.OpenGL.GL.Shaders.Attribs as GLS

Expand All @@ -65,6 +65,10 @@ import Gfx.TextRendering ( renderText
)
import Gfx.OpenGL ( printErrors
, colToGLCol
, valueToGLfloat
, valueToGLfloatVec2
, valueToGLfloatVec3
, valueToGLfloatVec4
)
import Logging ( logError )

Expand Down Expand Up @@ -104,15 +108,13 @@ setUniform ("Pmatrix", _, UniformLocation uniformLoc) = do
setUniform ("FillColour", _, uniformLoc) = do
gfxFillStyle <- use (fillStyle . GS.value)
liftIO $ case gfxFillStyle of
(GFXFillColour fillColour) ->
GL.uniform uniformLoc $= colToGLCol fillColour
GFXNoFill -> GL.uniform uniformLoc $= colToGLCol (Colour 0 0 0 (-1))
(GFXFillColour fillColour) -> GL.uniform uniformLoc $= colToGLCol fillColour
GFXNoFill -> GL.uniform uniformLoc $= colToGLCol (Colour 0 0 0 (-1))
setUniform ("StrokeColour", _, uniformLoc) = do
gfxStrokeStyle <- use (strokeStyle . GS.value)
liftIO $ case gfxStrokeStyle of
(GFXStrokeColour strokeColour) ->
GL.uniform uniformLoc $= colToGLCol strokeColour
GFXNoStroke -> GL.uniform uniformLoc $= colToGLCol (Colour 0 0 0 (-1))
(GFXStrokeColour strokeColour) -> GL.uniform uniformLoc $= colToGLCol strokeColour
GFXNoStroke -> GL.uniform uniformLoc $= colToGLCol (Colour 0 0 0 (-1))
setUniform ("Texture", _, uniformLoc) = do
(GFXTextureStyling textName textFrame) <- use (textureStyle . GS.value)
textureLib <- use textureLibrary
Expand All @@ -124,32 +126,29 @@ setUniform ("Texture", _, uniformLoc) = do
setUniform (name, uniformType, uniformLoc) = do
matVar <- use (materialVars . GSM.value name)
liftIO $ case matVar of
Nothing -> logError $ name ++ " is not a known uniform"
Just v -> valueToUniform v uniformType uniformLoc
Nothing -> logError $ name ++ " is not a known uniform"
Just v -> valueToUniform v uniformType uniformLoc


valueToUniform :: Value -> GL.VariableType -> GL.UniformLocation -> IO ()
valueToUniform value utype uniformLoc =
case valueToList value of
Left err -> logError err
Right v -> case utype of
GLS.Float' -> GL.uniform uniformLoc $= (v !! 0)
GLS.FloatVec2 -> GL.uniform uniformLoc $= (GL.Vector2 (v !! 0) (v !! 1))
GLS.FloatVec3 -> GL.uniform uniformLoc $= (GL.Vector3 (v !! 0) (v !! 1) (v !! 2) )
GLS.FloatVec4 -> GL.uniform uniformLoc $= (GL.Vector4 (v !! 0) (v !! 1) (v !! 2) (v !! 3) )

valueToList :: Value -> Either String [Float]
valueToList (Number v) = Right $ replicate 4 v
valueToList (VList valList) = case valsToFloats valList of
Just [] -> Right $ replicate 4 0
Just vals -> Right $ (vals ++ [1, 1, 1, 1])
Nothing -> Left "Invalid list for material variable"
valueToList _ = Left "Invalid list for material variable"

valsToFloats :: [Value] -> Maybe [Float]
valsToFloats vals = mapM valToFloat vals
where
valToFloat (Number n) = Just n
valToFloat _ = Nothing
case utype of
GLS.Float' -> valueToGLfloatUniform value uniformLoc
GLS.FloatVec2 -> valueToVec2Uniform value uniformLoc
GLS.FloatVec3 -> valueToVec3Uniform value uniformLoc
GLS.FloatVec4 -> valueToVec4Uniform value uniformLoc

valueToGLfloatUniform :: Value -> GL.UniformLocation -> IO ()
valueToGLfloatUniform value uniformLoc = either logError (GL.uniform uniformLoc $=) (valueToGLfloat value)

valueToVec2Uniform :: Value -> GL.UniformLocation -> IO ()
valueToVec2Uniform value uniformLoc = either logError (GL.uniform uniformLoc $=) (valueToGLfloatVec2 value)

valueToVec3Uniform :: Value -> GL.UniformLocation -> IO ()
valueToVec3Uniform value uniformLoc = either logError (GL.uniform uniformLoc $=) (valueToGLfloatVec3 value)

valueToVec4Uniform :: Value -> GL.UniformLocation -> IO ()
valueToVec4Uniform value uniformLoc = either logError (GL.uniform uniformLoc $=) (valueToGLfloatVec4 value)


drawTriangles :: GeometryBuffers -> GraphicsEngine ()
Expand Down
44 changes: 44 additions & 0 deletions src/Gfx/OpenGL.hs
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,12 @@
module Gfx.OpenGL where

import Language.Ast ( Value(..) )
import Gfx.Types ( Colour(..) )
import Graphics.Rendering.OpenGL ( Color4(..)
, GLfloat
, Vector2(..)
, Vector3(..)
, Vector4(..)
, get
, errors
)
Expand All @@ -11,6 +15,46 @@ import System.IO ( hPutStrLn
, stderr
)

valueGetFloat :: Value -> Either String GLfloat
valueGetFloat (Number v) = Right v
valueGetFloat _ = Left "Expected number"

valueToGLfloat :: Value -> Either String GLfloat
valueToGLfloat (Number v) = Right v
valueToGLfloat (VList valList) = case valList of
x:_ -> valueGetFloat x
[] -> Left "Empty List"
valueToGLfloat _ = Left "Invalid value"

valueToGLfloatVec2 :: Value -> Either String (Vector2 GLfloat)
valueToGLfloatVec2 (Number v) = Right $ Vector2 v v
valueToGLfloatVec2 (VList valList) = case valList of
x:y:_ -> Vector2 <$> (valueGetFloat x) <*> (valueGetFloat y)
x:_ -> Vector2 <$> (valueGetFloat x) <*> (valueGetFloat x)
[] -> Left "Empty List"
valueToGLfloatVec2 _ = Left "Invalid value"

valueToGLfloatVec3 :: Value -> Either String (Vector3 GLfloat)
valueToGLfloatVec3 (Number v) = Right $ Vector3 v v v
valueToGLfloatVec3 (VList valList) = case valList of
x:y:z:_ -> Vector3 <$> (valueGetFloat x) <*> (valueGetFloat y) <*> (valueGetFloat z)
x:y:_ -> Vector3 <$> (valueGetFloat x) <*> (valueGetFloat y) <*> (valueGetFloat y)
x:_ -> Vector3 <$> (valueGetFloat x) <*> (valueGetFloat x) <*> (valueGetFloat x)
[] -> Left "Empty List"
valueToGLfloatVec3 _ = Left "Invalid value"

valueToGLfloatVec4 :: Value -> Either String (Vector4 GLfloat)
valueToGLfloatVec4 (Number v) = Right $ Vector4 v v v v
valueToGLfloatVec4 (VList valList) = case valList of
x:y:z:w:_ -> Vector4 <$> (valueGetFloat x) <*> (valueGetFloat y) <*> (valueGetFloat z) <*> (valueGetFloat w)
x:y:z:_ -> Vector4 <$> (valueGetFloat x) <*> (valueGetFloat y) <*> (valueGetFloat z) <*> (pure 1)
x:y:_ -> Vector4 <$> (valueGetFloat x) <*> (valueGetFloat y) <*> (valueGetFloat y) <*> (pure 1)
x:_ -> Vector4 <$> (valueGetFloat x) <*> (valueGetFloat x) <*> (valueGetFloat x) <*> (pure 1)
[] -> Left "Empty List"
valueToGLfloatVec4 _ = Left "Invalid value"



colToGLCol :: Colour -> Color4 GLfloat
colToGLCol (Colour r g b a) = Color4 r g b a

Expand Down

0 comments on commit bccd1f1

Please sign in to comment.