diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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).
+
+
+
+It comes with `hyde`, an accompanying rendering environment featuring:
+- *hot-reloading*
+- audio-reactive primitives
+- texture backbuffering
+
+
+
+
+## Install
```
cabal update
cabal install hylogen
```
+This will install the hylogen package and `hyde`, the rendering environment.
+
+
+
## 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)
+
-## 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)
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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
diff --git a/hylogen.cabal b/hylogen.cabal
--- a/hylogen.cabal
+++ b/hylogen.cabal
@@ -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
diff --git a/src/Hylogen.hs b/src/Hylogen.hs
--- a/src/Hylogen.hs
+++ b/src/Hylogen.hs
@@ -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
diff --git a/src/Hylogen/Booly.hs b/src/Hylogen/Booly.hs
new file mode 100644
--- /dev/null
+++ b/src/Hylogen/Booly.hs
@@ -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"
diff --git a/src/Hylogen/CSE.hs b/src/Hylogen/CSE.hs
deleted file mode 100644
--- a/src/Hylogen/CSE.hs
+++ /dev/null
@@ -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) []
-
diff --git a/src/Hylogen/Expr.hs b/src/Hylogen/Expr.hs
new file mode 100644
--- /dev/null
+++ b/src/Hylogen/Expr.hs
@@ -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
diff --git a/src/Hylogen/Globals.hs b/src/Hylogen/Globals.hs
--- a/src/Hylogen/Globals.hs
+++ b/src/Hylogen/Globals.hs
@@ -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
diff --git a/src/Hylogen/Program.hs b/src/Hylogen/Program.hs
new file mode 100644
--- /dev/null
+++ b/src/Hylogen/Program.hs
@@ -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
diff --git a/src/Hylogen/Texture.hs b/src/Hylogen/Texture.hs
new file mode 100644
--- /dev/null
+++ b/src/Hylogen/Texture.hs
@@ -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
diff --git a/src/Hylogen/Types.hs b/src/Hylogen/Types.hs
--- a/src/Hylogen/Types.hs
+++ b/src/Hylogen/Types.hs
@@ -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
diff --git a/src/Hylogen/Vec.hs b/src/Hylogen/Vec.hs
new file mode 100644
--- /dev/null
+++ b/src/Hylogen/Vec.hs
@@ -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
diff --git a/src/Hylogen/WithHyde.hs b/src/Hylogen/WithHyde.hs
new file mode 100644
--- /dev/null
+++ b/src/Hylogen/WithHyde.hs
@@ -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