fwgl 0.1.2.0 → 0.1.2.1
raw patch · 19 files changed
+859/−233 lines, 19 files
Files
- FWGL.hs +39/−1
- FWGL/Backend/GLES.hs +8/−2
- FWGL/Backend/IO.hs +4/−2
- FWGL/Geometry.hs +1/−0
- FWGL/Geometry/OBJ.hs +0/−3
- FWGL/Graphics/Custom.hs +13/−4
- FWGL/Graphics/D2.hs +6/−2
- FWGL/Graphics/D3.hs +16/−2
- FWGL/Graphics/Draw.hs +81/−25
- FWGL/Graphics/Texture.hs +2/−14
- FWGL/Graphics/Types.hs +26/−12
- FWGL/Internal/Resource.hs +2/−2
- FWGL/Key.hs +58/−58
- FWGL/Shader.hs +45/−14
- FWGL/Shader/GLSL.hs +243/−24
- FWGL/Shader/Language.hs +294/−20
- FWGL/Utils.hs +0/−42
- FWGL/Vector.hs +19/−4
- fwgl.cabal +2/−2
FWGL.hs view
@@ -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
FWGL/Backend/GLES.hs view
@@ -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
FWGL/Backend/IO.hs view
@@ -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)
FWGL/Geometry.hs view
@@ -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
FWGL/Geometry/OBJ.hs view
@@ -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
FWGL/Graphics/Custom.hs view
@@ -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
FWGL/Graphics/D2.hs view
@@ -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
FWGL/Graphics/D3.hs view
@@ -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
FWGL/Graphics/Draw.hs view
@@ -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) =
FWGL/Graphics/Texture.hs view
@@ -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
FWGL/Graphics/Types.hs view
@@ -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
FWGL/Internal/Resource.hs view
@@ -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
FWGL/Key.hs view
@@ -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)
FWGL/Shader.hs view
@@ -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)
FWGL/Shader/GLSL.hs view
@@ -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)
FWGL/Shader/Language.hs view
@@ -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
FWGL/Utils.hs view
@@ -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."--}-
FWGL/Vector.hs view
@@ -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
fwgl.cabal view
@@ -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