packages feed

hylogen 0.1.0.12 → 0.1.1.0

raw patch · 13 files changed

+641/−893 lines, 13 filesdep +data-reifydep −containersdep −hashabledep −mtlnew-component:exe:hyde

Dependencies added: data-reify

Dependencies removed: containers, hashable, mtl

Files

README.md view
@@ -1,43 +1,64 @@ # [*H Y L O G E N*](https://hylogen.com) -Hylogen is a purely functional language [embedded in Haskell](https://wiki.haskell.org/Embedded_domain_specific_language) for live-coding fragment shaders.+Hylogen is a purely functional language [embedded in Haskell](https://wiki.haskell.org/Embedded_domain_specific_language) for live-coding fragment shaders, featuring: -## Setup+- a simple and pure syntax+- standard operators (`+`, `*`, [`*^`,  `<.>`](https://hackage.haskell.org/package/vector-space))+- compat. w/ your fav haskell goodies (higher-order functions, ADTS, swanky polymorphism).++<br/>++It comes with `hyde`, an accompanying rendering environment featuring:+- *hot-reloading*+- audio-reactive primitives+- texture backbuffering++<br/>+++## Install ``` cabal update cabal install hylogen ``` +This will install the hylogen package and `hyde`, the rendering environment.++<br/>+ ## Usage  ```haskell -- ./Main.hs module Main where-import Hylogen+import Hylogen.WithHyde  color = vec4 (a, a, a, 1)   where     a = cos(X uvN * sin(time/ 10) * 10 + X mouse)       + sin(Y uvN * sin(time / 10) * 10 + Y mouse) -main = putStrLn $ toGLSL $ color+main = putStrLn . toGLSL $ color ``` -#### 1. run hylogen server+#### 1. run hyde...  ```-hylogen Main.hs+hyde Main.hs ``` -#### 2. play!-Visit [localhost:5678](http://localhost:5678) in your browser.+#### 2. ... live-code!+Go to [localhost:5678](http://localhost:5678) in your browser. -Changes in `Main.hs` will now be propagated in realtime to your WebGL rendering context!+You will now see your changes to `Main.hs` propagate to your WebGL rendering environment! -## inspiration-- [The_Force](https://github.com/shawnlawson/The_Force)+<br/> -## resources-[hackage](https://hackage.haskell.org/package/hylogen)+## References+- [The_Force](https://github.com/shawnlawson/The_Force) by Shawn Lawson. Live-coding audio-reactive shaders!+- [Type-Safe Observable Sharing](https://pdfs.semanticscholar.org/4838/bd0a91b3058b467fa31ad9e0810121b46388.pdf) by Andy Gill. [`data-reify`](https://hackage.haskell.org/package/data-reify) made compile times combinatorially faster! -[examples](https://github.com/sleexyz/hylogen-yay)+## Resources+- [hackage](https://hackage.haskell.org/package/hylogen)++- [examples](https://github.com/sleexyz/hylogen-yay)
app/Main.hs view
@@ -18,12 +18,10 @@ import Network.Wai.Handler.Warp import Network.HTTP.Types (status200, status404) --- import System.Random- main :: IO () main = getArgs >>= \case   [pathToWatch] -> main' pathToWatch-  _ -> error "Name a file to watch!"+  _ -> error "Error: Name a file to watch!"  main' :: FilePath ->  IO () main' pathToWatch = do
hylogen.cabal view
@@ -1,5 +1,5 @@ name:                hylogen-version:             0.1.0.12+version:             0.1.1.0 synopsis:            an EDSL for live-coding fragment shaders description:         an EDSL for live-coding fragment shaders homepage:            https://hylogen.com@@ -18,19 +18,23 @@ library   exposed-modules:     Hylogen                      , Hylogen.Types+                     , Hylogen.Vec+                     , Hylogen.Expr+                     , Hylogen.Booly+                     , Hylogen.Texture                      , Hylogen.Globals-                     , Hylogen.CSE+                     , Hylogen.Program+                     , Hylogen.WithHyde   build-depends:       base >=4.8 && <4.9                      , vector-space-                     , containers-                     , hashable-                     , mtl+                     , data-reify   hs-source-dirs:      src   default-language:    Haskell2010   -executable hylogen+executable hyde   main-is:             Main.hs   other-extensions:    OverloadedStrings+  other-modules:       Paths_hylogen   build-depends:       base                      , bytestring                      , filepath
src/Hylogen.hs view
@@ -1,47 +1,7 @@-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE ExplicitForAll            #-}-{-# LANGUAGE ExtendedDefaultRules      #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE NoMonoLocalBinds          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PolyKinds                 #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}--module Hylogen-       ( module Hylogen-       , module Hylogen.Types-       , module Hylogen.Globals-       )-       where+module Hylogen ( module Hylogen.Types+               , module Hylogen.Globals+               ) where -import           Data.Monoid-import           Data.List-import           Hylogen.CSE     (contextToAssignments, getTopLevel, genContext) import           Hylogen.Globals-import           Hylogen.Types   (Vec (fromVec1, select, toList),-                                  Vec1 (W, X, Y, Z), Vec2, Vec3, Vec4)--toGLSL' :: Vec4 -> String-toGLSL' v = unlines [ "void main() {"-                    , "    gl_FragColor = " <> show v<> ";"-                    , "}"-                    ]---toGLSL :: Vec4 -> String-toGLSL v = unlines [ "void main() {"-                   , assignments-                   , ""-                   , "    gl_FragColor = " <> show topLevel <> ";"-                   , "}"-                   ]-  where-    assignments = mconcat . fmap ("\n    "<>) $ contextToAssignments glsl-    glsl = genContext v-    topLevel = getTopLevel glsl+import           Hylogen.Types
+ src/Hylogen/Booly.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Hylogen.Booly where++import Hylogen.Expr++data BoolyType = BoolyType+instance ToGLSLType BoolyType where+  toGLSLType _ = GLSLBool+  tag = BoolyType++type Booly = Expr BoolyType++instance Num Booly where+  (+) = op2 "||"+  (*) = op2 "&&"+  negate = op1 "!"+  abs = id+  signum = id+  fromInteger x+    | x > 0 = uniform "true"+    | otherwise = uniform "false"
− src/Hylogen/CSE.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE DeriveAnyClass            #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE LambdaCase#-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TupleSections #-}--module Hylogen.CSE where--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.Arrow--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!-type GLSL = ( IntMap (ExprForm, GLSLType, String, [Either Expr Hash])-            , [(ExprForm, GLSLType, String, Hash, [Either Expr Hash])]-            )---- TODO:--- newtype GLSL = GLSL ([(Id, (Expr, [Hash]))], IntMap.Map Hash Id)---                deriving (Show)---initialGLSL :: GLSL-initialGLSL = (IntMap.empty, [])------ 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----- TODO: slow---- HashTree = Tree (ExprForm, GLSLType, String, Hash, [Hash])-toContext :: HashTree -> GLSL-toContext ht = genContext' ht initialGLSL-  where-    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--hash2Name :: Hash -> String-hash2Name h-  | h < 0     = "_n" <> tail shown-  | otherwise = "_" <> shown-    where-      shown = show h-----getTopLevel :: GLSL -> Expr-getTopLevel (_, output) = tagsToExpr $ head output--contextToAssignments :: GLSL -> [String]-contextToAssignments (_, output) = foldl fn [] output-  where-    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/Expr.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE DeriveFunctor #-}+++module Hylogen.Expr where++import Data.Reify++data GLSLType = GLSLFloat+              | GLSLVec2+              | GLSLVec3+              | GLSLVec4+              | GLSLBool+              | GLSLTexture+              deriving (Eq, Ord)++instance Show GLSLType where+  show x = case x of+    GLSLFloat -> "float"+    GLSLVec2 -> "vec2"+    GLSLVec3 -> "vec3"+    GLSLVec4 -> "vec4"+    GLSLBool -> "bool"+    GLSLTexture -> "sampler2D"++data ExprForm = Uniform+              | Variable+              | Op1+              | Op1Pre+              | Op2+              | Op2Pre+              | Op3Pre+              | Op4Pre+              | Select+              | Access+                deriving (Show)++data Tree a  = Tree { getElem     :: a+                    , getChildren :: [Tree a]+                    }+++type ExprMono = Tree (ExprForm, GLSLType, String)++instance Show ExprMono where+  show (Tree (form, _, str) xs) = case form of+    Uniform  -> str+    Variable -> str+    Op1      -> mconcat ["(", str, show (xs!!0), ")"]+    Op1Pre   -> mconcat [ str, "(", show (xs!!0), ")"]+    Op2      -> mconcat ["(", show (xs !! 0), " ", str, " ", show (xs !! 1), ")"]+    Op2Pre   -> mconcat [str, "(", show (xs!!0), ", ", show (xs!!1), ")"]+    Op3Pre   -> mconcat [str, "(", show (xs!!0), ", ", show (xs!!1), ", ", show (xs!!2), ")"]+    Op4Pre   -> mconcat [str, "(", show (xs!!0), ", ", show (xs!!1), ", ", show (xs!!2), ", ", show (xs!!3), ")"]+    Select   -> mconcat ["( ", show (xs!!0), " ? ", show (xs!!1), " : ", show (xs!!2), ")"]+    Access   -> mconcat [show (xs!!0), ".", str]++-- The GLSLType needs to be manually dependent++-- light typed wrapper+data Expr ty = Expr { getTypeTag :: ty+                    , toMono ::  Tree (ExprForm, GLSLType, String)+                    }++instance ToGLSLType ty => Show (Expr ty) where+  show = show . toMono++class ToGLSLType  ty where+  toGLSLType :: ty -> GLSLType+  tag :: ty -- TODO: fill in!++uniform :: forall a+           . ToGLSLType a+           => String -> Expr a+uniform str = Expr t (Tree (Uniform, toGLSLType t, str) [])+  where t = tag :: a++op1 :: forall a b+       . (ToGLSLType a, ToGLSLType b)+       => String -> Expr a -> Expr b+op1 str a = Expr t (Tree (Op1, toGLSLType t, str) [toMono a])+  where t = tag :: b++op1'' :: forall a+       . (ToGLSLType a)+       => String -> Expr a -> Expr a+op1'' str a = Expr t (Tree (Op1, toGLSLType t, str) [toMono a])+  where t = tag :: a++op1pre :: forall a b+          . (ToGLSLType a, ToGLSLType b)+          => String -> Expr a -> Expr b+op1pre str a = Expr t (Tree (Op1Pre, toGLSLType t, str) [toMono a])+  where t = tag :: b++op1pre'' :: forall a+          . (ToGLSLType a)+          => String -> Expr a -> Expr a+op1pre'' str a = Expr t (Tree (Op1Pre, toGLSLType t, str) [toMono a])+  where t = tag :: a++op2 :: forall a b c+       . (ToGLSLType a, ToGLSLType b, ToGLSLType c)+       => String -> Expr a -> Expr b -> Expr c+op2 str a b = Expr t (Tree (Op2, toGLSLType t, str) [toMono a, toMono b])+  where t = tag :: c++op2' :: forall a c+       . (ToGLSLType a, ToGLSLType c)+       => String -> Expr a -> Expr a -> Expr c+op2' str a b = Expr t (Tree (Op2, toGLSLType t, str) (fmap toMono [a, b]))+  where t = tag :: c++op2'' :: forall a+       . (ToGLSLType a)+       => String -> Expr a -> Expr a -> Expr a+op2'' str a b = Expr t (Tree (Op2, toGLSLType t, str) (fmap toMono [a, b]))+  where t = tag :: a+++op2pre :: forall a b c+          . (ToGLSLType a, ToGLSLType b, ToGLSLType c)+          => String -> Expr a -> Expr b -> Expr c+op2pre str a b = Expr t (Tree (Op2Pre, toGLSLType t, str) [toMono a, toMono b])+  where t = tag :: c++op2pre' :: forall a c+       . (ToGLSLType a, ToGLSLType c)+       => String -> Expr a -> Expr a -> Expr c+op2pre' str a b = Expr t (Tree (Op2Pre, toGLSLType t, str) (fmap toMono [a, b]))+  where t = tag :: c++op2pre'' :: forall a+       . (ToGLSLType a)+       => String -> Expr a -> Expr a -> Expr a+op2pre'' str a b = Expr t (Tree (Op2Pre, toGLSLType t, str) (fmap toMono [a, b]))+  where t = tag :: a++op3pre :: forall a b c d+          . (ToGLSLType a, ToGLSLType b, ToGLSLType c, ToGLSLType d)+          => String -> Expr a -> Expr b -> Expr c -> Expr d+op3pre str a b c = Expr t (Tree (Op3Pre, toGLSLType t, str) [toMono a, toMono b, toMono c])+  where t = tag :: d++op3pre' :: forall a d+          . (ToGLSLType a, ToGLSLType d)+          => String -> Expr a -> Expr a -> Expr a -> Expr d+op3pre' str a b c = Expr t (Tree (Op3Pre, toGLSLType t, str) (fmap toMono [a, b, c]))+  where t = tag :: d++op3pre'' :: forall a+          . (ToGLSLType a)+          => String -> Expr a -> Expr a -> Expr a -> Expr a+op3pre'' str a b c = Expr t (Tree (Op3Pre, toGLSLType t, str) (fmap toMono [a, b, c]))+  where t = tag :: a+++op4pre :: forall a b c d e+          . (ToGLSLType a, ToGLSLType b, ToGLSLType c, ToGLSLType d, ToGLSLType e)+          => String -> Expr a -> Expr b -> Expr c -> Expr d -> Expr e+op4pre str a b c d = Expr t (Tree (Op4Pre, toGLSLType t, str) [toMono a, toMono b, toMono c, toMono d])+  where t = tag :: e++op4pre' :: forall a e+          . (ToGLSLType a, ToGLSLType e)+          => String -> Expr a -> Expr a -> Expr a -> Expr a -> Expr e+op4pre' str a b c d = Expr t (Tree (Op4Pre, toGLSLType t, str) (fmap toMono [a, b, c, d]))+  where t = tag :: e++op4pre'' :: forall a e+          . (ToGLSLType a, ToGLSLType e)+          => String -> Expr a -> Expr a -> Expr a -> Expr a -> Expr e+op4pre'' str a b c d = Expr t (Tree (Op4Pre, toGLSLType t, str) (fmap toMono [a, b, c, d]))+  where t = tag :: e+++++data TreeF a b = TreeF { getElemF     :: a+                       , getChildrenF   :: [Maybe b]+                       }+                 deriving (Functor)++type ExprMonoF = TreeF (ExprForm, GLSLType, String, [ExprMono])++emfStringAt :: (Show a) => ExprMonoF a -> Int -> String+emfStringAt (TreeF (_, _, _, xs) ys)  i = zipWith fn xs ys !! i+  where+    fn x Nothing = show x+    fn _ (Just y)= show y++instance (Show a) => Show (ExprMonoF a) where+  show expr@(TreeF (form, _, str, _) _) = case form of+    Uniform  -> str+    Variable -> str+    Op1      -> mconcat ["(", str, strAt 0, ")"]+    Op1Pre   -> mconcat [ str, "(", strAt 0, ")"]+    Op2      -> mconcat ["(", strAt 0, " ", str, " ", strAt 1, ")"]+    Op2Pre   -> mconcat [str, "(", strAt 0, ", ", strAt 1, ")"]+    Op3Pre   -> mconcat [str, "(", strAt 0, ", ", strAt 1, ", ", strAt 2, ")"]+    Op4Pre   -> mconcat [str, "(", strAt 0, ", ", strAt 1, ", ", strAt 2, ", ", strAt 3, ")"]+    Select   -> mconcat ["( ", strAt 0, " ? ", strAt 1, " : ", strAt 2, ")"]+    Access   -> mconcat [strAt 0, ".", str]+    where+      strAt = emfStringAt expr++-- instance MuRef ExprMono where+--   type DeRef ExprMono = ExprMonoF+--   mapDeRef f (Tree tup xs) = TreeF tup <$> traverse f xs++instance MuRef ExprMono where+  type DeRef ExprMono = ExprMonoF+  mapDeRef func (Tree (form, ty, str) xs) = TreeF (form, ty, str, xs) <$> g xs+    where+      g (x:xs) = (:) <$> (traverse func $ shouldShare x) <*> (g $  xs)+      g [] = pure []++      shouldShare :: ExprMono -> Maybe ExprMono+      shouldShare (Tree (Uniform, _, _) _) = Nothing+      shouldShare expr = Just expr
src/Hylogen/Globals.hs view
@@ -1,39 +1,36 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}  module Hylogen.Globals where  import Hylogen.Types+import Hylogen.Expr import Data.VectorSpace -vec2 :: (ConstructFrom tc Vec2) => tc -> Vec2-vec2 = Vec2 -vec3 :: (ConstructFrom tc Vec3) => tc -> Vec3-vec3 = Vec3 -vec4 :: (ConstructFrom tc Vec4) => tc -> Vec4-vec4 = Vec4 -inverseSqrt :: (Vec a) => a -> a-inverseSqrt = vuop "inversesqrt"+inverseSqrt :: forall n. (Veccable n) => Vec n -> Vec n+inverseSqrt = op1pre'' "inversesqrt" -fract :: (Vec a) => a -> a-fract = vuop "fract"+fract :: forall n. (Veccable n) => Vec n -> Vec n+fract = op1pre'' "fract" -floor_ :: (Vec a) => a -> a-floor_ = vuop "floor"+floor_:: forall n. (Veccable n) => Vec n -> Vec n+floor_ = op1pre'' "floor" -ceil_ :: (Vec a) => a -> a-ceil_ = vuop "ceil"+ceil_ :: forall n. (Veccable n) => Vec n -> Vec n+ceil_ = op1pre'' "ceil" -min_ :: (Vec a) => a -> a -> a-min_ = vboppre "min"+min_ :: forall n. (Veccable n) => Vec n -> Vec n -> Vec n+min_ = op2pre'' "min" -max_:: (Vec a) => a -> a -> a-max_ = vboppre "max"+max_ :: forall n. (Veccable n) => Vec n -> Vec n -> Vec n+max_ = op2pre'' "max" -clamp :: (Vec a) => a -> a -> a -> a+clamp :: forall n. (Veccable n) => Vec n -> Vec n -> Vec n -> Vec n clamp x y z = (z `min_` y) `max_` x  @@ -44,60 +41,42 @@ linlin (a, b, c, d) x = c + (d - c) * ((x - a) / (b - a))  -time :: Vec1-time = V1u "time" -uv :: Vec2-uv = V2u "uv()"--uvN :: Vec2-uvN = V2u "uvN"--resolution :: Vec2-resolution = V2u "resolution"--mouse :: Vec2-mouse = V2u "mouse"---audio :: Vec4-audio = V4u "audio"--backBuffer :: Texture-backBuffer = Tu "backBuffer"--channel1 :: Texture-channel1 = Tu "channel1"- mix :: Vec1 -> Vec4 -> Vec4 -> Vec4 mix p a b = p *^ a + (1 - p) *^ b --- | Booly's- true :: Booly-true = Bu "true"+true = uniform "true"  false :: Booly-false = Bu "false"+false = uniform "false" -eq :: (Vec v) => v -> v -> Booly-eq = Bcomp "=="+bcomp :: (Veccable v) => String -> Vec v -> Vec v -> Booly+bcomp str x y = product $ zipWith (op2' str) (toList x) (toList y) -neq :: (Vec v) => v -> v -> Booly-neq = Bcomp "!="+eq :: (Veccable v) => Vec v -> Vec v -> Booly+eq = bcomp "==" -lt :: (Vec v) => v -> v -> Booly-lt = Bcomp "<"+neq :: (Veccable v) => Vec v -> Vec v -> Booly+neq = bcomp "!=" -gt :: (Vec v) => v -> v -> Booly-gt = Bcomp ">"+lt :: (Veccable v) => Vec v -> Vec v -> Booly+lt = bcomp "<" -leq :: (Vec v) => v -> v -> Booly-leq = Bcomp "<="+gt :: (Veccable v) => Vec v -> Vec v -> Booly+gt = bcomp ">" -geq :: (Vec v) => v -> v -> Booly-geq = Bcomp ">="+leq :: (Veccable v) => Vec v -> Vec v -> Booly+leq = bcomp "<=" +geq :: (Veccable v) => Vec v -> Vec v -> Booly+geq = bcomp ">="  texture2D :: Texture -> Vec2 -> Vec4-texture2D = Texture2D+texture2D = op2pre "texture2D"++select :: forall a+          . (ToGLSLType a)+          => Booly -> Expr a -> Expr a -> Expr a+select a b c = Expr t (Tree (Select, toGLSLType t, "") ([toMono a, toMono b, toMono c]))+  where t = tag :: a
+ src/Hylogen/Program.hs view
@@ -0,0 +1,40 @@+module Hylogen.Program where++import Data.Reify+import Data.Monoid+import System.IO.Unsafe++import Hylogen.Expr++-- Just for printing!+newtype Id = Id Int+instance Show Id where+  show (Id h) = "_" <> show h++data Statement = NewAssign (Unique, ExprMonoF Unique)+               -- | MutAssign (Unique, ExprMonoF Unique)++getExpr :: Statement -> ExprMonoF Unique+getExpr (NewAssign (_, expr)) = expr++++instance Show Statement where+  show (NewAssign (i, expr@(TreeF (_, ty, _, _) _)))+    = mconcat [ show ty, " ", show . Id $ i, " = ", show . (Id<$>) $  expr, ";"]++newtype Function = Function [Statement]+instance Show Function where+  show (Function xs) = unlines [ "void main() {"+                              , assignments+                              , "    gl_FragColor = _1;"+                              , "}"+                              ]+    where+      assignments = mconcat $  (<> "\n") . ("    "<>) . show <$> reverse xs+++toProgram :: ExprMono -> Function+toProgram v = unsafePerformIO $ do+  Graph nodes _ <- reifyGraph v+  return . Function $ NewAssign <$> nodes
+ src/Hylogen/Texture.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Hylogen.Texture where++import Hylogen.Expr++data TextureType = TextureType+instance ToGLSLType TextureType where+  toGLSLType _ = GLSLTexture+  tag = TextureType++type Texture = Expr TextureType
src/Hylogen/Types.hs view
@@ -1,615 +1,9 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-}--module Hylogen.Types where---import Data.Monoid-import Data.VectorSpace-import GHC.Exts (Constraint)-import Data.Hashable-import GHC.Generics--class (ConstructFrom' tuple hprim, Show tuple, Vec hprim) => ConstructFrom tuple hprim where-  exprFormFromTuple :: tuple -> hprim -> Expr--instance ConstructFrom Float Vec1 where-  exprFormFromTuple x _ = Tree (Uniform, GLSLFloat, (show x)) [] -- TODO: this is a hack!-instance ConstructFrom (Vec1, Vec1) Vec2 where-  exprFormFromTuple (x, y) _  = Tree (BinaryOpPre, GLSLVec2, "vec2") [toExpr x, toExpr y]-instance ConstructFrom (Vec1, Vec1, Vec1) Vec3 where-  exprFormFromTuple (x, y, z) _  = Tree (TernaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y, toExpr z]-instance ConstructFrom (Vec2, Vec1) Vec3 where-  exprFormFromTuple (x, y) _  = Tree (BinaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y]-instance ConstructFrom (Vec1, Vec2) Vec3 where-  exprFormFromTuple (x, y) _  = Tree (BinaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y]-instance ConstructFrom (Vec1, Vec1, Vec1, Vec1) Vec4 where-  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) _  = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z]-instance ConstructFrom (Vec1, Vec2, Vec1) Vec4 where-  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) _  = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z]-instance ConstructFrom (Vec3, Vec1) Vec4 where-  exprFormFromTuple (x, y) _  = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y]-instance (a ~ Vec1) => ConstructFrom (a, Vec3) Vec4 where-  exprFormFromTuple (x, y) _  = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y]-instance (a ~ Vec2) => ConstructFrom (a, Vec2) Vec4 where-  exprFormFromTuple (x, y) _  = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y]--type family (ConstructFrom' tuple hprim) :: Constraint where-  ConstructFrom' a Vec1 = a ~ Float-  ConstructFrom' (a, b) Vec2 = (a ~ Vec1, b ~ Vec1)--  ConstructFrom' (a, b, c) Vec3 = (a ~ Vec1, b ~ Vec1, c ~ Vec1)-  ConstructFrom' (Vec2, b) Vec3 = (b ~ Vec1)-  ConstructFrom' (a, Vec2) Vec3 = (a ~ Vec1)--  ConstructFrom' (a, b, c, d) Vec4 = (a ~ Vec1, b ~ Vec1, c ~ Vec1, d ~ Vec1)-  ConstructFrom' (Vec3, b) Vec4 = (b ~ Vec1)-  ConstructFrom' (Vec2, b) Vec4 = (b ~ Vec2)-  ConstructFrom' (a, Vec3) Vec4 = (a ~ Vec1)---  -- ConstructFrom' (Vec1, Vec1, Vec2) Vec4 = ()-  -- ConstructFrom' (Vec1, Vec2, Vec1) Vec4 = ()-  -- ConstructFrom' (Vec2, Vec1, Vec1) Vec4 = ()--  ConstructFrom' (Vec2, b, c) Vec4 = (b ~ Vec1, c ~ Vec1)-  ConstructFrom' (a, Vec2, c) Vec4 = (a ~ Vec1, c ~ Vec1) -- works-  ConstructFrom' (a, b, Vec2) Vec4 = (a ~ Vec1, b ~ Vec1)------class (Expressible v, Show v) => Vec v where-  vec :: (ConstructFrom tuple v) => tuple -> v-  vu :: String -> v-  vuop :: String -> v -> v-  vuoppre :: String -> v -> v-  vbop :: String -> v -> v -> v-  vboppre :: String -> v -> v -> v-  select :: Booly -> v -> v -> v-  fromVec1 :: Vec1 -> v-  toList :: v -> [Vec1]----class (Expressible a, Show a) => HasX a-class HasX a => HasY a-class HasY a => HasZ a-class HasZ a => HasW a---data Vec1 where-  Vec1 :: Float -> Vec1-  V1u :: String -> Vec1-  V1uop :: String -> Vec1 -> Vec1-  V1uoppre :: String -> Vec1 -> Vec1-  V1bop :: String -> Vec1 -> Vec1 -> Vec1-  V1boppre :: String -> Vec1 -> Vec1 -> Vec1-  V1select :: Booly -> Vec1 -> Vec1 -> Vec1-  Dot :: (Vec a) => a -> a -> Vec1-  X :: (HasX a) => a -> Vec1-  Y :: (HasY a) => a -> Vec1-  Z :: (HasZ a) => a -> Vec1-  W :: (HasW a) => a -> Vec1----instance Show Vec1 where-  show expr = case expr of-    Vec1 x -> show x-    V1u x -> x-    V1uop u x -> u <> "(" <> show x <> ")"-    V1uoppre u x -> "(" <> u <> show x <> ")"-    V1bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V1boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"-    V1select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"-    Dot x y -> "dot(" <> show x <> ", " <> show y <> ")"-    X x ->  show x <> ".x"-    Y x ->  show x <> ".y"-    Z x ->  show x <> ".z"-    W x ->  show x <> ".w"---instance Vec Vec1 where-  vec = Vec1-  vu = V1u-  vuop = V1uop-  vuoppre = V1uoppre-  vbop = V1bop-  vboppre = V1boppre-  select = V1select-  fromVec1 = id-  toList x = [x]--instance Num Vec1 where-  (+) = vbop "+"-  (*) = vbop "*"-  negate = vuoppre "-"-  abs = vuop "abs"-  signum = vuop "sign"-  fromInteger = Vec1 . fromInteger--instance Fractional Vec1 where-  (/) = vbop "/"-  recip = vbop "/" 1-  fromRational = Vec1 . fromRational---instance Floating Vec1 where-  pi = vu "pi"-  exp = vuop "exp"-  log = vuop "log"-  sqrt = vuop "sqrt"-  (**) = vboppre "pow"-  sin = vuop "sin"-  cos = vuop "cos"-  tan = vuop "tan"-  asin = vuop "asin"-  acos = vuop "acos"-  atan = vuop "atan"-  sinh x = (exp x - exp (negate x))/2-  cosh x = (exp x + exp (negate x))/2-  tanh x = sinh x / cosh x-  asinh x = log $ x + sqrt(x**2 + 1)-  acosh x = log $ x + sqrt(x**2 - 1)-  atanh x = 0.5 * log ((1 + x)/(1 - x))--instance AdditiveGroup Vec1 where-  zeroV = 0-  (^+^) = (+)-  negateV = negate-  (^-^) = (-)--instance VectorSpace Vec1 where-  type Scalar Vec1 = Vec1-  a *^ b = a * b--instance InnerSpace Vec1 where-  (<.>) = Dot---- | Vec2:--data Vec2 where-  Vec2 :: (ConstructFrom tuple Vec2) => tuple -> Vec2-  V2u :: String -> Vec2-  V2uop :: String -> Vec2 -> Vec2-  V2uoppre :: String -> Vec2 -> Vec2-  V2bop :: String -> Vec2 -> Vec2 -> Vec2-  V2boppre :: String -> Vec2 -> Vec2 -> Vec2-  V2bops :: String -> Vec1 -> Vec2 -> Vec2-  V2select :: Booly -> Vec2 -> Vec2 -> Vec2---instance Vec Vec2 where-  vec = Vec2-  vu = V2u-  vuop = V2uop-  vuoppre = V2uoppre-  vbop = V2bop-  vboppre = V2boppre-  select = V2select-  fromVec1 x = Vec2 (x, x)-  toList x = [X x, Y x]---instance Show Vec2 where-  show expr = case expr of-    Vec2 tuple -> "vec2" <> show tuple-    V2u x -> x-    V2uop u x -> u <> "(" <> show x <> ")"-    V2uoppre u x -> "(" <> u <> show x <> ")"-    V2bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V2boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"-    V2bops b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V2select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"--instance Num Vec2 where-  (+) = vbop "+"-  (*) = vbop "*"-  negate = vuoppre "-"-  abs = vuop "abs"-  signum = vuop "sign"-  fromInteger = fromVec1 . fromInteger--instance Fractional Vec2 where-  (/) = vbop "/"-  recip = vbop "/" 1-  fromRational = fromVec1 . fromRational---instance Floating Vec2 where-  pi = vu "pi"-  exp = vuop "exp"-  log = vuop "log"-  sqrt = vuop "sqrt"-  (**) = vboppre "pow"-  sin = vuop "sin"-  cos = vuop "cos"-  tan = vuop "tan"-  asin = vuop "asin"-  acos = vuop "acos"-  atan = vuop "atan"-  sinh x = (exp x - exp (negate x))/2-  cosh x = (exp x + exp (negate x))/2-  tanh x = sinh x / cosh x-  asinh x = log $ x + sqrt(x**2 + 1)-  acosh x = log $ x + sqrt(x**2 - 1)-  atanh x = 0.5 * log ((1 + x)/(1 - x))--instance AdditiveGroup Vec2 where-  zeroV = 0-  (^+^) = (+)-  negateV = negate-  (^-^) = (-)--instance VectorSpace Vec2 where-  type Scalar Vec2 = Vec1-  a *^ b = V2bops "*" a b--instance InnerSpace Vec2 where-  (<.>) = Dot--instance HasX Vec2-instance HasY Vec2----- | Vec3:--data Vec3 where-  Vec3 :: (ConstructFrom tuple Vec3) => tuple -> Vec3-  V3u :: String -> Vec3-  V3uop :: String -> Vec3 -> Vec3-  V3uoppre :: String -> Vec3 -> Vec3-  V3bop :: String -> Vec3 -> Vec3 -> Vec3-  V3boppre :: String -> Vec3 -> Vec3 -> Vec3-  V3bops :: String -> Vec1 -> Vec3 -> Vec3-  V3select :: Booly -> Vec3 -> Vec3 -> Vec3--instance Vec Vec3 where-  vec = Vec3-  vu = V3u-  vuop = V3uop-  vuoppre = V3uoppre-  vbop = V3bop-  vboppre = V3boppre-  select = V3select-  fromVec1 x = Vec3 (x, x, x)-  toList x = [X x, Y x, Z x]--instance Show Vec3 where-  show expr = case expr of-    Vec3 tuple -> "vec3" <> show tuple-    V3u x -> x-    V3uop u x -> u <> "(" <> show x <> ")"-    V3uoppre u x -> "(" <> u <> show x <> ")"-    V3bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V3boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"-    V3bops b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V3select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"--instance Num Vec3 where-  (+) = vbop "+"-  (*) = vbop "*"-  negate = vuoppre "-"-  abs = vuop "abs"-  signum = vuop "sign"-  fromInteger = fromVec1 . fromInteger--instance Fractional Vec3 where-  (/) = vbop "/"-  recip = vbop "/" 1-  fromRational = fromVec1 . fromRational---instance Floating Vec3 where-  pi = vu "pi"-  exp = vuop "exp"-  log = vuop "log"-  sqrt = vuop "sqrt"-  (**) = vboppre "pow"-  sin = vuop "sin"-  cos = vuop "cos"-  tan = vuop "tan"-  asin = vuop "asin"-  acos = vuop "acos"-  atan = vuop "atan"-  sinh x = (exp x - exp (negate x))/2-  cosh x = (exp x + exp (negate x))/2-  tanh x = sinh x / cosh x-  asinh x = log $ x + sqrt(x**2 + 1)-  acosh x = log $ x + sqrt(x**2 - 1)-  atanh x = 0.5 * log ((1 + x)/(1 - x))--instance AdditiveGroup Vec3 where-  zeroV = 0-  (^+^) = (+)-  negateV = negate-  (^-^) = (-)--instance VectorSpace Vec3 where-  type Scalar Vec3 = Vec1-  a *^ b = V3bops "*" a b--instance InnerSpace Vec3 where-  (<.>) = Dot--instance HasX Vec3-instance HasY Vec3-instance HasZ Vec3------ | Vec4:--data Vec4 where-  Vec4 :: (ConstructFrom tuple Vec4) => tuple -> Vec4-  V4u :: String -> Vec4-  V4uop :: String -> Vec4 -> Vec4-  V4uoppre :: String -> Vec4 -> Vec4-  V4bop :: String -> Vec4 -> Vec4 -> Vec4-  V4boppre :: String -> Vec4 -> Vec4 -> Vec4-  V4bops :: String -> Vec1 -> Vec4 -> Vec4-  V4select :: Booly -> Vec4 -> Vec4 -> Vec4-  Texture2D :: Texture -> Vec2 -> Vec4---instance Vec Vec4 where-  vec = Vec4-  vu = V4u-  vuop = V4uop-  vuoppre = V4uoppre-  vbop = V4bop-  vboppre = V4boppre-  select = V4select-  fromVec1 x = Vec4 (x, x, x, x)-  toList x = [X x, Y x, Z x, W x]--instance Show Vec4 where-  show expr = case expr of-    Vec4 tuple -> "vec4" <> show tuple-    V4u x -> x-    V4uop u x -> u <> "(" <> show x <> ")"-    V4uoppre u x -> "(" <> u <> show x <> ")"-    V4bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V4boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"-    V4bops b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"-    V4select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"-    Texture2D t v -> "texture2D(" <> show t <> ", " <> show v <> ")"--instance Num Vec4 where-  (+) = vbop "+"-  (*) = vbop "*"-  negate = vuoppre "-"-  abs = vuop "abs"-  signum = vuop "sign"-  fromInteger = fromVec1 . fromInteger--instance Fractional Vec4 where-  (/) = vbop "/"-  recip = vbop "/" 1-  fromRational = fromVec1 . fromRational---instance Floating Vec4 where-  pi = vu "pi"-  exp = vuop "exp"-  log = vuop "log"-  sqrt = vuop "sqrt"-  (**) = vboppre "pow"-  sin = vuop "sin"-  cos = vuop "cos"-  tan = vuop "tan"-  asin = vuop "asin"-  acos = vuop "acos"-  atan = vuop "atan"-  sinh x = (exp x - exp (negate x))/2-  cosh x = (exp x + exp (negate x))/2-  tanh x = sinh x / cosh x-  asinh x = log $ x + sqrt(x**2 + 1)-  acosh x = log $ x + sqrt(x**2 - 1)-  atanh x = 0.5 * log ((1 + x)/(1 - x))--instance AdditiveGroup Vec4 where-  zeroV = 0-  (^+^) = (+)-  negateV = negate-  (^-^) = (-)--instance VectorSpace Vec4 where-  type Scalar Vec4 = Vec1-  a *^ b = V4bops "*" a b--instance InnerSpace Vec4 where-  (<.>) = Dot--instance HasX Vec4-instance HasY Vec4-instance HasZ Vec4-instance HasW Vec4---data Texture where-  Tu :: String -> Texture--instance Show Texture where-  show (Tu xs) = xs---- | We implement Bool as a Num--data Booly where-  Bu:: String -> Booly-  Buop :: String -> Booly -> Booly-  Buoppre :: String -> Booly -> Booly-  Bbop :: String -> Booly -> Booly -> Booly-  Bcomp :: (Vec a) => String -> a -> a -> Booly-  Bcomp_ :: String -> Vec1 -> Vec1 -> Booly--instance Show Booly where-  show expr = case expr of-    Bu x -> x-    Buop u x -> u <> "(" <> show x <> ")"-    Buoppre u x -> "(" <> u <> show x <> ")"-    Bbop u x y -> "(" <> show x <> " " <> u <> " " <>  show y <> ")"-    Bcomp u x y -> show . product $ zipWith (Bcomp_ u) (toList x) (toList y)-    Bcomp_ u x y -> "(" <> show x <> " " <> u <> " " <>  show y <> ")"--instance Num Booly where-  (+) = Bbop "||"-  (*) = Bbop "&&"-  negate = Buoppre "!"-  abs = id-  signum = id-  fromInteger x-    | x > 0 = Bu "true"-    | otherwise = Bu "false"----data GLSLType = GLSLFloat-              | GLSLVec2-              | GLSLVec3-              | GLSLVec4-              | GLSLBool-              | GLSLTexture-              deriving (Generic, Hashable, Eq, Ord)--instance Show GLSLType where-  show x = case x of-    GLSLFloat -> "float"-    GLSLVec2 -> "vec2"-    GLSLVec3 -> "vec3"-    GLSLVec4 -> "vec4"-    GLSLBool -> "bool"-    GLSLTexture -> "(texture)" -- this should never be variablized---class (Show a) => Expressible a where-  toExpr :: a -> Expr------ TODO: get rid of Vec?, replace with Expr? at least get rid of all the duplicate show statements in my primitives!--data ExprForm = Uniform-              | Variable-              | UnaryOp-              | UnaryOpPre-              | BinaryOp-              | BinaryOpPre-              | TernaryOpPre-              | QuaternaryOpPre-              | Select-              | Access-                deriving (Show, Generic, Hashable)---data Tree a  = Tree { getElem     :: a-                    , getChildren :: [Tree a]-                    }-               deriving (Functor)--type Expr = Tree (ExprForm, GLSLType, String)--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          -> 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          -> 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          -> 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          -> 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+module Hylogen.Types ( module Hylogen.Vec+                     , module Hylogen.Booly+                     , module Hylogen.Texture+                     ) where  -instance Expressible Booly where-  toExpr foo = case foo of-    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+import Hylogen.Vec hiding (FloatVec, swizzShow)+import Hylogen.Booly hiding (BoolyType)+import Hylogen.Texture hiding (TextureType) -instance Expressible Texture where-  toExpr (Tu str) = Tree (Uniform, ty, str) []-    where-      ty = GLSLTexture
+ src/Hylogen/Vec.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE InstanceSigs #-}+++module Hylogen.Vec where++import GHC.TypeLits+import Data.VectorSpace++import Hylogen.Expr+++data FloatVec (n :: Nat) = FloatVec++type Vec n = Expr (FloatVec n)+type Vec1 = Vec 1+type Vec2 = Vec 2+type Vec3 = Vec 3+type Vec4 = Vec 4++instance ToGLSLType (FloatVec 1) where+  toGLSLType _ = GLSLFloat+  tag = FloatVec+instance ToGLSLType (FloatVec 2) where+  toGLSLType _ = GLSLVec2+  tag = FloatVec+instance ToGLSLType (FloatVec 3) where+  toGLSLType _ = GLSLVec3+  tag = FloatVec+instance ToGLSLType (FloatVec 4) where+  toGLSLType _ = GLSLVec4+  tag = FloatVec++++class (ToGLSLType (FloatVec n), KnownNat n) => Veccable n where+  copy :: Vec1 -> Vec n+  toList :: Vec n -> [Vec1]+++instance Veccable 1 where+  copy = id+  toList x = [x]+instance Veccable 2 where+  copy x = op2pre' "vec2" x x+  toList x = [x ! X, x ! Y]+instance Veccable 3 where+  copy x = op3pre' "vec3" x x x+  toList x = [x ! X, x ! Y, x ! Z]+instance Veccable 4 where+  copy x = op4pre' "vec4" x x x x+  toList x = [x ! X, x ! Y, x ! Z, x ! W]++++instance (Veccable n) => Num (Vec n) where+  (+) = op2' "+"+  (-) = op2' "-"+  (*) = op2' "*"+  abs = op1pre "abs"+  signum = op1pre "sign"+  negate = op1 "-"+  fromInteger x = copy . uniform . show $ (fromInteger x :: Float)+++instance (Veccable n) => Fractional (Vec n) where+  (/) = op2' "/"+  fromRational x = copy . uniform . show $ (fromRational x :: Float)++instance (Veccable n) => Floating (Vec n) where+  -- pi = copy $ uniform "pi"+  pi = copy $ uniform "3.141592653589793238462643383"+  exp = op1pre "exp"+  log = op1pre "log"+  sqrt = op1pre "sqrt"+  (**) = op2pre' "pow"+  sin = op1pre "sin"+  cos = op1pre "cos"+  tan = op1pre "tan"+  asin = op1pre "asin"+  acos = op1pre "acos"+  atan = op1pre "atan"+  sinh x = (exp x - exp (negate x)) / 2+  cosh x = (exp x + exp (negate x))/2+  tanh x = sinh x / cosh x+  asinh x = log $ x + sqrt(x**2 + 1)+  acosh x = log $ x + sqrt(x**2 - 1)+  atanh x = 0.5 * log ((1 + x)/(1 - x))++instance Veccable n => AdditiveGroup (Vec n) where+  zeroV = 0+  (^+^) = (+)+  negateV = negate+  (^-^) = (-)++instance Veccable n => VectorSpace (Vec n) where+  type Scalar (Vec n) = Vec 1+  a *^ b = copy a * b++instance Veccable n => InnerSpace (Vec n) where+  a <.> b = Expr fv (Tree (Op2Pre, GLSLFloat, "dot") (fmap toMono [a, b]))+    where fv = FloatVec :: FloatVec 1+++  +type (>=) x y = (x + 1 <=? y) ~ 'False++class Swizzle a where+  type InputMin a :: Nat+  type OutputDim a :: Nat+  swizzShow :: a -> String++  (!) :: forall n. (Veccable (OutputDim a), n >= InputMin a) => Vec n -> a -> Vec (OutputDim a)+  x ! sw = Expr fv (Tree (Access, toGLSLType fv, swizzShow sw) (fmap toMono [x]))+    where fv = FloatVec :: FloatVec (OutputDim a)++data X = X+instance Swizzle X where+  type InputMin X = 2+  type OutputDim X = 1+  swizzShow _ = "x"++data Y = Y+instance Swizzle Y where+  type InputMin Y = 2+  type OutputDim Y = 1+  swizzShow _ = "y"++data Z = Z+instance Swizzle Z where+  type InputMin Z = 3+  type OutputDim Z = 1+  swizzShow _ = "z"++data W = W+instance Swizzle W where+  type InputMin W = 4+  type OutputDim W = 1+  swizzShow _ = "w"++-- TODO: finish swizzling!+++vec2 :: (Vec1, Vec1) -> Vec2+vec2 (x, y) = op2pre' "vec2" x y+++class ToVec3 tuple where vec3 :: tuple -> Vec3++instance (a ~ Vec m, b ~ Vec (3 - m)) => ToVec3 (a, b) where+  vec3 (x, y) = Expr fv (Tree (Op2Pre, toGLSLType fv, "vec3") [toMono x, toMono y])+      where fv = FloatVec :: FloatVec 3++instance (a ~ Vec1, b ~ Vec1, c ~ Vec1) => ToVec3 (a, b, c) where+  vec3 (x, y, z) = Expr fv (Tree (Op3Pre, toGLSLType fv, "vec3") (fmap toMono [x, y, z]))+      where fv = FloatVec :: FloatVec 3+++class ToVec4 tuple where vec4 :: tuple -> Vec4++instance (a ~ Vec m, b ~ Vec (4 - m)) => ToVec4 (a, b) where+  vec4 (x, y) = Expr fv (Tree (Op2Pre, toGLSLType fv, "vec4") [toMono x,toMono y])+      where fv = FloatVec :: FloatVec 4++instance {-#INCOHERENT#-} (b ~ Vec1, c ~ Vec1) => ToVec4 (Vec2, b, c) where+  vec4 (x, y, z) = Expr fv (Tree (Op3Pre, toGLSLType fv, "vec4") [toMono x,toMono y,toMono z])+      where fv = FloatVec :: FloatVec 4++instance {-#INCOHERENT#-} (a ~ Vec1, c ~ Vec1) => ToVec4 (a, Vec2, c) where+  vec4 (x, y, z) = Expr fv (Tree (Op3Pre, toGLSLType fv, "vec4") [toMono x,toMono y,toMono z])+      where fv = FloatVec :: FloatVec 4++instance {-#INCOHERENT#-} (a ~ Vec1, b ~ Vec1) => ToVec4 (a, b, Vec2) where+  vec4 (x, y, z) = Expr fv (Tree (Op3Pre, toGLSLType fv, "vec4") [toMono x,toMono y,toMono z])+      where fv = FloatVec :: FloatVec 4+++instance (a ~ Vec1, b ~ Vec1, c ~ Vec1, d ~ Vec1) => ToVec4 (a, b, c, d) where+  vec4 (x, y, z, w) = Expr fv (Tree (Op4Pre, toGLSLType fv, "vec4") (fmap toMono [x, y, z, w]))+      where fv = FloatVec :: FloatVec 4
+ src/Hylogen/WithHyde.hs view
@@ -0,0 +1,48 @@+module Hylogen.WithHyde ( module Hylogen.WithHyde+                        , module Hylogen+                        ) where++import           Data.Monoid+import           Hylogen+import           Hylogen.Expr+import           Hylogen.Program (toProgram)++-- TODO: flip these definitions! Normalized means ??+uv :: Vec2+uv = uniform "uv()"++uvN :: Vec2+uvN = uniform "uvN"++time :: Vec1+time = uniform "time"+++resolution :: Vec2+resolution = uniform "resolution"++mouse :: Vec2+mouse = uniform "mouse"+++audio :: Vec4+audio = uniform "audio"++backBuffer :: Texture+backBuffer = uniform "backBuffer"++channel1 :: Texture+channel1 = uniform "channel1"+++-- | No sharing+toGLSL' :: Vec4 -> String+toGLSL' v = unlines [ "void main() {"+                    , "    gl_FragColor = " <> show v <> ";"+                    , "}"+                    ]+++-- | sharing via Data.reify+toGLSL :: Vec4 -> String+toGLSL = show . toProgram . toMono