diff --git a/FWGL.hs b/FWGL.hs --- a/FWGL.hs +++ b/FWGL.hs @@ -24,18 +24,27 @@ draw, run, run', + loadOBJ, + loadOBJAsync, Output, (.>), io, + freeGeometry, + freeTexture, + freeProgram ) where +import Control.Concurrent import Control.Monad.IO.Class import FWGL.Audio -import FWGL.Backend +import FWGL.Backend hiding (Texture, Program) import FWGL.Input import FWGL.Internal.GL (evalGL) +import FWGL.Geometry (Geometry3) +import FWGL.Geometry.OBJ import FWGL.Graphics.Draw import FWGL.Graphics.Types +import FWGL.Shader.Program (Program) import FWGL.Utils import FRP.Yampa @@ -54,6 +63,18 @@ io :: IO () -> Output io = Output . liftIO +-- | Delete a 'Geometry' from the GPU. +freeGeometry :: BackendIO => Geometry i -> Output +freeGeometry = Output . removeGeometry + +-- | Delete a 'Texture' from the GPU. +freeTexture :: BackendIO => Texture -> Output +freeTexture = Output . removeTexture + +-- | Delete a 'Program' from the GPU. +freeProgram :: BackendIO => Program g i -> Output +freeProgram = Output . removeProgram + -- | Run a FWGL program. run :: BackendIO => SF (Input ()) Output -- ^ Main signal @@ -72,3 +93,20 @@ drawBegin act drawEnd + +-- | Load a model from an OBJ file asynchronously. +loadOBJAsync :: BackendIO + => FilePath + -> (Either String (Geometry Geometry3) -> IO ()) + -> IO () +loadOBJAsync fp k = loadTextFile fp $ + \e -> case e of + Left err -> k $ Left err + Right str -> k . Right . geometryOBJ + . parseOBJ $ str + +-- | Load a model from an OBJ file. +loadOBJ :: BackendIO => FilePath -> IO (Either String (Geometry Geometry3)) +loadOBJ fp = do var <- newEmptyMVar + loadOBJAsync fp $ putMVar var + takeMVar var diff --git a/FWGL/Backend/GLES.hs b/FWGL/Backend/GLES.hs --- a/FWGL/Backend/GLES.hs +++ b/FWGL/Backend/GLES.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NullaryTypeClasses, TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} module FWGL.Backend.GLES where @@ -16,7 +16,13 @@ , Num GLUInt , Num GLInt , Num GLPtrDiff - , Num GLSize) => GLES where + , Num GLSize + , Eq GLEnum + , Eq GLUInt + , Eq GLInt + , Eq GLPtrDiff + , Eq GLSize + , Eq Texture) => GLES where type Ctx type GLEnum type GLUInt diff --git a/FWGL/Backend/IO.hs b/FWGL/Backend/IO.hs --- a/FWGL/Backend/IO.hs +++ b/FWGL/Backend/IO.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NullaryTypeClasses, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} module FWGL.Backend.IO where @@ -8,7 +8,9 @@ class GLES => BackendIO where -- TODO: loadImage may fail - loadImage :: String -> ((Image, Int, Int) -> IO ()) -> IO () + loadImage :: FilePath -> ((Image, Int, Int) -> IO ()) -> IO () + + loadTextFile :: FilePath -> (Either String String -> IO ()) -> IO () setup :: (Int -> Int -> Ctx -> IO state) -> (out -> Ctx -> state -> IO state) diff --git a/FWGL/Geometry.hs b/FWGL/Geometry.hs --- a/FWGL/Geometry.hs +++ b/FWGL/Geometry.hs @@ -40,6 +40,7 @@ AttrListNil :: AttrList '[] AttrListCons :: (H.Hashable c, AttributeCPU c g) => g -> [c] -> AttrList gs -> AttrList (g ': gs) + -- TODO: storable vectors? -- | A set of attributes and indices. data Geometry (is :: [*]) = Geometry (AttrList is) [Word16] Int diff --git a/FWGL/Geometry/OBJ.hs b/FWGL/Geometry/OBJ.hs --- a/FWGL/Geometry/OBJ.hs +++ b/FWGL/Geometry/OBJ.hs @@ -19,9 +19,6 @@ objFaces :: [[(Int, Int, Int)]] } deriving (Show) -loadOBJ :: FilePath -> IO OBJModel -loadOBJ = fmap parseOBJ . readFile -- TODO: substitute with ajax - parseOBJ :: String -> OBJModel parseOBJ file = runST $ do vs <- new diff --git a/FWGL/Graphics/Custom.hs b/FWGL/Graphics/Custom.hs --- a/FWGL/Graphics/Custom.hs +++ b/FWGL/Graphics/Custom.hs @@ -6,7 +6,7 @@ (~~), unsafeJoin, nothing, - static, + geom, Program, program, @@ -18,6 +18,7 @@ Layer, layer, subLayer, + depthSubLayer, Geometry, AttrList(..), @@ -54,8 +55,8 @@ nothing = ObjectEmpty -- | A custom object with a specified 'Geometry'. -static :: Geometry i -> Object '[] i -static = ObjectMesh . StaticGeom +geom :: Geometry i -> Object '[] i +geom = ObjectMesh -- | Sets a global variable (uniform) of an object. global :: (Typeable g, UniformCPU c g) => g -> c @@ -103,4 +104,12 @@ -> Layer -- ^ Layer to draw on a 'Texture'. -> (Texture -> [Layer]) -- ^ Layer to draw on the screen. -> Layer -subLayer = SubLayer +subLayer = SubLayer ColorSubLayer + +-- | Use the depth 'Layer' as a 'Texture' on another. +depthSubLayer :: Int -- ^ Texture width. + -> Int -- ^ Texture height. + -> Layer -- ^ Layer to draw on a 'Texture'. + -> (Texture -> [Layer]) -- ^ Layer to draw on the screen. + -> Layer +depthSubLayer = SubLayer DepthSubLayer diff --git a/FWGL/Graphics/D2.hs b/FWGL/Graphics/D2.hs --- a/FWGL/Graphics/D2.hs +++ b/FWGL/Graphics/D2.hs @@ -37,9 +37,10 @@ Program, layer, layerPrg, - program, + C.program, -- ** Sublayers C.subLayer, + C.depthSubLayer, -- * Custom 2D objects Object, object, @@ -119,9 +120,12 @@ -- the default 2D shader), you have to set it with 'viewObject'. object1 :: BackendIO => Element -> Object '[Image, Depth, Transform2] Geometry2 object1 (Element d t m g) = C.globalTexture (undefined :: Image) t $ + +-- TODO: object1Image, object1Depth, object1Trans, object1ImageDepth, +-- object1ImageTrans, object1DepthTrans C.global (undefined :: Depth) d $ C.globalDraw (undefined :: Transform2) m $ - C.static g + C.geom g -- | Create a standard 'Layer' from a list of 'Element's. elements :: BackendIO => [Element] -> Layer diff --git a/FWGL/Graphics/D3.hs b/FWGL/Graphics/D3.hs --- a/FWGL/Graphics/D3.hs +++ b/FWGL/Graphics/D3.hs @@ -37,13 +37,16 @@ Program, layer, layerPrg, - program, -- TODO: wrong! + C.program, -- ** Sublayers C.subLayer, + C.depthSubLayer, -- * Custom 3D objects Object, object, object1, + object1Trans, + object1Tex, (C.~~), -- ** Globals C.global, @@ -61,6 +64,7 @@ mul4, -- ** View matrices perspectiveMat4, + orthoMat4, cameraMat4, -- ** Transformation matrices idMat4, @@ -108,7 +112,17 @@ object1 :: BackendIO => Element -> Object '[Transform3, Texture2] Geometry3 object1 (Element t m g) = C.globalDraw (undefined :: Transform3) m $ C.globalTexture (undefined :: Texture2) t $ - C.static g + C.geom g + +-- | Like 'object1', but it will only set the transformation matrix. +object1Trans :: BackendIO => Element -> Object '[Transform3] Geometry3 +object1Trans (Element _ m g) = C.globalDraw (undefined :: Transform3) m $ + C.geom g + +-- | Like 'object1, but it will only set the texture. +object1Tex :: BackendIO => Element -> Object '[Texture2] Geometry3 +object1Tex (Element t _ g) = C.globalTexture (undefined :: Texture2) t $ + C.geom g -- | Create a standard 'Layer' from a list of 'Element's. elements :: BackendIO => [Element] -> Layer diff --git a/FWGL/Graphics/Draw.hs b/FWGL/Graphics/Draw.hs --- a/FWGL/Graphics/Draw.hs +++ b/FWGL/Graphics/Draw.hs @@ -9,6 +9,9 @@ drawBegin, drawLayer, drawEnd, + removeGeometry, + removeTexture, + removeProgram, textureUniform, textureSize, setProgram, @@ -31,6 +34,7 @@ import Data.Bits ((.|.)) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as H +import qualified Data.Vector as V import Data.Typeable import Data.Word (Word) import Control.Applicative @@ -55,10 +59,14 @@ , programs = newGLResMap , gpuMeshes = newGLResMap , uniforms = newGLResMap - , textureImages = newGLResMap } + , textureImages = newGLResMap + , activeTextures = + V.replicate maxTexs Nothing } where newGLResMap :: (Hashable i, Resource i r GL) => ResMap i r newGLResMap = newResMap + maxTexs = fromIntegral gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS + -- | Execute a 'Draw' action. execDraw :: Draw () -- ^ Action. -> DrawState -- ^ State. @@ -74,45 +82,63 @@ -- | Clear the buffers. drawBegin :: GLES => Draw () -drawBegin = gl . clear $ gl_COLOR_BUFFER_BIT .|. gl_DEPTH_BUFFER_BIT +drawBegin = do freeActiveTextures + gl . clear $ gl_COLOR_BUFFER_BIT .|. gl_DEPTH_BUFFER_BIT drawEnd :: GLES => Draw () drawEnd = return () +removeGeometry :: GLES => Geometry is -> Draw () +removeGeometry = removeDrawResource gl gpuMeshes (\m s -> s { gpuMeshes = m }) + . castGeometry + +removeTexture :: BackendIO => Texture -> Draw () +removeTexture (TextureImage i) = removeDrawResource gl textureImages + (\m s -> s { textureImages = m }) i +removeTexture (TextureLoaded l) = gl $ unloadResource + (Nothing :: Maybe TextureImage) l + +removeProgram :: GLES => Program gs is -> Draw () +removeProgram = removeDrawResource gl programs (\m s -> s { programs = m }) + . castProgram + -- | Draw a 'Layer'. drawLayer :: (GLES, BackendIO) => Layer -> Draw () drawLayer (Layer prg obj) = setProgram prg >> drawObject obj -drawLayer (SubLayer w' h' sub sup) = - do t <- renderTexture w h sub +drawLayer (SubLayer stype w' h' sub sup) = + do t <- renderTexture internalFormat format ptype attachment w h sub mapM_ drawLayer $ sup (TextureLoaded $ LoadedTexture w h t) gl $ deleteTexture t where w = fromIntegral w' h = fromIntegral h' + (internalFormat, format, ptype, attachment) = + case stype of + ColorSubLayer -> ( fromIntegral gl_RGBA + , gl_RGBA + , gl_UNSIGNED_BYTE + , gl_COLOR_ATTACHMENT0 ) + DepthSubLayer -> ( fromIntegral gl_DEPTH_COMPONENT + , gl_DEPTH_COMPONENT + , gl_FLOAT + , gl_DEPTH_ATTACHMENT ) drawObject :: (GLES, BackendIO) => Object gs is -> Draw () drawObject ObjectEmpty = return () -drawObject (ObjectMesh m) = drawMesh m +drawObject (ObjectMesh g) = withRes_ (getGPUGeometry $ castGeometry g) + drawGPUGeometry drawObject (ObjectGlobal g c o) = c >>= uniform g >> drawObject o drawObject (ObjectAppend o o') = drawObject o >> drawObject o' -drawMesh :: GLES => Mesh is -> Draw () -drawMesh Empty = return () -drawMesh Cube = drawMesh (StaticGeom cubeGeometry) -drawMesh (StaticGeom g) = withRes_ (getGPUGeometry $ castGeometry g) - drawGPUGeometry -drawMesh (DynamicGeom _ _) = error "drawMesh DynamicGeom: unsupported" --- drawMesh (DynamicGeom d g) = delete {- removeResource -} d >> drawMesh (StaticGeom g) - uniform :: (GLES, Typeable g, UniformCPU c g) => g -> c -> Draw () uniform g c = withRes_ (getUniform g) $ \(UniformLocation l) -> gl $ setUniform l g c textureUniform :: (GLES, BackendIO) => Texture -> Draw ActiveTexture -textureUniform tex = do withRes_ (getTexture tex) +textureUniform tex = withRes (getTexture tex) (return $ ActiveTexture 0) $ \(LoadedTexture _ _ wtex) -> - gl $ do activeTexture gl_TEXTURE0 - bindTexture gl_TEXTURE_2D wtex - return $ ActiveTexture 0 + do at <- makeActive tex + gl $ bindTexture gl_TEXTURE_2D wtex + return at -- | Get the dimensions of a 'Texture'. textureSize :: (GLES, BackendIO, Num a) => Texture -> Draw (a, a) @@ -164,21 +190,39 @@ getProgram :: GLES => Program '[] '[] -> Draw (ResStatus LoadedProgram) getProgram = getDrawResource gl programs (\ m s -> s { programs = m }) -renderTexture :: (GLES, BackendIO) => GLSize -> GLSize - -> Layer -> Draw GL.Texture -renderTexture w h layer = do +freeActiveTextures :: Draw () +freeActiveTextures = Draw . modify $ \ds -> + ds { activeTextures = V.map (const Nothing) $ activeTextures ds } + +makeActive :: GLES => Texture -> Draw ActiveTexture +makeActive t = do ats <- activeTextures <$> Draw get + let at@(ActiveTexture atn) = + case V.elemIndex (Just t) ats of + Just n -> ActiveTexture $ fi n + Nothing -> + case V.elemIndex Nothing ats of + Just n -> ActiveTexture $ fi n + Nothing -> ActiveTexture 0 -- XXX + gl . activeTexture $ gl_TEXTURE0 + fi atn + Draw . modify $ \ds -> + ds { activeTextures = ats V.// [(fi atn, Just t)] } + return at + where fi :: (Integral a, Integral b) => a -> b + fi = fromIntegral + +renderTexture :: (GLES, BackendIO) => GLInt -> GLEnum -> GLEnum + -> GLEnum -> GLSize -> GLSize -> Layer -> Draw GL.Texture +renderTexture internalFormat format pixelType attachment w h layer = do fb <- gl createFramebuffer t <- gl emptyTexture gl $ do arr <- liftIO $ noArray bindTexture gl_TEXTURE_2D t - texImage2DBuffer gl_TEXTURE_2D 0 (fromIntegral gl_RGBA) w - h 0 gl_RGBA - gl_UNSIGNED_BYTE arr + texImage2DBuffer gl_TEXTURE_2D 0 internalFormat w + h 0 format pixelType arr bindFramebuffer gl_FRAMEBUFFER fb - framebufferTexture2D gl_FRAMEBUFFER - gl_COLOR_ATTACHMENT0 + framebufferTexture2D gl_FRAMEBUFFER attachment gl_TEXTURE_2D t 0 -- viewport ? @@ -202,6 +246,18 @@ (r, map) <- lft . getResource i $ mg s Draw . put $ ms map s return r + +removeDrawResource :: (Resource i r m, Hashable i) + => (m (ResMap i r) -> Draw (ResMap i r)) + -> (DrawState -> ResMap i r) + -> (ResMap i r -> DrawState -> DrawState) + -> i + -> Draw () +removeDrawResource lft mg ms i = do + s <- Draw get + map <- lft . removeResource i $ mg s + Draw . put $ ms map s + return () drawGPUGeometry :: GLES => GPUGeometry -> Draw () drawGPUGeometry (GPUGeometry abs eb ec) = diff --git a/FWGL/Graphics/Texture.hs b/FWGL/Graphics/Texture.hs --- a/FWGL/Graphics/Texture.hs +++ b/FWGL/Graphics/Texture.hs @@ -4,7 +4,6 @@ mkTexture, textureURL, textureFile, - textureHash, emptyTexture ) where @@ -25,7 +24,8 @@ -> [Color] -- ^ List of pixels -> Texture mkTexture w h ps = TextureImage . TexturePixels ps (fromIntegral w) - (fromIntegral h) $ hash ps + (fromIntegral h) + $ hash (w, h, ps) -- | Creates a 'Texture' from an URL or a local file. textureURL :: String -- ^ URL @@ -35,18 +35,6 @@ -- | The same as 'textureURL'. textureFile :: String -> Texture textureFile = textureURL - -textureHash :: TextureImage -> Int -textureHash (TexturePixels _ _ _ h) = h -textureHash (TextureURL _ h) = h - -instance Hashable TextureImage where - hashWithSalt salt tex = hashWithSalt salt $ textureHash tex - -instance Eq TextureImage where - (TexturePixels _ _ _ h) == (TexturePixels _ _ _ h') = h == h' - (TextureURL _ h) == (TextureURL _ h') = h == h' - _ == _ = False instance (BackendIO, GLES) => Resource TextureImage LoadedTexture GL where loadResource i f = loadTextureImage i $ f . Right -- TODO: err check diff --git a/FWGL/Graphics/Types.hs b/FWGL/Graphics/Types.hs --- a/FWGL/Graphics/Types.hs +++ b/FWGL/Graphics/Types.hs @@ -9,14 +9,16 @@ TextureImage(..), LoadedTexture(..), Geometry(..), - Mesh(..), Object(..), - Layer(..) + Layer(..), + SubLayerType(..) ) where import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Trans.State +import Data.Hashable +import Data.Vector (Vector) import Data.Typeable import FWGL.Geometry import FWGL.Graphics.Color @@ -37,7 +39,8 @@ programs :: ResMap (Program '[] '[]) LoadedProgram, uniforms :: ResMap (LoadedProgram, String) UniformLocation, gpuMeshes :: ResMap (Geometry '[]) GPUGeometry, - textureImages :: ResMap TextureImage LoadedTexture + textureImages :: ResMap TextureImage LoadedTexture, + activeTextures :: Vector (Maybe Texture) } -- | A monad that represents OpenGL actions with some state ('DrawState'). @@ -47,19 +50,13 @@ -- | A texture. data Texture = TextureImage TextureImage | TextureLoaded LoadedTexture + deriving Eq data TextureImage = TexturePixels [Color] GLSize GLSize Int | TextureURL String Int data LoadedTexture = LoadedTexture GLSize GLSize GL.Texture --- | A static or dinamic geometry. -data Mesh is where - Empty :: Mesh '[] - Cube :: Mesh Geometry3 - StaticGeom :: Geometry is -> Mesh is - DynamicGeom :: Geometry is -> Geometry is -> Mesh is - -- | An object is a set of geometries associated with some uniforms. For -- example, if you want to draw a rotating cube, its vertices, normals, etc. -- would be the 'Geometry', the combination of the geometry and the value of the @@ -70,7 +67,7 @@ -- and they are ultimately converted to them. data Object (gs :: [*]) (is :: [*]) where ObjectEmpty :: Object gs is - ObjectMesh :: Mesh is -> Object gs is + ObjectMesh :: Geometry is -> Object gs is ObjectGlobal :: (Typeable g, UniformCPU c g) => g -> Draw c -> Object gs is -> Object gs' is ObjectAppend :: Object gs is -> Object gs' is' -> Object gs'' is'' @@ -79,4 +76,21 @@ -- another. data Layer = forall oi pi og pg. (Subset oi pi, Subset og pg) => Layer (Program pg pi) (Object og oi) - | SubLayer Int Int Layer (Texture -> [Layer]) + | SubLayer SubLayerType Int Int Layer (Texture -> [Layer]) + +data SubLayerType = ColorSubLayer | DepthSubLayer deriving Eq + +instance Hashable TextureImage where + hashWithSalt salt tex = hashWithSalt salt $ textureHash tex + +instance Eq TextureImage where + (TexturePixels _ _ _ h) == (TexturePixels _ _ _ h') = h == h' + (TextureURL _ h) == (TextureURL _ h') = h == h' + _ == _ = False + +instance GLES => Eq LoadedTexture where + LoadedTexture _ _ t == LoadedTexture _ _ t' = t == t' + +textureHash :: TextureImage -> Int +textureHash (TexturePixels _ _ _ h) = h +textureHash (TextureURL _ h) = h diff --git a/FWGL/Internal/Resource.hs b/FWGL/Internal/Resource.hs --- a/FWGL/Internal/Resource.hs +++ b/FWGL/Internal/Resource.hs @@ -26,7 +26,7 @@ class (Eq i, Applicative m, MonadIO m) => Resource i r m | i -> r m where loadResource :: i -> (Either String r -> m ()) -> m () - unloadResource :: i -> r -> m () + unloadResource :: Maybe i -> r -> m () newResMap :: Hashable i => Resource i r m => ResMap i r newResMap = ResMap H.empty @@ -59,7 +59,7 @@ removeResource i rmap@(ResMap map) = do status <- checkResource i rmap case status of - Loaded r -> unloadResource i r + Loaded r -> unloadResource (Just i) r Loading -> return () --- XXX _ -> return () return . ResMap $ H.delete i map diff --git a/FWGL/Key.hs b/FWGL/Key.hs --- a/FWGL/Key.hs +++ b/FWGL/Key.hs @@ -41,63 +41,63 @@ | Key7 | Key8 | Key9 - | KeySpace - | KeyEnter - | KeyTab - | KeyEsc - | KeyBackspace - | KeyShift - | KeyControl - | KeyAlt - | KeyCapsLock - | KeyNumLock - | KeyArrowLeft - | KeyArrowUp - | KeyArrowRight - | KeyArrowDown - | KeyIns - | KeyDel - | KeyHome - | KeyEnd - | KeyPgUp - | KeyPgDown - | KeyF1 - | KeyF2 - | KeyF3 - | KeyF4 - | KeyF5 - | KeyF6 - | KeyF7 - | KeyF8 - | KeyF9 - | KeyF10 - | KeyF11 - | KeyF12 - | KeyPadDel - | KeyPadIns - | KeyPadEnd - | KeyPadDown - | KeyPadPgDown - | KeyPadLeft - | KeyPadRight - | KeyPadHome - | KeyPadUp - | KeyPadPgUp - | KeyPadAdd - | KeyPadSub - | KeyPadMul - | KeyPadDiv - | KeyPadEnter - | KeyPadDot - | KeyPad0 - | KeyPad1 - | KeyPad2 - | KeyPad3 - | KeyPad4 - | KeyPad5 - | KeyPad6 - | KeyPad7 - | KeyPad8 - | KeyPad9 + | KeySpace + | KeyEnter + | KeyTab + | KeyEsc + | KeyBackspace + | KeyShift + | KeyControl + | KeyAlt + | KeyCapsLock + | KeyNumLock + | KeyArrowLeft + | KeyArrowUp + | KeyArrowRight + | KeyArrowDown + | KeyIns + | KeyDel + | KeyHome + | KeyEnd + | KeyPgUp + | KeyPgDown + | KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyPadDel + | KeyPadIns + | KeyPadEnd + | KeyPadDown + | KeyPadPgDown + | KeyPadLeft + | KeyPadRight + | KeyPadHome + | KeyPadUp + | KeyPadPgUp + | KeyPadAdd + | KeyPadSub + | KeyPadMul + | KeyPadDiv + | KeyPadEnter + | KeyPadDot + | KeyPad0 + | KeyPad1 + | KeyPad2 + | KeyPad3 + | KeyPad4 + | KeyPad5 + | KeyPad6 + | KeyPad7 + | KeyPad8 + | KeyPad9 | KeyUnknown deriving (Eq, Show) diff --git a/FWGL/Shader.hs b/FWGL/Shader.hs --- a/FWGL/Shader.hs +++ b/FWGL/Shader.hs @@ -86,27 +86,58 @@ (<=), (<), (>), + ifThenElse, + loop, + true, + false, + store, + texture2D, + radians, + degrees, + sin, + cos, + tan, + asin, + acos, + atan, + atan2, + exp, + log, + exp2, + log2, + sqrt, + inversesqrt, abs, sign, - sqrt, - texture2D, + floor, + ceil, + fract, + mod, + min, + max, + clamp, + mix, + step, + smoothstep, + length, + distance, + dot, + cross, + normalize, + faceforward, + reflect, + refract, + matrixCompMult, + position, + fragColor, STList((:-), N), - {- - (>>=), - (>>), - fail, - return, - get, - global, - put, - putVertex, - putFragment, - -} (.), id, const, flip, - ($) + ($), + CPU.fst, + CPU.snd ) where import Data.Typeable (Typeable) diff --git a/FWGL/Shader/GLSL.hs b/FWGL/Shader/GLSL.hs --- a/FWGL/Shader/GLSL.hs +++ b/FWGL/Shader/GLSL.hs @@ -6,15 +6,19 @@ vertexToGLSL, fragmentToGLSL, shaderToGLSL, - exprToGLSL, globalName, attributeName ) where +import Control.Monad +import Data.Hashable (hash) +import qualified Data.HashMap.Strict as H import Data.Typeable import FWGL.Shader.Shader -import FWGL.Shader.Language (Expr(..), ShaderType(..)) +import FWGL.Shader.Language ( Expr(..), ShaderType(..), Unknown, Action(..) + , ContextVarType(..) ) import FWGL.Shader.Stages (VertexShader, FragmentShader, ValidVertex) +import Text.Printf type ShaderVars = ( [(String, String)] , [(String, String, Int)] @@ -38,21 +42,26 @@ [("hvFragmentShaderOutput", "gl_FragColor")] shaderToGLSL :: String -> String -> String -> ShaderVars -> [(String, String)] -> String -shaderToGLSL header ins outs (gs, is, os) predec = - header ++ - concatMap (var "uniform") gs ++ - concatMap (\(t, n, _) -> var ins (t, n)) is ++ - concatMap (\(t, n, _) -> if any ((== n) . fst) predec - then [] - else var outs (t, n) - ) os ++ - "void main(){" ++ - concatMap (\(_, n, e) -> replace n predec ++ "=" ++ - exprToGLSL e ++ ";") os ++ "}" +shaderToGLSL header ins outs (gs, is, os) predec = concat + [ header + , concatMap (var "uniform") gs + , concatMap (\(t, n, _) -> var ins (t, n)) is + , concatMap (\(t, n, _) -> if any ((== n) . fst) predec + then [] + else var outs (t, n) + ) os + , "void main(){" + , actions + , concatMap (\(n, s) -> replace n predec ++ "=" ++ s ++ ";") + compiledOuts + , "}" ] where var qual (ty, nm) = qual ++ " " ++ ty ++ " " ++ nm ++ ";" replace x xs = case filter ((== x) . fst) xs of ((_, y) : []) -> y _ -> x + (_, outNames, outExprs) = unzip3 os + (actions, outStrs) = compile outExprs + compiledOuts = zip outNames outStrs vars :: Valid gs is os => Bool -> Shader gs is os -> ShaderVars vars isFragment (shader :: Shader gs is os) = @@ -79,17 +88,227 @@ outputVar x = let (ty, nm) = varyingTypeAndName x in (ty, nm, toExpr x) -exprToGLSL :: Expr -> String -exprToGLSL Empty = "" -exprToGLSL (Read s) = s -exprToGLSL (Op1 s e) = "(" ++ s ++ exprToGLSL e ++ ")" -exprToGLSL (Op2 s x y) = "(" ++ exprToGLSL x ++ s ++ exprToGLSL y ++ ")" -exprToGLSL (Apply s es) = s ++ "(" ++ tail (es >>= (',' :) . exprToGLSL) ++ ")" -exprToGLSL (X x) = exprToGLSL x ++ ".x" -exprToGLSL (Y x) = exprToGLSL x ++ ".y" -exprToGLSL (Z x) = exprToGLSL x ++ ".z" -exprToGLSL (W x) = exprToGLSL x ++ ".w" -exprToGLSL (Literal s) = s +type ActionID = Int +type ActionMap = H.HashMap ActionID Action +type ActionSet = H.HashMap ActionID () + +data ActionInfo = ActionInfo { + actionGenerator :: ActionGenerator, + actionDeps :: ActionSet, + actionContext :: ActionContext +} + +instance Show ActionInfo where + show (ActionInfo gen deps ctx) = "{{ \"" ++ gen "CHILDREN;" ++ "\", " ++ show (H.keys deps) ++ ", " ++ show ctx ++ "}}" + +type ActionGenerator = String -> String + +-- | The context is where an action should be put. Only for-loops are considered +-- contexts, because there is no reason to put some action inside another block. +-- Of course, an action could have many contexts (e.g. for(..) { for (..) { +-- act; } }), but only one is actually needed to compile the action. +data ActionContext = ShallowContext ActionSet -- ^ The contexts of the expressions used in the action. + | DeepContext ActionSet -- ^ All the contexts (including those of the dependencies). + | NoContext -- ^ Root action. + | LeastContext Int ActionID -- ^ Depth and smallest context. + deriving (Show) + +type ActionGraph = H.HashMap ActionID ActionInfo + +-- | Compile a list of 'Expr', sharing their actions. +compile :: [Expr] -> (String, [String]) +compile exprs = let (strs, deps, _) = unzip3 $ map compileExpr exprs + depGraph = buildHierarchicalGraph $ H.unions deps + sorted = sortActions depGraph + in (sorted >>= uncurry generate, strs) + +generate :: ActionGenerator -> ActionGraph -> String +generate gen graph = gen $ sortActions graph >>= uncurry generate + +sortActions :: ActionGraph -> [(ActionGenerator, ActionGraph)] +sortActions fullGraph = visitLoop (H.empty, [], fullGraph) + where visitLoop state@(childrenMap, sortedIDs, graph) + | H.null graph = map (makePair childrenMap fullGraph) sortedIDs + | otherwise = visitLoop $ visit (head $ H.keys graph) state + + visit aID state@(_, _, graph) = + case H.lookup aID graph of + Nothing -> state + Just ai -> visitNew aID ai state + + visitNew aID ai (childrenMap, sortedIDs, graph) = + let deps = actionDeps ai + (childrenMap', sortedIDs', graph') = + H.foldrWithKey + (\aID _ state -> visit aID state) + (childrenMap, sortedIDs, graph) + deps + in case actionContext ai of + LeastContext _ parentID -> + let ai' = ai { actionContext = + decDepth $ actionContext ai } + cmap' = H.insertWith H.union + parentID + (H.singleton aID ai') + childrenMap' + in (cmap', sortedIDs', H.delete aID graph') + NoContext -> + ( childrenMap', sortedIDs' ++ [aID] + , H.delete aID graph' ) + + makePair childrenMap graph aID = + ( actionGenerator $ graph H.! aID + , case H.lookup aID childrenMap of + Just g -> g + Nothing -> H.empty ) + +-- | Build an action graph with full contexts. It is both a graph (with +-- dependencies as edges) and a tree (with contexts). +buildHierarchicalGraph :: ActionMap -> ActionGraph +buildHierarchicalGraph = + contextAll depth . contextAll deep . buildActionGraph + +-- | Build an action graph with shallow contexts. +buildActionGraph :: ActionMap -> ActionGraph +buildActionGraph = flip H.foldrWithKey H.empty $ + \aID act graph -> + let (info, deps) = compileAction aID act + in H.union (H.insert aID info graph) + (buildActionGraph deps) + +-- | Transform every context. +contextAll :: (ActionID -> ActionGraph -> (ActionContext, ActionGraph)) + -> ActionGraph -> ActionGraph +contextAll f g = H.foldrWithKey (\aID _ graph -> snd $ f aID graph) g g + +decDepth :: ActionContext -> ActionContext +decDepth NoContext = NoContext +decDepth (LeastContext 1 _) = NoContext +decDepth (LeastContext n p) = LeastContext (n - 1) p +decDepth _ = error "decDepth: invalid context" + +-- | Calculate the depth of the contexts and pick the smallest context. +depth :: ActionID -> ActionGraph -> (ActionContext, ActionGraph) +depth aID graph = + case actionContext act of + ShallowContext _ -> error "depth: action must be contextualized" + DeepContext ctx -> updateContext $ + H.foldrWithKey accumDepth (NoContext, graph) ctx + ctx -> (ctx, graph) + where act = graph H.! aID + updateContext (ctx, graph) = + (ctx, H.insert aID (act { actionContext = ctx }) graph) + + depthNum NoContext = 0 + depthNum (LeastContext n _) = n + + accumDepth aID' act' (ctx, graph) = + let dep = depthNum ctx + (ctx', graph') = depth aID' graph + dep' = depthNum ctx' + in if dep <= dep' + then (LeastContext (dep' + 1) aID', graph') + else (ctx, graph') + +-- | Find and build the deep context of this action. Returns a deep context and +-- a new graph with the deep contexts of this action and of its dependencies. +deep :: ActionID -> ActionGraph -> (ActionContext, ActionGraph) +deep aID graph = + case actionContext act of + ShallowContext sctx -> + let (dctx, graph') = H.foldrWithKey addDepContext + (sctx, graph) + (actionDeps act) + ctx' = DeepContext $ H.delete aID dctx + in (ctx', H.insert + aID (act { actionContext = ctx' }) graph') + ctx -> (ctx, graph) + where act = graph H.! aID + addDepContext depID depInfo (ctx, graph) = + let (DeepContext dCtx, graph') = deep depID graph + in (H.union ctx dCtx, graph') + +-- | Compile an 'Expr'. Returns the compiled expression, the map of dependencies +-- and the context. +compileExpr :: Expr -> (String, ActionMap, ActionSet) +compileExpr Empty = ("", H.empty, H.empty) +compileExpr (Read s) = (s, H.empty, H.empty) + +compileExpr (Op1 s e) = first3 (\x -> "(" ++ s ++ x ++ ")") $ compileExpr e + +compileExpr (Op2 s ex ey) = let (x, ax, cx) = compileExpr ex + (y, ay, cy) = compileExpr ey + in ( "(" ++ x ++ s ++ y ++ ")" + , H.union ax ay, H.union cx cy ) + +compileExpr (Apply s es) = let (vs, as, cs) = unzip3 $ map compileExpr es + in ( concat $ [ s, "(" , tail (vs >>= (',' :)), ")" ] + , H.unions as, H.unions cs) + +compileExpr (X e) = first3 (++ "[0]") $ compileExpr e +compileExpr (Y e) = first3 (++ "[1]") $ compileExpr e +compileExpr (Z e) = first3 (++ "[2]") $ compileExpr e +compileExpr (W e) = first3 (++ "[3]") $ compileExpr e +compileExpr (Literal s) = (s, H.empty, H.empty) +compileExpr (Action a) = let h = hash a + in (actionName h, H.singleton h a, H.empty) +compileExpr (ContextVar i t) = (contextVarName t i, H.empty, H.singleton i ()) +compileExpr (Dummy _) = error "compileExpr: Dummy" + +first3 :: (a -> a') -> (a, b, c) -> (a', b, c) +first3 f (a, b, c) = (f a, b, c) + +compileAction :: ActionID -> Action -> (ActionInfo, ActionMap) +compileAction aID (Store ty expr) = + let (eStr, deps, ctxs) = compileExpr expr + in ( ActionInfo (\c -> concat [ c, ty, " ", actionName aID + , "=", eStr, ";" ]) + (H.map (const ()) deps) + (ShallowContext ctxs) + , deps ) + +compileAction aID (If cExpr ty tExpr fExpr) = + let (cStr, cDeps, cCtxs) = compileExpr cExpr + (tStr, tDeps, tCtxs) = compileExpr tExpr + (fStr, fDeps, fCtxs) = compileExpr fExpr + deps = H.unions [cDeps, tDeps, fDeps] + name = actionName aID + in ( ActionInfo (\c -> concat [ ty, " ", name, ";if(" + , cStr, "){", c, name, "=", tStr + , ";}else{" , name, "=", fStr, ";}" ]) + (H.map (const ()) deps) + (ShallowContext $ H.unions [cCtxs, tCtxs, fCtxs]) + , deps ) + +compileAction aID (For iters ty initVal body) = + let iterName = contextVarName LoopIteration aID + valueName = contextVarName LoopValue aID + (nExpr, sExpr) = body (ContextVar aID LoopIteration) + (ContextVar aID LoopValue) + (iStr, iDeps, iCtxs) = compileExpr initVal + (nStr, nDeps, nCtxs) = compileExpr nExpr + (sStr, sDeps, sCtxs) = compileExpr sExpr + deps = H.unions [iDeps, nDeps, sDeps] + in ( ActionInfo (\c -> concat [ ty, " ", valueName, "=", iStr, ";" + , "for(float ", iterName, "=0.0;" + , iterName, "<", show iters, ".0;" + , "++", iterName, "){", c + , "if(", sStr, "){break;}" + , valueName, "=", nStr, ";}" ]) + (H.map (const ()) deps) + (ShallowContext . H.delete aID $ + H.unions [iCtxs, nCtxs, sCtxs]) + , deps ) + +actionName :: ActionID -> String +actionName = ('a' :) . hashName + +contextVarName :: ContextVarType -> ActionID -> String +contextVarName LoopIteration = ('l' :) . hashName +contextVarName LoopValue = actionName + +hashName :: ActionID -> String +hashName = printf "%x" globalTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String) globalTypeAndName t = (typeName t, globalName t) diff --git a/FWGL/Shader/Language.hs b/FWGL/Shader/Language.hs --- a/FWGL/Shader/Language.hs +++ b/FWGL/Shader/Language.hs @@ -1,10 +1,14 @@ {-# LANGUAGE GADTs, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, FunctionalDependencies #-} +-- TODO FWGL.Shader.Language.Prefix and FWGL.Shader.Prefix (or Postfix) module FWGL.Shader.Language ( ShaderType(..), Expr(..), + Action(..), + ContextVarType(..), Float(..), + Unknown(..), Sampler2D(..), V2(..), V3(..), @@ -12,7 +16,6 @@ M2(..), M3(..), M4(..), - -- (==), (>=, >, ..), ifThenElse fromRational, fromInteger, negate, @@ -30,21 +33,79 @@ (<=), (<), (>), - abs, - sign, + ifThenElse, + loop, + true, + false, + store, texture2D, + radians, + degrees, + sin, + cos, + tan, + asin, + acos, + atan, + atan2, + exp, + log, + exp2, + log2, sqrt, + inversesqrt, + abs, + sign, + floor, + ceil, + fract, + mod, + min, + max, + clamp, + mix, + step, + smoothstep, + length, + distance, + dot, + cross, + normalize, + faceforward, + reflect, + refract, + matrixCompMult, + position, + fragColor + -- TODO: memoized versions of the functions ) where +import Control.Applicative +import Control.Monad +import Data.Hashable +import Data.IORef import Data.Typeable -import Prelude (String, (.), ($)) +import Prelude (String, (.), ($), error, Maybe(..), const, fst, snd, Eq) import qualified Prelude import Text.Printf +import System.IO.Unsafe +-- | CPU integer. +type CInt = Prelude.Int + +-- | An expression. data Expr = Empty | Read String | Op1 String Expr | Op2 String Expr Expr | Apply String [Expr] | X Expr | Y Expr | Z Expr | W Expr - | Literal String deriving (Prelude.Eq) + | Literal String | Action Action | Dummy CInt + | ContextVar CInt ContextVarType + deriving Eq +-- | Expressions that have to be compiled to a statement. +data Action = Store String Expr | If Expr String Expr Expr + | For CInt String Expr (Expr -> Expr -> (Expr, Expr)) + +data ContextVarType = LoopIteration | LoopValue deriving Eq + -- | A GPU boolean. newtype Bool = Bool Expr deriving Typeable @@ -54,6 +115,9 @@ -- | A GPU sampler (sampler2D in GLSL). newtype Sampler2D = Sampler2D Expr deriving Typeable +-- | The type of a generic expression. +newtype Unknown = Unknown Expr + -- | A GPU 2D vector. -- NB: This is a different type from FWGL.Vector.'FWGL.Vector.V2'. data V2 = V2 Float Float deriving (Typeable) @@ -73,25 +137,38 @@ -- | A GPU 4x4 matrix. data M4 = M4 V4 V4 V4 V4 deriving (Typeable) +-- | CPU equality. infix 4 =! (=!) :: Prelude.Eq a => a -> a -> Prelude.Bool (=!) = (Prelude.==) +-- | CPU and. infixr 3 &&! (&&!) :: Prelude.Bool -> Prelude.Bool -> Prelude.Bool (&&!) = (Prelude.&&) -- | A type in the GPU. class ShaderType t where + zero :: t + toExpr :: t -> Expr fromExpr :: Expr -> t typeName :: t -> String - size :: t -> Prelude.Int + size :: t -> CInt +instance ShaderType Unknown where + zero = error "zero: Unknown type." + toExpr (Unknown e) = e + fromExpr = Unknown + typeName = error "typeName: Unknown type." + size = error "size: Unknown type." + instance ShaderType Bool where + zero = Bool $ Literal "false" + toExpr (Bool e) = e fromExpr = Bool @@ -101,6 +178,8 @@ size _ = 1 instance ShaderType Float where + zero = Float $ Literal "0.0" + toExpr (Float e) = e fromExpr = Float @@ -110,6 +189,8 @@ size _ = 1 instance ShaderType Sampler2D where + zero = Sampler2D $ Literal "0" + toExpr (Sampler2D e) = e fromExpr = Sampler2D @@ -119,7 +200,9 @@ size _ = 1 instance ShaderType V2 where - toExpr (V2 (Float (X v)) (Float (Y v'))) | v =! v' = v + zero = V2 zero zero + + toExpr (V2 (Float (X v)) (Float (Y v'))) | v =! v' = Apply "vec2" [v] toExpr (V2 (Float x) (Float y)) = Apply "vec2" [x, y] fromExpr v = V2 (Float (X v)) (Float (Y v)) @@ -129,8 +212,10 @@ size _ = 1 instance ShaderType V3 where + zero = V3 zero zero zero + toExpr (V3 (Float (X v)) (Float (Y v')) (Float (Z v''))) - | v =! v' &&! v' =! v'' = v + | v =! v' &&! v' =! v'' = Apply "vec3" [v] toExpr (V3 (Float x) (Float y) (Float z)) = Apply "vec3" [x, y, z] fromExpr v = V3 (Float (X v)) (Float (Y v)) (Float (Z v)) @@ -140,8 +225,10 @@ size _ = 1 instance ShaderType V4 where + zero = V4 zero zero zero zero + toExpr (V4 (Float (X v)) (Float (Y v1)) (Float (Z v2)) (Float (W v3))) - | v =! v1 &&! v1 =! v2 &&! v2 =! v3 = v + | v =! v1 &&! v1 =! v2 &&! v2 =! v3 = Apply "vec4" [v] toExpr (V4 (Float x) (Float y) (Float z) (Float w)) = Apply "vec4" [x, y, z, w] @@ -152,9 +239,11 @@ size _ = 1 instance ShaderType M2 where + zero = M2 zero zero + toExpr (M2 (V2 (Float (X (X m))) (Float (X (Y m1)))) (V2 (Float (Y (X m2))) (Float (Y (Y m3))))) - | m =! m1 &&! m1 =! m2 &&! m2 =! m3 = m + | m =! m1 &&! m1 =! m2 &&! m2 =! m3 = Apply "mat2" [m] toExpr (M2 (V2 (Float xx) (Float xy)) (V2 (Float yx) (Float yy))) = Apply "mat2" [xx, yx, xy, yy] @@ -167,6 +256,8 @@ size _ = 2 instance ShaderType M3 where + zero = M3 zero zero zero + toExpr (M3 (V3 (Float (X (X m))) (Float (X (Y m1))) (Float (X (Z m2)))) @@ -177,7 +268,8 @@ (Float (Z (Y m7))) (Float (Z (Z m8))))) | m =! m1 &&! m1 =! m2 &&! m2 =! m3 &&! m3 =! m4 &&! - m4 =! m5 &&! m5 =! m6 &&! m6 =! m7 &&! m7 =! m8 = m + m4 =! m5 &&! m5 =! m6 &&! m6 =! m7 &&! m7 =! m8 = + Apply "mat3" [m] toExpr (M3 (V3 (Float xx) (Float xy) (Float xz)) (V3 (Float yx) (Float yy) (Float yz)) (V3 (Float zx) (Float zy) (Float zz))) @@ -198,6 +290,8 @@ size _ = 3 instance ShaderType M4 where + zero = M4 zero zero zero zero + toExpr (M4 (V4 (Float (X (X m))) (Float (X (Y m1))) (Float (X (Z m2))) @@ -217,7 +311,7 @@ | m =! m1 &&! m1 =! m2 &&! m2 =! m3 &&! m3 =! m4 &&! m4 =! m5 &&! m5 =! m6 &&! m6 =! m7 &&! m7 =! m8 &&! m8 =! m9 &&! m9 =! m10 &&! m10 =! m11 &&! m11 =! m12 &&! - m12 =! m13 &&! m13 =! m14 &&! m14 =! m15 = m + m12 =! m13 &&! m13 =! m14 &&! m14 =! m15 = Apply "mat4" [m] toExpr (M4 (V4 (Float xx) (Float xy) (Float xz) (Float xw)) (V4 (Float yx) (Float yy) (Float yz) (Float yw)) (V4 (Float zx) (Float zy) (Float zz) (Float zw)) @@ -248,12 +342,12 @@ size _ = 4 -class Vector a +class ShaderType a => Vector a instance Vector V2 instance Vector V3 instance Vector V4 -class Matrix a +class ShaderType a => Matrix a instance Matrix M2 instance Matrix M3 instance Matrix M4 @@ -286,6 +380,13 @@ instance Mul V3 M3 V3 instance Mul V4 M4 V4 +-- | Floats or vectors. +class ShaderType a => GenType a +instance GenType Float +instance GenType V2 +instance GenType V3 +instance GenType V4 + infixl 7 * (*) :: (Mul a b c, ShaderType a, ShaderType b, ShaderType c) => a -> b -> c x * y = fromExpr $ Op2 "*" (toExpr x) (toExpr y) @@ -349,6 +450,8 @@ (>) :: ShaderType a => a -> a -> Bool x > y = fromExpr $ Op2 ">" (toExpr x) (toExpr y) +-- TODO: not + negate :: Float -> Float negate (Float e) = Float $ Op1 "-" e @@ -360,16 +463,187 @@ . (printf "%f" :: Prelude.Float -> String) . Prelude.fromRational -abs :: Float -> Float -abs (Float e) = Float $ Apply "abs" [e] +radians :: GenType a => a -> a +radians x = fromExpr $ Apply "radians" [toExpr x] -sign :: Float -> Float -sign (Float e) = Float $ Apply "sign" [e] +degrees :: GenType a => a -> a +degrees x = fromExpr $ Apply "degrees" [toExpr x] +sin :: GenType a => a -> a +sin x = fromExpr $ Apply "sin" [toExpr x] + +cos :: GenType a => a -> a +cos x = fromExpr $ Apply "cos" [toExpr x] + +tan :: GenType a => a -> a +tan x = fromExpr $ Apply "tan" [toExpr x] + +asin :: GenType a => a -> a +asin x = fromExpr $ Apply "asin" [toExpr x] + +acos :: GenType a => a -> a +acos x = fromExpr $ Apply "acos" [toExpr x] + +atan :: GenType a => a -> a +atan x = fromExpr $ Apply "atan" [toExpr x] + +atan2 :: GenType a => a -> a -> a +atan2 x y = fromExpr $ Apply "atan" [toExpr x, toExpr y] + +exp :: GenType a => a -> a +exp x = fromExpr $ Apply "exp" [toExpr x] + +log :: GenType a => a -> a +log x = fromExpr $ Apply "log" [toExpr x] + +exp2 :: GenType a => a -> a +exp2 x = fromExpr $ Apply "exp2" [toExpr x] + +log2 :: GenType a => a -> a +log2 x = fromExpr $ Apply "log2" [toExpr x] + +sqrt :: GenType a => a -> a +sqrt x = fromExpr $ Apply "sqrt" [toExpr x] + +inversesqrt :: GenType a => a -> a +inversesqrt x = fromExpr $ Apply "inversesqrt" [toExpr x] + +abs :: GenType a => a -> a +abs x = fromExpr $ Apply "abs" [toExpr x] + +sign :: GenType a => a -> a +sign x = fromExpr $ Apply "sign" [toExpr x] + +floor :: GenType a => a -> a +floor x = fromExpr $ Apply "floor" [toExpr x] + +ceil :: GenType a => a -> a +ceil x = fromExpr $ Apply "ceil" [toExpr x] + +fract :: GenType a => a -> a +fract x = fromExpr $ Apply "fract" [toExpr x] + +mod :: (GenType a, GenType b) => a -> b -> a +mod x y = fromExpr $ Apply "mod" [toExpr x, toExpr y] + +min :: GenType a => a -> a -> a +min x y = fromExpr $ Apply "min" [toExpr x, toExpr y] + +max :: GenType a => a -> a -> a +max x y = fromExpr $ Apply "max" [toExpr x, toExpr y] + +clamp :: (GenType a, GenType b) => a -> b -> b -> a +clamp x y z = fromExpr $ Apply "clamp" [toExpr x, toExpr y, toExpr z] + +mix :: (GenType a, GenType b) => a -> a -> b -> a +mix x y z = fromExpr $ Apply "mix" [toExpr x, toExpr y, toExpr z] + +step :: GenType a => a -> a -> a +step x y = fromExpr $ Apply "step" [toExpr x, toExpr y] + +smoothstep :: (GenType a, GenType b) => b -> b -> a -> a +smoothstep x y z = fromExpr $ Apply "smoothstep" [toExpr x, toExpr y, toExpr z] + +length :: GenType a => a -> Float +length x = fromExpr $ Apply "length" [toExpr x] + +distance :: GenType a => a -> a -> Float +distance x y = fromExpr $ Apply "distance" [toExpr x, toExpr y] + +dot :: GenType a => a -> a -> Float +dot x y = fromExpr $ Apply "dot" [toExpr x, toExpr y] + +cross :: V3 -> V3 -> V3 +cross x y = fromExpr $ Apply "cross" [toExpr x, toExpr y] + +normalize :: GenType a => a -> a +normalize x = fromExpr $ Apply "normalize" [toExpr x] + +faceforward :: GenType a => a -> a -> a -> a +faceforward x y z = fromExpr $ Apply "faceforward" [toExpr x, toExpr y, toExpr z] + +reflect :: GenType a => a -> a -> a +reflect x y = fromExpr $ Apply "reflect" [toExpr x, toExpr y] + +refract :: GenType a => a -> a -> Float -> a +refract x y z = fromExpr $ Apply "refract" [toExpr x, toExpr y, toExpr z] + +-- TODO: unsafe +matrixCompMult :: (Matrix a, Matrix b, Matrix c) => a -> b -> c +matrixCompMult x y = fromExpr $ Apply "matrixCompMult" [toExpr x, toExpr y] + + -- TODO: add functions, ifThenElse, etc. -sqrt :: Float -> Float -sqrt (Float e) = Float $ Apply "sqrt" [e] +-- | Avoid executing this expression more than one time. Conditionals and loops +-- imply it. +store :: ShaderType a => a -> a +store x = fromExpr . Action $ Store (typeName x) (toExpr x) +true :: Bool +true = Bool $ Literal "true" + +false :: Bool +false = Bool $ Literal "false" + +-- | Rebinded if. +ifThenElse :: ShaderType a => Bool -> a -> a -> a +ifThenElse b t f = fromExpr . Action $ If (toExpr b) (typeName t) + (toExpr t) (toExpr f) + +loop :: ShaderType a + => Float -- ^ Maximum number of iterations (should be as low as possible, must be an integer literal) + -> a -- ^ Initial value + -> (Float -> a -> (a, Bool)) -- ^ Iteration -> Old value -> (Next, Stop) + -> a +loop (Float (Literal iters)) iv f = + fromExpr . Action $ + For (Prelude.floor (Prelude.read iters :: Prelude.Float)) + (typeName iv) + (toExpr iv) + (\ie ve -> let (next, stop) = f (fromExpr ie) (fromExpr ve) + in (toExpr next, toExpr stop)) +loop _ _ _ = error "loop: iteration number is not a literal." + texture2D :: Sampler2D -> V2 -> V4 texture2D (Sampler2D s) v = fromExpr $ Apply "texture2D" [s, toExpr v] + +-- | The position of the vertex (only works in the vertex shader). +position :: V4 +position = fromExpr $ Read "gl_Position" + +-- | The color of the fragment (only works in the fragment shader). +fragColor :: V4 +fragColor = fromExpr $ Read "gl_FragColor" + +instance Hashable Expr where + hashWithSalt s e = case e of + Empty -> hash2 s 0 (0 :: CInt) + Read str -> hash2 s 1 str + Op1 str exp -> hash2 s 2 (str, exp) + Op2 str exp exp' -> hash2 3 s (str, exp, exp') + Apply str exps -> hash2 4 s exps + X exp -> hash2 5 s exp + Y exp -> hash2 6 s exp + Z exp -> hash2 7 s exp + W exp -> hash2 8 s exp + Literal str -> hash2 s 9 str + Action hash -> hash2 s 10 hash + Dummy i -> hash2 s 11 i + ContextVar i LoopIteration -> hash2 s 12 i + ContextVar i LoopValue -> hash2 s 13 i + +instance Hashable Action where + hashWithSalt s (Store t e) = hash2 s 0 (t, e) + hashWithSalt s (If eb tt et ef) = hash2 s 1 (eb, tt, et, ef) + hashWithSalt s (For iters tv iv eFun) = + let baseHash = hash (iters, tv, iv, eFun (Dummy 0) (Dummy 1)) + in hash2 s 2 ( baseHash + , eFun (Dummy baseHash) + (Dummy $ baseHash Prelude.+ 1)) + +instance Prelude.Eq Action where + a == a' = hash a =! hash a' + +hash2 :: Hashable a => CInt -> CInt -> a -> CInt +hash2 s i x = s `hashWithSalt` i `hashWithSalt` x diff --git a/FWGL/Utils.hs b/FWGL/Utils.hs --- a/FWGL/Utils.hs +++ b/FWGL/Utils.hs @@ -33,45 +33,3 @@ perspectiveView far near fov = perspective4 far near fov *** identity >>^ \(perspMat, viewMat) -> mul4 viewMat perspMat - --- | Like 'dynamic', but instead of comparing the two objects it checks the --- event with the new object. -dynamicE :: Object g i -- ^ Initial 'Object'. - -> SF (Event (Object g i)) (Object g i) -dynamicE = dynamicG $ flip const - --- | Automatically deallocate the previous mesh from the GPU when it changes. -dynamic :: SF (Object g i) (Object g i) -dynamic = undefined -{- -dynamic = - dynamicG (\ o n -> if objectGeometry o == objectGeometry n - then Event n - else NoEvent - ) nothing --} - -dynamicG :: (Object g i -> a -> Event (Object g i)) -> (Object g i) -> SF a (Object g i) -dynamicG = undefined -{- -dynamicG f i = flip sscan i $ \ oldObj inp -> - case f oldObj inp of - Event (SolidObject (Solid (StaticGeom newG) mat tex)) -> - SolidObject ( - Solid (DynamicGeom (objectGeometry oldObj) - newG) - mat - tex - ) - NoEvent -> case oldObj of - SolidObject ( - Solid (DynamicGeom _ new) mat t - ) -> SolidObject ( - Solid (StaticGeom new) - mat - t - ) - _ -> oldObj - _ -> error "dynamicG: not a Geometry." --} - diff --git a/FWGL/Vector.hs b/FWGL/Vector.hs --- a/FWGL/Vector.hs +++ b/FWGL/Vector.hs @@ -22,6 +22,7 @@ rotZMat4, rotAAMat4, scaleMat4, + orthoMat4, perspectiveMat4, cameraMat4, -- lookAtMat4, @@ -177,9 +178,9 @@ (V4 _9 _a _b _c) (V4 _d _e _f _g)) (M4 (V4 a b c d) - (V4 e f g h) - (V4 i j k l) - (V4 m n o p)) = + (V4 e f g h) + (V4 i j k l) + (V4 m n o p)) = mat4 ( _1 * a + _2 * e + _3 * i + _4 * m, _1 * b + _2 * f + _3 * j + _4 * n, @@ -260,7 +261,7 @@ , 0, y, 0 , 0, 0, z ) --- | 4x4 perspective matrix. +-- | 4x4 perspective projection matrix. perspectiveMat4 :: Float -- ^ Far -> Float -- ^ Near -> Float -- ^ FOV @@ -272,6 +273,20 @@ , 0 , 0 , (f + n) / (n - f) , (2 * f * n) / (n - f) , 0 , 0 , - 1 , 0) where s = 1 / tan (fov * pi / 360) + +-- | 4x4 orthographic projection matrix. +orthoMat4 :: Float -- ^ Far + -> Float -- ^ Near + -> Float -- ^ Left + -> Float -- ^ Right + -> Float -- ^ Bottom + -> Float -- ^ Top + -> M4 +orthoMat4 f n l r b t = + mat4 ( 2 / (r - l) , 0 , 0 , (r + l) / (r - l) + , 0 , 2 / (t - b) , 0 , (t + b) / (t - b) + , 0 , 0 , 2 / (n - f) , ( f + n) / (n - f) + , 0 , 0 , 0 , 1) -- | 4x4 FPS camera matrix. cameraMat4 :: V3 -- ^ Eye diff --git a/fwgl.cabal b/fwgl.cabal --- a/fwgl.cabal +++ b/fwgl.cabal @@ -1,5 +1,5 @@ name: fwgl -version: 0.1.2.0 +version: 0.1.2.1 synopsis: FRP 2D/3D game engine description: FRP 2D/3D game engine (work in progress). homepage: https://github.com/ziocroc/FWGL @@ -16,6 +16,6 @@ exposed-modules: FWGL, FWGL.Shader, FWGL.Geometry, FWGL.Utils, FWGL.Vector, FWGL.Audio, FWGL.Key, FWGL.Backend, FWGL.Input, FWGL.Graphics.Draw, FWGL.Graphics.D2, FWGL.Graphics.D3, FWGL.Graphics.Texture, FWGL.Graphics.Types, FWGL.Graphics.Color, FWGL.Graphics.Custom, FWGL.Graphics.Shapes, FWGL.Internal.GL, FWGL.Internal.TList, FWGL.Geometry.OBJ, FWGL.Shader.GLSL, FWGL.Shader.Stages, FWGL.Shader.Program, FWGL.Shader.CPU, FWGL.Shader.Default3D, FWGL.Shader.Shader, FWGL.Shader.Language, FWGL.Shader.Default2D, FWGL.Backend.GLES, FWGL.Backend.IO other-modules: FWGL.Internal.STVectorLen, FWGL.Internal.Resource other-extensions: FlexibleContexts, RankNTypes, GADTs, TypeOperators, KindSignatures, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, ConstraintKinds, TypeFamilies, ExistentialQuantification, GeneralizedNewtypeDeriving, PolyKinds, UndecidableInstances, ScopedTypeVariables, OverlappingInstances, FunctionalDependencies, DeriveDataTypeable, ImpredicativeTypes, RebindableSyntax, NullaryTypeClasses, Arrows - build-depends: base >=4.7 && <4.8, Yampa >=0.9 && <0.10, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.11, transformers + build-depends: base >=4.7 && <4.9, Yampa >=0.9 && <0.10, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.11, transformers hs-source-dirs: . default-language: Haskell2010