hylogen 0.1.0.11 → 0.1.0.12
raw patch · 5 files changed
+222/−279 lines, 5 files
Files
- app/Main.hs +7/−3
- hylogen.cabal +1/−1
- src/Hylogen.hs +3/−3
- src/Hylogen/CSE.hs +129/−105
- src/Hylogen/Types.hs +82/−167
app/Main.hs view
@@ -28,6 +28,10 @@ main' :: FilePath -> IO () main' pathToWatch = do _ <- forkIO serveIndex+ serveGLSL pathToWatch++serveGLSL :: FilePath -> IO ()+serveGLSL pathToWatch = do withManager $ runServer "127.0.0.1" 8080 . handleConnection pathToWatch@@ -55,16 +59,16 @@ getNewSource pathToWatch = do -- TODO: more robust paths!: -- c <- readFile pathToWatch- let (dirToWatch, fileToWatch) = splitFileName pathToWatch+ let (dirToWatch, _) = splitFileName pathToWatch (ec, stdout, stderr) <- readProcessWithExitCode "runghc" [ "-i"++dirToWatch , pathToWatch ] "" case ec of ExitSuccess -> do- putStrLn "updated"+ putStrLn stdout return (Just stdout)- ExitFailure i -> do+ ExitFailure _ -> do putStrLn stderr return Nothing
hylogen.cabal view
@@ -1,5 +1,5 @@ name: hylogen-version: 0.1.0.11+version: 0.1.0.12 synopsis: an EDSL for live-coding fragment shaders description: an EDSL for live-coding fragment shaders homepage: https://hylogen.com
src/Hylogen.hs view
@@ -21,7 +21,7 @@ import Data.Monoid import Data.List-import Hylogen.CSE (glslToAssignments, getTopLevel, genGLSL)+import Hylogen.CSE (contextToAssignments, getTopLevel, genContext) import Hylogen.Globals import Hylogen.Types (Vec (fromVec1, select, toList), Vec1 (W, X, Y, Z), Vec2, Vec3, Vec4)@@ -41,7 +41,7 @@ , "}" ] where- assignments = mconcat . fmap ("\n "<>) $ glslToAssignments glsl- glsl = genGLSL v+ assignments = mconcat . fmap ("\n "<>) $ contextToAssignments glsl+ glsl = genContext v topLevel = getTopLevel glsl
src/Hylogen/CSE.hs view
@@ -1,129 +1,153 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE LambdaCase#-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TupleSections #-}+ module Hylogen.CSE where -import qualified Data.Map as Map+import Data.IntMap.Lazy (IntMap)+import qualified Data.IntMap as IntMap import Data.Monoid+import Data.Hashable+import GHC.Generics import Hylogen.Types-import Control.Monad.State.Lazy-import Data.List+import Control.Arrow -type Id = Int-type Count = Int+type Hash = Int +-- data HashTree a = Leaf Hash a | Branch Hash a [HashTree a]+-- deriving (Generic, Hashable, Show, Eq, Ord, Foldable)++type Tags = (ExprForm, GLSLType, String, Hash, [Either Expr Hash])++type HashTree = Tree (ExprForm, GLSLType, String, Hash, [Either Expr Hash])++getHash :: HashTree -> Hash+getHash (Tree (_, _, _, h, _) _) = h++getExprForm :: HashTree -> ExprForm+getExprForm (Tree (ef, _, _, _, _) _) = ef+++toHashTree :: Tree (ExprForm, GLSLType, String) -> Tree (ExprForm, GLSLType, String, Hash, [Either Expr Hash])+toHashTree (Tree (ef, ty, str) subtrees) = let+ subHashTrees :: [Tree (ExprForm, GLSLType, String, Hash, [Either Expr Hash])]+ subHashTrees = toHashTree <$> subtrees++ subHashes :: [Hash]+ subHashes = getHash <$> subHashTrees++ parentHash :: Hash+ parentHash = hash (ef, ty, str, subHashes)++ subHashes' :: [Either Expr Hash]+ subHashes' = zipWith fn subHashes subtrees+ where+ fn :: Hash -> Expr -> Either Expr Hash+ fn h expr@(Tree (ef, _, _) _) = case ef of+ Uniform -> Left expr+ _ -> Right h+ + in Tree (ef, ty, str, parentHash, subHashes') subHashTrees++-- variablize :: [Hash] -> HashTree -> [Hash] -> HashTree+-- variablize subHashes tree@(Tree (ef, ty, str, h) _) = case ef of+-- Uniform -> tree+-- _ -> tree++++++type Id = Int -- | Add if in first, variabalize!-newtype GLSL = GLSL (Map.Map Id Expr, Map.Map Hash (Id, Count))+type GLSL = ( IntMap (ExprForm, GLSLType, String, [Either Expr Hash])+ , [(ExprForm, GLSLType, String, Hash, [Either Expr Hash])]+ ) -getTopLevel :: GLSL -> Expr-getTopLevel (GLSL (id2expr, _)) = case Map.maxViewWithKey id2expr of- Nothing -> error "must have top level?"- Just ((k, e), _) -> Uniform (getType e) ("_" <> show k)+-- TODO:+-- newtype GLSL = GLSL ([(Id, (Expr, [Hash]))], IntMap.Map Hash Id)+-- deriving (Show) +initialGLSL :: GLSL+initialGLSL = (IntMap.empty, []) -type GLSLState = State GLSL -addNode:: Hash -> Expr -> GLSLState Id-addNode hashish expr = do- GLSL (id2expr, hash2id) <- get- let newid = case Map.maxViewWithKey id2expr of- Nothing -> 0- Just ((k, _), _) -> k + 1 - if Map.member hashish hash2id- then do- modify (\(GLSL (foo, bar)) -> GLSL ( foo- , Map.adjust (\(a, b) -> (a, b+1)) hashish bar- ))- return $ fst $ hash2id Map.! hashish- else do- modify (\(GLSL (foo, bar)) -> GLSL ( Map.insert newid expr foo- , Map.insert hashish (newid, 1) bar- ))- return $ newid+-- genContext :: HashTree -> GLSL+-- genContext = foldr fn initialGLSL+-- where+-- fn :: (Hash, Expr, [Hash]) -> GLSL -> GLSL+-- fn (h, e, children) glsl =+-- case e of+-- Uniform _ _ -> glsl+-- _ -> snd $ addNode' h e children glsl -addTree :: HashTree -> GLSLState ()-addTree ht = case ht of- Leaf h e -> do- -- _ <- addNode h e- return ()- Branch h e subTrees -> do- -- | post-order traversal guarantees topological ordering!- forM_ subTrees addTree- i <- addNode h e- newExpr <- variablize e subTrees- modify (\(GLSL (foo, bar)) -> GLSL ( Map.adjust (const newExpr) i foo- , bar )) -genGLSL :: (Expressible a) => a -> GLSL-genGLSL x = execState (addTree . toHashTree . toExpr $ x ) initialGLSL- where- initialGLSL :: GLSL- initialGLSL = GLSL (Map.empty, Map.empty)+-- TODO: slow -glslToAssignments:: GLSL -> [String]-glslToAssignments glsl = do- let (GLSL (id2expr, _)) = glsl- fmap assign $ Map.toList id2expr+-- HashTree = Tree (ExprForm, GLSLType, String, Hash, [Hash])+toContext :: HashTree -> GLSL+toContext ht = genContext' ht initialGLSL where- assign :: (Id, Expr) -> String- assign (i, e) = show (getType e) <> " " <> "_" <> show i <> " = " <> show e <> ";"+ genContext' :: HashTree -> GLSL -> GLSL+ genContext' (Tree foo subTrees) glsl = fn foo (foldr genContext' glsl subTrees)+ where+ fn :: (ExprForm, GLSLType, String, Hash, [Either Expr Hash]) -> GLSL -> GLSL+ fn orig@(ef, ty, str, h, hs) (hashmap, output)+ = if IntMap.member h hashmap+ then ( hashmap+ , output+ )+ else ( IntMap.insert h (ef, ty, str, hs) hashmap+ , orig:output+ ) +genContext :: (Expressible a) => a -> GLSL+genContext = toExpr+ >>> toHashTree+ >>> toContext -getName :: HashTree -> GLSLState String-getName ht = do- let h = case ht of- Leaf h _ -> h- Branch h _ _ -> h- GLSL (_, hash2id) <- get- return $ "_" <> show (fst $ hash2id Map.! h)+hash2Name :: Hash -> String+hash2Name h+ | h < 0 = "_n" <> tail shown+ | otherwise = "_" <> shown+ where+ shown = show h -variablize :: Expr -> [HashTree] -> GLSLState Expr-variablize expr subTrees = case expr of- Uniform ty st- -> return $ Uniform ty st- UnaryOp ty st x- -> UnaryOp ty st- <$> f x (subTrees !! 0)- UnaryOpPre ty st x- -> UnaryOpPre ty st- <$> f x (subTrees !! 0)- BinaryOp ty st x y- -> BinaryOp ty st- <$> f x (subTrees !! 0)- <*> f y (subTrees !! 1)- BinaryOpPre ty st x y- -> BinaryOpPre ty st- <$> f x (subTrees !! 0)- <*> f y (subTrees !! 1)- TernaryOpPre ty st x y z- -> TernaryOpPre ty st- <$> f x (subTrees !! 0)- <*> f y (subTrees !! 1)- <*> f z (subTrees !! 2)- QuaternaryOpPre ty st x y z w- -> QuaternaryOpPre ty st- <$> f x (subTrees !! 0)- <*> f y (subTrees !! 1)- <*> f z (subTrees !! 2)- <*> f w (subTrees !! 3)- Select ty x y z- -> Select ty- <$> f x (subTrees !! 0)- <*> f y (subTrees !! 1)- <*> f z (subTrees !! 2)- Access ty st x- -> Access ty st- <$> f x (subTrees !! 0)++++getTopLevel :: GLSL -> Expr+getTopLevel (_, output) = tagsToExpr $ head output++contextToAssignments :: GLSL -> [String]+contextToAssignments (_, output) = foldl fn [] output where- f :: Expr -> HashTree -> GLSLState Expr- f x ht = do- let h = case ht of- Leaf h _ -> h- Branch h _ _ -> h- (GLSL (_, hash2id)) <- get- if Map.member h hash2id- then Uniform (getType x) <$> (getName ht)- else return x+ fn bs tags@(ef, _, _, _, _) = case ef of+ Uniform -> bs+ _ -> assign tags : bs+-- contextToAssignments :: GLSL -> [String]+-- contextToAssignments (_, output) = assign <$> reverse output++assign :: (ExprForm, GLSLType, String, Hash, [Either Expr Hash]) -> String+assign tags@(ef, ty, str, h, hs)+ = show ty <> " "+ <> hash2Name h <> " = "+ <> show expr <> ";"+ where+ expr = tagsToExpr tags++-- type Tags = (ExprForm, GLSLType, String, Hash, [Hash])+tagsToExpr :: Tags -> Expr+tagsToExpr (ef, ty, str, h, hs) = case ef of+ _ -> Tree (ef, ty, str) $ fn <$> hs+ where+ fn :: Either Expr Hash -> Expr+ fn (Left e) = e+ fn (Right h) = Tree (Variable, GLSLFloat, hash2Name h) []+
src/Hylogen/Types.hs view
@@ -11,6 +11,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-} module Hylogen.Types where @@ -25,29 +27,29 @@ exprFormFromTuple :: tuple -> hprim -> Expr instance ConstructFrom Float Vec1 where- exprFormFromTuple x _ = Uniform GLSLFloat (show x) -- TODO: this is a hack!+ exprFormFromTuple x _ = Tree (Uniform, GLSLFloat, (show x)) [] -- TODO: this is a hack! instance ConstructFrom (Vec1, Vec1) Vec2 where- exprFormFromTuple (x, y) _ = BinaryOpPre GLSLVec2 "vec2" (toExpr x) (toExpr y)+ exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec2, "vec2") [toExpr x, toExpr y] instance ConstructFrom (Vec1, Vec1, Vec1) Vec3 where- exprFormFromTuple (x, y, z) _ = TernaryOpPre GLSLVec3 "vec3" (toExpr x) (toExpr y) (toExpr z)+ exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y, toExpr z] instance ConstructFrom (Vec2, Vec1) Vec3 where- exprFormFromTuple (x, y) _ = BinaryOpPre GLSLVec3 "vec3" (toExpr x) (toExpr y)+ exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y] instance ConstructFrom (Vec1, Vec2) Vec3 where- exprFormFromTuple (x, y) _ = BinaryOpPre GLSLVec3 "vec3" (toExpr x) (toExpr y)+ exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y] instance ConstructFrom (Vec1, Vec1, Vec1, Vec1) Vec4 where- exprFormFromTuple (x, y, z, w) _ = QuaternaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y) (toExpr z) (toExpr w)+ exprFormFromTuple (x, y, z, w) _ = Tree (QuaternaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z, toExpr w] instance ConstructFrom (Vec2, Vec1, Vec1) Vec4 where- exprFormFromTuple (x, y, z) _ = TernaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y) (toExpr z)+ exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z] instance ConstructFrom (Vec1, Vec2, Vec1) Vec4 where- exprFormFromTuple (x, y, z) _ = TernaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y) (toExpr z)+ exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z] instance (a ~ Vec1, b ~ Vec1) => ConstructFrom (a, b, Vec2) Vec4 where- exprFormFromTuple (x, y, z) _ = TernaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y) (toExpr z)+ exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z] instance ConstructFrom (Vec3, Vec1) Vec4 where- exprFormFromTuple (x, y) _ = BinaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y)+ exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y] instance (a ~ Vec1) => ConstructFrom (a, Vec3) Vec4 where- exprFormFromTuple (x, y) _ = BinaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y)+ exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y] instance (a ~ Vec2) => ConstructFrom (a, Vec2) Vec4 where- exprFormFromTuple (x, y) _ = BinaryOpPre GLSLVec4 "vec4" (toExpr x) (toExpr y)+ exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y] type family (ConstructFrom' tuple hprim) :: Constraint where ConstructFrom' a Vec1 = a ~ Float@@ -481,25 +483,6 @@ --instance Hashable Vec1 where- hashWithSalt salt x = hashWithSalt salt $ ("vec1", show x)-instance Hashable Vec2 where- hashWithSalt salt x = hashWithSalt salt $ ("vec2", show x)-instance Hashable Vec3 where- hashWithSalt salt x = hashWithSalt salt $ ("vec3", show x)-instance Hashable Vec4 where- hashWithSalt salt x = hashWithSalt salt $ ("vec4", show x)-instance Hashable Booly where- hashWithSalt salt x = hashWithSalt salt $ ("booly", show x)--instance Hashable Texture where- hashWithSalt salt x = hashWithSalt salt $ ("texture2D", show x)---- TODO: textures cannot be saved as variable!--- data GLSLType = GLSLFloat | GLSLVec2 | GLSLVec3@@ -517,14 +500,7 @@ GLSLBool -> "bool" GLSLTexture -> "(texture)" -- this should never be variablized -newtype Hash = Hash Int- deriving (Generic, Hashable, Eq, Ord)-instance Show Hash where- show (Hash i) = "h_" <> show i -data HashTree = Leaf Hash Expr | Branch Hash Expr [HashTree]- deriving (Generic, Hashable, Show, Eq, Ord)- class (Show a) => Expressible a where toExpr :: a -> Expr @@ -532,169 +508,108 @@ -- TODO: get rid of Vec?, replace with Expr? at least get rid of all the duplicate show statements in my primitives! -data Expr = Uniform GLSLType String- | UnaryOp GLSLType String Expr- | UnaryOpPre GLSLType String Expr- | BinaryOp GLSLType String Expr Expr- | BinaryOpPre GLSLType String Expr Expr- | TernaryOpPre GLSLType String Expr Expr Expr- | QuaternaryOpPre GLSLType String Expr Expr Expr Expr- | Select GLSLType Expr Expr Expr -- for ternary selection- | Access GLSLType String Expr -- field accessor- deriving (Generic, Hashable, Eq, Ord)+data ExprForm = Uniform+ | Variable+ | UnaryOp+ | UnaryOpPre+ | BinaryOp+ | BinaryOpPre+ | TernaryOpPre+ | QuaternaryOpPre+ | Select+ | Access+ deriving (Show, Generic, Hashable) --- TODO: is there any way to do this automatically?-getType :: Expr -> GLSLType-getType x = case x of- Uniform ty _ -> ty- UnaryOp ty _ _ -> ty- UnaryOpPre ty _ _ -> ty- BinaryOp ty _ _ _ -> ty- BinaryOpPre ty _ _ _ -> ty- TernaryOpPre ty _ _ _ _ -> ty- QuaternaryOpPre ty _ _ _ _ _ -> ty- Select ty _ _ _ -> ty- Access ty _ _ -> ty -instance Show Expr where- show foo = case foo of- Uniform _ x -> x- UnaryOp _ u x -> u <> "(" <> show x <> ")"- UnaryOpPre _ u x -> "(" <> u <> show x <> ")"- BinaryOp _ b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"- BinaryOpPre _ b x y -> b <> "(" <> show x <> ", " <> show y <> ")"- TernaryOpPre _ b x y z -> b <> "(" <> show x <> ", " <> show y <> ", " <> show z <> ")"- QuaternaryOpPre _ b x y z w -> b <> "(" <> show x <> ", " <> show y <> ", " <> show z <> ", " <> show w <> ")"- Select _ b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"- Access _ field x -> show x <> "." <> field---- Type information?--- STring information?-toHashTree :: Expr -> HashTree-toHashTree exprForm = case exprForm of- a@(Uniform ty str) -> mkLeaf (ty, str) a- UnaryOp ty str x -> mkBranch1 (ty, str) exprForm x- UnaryOpPre ty str x -> mkBranch1 (ty, str) exprForm x- BinaryOp ty str x y -> mkBranch2 (ty, str) exprForm x y- BinaryOpPre ty str x y -> mkBranch2 (ty, str) exprForm x y- TernaryOpPre ty str x y z -> mkBranch3 (ty, str) exprForm x y z- QuaternaryOpPre ty str x y z w -> mkBranch4 (ty, str) exprForm x y z w- Select ty b x y -> mkBranch3 (ty, "?:") exprForm b x y- Access ty str x -> mkBranch1 (ty, "." <> str) exprForm x--type HashContext = (GLSLType, String)--mkLeaf :: HashContext -> Expr -> HashTree-mkLeaf hc expr = Leaf (Hash $ hash (expr, hc)) expr--mkBranch1 :: HashContext -> Expr -> Expr -> HashTree-mkBranch1 hc expr x = Branch (Hash $ hash (expr, hc, subTrees)) expr subTrees- where- subTrees = [toHashTree x]--mkBranch2 :: HashContext -> Expr -> Expr -> Expr -> HashTree-mkBranch2 hc expr x y = Branch (Hash $ hash (expr, hc, subTrees)) expr subTrees- where- subTrees = [toHashTree x, toHashTree y]--mkBranch3 :: HashContext -> Expr -> Expr -> Expr -> Expr -> HashTree-mkBranch3 hc expr x y z = Branch (Hash $ hash (expr, hc, subTrees)) expr subTrees- where- subTrees = [toHashTree x, toHashTree y, toHashTree z]+data Tree a = Tree { getElem :: a+ , getChildren :: [Tree a]+ }+ deriving (Functor) -mkBranch4 :: HashContext -> Expr -> Expr -> Expr -> Expr -> Expr -> HashTree-mkBranch4 hc expr x y z w = Branch (Hash $ hash (expr, hc, subTrees)) expr subTrees- where- subTrees = [toHashTree x, toHashTree y, toHashTree z, toHashTree w]+type Expr = Tree (ExprForm, GLSLType, String) --- TODO: tag strings so hash is correct+instance Show Expr where+ show (Tree (form, _, str) xs) = case form of+ Uniform -> str+ Variable -> str+ UnaryOp -> str <> "(" <> show (xs!!0) <> ")"+ UnaryOpPre -> "(" <> str <> show (xs!!0) <> ")"+ BinaryOp -> "(" <> show (xs !! 0) <> " " <> str <> " " <> show (xs !! 1) <> ")"+ BinaryOpPre -> str <> "(" <> show (xs!!0) <> ", " <> show (xs!!1) <> ")"+ TernaryOpPre -> str <> "(" <> show (xs!!0) <> ", " <> show (xs!!1) <> ", " <> show (xs!!2) <> ")"+ QuaternaryOpPre -> str <> "(" <> show (xs!!0) <> ", " <> show (xs!!1) <> ", " <> show (xs!!2) <> ", " <> show (xs!!3) <> ")"+ Select -> "( " <> show (xs!!0) <> " ? " <> show (xs!!1) <> " : " <> show (xs!!2) <> ")"+ Access -> show (xs!!0) <> "." <> str instance Expressible Vec1 where toExpr foo = case foo of Vec1 x -> exprFormFromTuple x foo- V1u str -> Uniform ty str- V1uop str x -> UnaryOp ty str (toExpr x)- V1uoppre str x -> UnaryOpPre ty str (toExpr x)- V1bop str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V1boppre str x y -> BinaryOpPre ty str (toExpr x) (toExpr y)- V1select b x y -> Select ty (toExpr b) (toExpr x) (toExpr y)- Dot x y -> BinaryOpPre ty "dot" (toExpr x) (toExpr y)- X x -> Access ty "x" (toExpr x)- Y x -> Access ty "y" (toExpr x)- Z x -> Access ty "z" (toExpr x)- W x -> Access ty "w" (toExpr x)+ V1u str -> Tree (Uniform, ty, str) []+ V1uop str x -> Tree (UnaryOp, ty, str) [toExpr x]+ V1uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]+ V1bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]+ V1boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]+ V1select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y]+ Dot x y -> Tree (BinaryOpPre, ty, "dot") [toExpr x, toExpr y]+ X x -> Tree (Access, ty, "x") [toExpr x]+ Y x -> Tree (Access, ty, "y") [toExpr x]+ Z x -> Tree (Access, ty, "z") [toExpr x]+ W x -> Tree (Access, ty, "w") [toExpr x] where ty = GLSLFloat instance Expressible Vec2 where toExpr foo = case foo of Vec2 x -> exprFormFromTuple x foo- V2u str -> Uniform ty str- V2uop str x -> UnaryOp ty str (toExpr x)- V2uoppre str x -> UnaryOpPre ty str (toExpr x)- V2bop str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V2boppre str x y -> BinaryOpPre ty str (toExpr x) (toExpr y)- V2bops str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V2select b x y -> Select ty (toExpr b) (toExpr x) (toExpr y)+ V2u str -> Tree (Uniform, ty, str) []+ V2uop str x -> Tree (UnaryOp, ty, str) [toExpr x]+ V2uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]+ V2bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]+ V2boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]+ V2bops str x y -> Tree (BinaryOp , ty, str) [toExpr x, toExpr y]+ V2select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y] where ty = GLSLVec2 instance Expressible Vec3 where toExpr foo = case foo of Vec3 x -> exprFormFromTuple x foo- V3u str -> Uniform ty str- V3uop str x -> UnaryOp ty str (toExpr x)- V3uoppre str x -> UnaryOpPre ty str (toExpr x)- V3bop str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V3boppre str x y -> BinaryOpPre ty str (toExpr x) (toExpr y)- V3bops str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V3select b x y -> Select ty (toExpr b) (toExpr x) (toExpr y)+ V3u str -> Tree (Uniform, ty, str) []+ V3uop str x -> Tree (UnaryOp, ty, str) [toExpr x]+ V3uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]+ V3bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]+ V3boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]+ V3bops str x y -> Tree (BinaryOp , ty, str) [toExpr x, toExpr y]+ V3select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y] where ty = GLSLVec3 instance Expressible Vec4 where toExpr foo = case foo of Vec4 x -> exprFormFromTuple x foo- V4u str -> Uniform ty str- V4uop str x -> UnaryOp ty str (toExpr x)- V4uoppre str x -> UnaryOpPre ty str (toExpr x)- V4bop str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V4boppre str x y -> BinaryOpPre ty str (toExpr x) (toExpr y)- V4bops str x y -> BinaryOp ty str (toExpr x) (toExpr y)- V4select b x y -> Select ty (toExpr b) (toExpr x) (toExpr y)- Texture2D t x -> BinaryOpPre ty "texture2D" (toExpr t) (toExpr x)+ V4u str -> Tree (Uniform, ty, str) []+ V4uop str x -> Tree (UnaryOp, ty, str) [toExpr x]+ V4uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]+ V4bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]+ V4boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]+ V4bops str x y -> Tree (BinaryOp , ty, str) [toExpr x, toExpr y]+ V4select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y]+ Texture2D t x -> Tree (BinaryOpPre, ty, "texture2D") [toExpr t, toExpr x] where ty = GLSLVec4 instance Expressible Booly where toExpr foo = case foo of- Bu str -> Uniform ty str- Buop str x -> UnaryOp ty str (toExpr x)- Buoppre str x -> UnaryOpPre ty str (toExpr x)- Bbop str x y -> BinaryOp ty str (toExpr x) (toExpr y)- Bcomp_ str x y -> BinaryOp ty str (toExpr x) (toExpr y)- Bcomp str x y -> toExpr . product $ zipWith (Bcomp_ str) (toList x) (toList y)+ Bu str -> Tree (Uniform, ty, str) []+ Buop str x -> Tree (UnaryOp, ty, str) [toExpr x]+ Buoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]+ Bbop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]+ Bcomp_ str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]+ Bcomp str x y -> toExpr . product $ zipWith (Bcomp_ str) (toList x) (toList y) where ty = GLSLBool instance Expressible Texture where- toExpr (Tu str) = Uniform ty str+ toExpr (Tu str) = Tree (Uniform, ty, str) [] where ty = GLSLTexture---- | Existential--- data Expr where--- ToExpr :: (Expressible a) => a -> Expr---- instance Show Expr where--- show (ToExpr a) = show (getType a) <> " blah = " <> show a <> ";"--- -- TODO: implement Variable as a contructor for Expression--- data Variable where--- VVec1 :: Vec1 -> Variable--- VVec2 :: Vec2 -> Variable--- VVec3 :: Vec3 -> Variable--- VBooly :: Booly -> Variable---- instance Num (Context Vec1) where