├── .gitignore ├── LICENSE ├── LambdaDesigner.cabal ├── LambdaDesigner ├── Chop.hs ├── JSONOutput.hs ├── Lib.hs ├── Op.hs └── ParsedOps.hs ├── Presentation.hs ├── README.md ├── Setup.hs ├── Source.hs ├── app └── Main.hs ├── ldesigner.el ├── scratch.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.swp 4 | *.tag 5 | *~ 6 | *_flymake.hs 7 | .hsenv 8 | .stack-work/ 9 | .stack-root/ 10 | /.cabal-sandbox/ 11 | TAGS 12 | cabal-dev/ 13 | cabal.sandbox.config 14 | dist/ 15 | tags 16 | /_release/ 17 | .vagrant/ 18 | *.imports 19 | /.idea/ 20 | /*.iml 21 | /src/highlight.js 22 | /src/style.css 23 | /_site/ 24 | /.dir-locals.el 25 | /.git/ 26 | .vscode/ -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Ulysses Popple (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /LambdaDesigner.cabal: -------------------------------------------------------------------------------- 1 | name: LambdaDesigner 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/ulyssesp/LambdaDesigner#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Ulysses Popple 9 | maintainer: ulysses.popple@gmail.com 10 | copyright: 2017 Ulysses Popple 11 | synopsis: A type-safe EDSL for TouchDesigner written in Haskell. 12 | description: TouchDesigner nodes written as functions in Haskell and sent to TouchDesigner as json. 13 | category: TouchDesigner 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: LambdaDesigner.Lib 20 | , LambdaDesigner.JSONOutput 21 | , LambdaDesigner.Op 22 | , LambdaDesigner.ParsedOps 23 | build-depends: base >= 4.7 && < 5 24 | , aeson 25 | , bytestring 26 | , bytestring-trie >= 0.2.3.2 27 | , containers >= 0.5 28 | , lens 29 | , lens-aeson 30 | , matrix 31 | , text 32 | , transformers >= 0.5 33 | , vector >= 0.11 34 | default-language: Haskell2010 35 | ghc-options: -fwarn-incomplete-patterns 36 | 37 | executable LambdaDesigner 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-patterns 41 | build-depends: base 42 | , LambdaDesigner 43 | default-language: Haskell2010 44 | 45 | source-repository head 46 | type: git 47 | location: https://github.com/ulyssesp/LambdaDesigner 48 | -------------------------------------------------------------------------------- /LambdaDesigner/Chop.hs: -------------------------------------------------------------------------------- 1 | module Chop where 2 | 3 | import Op 4 | 5 | import Data.Maybe 6 | 7 | -------------------------------------------------------------------------------- /LambdaDesigner/JSONOutput.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE RecursiveDo #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | 9 | module LambdaDesigner.JSONOutput where 10 | 11 | import Debug.Trace 12 | 13 | import LambdaDesigner.Op 14 | import LambdaDesigner.ParsedOps 15 | 16 | import Control.Lens 17 | import Control.Lens.Cons 18 | import Control.Monad.Trans.State.Lazy 19 | import Control.Monad 20 | import Data.Maybe 21 | import Data.Text.Encoding 22 | import GHC.Generics 23 | 24 | import Data.ByteString.Char8 as BS 25 | import Data.ByteString.Lazy as BSL 26 | import Data.List as L 27 | import Data.List.Lens 28 | import Data.Map.Strict as M 29 | import Data.Trie as T 30 | 31 | import qualified Data.Aeson as A 32 | import qualified Data.Vector as V 33 | import qualified Data.Text as Tx 34 | 35 | data Messagable = Create BS.ByteString 36 | | Connect Int BS.ByteString 37 | | RevConnect Int BS.ByteString 38 | | Parameter BS.ByteString BS.ByteString 39 | | RevParameter BS.ByteString BS.ByteString BS.ByteString 40 | | CustomPar BS.ByteString BS.ByteString 41 | | TextContent BS.ByteString 42 | | Command BS.ByteString [BS.ByteString] 43 | | Fixed BS.ByteString 44 | deriving (Eq, Show) 45 | 46 | data JSONNode = JSONNode { _nodeType :: Tx.Text 47 | , _nodeConnections :: [(Int, Tx.Text)] 48 | , _nodeParameters :: Map Tx.Text Tx.Text 49 | , _nodeCommands :: [(Tx.Text, [Tx.Text])] 50 | , _nodeText :: Maybe Tx.Text 51 | } 52 | deriving Generic 53 | 54 | nodeCommands :: Lens' JSONNode [(Tx.Text, [Tx.Text])] 55 | nodeCommands = lens _nodeCommands (\a b -> a {_nodeCommands = b}) 56 | 57 | nodeType :: Lens' JSONNode Tx.Text 58 | nodeType = lens _nodeType (\a b -> a {_nodeType = b}) 59 | 60 | nodeConnections :: Lens' JSONNode [(Int, Tx.Text)] 61 | nodeConnections = lens _nodeConnections (\a b -> a {_nodeConnections = b}) 62 | 63 | nodeParameters :: Lens' JSONNode (Map Tx.Text Tx.Text) 64 | nodeParameters = lens _nodeParameters (\a b -> a {_nodeParameters = b}) 65 | 66 | nodeText :: Lens' JSONNode (Maybe Tx.Text) 67 | nodeText = lens _nodeText (\a b -> a {_nodeText = b}) 68 | 69 | emptyJsonNode = JSONNode "" [] mempty [] Nothing 70 | 71 | selectchoppars = SelectCHOP Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] 72 | selecttoppars = SelectTOP Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] 73 | 74 | instance A.ToJSON JSONNode where 75 | toJSON (JSONNode {..}) = A.object [ "ty" A..= _nodeType 76 | , "connections" A..= (connsvalue _nodeConnections) 77 | , "parameters" A..= _nodeParameters 78 | , "commands" A..= comsvalue _nodeCommands 79 | , "text" A..= _nodeText 80 | ] 81 | where 82 | connsvalue cs = V.replicate (L.length cs) "" V.// cs 83 | comsvalue = V.fromList . L.map (\a -> A.object ["command" A..= fst a, "args" A..= V.fromList (snd a)]) 84 | toEncoding = A.genericToEncoding A.defaultOptions 85 | 86 | 87 | type Messages = Trie [Messagable] 88 | 89 | parseParam :: (Monad m) => Tree a -> StateT Messages m BS.ByteString 90 | parseParam t@(N p) = parseTree "" t >>= return . wrapOp 91 | parseParam t@(Comp {}) = parseTree "" t >>= return . wrapOp 92 | parseParam t@(FC {}) = parseTree "" t >>= return . wrapOp 93 | parseParam t@(FT {}) = parseTree "" t >>= return . wrapOp 94 | parseParam t@(Fix {}) = parseTree "" t >>= return . wrapOp 95 | parseParam t = parseTree "" t 96 | 97 | wrapOp :: BS.ByteString -> BS.ByteString 98 | wrapOp op = BS.concat ["op(\"", BS.tail op, "\")"] 99 | 100 | parseTree :: (Monad m) => BS.ByteString -> Tree a -> StateT Messages m BS.ByteString 101 | parseTree pre (N p) = opsMessages pre p 102 | -- parseTree pre (Comp p child) = 103 | -- do 104 | -- addr <- opsMessages pre p 105 | -- tr <- execStateT (parseTree pre child) T.empty 106 | -- let modMsg ((Connect i a):ms) = (Connect i (BS.concat [addr, a])):(modMsg ms) 107 | -- modMsg ((RevParameter i a b):ms) = (RevParameter i (BS.concat [addr, a]) b):(modMsg ms) 108 | -- modMsg (m:ms) = m:(modMsg ms) 109 | -- modMsg [] = [] 110 | -- modify $ unionR . T.fromList . fmap (\(a, ms) -> (BS.concat [addr, a], modMsg ms)) . T.toList $ tr 111 | -- return addr 112 | -- parseTree pre (BComp p f a) = do addr <- opsMessages pre p 113 | -- aaddr <- parseTree pre a 114 | -- let inNode = inOp 115 | -- outNode = outOp 116 | -- tr <- execStateT (parseTree pre $ outNode $ f inNode) T.empty 117 | -- let modMsg ((Connect i a):ms) = (Connect i (BS.concat [addr, a])):(modMsg ms) 118 | -- modMsg (m:ms) = m:(modMsg ms) 119 | -- modMsg [] = [] 120 | -- modify $ unionR . T.fromList . fmap (\(a, ms) -> (BS.concat [addr, a], modMsg ms)) . T.toList $ tr 121 | -- modify $ T.adjust ((:) (Connect 0 aaddr)) addr 122 | -- return addr 123 | parseTree pre (Comp p params ain bin cin din) = 124 | do 125 | addr <- opsMessages pre p 126 | aaddrs <- sequence $ parseTree pre <$> ain 127 | baddrs <- sequence $ parseTree pre <$> bin 128 | caddrs <- sequence $ parseTree pre <$> cin 129 | daddrs <- sequence $ parseTree pre <$> din 130 | mapM_ (\(k, p) -> 131 | do 132 | val <- parseParam p 133 | let msg = CustomPar k val 134 | modify $ T.adjust ((:) msg) addr 135 | return ()) (params) 136 | let 137 | alladdrs = mconcat [aaddrs, baddrs, caddrs,daddrs] 138 | connects = L.zipWith Connect [0..] alladdrs 139 | modify $ T.adjust ((++) connects) addr 140 | return addr 141 | parseTree pre (FC fbnod reset loop sel) = 142 | do 143 | faddr <- parseTree pre $ N $ fbnod & chopIns .~ [reset] 144 | let fname = BS.tail faddr 145 | laddr <- parseTree (BS.concat [pre, "_", fname]) (loop $ fix fname $ selectCHOP id []) 146 | let lname = BS.tail laddr 147 | saddr <- parseTree (BS.concat [pre, "_", fname]) $ sel $ selectCHOP (selectCHOPchop ?~ (fix lname $ selectCHOP id [])) [] 148 | let sname = BS.tail saddr 149 | modify $ T.adjust ((:) (RevConnect 0 faddr)) saddr 150 | removeDuplicates saddr 151 | return laddr 152 | parseTree pre (FT fbnod reset loop sel) = 153 | do 154 | faddr <- parseTree pre $ N $ fbnod & topIns .~ [reset] 155 | let fname = BS.tail faddr 156 | laddr <- parseTree (BS.concat [pre, "_", fname]) (loop $ fix fname $ selectTOP id) 157 | let lname = BS.tail laddr 158 | saddr <- parseTree (BS.concat [pre, "_", fname]) $ sel $ selectTOP (selectTOPtop ?~ (fix lname $ selectTOP id)) 159 | let sname = BS.tail saddr 160 | modify $ T.adjust ((:) (RevParameter "top" faddr laddr)) saddr 161 | removeDuplicates saddr 162 | return laddr 163 | parseTree pre (Fix name op) = 164 | do 165 | messages <- get 166 | let name' = BS.append "/" name 167 | case T.member name' messages of 168 | True -> return name' 169 | False -> do 170 | modify $ T.insert name' [(Fixed name)] 171 | addr <- parseTree pre op 172 | messages' <- get 173 | modify $ T.insert name' . ((:) (Fixed name)) . fromJust $ T.lookup addr messages' 174 | modify $ T.delete addr 175 | return name' 176 | 177 | parseTree pre (PyExpr s) = pure s 178 | parseTree pre (Mod f ta) = do aaddr <- parseParam ta 179 | return . f $ aaddr 180 | parseTree pre (Mod2 f ta tb) = do aaddr <- parseParam ta 181 | baddr <- parseParam tb 182 | return $ f aaddr baddr 183 | parseTree pre (Mod3 f ta tb tc) = do aaddr <- parseParam ta 184 | baddr <- parseParam tb 185 | caddr <- parseParam tc 186 | return $ f aaddr baddr caddr 187 | parseTree pre (Resolve r) = parseTree pre r 188 | parseTree pre (ResolvePS l) = do ps <- sequence $ parseParam . ResolveP <$> l 189 | return $ BS.concat ["[", BS.intercalate "," ps, "]"] 190 | parseTree pre (ResolveP r) = parseParam r 191 | 192 | parseCommand :: (Monad m) => BS.ByteString -> CommandType -> StateT Messages m Messagable 193 | parseCommand pre (Pulse bs v f) = pure $ Command "pulse" [bs, v, BS.pack $ show f] 194 | parseCommand pre (Store bs t) = do ttype <- parseParam t 195 | return $ Command "store" [bs, ttype] 196 | 197 | 198 | opsMessages :: (Monad m, Op a) => BS.ByteString -> a -> StateT Messages m BS.ByteString 199 | opsMessages pre a = do let ty = opType a 200 | messages <- get 201 | let addr = findEmpty ty pre messages 202 | let createMessage = Create ty 203 | let textMessage = 204 | case text a of 205 | Just content -> [TextContent content] 206 | Nothing -> [] 207 | modify $ T.insert addr (createMessage:textMessage) 208 | mapM_ (\(k, p) -> do val <- parseParam p 209 | let msg = Parameter k val 210 | modify $ T.adjust ((:) msg) addr 211 | return ()) (pars a) 212 | mapM_ (\(i, op) -> do a <- parseTree pre op 213 | let connect = Connect i a 214 | modify $ T.adjust ((:) connect) addr 215 | return a) . Prelude.zip [0..] $ connections a 216 | mapM_ (\c -> do m <- parseCommand pre c 217 | modify $ T.adjust ((:) m) addr 218 | return ()) (commands a) 219 | addr' <- removeDuplicates addr 220 | return $ addr' 221 | 222 | removeDuplicates :: (Monad m) => BS.ByteString -> StateT Messages m BS.ByteString 223 | removeDuplicates addr = do messages <- get 224 | let nodesOfType = submap (BS.takeWhile (/= '_') addr) messages 225 | let addrMsgs = T.lookup addr messages 226 | -- If messages are all the same then they're equivalent so we can combine the nodes 227 | case L.filter (\(a, ms) -> a /= addr && addrMsgs == Just ms) (T.toList nodesOfType) of 228 | ((maddr, _):_) -> do modify . T.delete $ addr 229 | return maddr 230 | _ -> return addr 231 | 232 | findEmpty :: BS.ByteString -> BS.ByteString -> Messages -> BS.ByteString 233 | findEmpty ty pre ms = L.head . L.filter (not . flip T.member ms) . L.map (\n -> BS.concat ["/", ty, "_", BS.pack $ show n, pre]) $ [0..] 234 | 235 | applyRevPars :: Messages -> Messages 236 | applyRevPars ms = L.foldl (\ms (a, msgs) -> parseMessages ms a msgs) ms $ T.toList ms 237 | where 238 | parseMessages ms addr ((RevParameter par dest local):msgs) = T.adjust ((:) (Parameter par (wrapOp local))) dest ms 239 | parseMessages ms addr ((RevConnect par dest):msgs) = T.adjust (addConnect par addr) dest ms 240 | parseMessages ms addr (_:msgs) = parseMessages ms addr msgs 241 | parseMessages ms addr [] = ms 242 | addConnect i addr (cn@(Connect i' addr'):msgs) = (if i' >= i then Connect (i' + 1) addr' else cn):(addConnect i addr msgs) 243 | addConnect i addr (msg:msgs) = msg:(addConnect i addr msgs) 244 | addConnect i addr [] = [Connect i addr] 245 | 246 | makeMessages :: Messages -> BS.ByteString 247 | makeMessages msgs = BSL.toStrict . A.encode $ A.toJSON . A.object $ 248 | L.map (\(k, v) -> decodeUtf8 k A..= jsonNode v) $ T.toList $ applyRevPars msgs 249 | 250 | jsonNode :: [Messagable] -> JSONNode 251 | jsonNode = L.foldl modmsg emptyJsonNode 252 | where 253 | modmsg jsnode (Create (Tx.pack . BS.unpack -> t)) = jsnode & nodeType .~ t 254 | modmsg jsnode (Connect i (Tx.pack . BS.unpack -> c)) = jsnode & nodeConnections %~ \cs -> (i, c):cs 255 | modmsg jsnode (Parameter (Tx.pack . BS.unpack -> k) (Tx.pack . BS.unpack -> v)) = 256 | jsnode & nodeParameters %~ M.insert k v 257 | modmsg jsnode (CustomPar (Tx.pack . BS.unpack -> k) (Tx.pack . BS.unpack -> v)) = 258 | jsnode & nodeParameters %~ M.insert k v 259 | modmsg jsnode (Command (Tx.pack . BS.unpack -> c) (L.map (Tx.pack . BS.unpack) -> as)) = 260 | jsnode & nodeCommands %~ \cs -> (c, as):cs 261 | modmsg jsnode (TextContent (Tx.pack . BS.unpack -> c)) = jsnode & nodeText ?~ c 262 | modmsg jsnode _ = jsnode -------------------------------------------------------------------------------- /LambdaDesigner/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LambdaDesigner.Lib 4 | ( topCompiler 5 | , compile 6 | , printMessages 7 | ) where 8 | 9 | import LambdaDesigner.JSONOutput 10 | import LambdaDesigner.Op 11 | import LambdaDesigner.ParsedOps 12 | 13 | import Control.Monad.Trans.State 14 | import Data.ByteString.Char8 as BS 15 | import Data.IORef 16 | import Data.Functor.Identity 17 | import Data.List 18 | import Data.Trie 19 | 20 | compile :: (Op a, Op b) => [Tree a] -> [Tree b] -> Messages -> Messages 21 | compile tas tbs state' = let 22 | ms = execState (mapM_ (\t -> parseTree "" t) tas) mempty 23 | ms' = execState (mapM_ (\t -> parseTree "" t) tbs) ms 24 | in 25 | unionR state' ms' 26 | 27 | printMessages :: Messages -> BS.ByteString 28 | printMessages state = makeMessages state 29 | 30 | topCompiler :: IO (Tree TOP -> BS.ByteString) 31 | topCompiler = do init <- newIORef mempty 32 | initState <- readIORef init 33 | return $ printMessages . flip (compile ([] :: [Tree TOP])) initState . (:[]) . outTOP id -------------------------------------------------------------------------------- /LambdaDesigner/Op.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | 10 | module LambdaDesigner.Op where 11 | 12 | import Prelude hiding (sin) 13 | 14 | import LambdaDesigner.ParsedOps 15 | 16 | import Control.Lens 17 | import Data.Matrix 18 | import Data.Maybe 19 | import Data.Monoid 20 | 21 | import Data.ByteString.Char8 as BS 22 | import Data.List as L 23 | import qualified Data.Bool as DB 24 | 25 | data Channel 26 | 27 | float :: Float -> Tree Float 28 | float = PyExpr . pack . show 29 | 30 | int :: Int -> Tree Int 31 | int = PyExpr . pack . show 32 | 33 | bool :: Bool -> Tree Bool 34 | bool = PyExpr . DB.bool "0" "1" 35 | 36 | bstr :: String -> Tree ByteString 37 | bstr = PyExpr . pack 38 | 39 | casti :: (Integral i) => Tree f -> Tree i 40 | casti = Mod (\fl -> BS.concat ["int(", fl, ")"]) 41 | 42 | castf :: (Floating f) => Tree i -> Tree f 43 | castf = Mod (\fl -> BS.concat ["float(", fl, ")"]) 44 | 45 | castb :: Tree a -> Tree b 46 | castb = Mod (\fl -> BS.concat ["bool(", fl, ")"]) 47 | 48 | caststr :: (Show a) => Tree a -> Tree ByteString 49 | caststr = Mod (\s -> BS.concat ["str(", s, ")"]) 50 | 51 | (!-) :: (Show a) => Tree a -> Tree a -> Tree a 52 | (!-) = Mod2 (\a b -> BS.concat ["(", a, "-", b, ")"]) 53 | 54 | (!*) :: (Show a) => Tree a -> Tree a -> Tree a 55 | (!*) = Mod2 (\a b -> BS.concat ["(", a, "*", b, ")"]) 56 | 57 | (!/) :: (Show a) => Tree a -> Tree a -> Tree a 58 | (!/) = Mod2 (\a b -> BS.concat ["(", a, "/", b, ")"]) 59 | 60 | (!^) :: (Show a) => Tree a -> Tree a -> Tree a 61 | (!^) = Mod2 (\a b -> BS.concat ["(", a, "**", b, ")"]) 62 | 63 | (!%) :: (Show a) => Tree a -> Tree a -> Tree a 64 | (!%) = Mod2 (\a b -> BS.concat ["(", a, "%", b, ")"]) 65 | 66 | (!==) :: Tree a -> Tree a -> Tree Bool 67 | (!==) = Mod2 (\a b -> BS.concat ["(", a, "==", b, ")"]) 68 | 69 | (!>) :: Tree a -> Tree a -> Tree Bool 70 | (!>) = Mod2 (\a b -> BS.concat ["(", a, ">", b, ")"]) 71 | 72 | (!>=) :: Tree a -> Tree a -> Tree Bool 73 | (!>=) = Mod2 (\a b -> BS.concat ["(", a, ">=", b, ")"]) 74 | 75 | (!<) :: Tree a -> Tree a -> Tree Bool 76 | (!<) = Mod2 (\a b -> BS.concat ["(", a, "<", b, ")"]) 77 | 78 | (!<=) :: Tree a -> Tree a -> Tree Bool 79 | (!<=) = Mod2 (\a b -> BS.concat ["(", a, "<=", b, ")"]) 80 | 81 | (!||) :: Tree Bool -> Tree Bool -> Tree Bool 82 | (!||) = Mod2 (\a b -> BS.concat ["(", a, ") or (", b, ")"]) 83 | 84 | (!&&) :: Tree Bool -> Tree Bool -> Tree Bool 85 | (!&&) = Mod2 (\a b -> BS.concat ["(", a, ") and (", b, ")"]) 86 | 87 | 88 | ternary :: Tree Bool -> Tree a -> Tree a -> Tree a 89 | ternary = Mod3 (\a b c -> BS.concat ["(", b, " if ", a, " else ", c, ")"]) 90 | 91 | seconds :: Tree Float 92 | seconds = PyExpr "absTime.seconds" 93 | 94 | frames :: Tree Int 95 | frames = PyExpr "absTime.frame" 96 | 97 | sampleIndex :: Tree Int 98 | sampleIndex = PyExpr "me.sampleIndex" 99 | 100 | chanIndex :: Tree Int 101 | chanIndex = PyExpr "me.chanIndex" 102 | 103 | opInput :: (Op a) => Tree Int -> Tree a 104 | opInput = Mod (\i -> BS.concat ["me.inputs[", i, "]"]) 105 | 106 | scycle :: Float -> Float -> Tree Float 107 | scycle a b = float b !* ((float a !* seconds) !% float 1) 108 | 109 | sincycle :: Float -> Float -> Tree Float 110 | sincycle a b =float b !* ((osin' $ float a !* seconds) !% float 1) 111 | 112 | floor :: (Num n) => Tree n -> Tree n 113 | floor = pyMathOp "floor" 114 | 115 | ceil :: (Num n) => Tree n -> Tree n 116 | ceil = pyMathOp "ceil" 117 | 118 | osin :: (Num n) => Tree n -> Tree n 119 | osin = pyMathOp "sin" 120 | osin' = (!* float 0.5) . (!+ float 1) . osin 121 | 122 | ocos :: (Num n) => Tree n -> Tree n 123 | ocos = pyMathOp "cos" 124 | ocos' = (!* float 0.5) . (!+ float 1) . ocos 125 | 126 | pmax :: (Num n) => Tree n -> Tree n -> Tree n 127 | pmax = Mod2 (\s t -> BS.concat ["max(", s, ", ", t, ")"]) 128 | 129 | pyMathOp :: (Num n) => String -> Tree n -> Tree n 130 | pyMathOp s = Mod (\n -> BS.concat ["math.", pack s, "(", n, ")"]) 131 | 132 | chan :: Int -> Tree CHOP -> Tree Channel 133 | chan n = Mod (\c -> BS.concat [c, "[", pack $ show n, "]"]) 134 | 135 | chan0 :: Tree CHOP -> Tree Channel 136 | chan0 = chan 0 137 | 138 | chanName :: String -> Tree CHOP -> Tree Channel 139 | chanName s = Mod (\c -> BS.concat [c, "[\"", pack s, "\"]"]) 140 | 141 | chanf :: Int -> Tree CHOP -> Tree Float 142 | chanf = (fmap . fmap) castf chan 143 | 144 | chan0f :: Tree CHOP -> Tree Float 145 | chan0f = castf . chan0 146 | 147 | chanNamef :: String -> Tree CHOP -> Tree Float 148 | chanNamef = (fmap . fmap) castf chanName 149 | 150 | chanSample :: Tree Int -> Tree Channel -> Tree Float 151 | chanSample = Mod2 (\i c -> BS.concat [c, "[", i, "]"]) 152 | 153 | numRows :: Tree DAT -> Tree Int 154 | numRows = Mod (\d -> BS.concat [d, ".numRows"]) 155 | 156 | -- Op helpers 157 | 158 | 159 | fix :: (Op a) => BS.ByteString -> Tree a -> Tree a 160 | fix = Fix 161 | 162 | feedbackC :: Tree CHOP -> (Tree CHOP -> Tree CHOP) -> (Tree CHOP -> Tree CHOP) -> Tree CHOP 163 | feedbackC = FC $ FeedbackCHOP Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] [] 164 | 165 | feedbackT :: Tree TOP -> (Tree TOP -> Tree TOP) -> (Tree TOP -> Tree TOP) -> Tree TOP 166 | feedbackT = FT $ FeedbackTOP Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] [] 167 | 168 | bcomppars = BaseCOMP Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] [] 169 | 170 | tox :: (Op a, Op b) => String -> (COMP -> COMP) -> [(ByteString, Tree ByteString)] -> Tree a -> Tree b 171 | tox t fs ps = Comp (bcomppars & (baseCOMPexternaltox ?~ str t) & fs & (compCommands .~ [Pulse "reinitnet" "1" 2])) ps ([] :: [Tree TOP]) ([] :: [Tree CHOP]) ([] :: [Tree DAT]) . (:[]) 172 | 173 | tox0 :: (Op a) => String -> (COMP -> COMP) -> [(ByteString, Tree ByteString)] -> Tree a 174 | tox0 t fs ps = Comp (bcomppars & (baseCOMPexternaltox ?~ (str t)) & fs & (compCommands .~ [Pulse "reinitnet" "1" 2])) ps ([] :: [Tree TOP]) ([] :: [Tree CHOP]) ([] :: [Tree DAT]) ([] :: [Tree MAT]) 175 | 176 | tox2 :: (Op a, Op b, Op c) => String -> (COMP -> COMP) -> [(ByteString, Tree ByteString)] -> Tree a -> Tree b -> Tree c 177 | tox2 t fs ps a b = Comp (bcomppars & (baseCOMPexternaltox ?~ str t) & fs & (compCommands .~ [Pulse "reinitnet" "1" 2])) ps ([] :: [Tree TOP]) ([] :: [Tree CHOP]) ([a]) ([b]) -------------------------------------------------------------------------------- /Presentation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Presentation where 4 | 5 | import Op 6 | import Lib 7 | import Visuals 8 | 9 | import Prelude hiding (floor, mod) 10 | 11 | import Control.Lens 12 | import Data.Matrix 13 | 14 | go = run [outT $ ] mempty 15 | 16 | simple1 = 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # λDesigner 2 | 3 | A type-safe EDSL for TouchDesigner written in Haskell. Instead of connecting nodes by hand, use the power of algebraic data types to program TouchDesigner projects in Haskell. 4 | 5 | ## Getting Started 6 | 7 | ### Prerequisites 8 | 9 | * TouchDesigner 10 | * `dictdiffer` python3 library 11 | * Haskell (only tested with [haskellstack](https://docs.haskellstack.org/en/stable/README/)) 12 | 13 | ### Installing 14 | 15 | 1. Clone or download [LambdaDesigner-sample](https://github.com/ulyssesp/lambdadesigner-sample). 16 | 2. Run `stack build` in the created directory 17 | 3. Open `LambdaDesigner.toe` 18 | 4. Run `stack exec LambdaDesigner-exe` 19 | 5. Check TouchDesigner - you should be seeing a banana! 20 | 21 | 22 | ## Using 23 | 24 | ### Setup 25 | 26 | This takes you through [`Main.hs`](https://github.com/ulyssesp/LambdaDesigner-sample/blob/master/app/Main.hs). Note that you must be running [`LambdaDesigner.toe`](https://github.com/ulyssesp/LambdaDesigner-sample/blob/master/TD/LambdaDesigner.toe) to see the results of running code. 27 | 28 | The first thing you need to do is grab a reference to the runner. 29 | 30 | ``` 31 | topRunner :: IO ( Tree TOP -> IO () ) 32 | 33 | main = do 34 | r <- topRunner 35 | ... 36 | ``` 37 | 38 | This will let us run a `Tree TOP` which will show up as an output connector on the `lambda` COMP in TouchDesigner. Lets see this happening by creating a `movieFileIn` top with the sample image. 39 | 40 | ``` 41 | main = do 42 | r <- topRunner 43 | r $ movieFileIn (bstr "app.samplesFolder+'/Map/Banana.tif'") 44 | ``` 45 | 46 | We have something we can run! 47 | 48 | ``` 49 | $ stack build 50 | $ stack exec LambdaDesigner-sample-exe 51 | ``` 52 | 53 | Take a look at it running in TouchDesigner! To experiment with different node types check out [the wiki](https://github.com/ulyssesp/lambdadesigner/wiki). Not every TouchDesigner node is represented yet, but the most common ones are there. 54 | 55 | You can also experiment with LambdaDesigner in ghci. The following code will create a node with the text "Hello, World!" 56 | 57 | ``` 58 | $ stack ghci 59 | > r <- topRunner 60 | > r $ textT id (bstr "Hello, world!") 61 | ``` 62 | 63 | ### More complex networks 64 | 65 | * If you're new to TouchDesigner, check out the [TouchDesigner wiki](https://www.derivative.ca/wiki099/index.php?title=Main_Page) for [some examples of nodes](https://www.derivative.ca/wiki099/index.php?title=Operator)! You can play around with nodes in TouchDesigner until you get an idea of how everything works. Even if you solely use LambdaDesigner, it's useful to understand what's happening in TouchDesigner to debug. Most of the nodes are implemented, but if you need a new node or parameter, please file an issue. 66 | 67 | * Try out [intero](https://commercialhaskell.github.io/intero/). It's a good way to compile and run hs files easily. 68 | 69 | * Check out some of [Oscillare's node functions](https://github.com/ulyssesp/oscillare/blob/master/src/Visuals.hs), they give a good idea of what LambdaDesigner can do. Everything under "Gens" is a `Tree TOP` and everything under "Effects" is a `Tree TOP -> Tree TOP`. Note that some of them depend on the `.frag` files found in [TD/scripts/Visuals](https://github.com/ulyssesp/oscillare/tree/master/TD/scripts/Visuals) 70 | 71 | 72 | ## Troubleshooting 73 | 74 | #### The `scripts` node has errors 75 | 76 | Click on the red X on the top right of the node. If it says that `dictdiffer` isn't found, make sure you have installed the `dictdiffer` python library using `pip`, and that TouchDesigner knows which python module directory to use. Check out the [TouchDesigner wiki article](http://derivative.ca/wiki099/index.php?title=Introduction_to_Python_Tutorial#Importing_Modules). 77 | 78 | If it's a different error, then please file an issue. 79 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Source.hs: -------------------------------------------------------------------------------- 1 | module Source where 2 | 3 | import Op 4 | import Lib 5 | 6 | import Control.Lens 7 | 8 | go 9 | = run [outT $ visual] mempty 10 | 11 | visual = 12 | vidIn 13 | & blur (float 27) 14 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import LambdaDesigner.Lib 4 | 5 | main :: IO () 6 | main = return () 7 | -------------------------------------------------------------------------------- /ldesigner.el: -------------------------------------------------------------------------------- 1 | ;; This mode is implemented as a derivation of `haskell' mode, 2 | ;; indentation and font locking is courtesy that mode. The 3 | ;; inter-process communication is courtesy `comint'. The symbol at 4 | ;; point acquisition is courtesy `thingatpt'. The directory search 5 | ;; facilities are courtesy `find-lisp'. 6 | 7 | (require 'comint) 8 | (require 'inf-haskell) 9 | 10 | (defvar oscillare-buffer 11 | "*oscillare*" 12 | ) 13 | 14 | (defun oscillare-start-haskell () 15 | "Start oscillare" 16 | (interactive) 17 | (call-interactively 'inferior-haskell-start-process) 18 | (oscillare-send-string ":module Oscillare") 19 | (oscillare-send-string "(p, t, base, thread) <- run") 20 | (split-window-below-and-focus) 21 | (switch-to-buffer inferior-haskell-buffer) 22 | ) 23 | 24 | (defun oscillare-quit-haskell () 25 | "Quit osicllare." 26 | (interactive) 27 | (switch-to-buffer inferior-haskell-buffer) 28 | (kill-buffer-and-window)) 29 | 30 | (defun oscillare-restart-haskell() 31 | "Restart oscillare" 32 | (interactive) 33 | (oscillare-quit-haskell) 34 | (oscillare-start-haskell) 35 | ) 36 | 37 | (defun oscillare-send-string (s) 38 | (if (comint-check-proc inferior-haskell-buffer) 39 | (let ((cs (chunk-string 64 (concat s "\n")))) 40 | (mapcar 41 | (lambda (c) (comint-send-string inferior-haskell-buffer c)) 42 | cs)) 43 | (error "no oscillare buffer running"))) 44 | 45 | (defun oscillare-run-line () 46 | "Send the current line to the haskell buffer" 47 | (interactive) 48 | (let* ((s (buffer-substring (line-beginning-position) 49 | (line-end-position)))) 50 | (oscillare-send-string s))) 51 | 52 | (defun oscillare-run-multiple-lines () 53 | "Send the current region to the interpreter as a single line." 54 | (interactive) 55 | (save-excursion 56 | (mark-paragraph) 57 | (let* ((s (buffer-substring-no-properties (region-beginning) 58 | (region-end)))) 59 | (oscillare-send-string ":{") 60 | (oscillare-send-string s) 61 | (oscillare-send-string ":}") 62 | (mark-paragraph) 63 | (pulse-momentary-highlight-region (mark) (point)) 64 | ))) 65 | 66 | (defun chunk-string (n s) 67 | "Split a string into chunks of n characters" 68 | (let* ((l (length s)) 69 | (m (min l n)) 70 | (c (substring s 0 m))) 71 | (if (<= l n) 72 | (list c) 73 | (cons c (chunk-string n (substring s n)))))) 74 | 75 | (defun oscillare-see-output () 76 | "Show output buffer" 77 | (interactive) 78 | (when (comint-check-proc inferior-haskell-buffer) 79 | (with-current-buffer inferior-haskell-buffer 80 | (let ((window (display-buffer (current-buffer)))) 81 | (goto-char (point-max)) 82 | (save-selected-window 83 | (set-window-point window (point-max))))))) 84 | 85 | (defun oscillare-mode-keybindings (map) 86 | "Oscillare keybindings" 87 | (define-key map [?\C-c ?\C-s] 'oscillare-see-output) 88 | (define-key map [?\C-c ?\C-c] 'oscillare-run-line) 89 | (define-key map (kbd "") 'oscillare-run-multiple-lines)) 90 | 91 | (defvar oscillare-mode-map nil 92 | "Keymap for oscillare") 93 | 94 | (if oscillare-mode-map 95 | () 96 | (let ((map (make-sparse-keymap "Oscillare"))) 97 | (oscillare-mode-keybindings map) 98 | (setq oscillare-mode-map map))) 99 | 100 | (define-derived-mode 101 | oscillare-mode 102 | haskell-mode 103 | "Oscillare" 104 | "Major mode for interacting with oscillare.") 105 | 106 | (add-to-list 'auto-mode-alist '("\\.osc$" . oscillare-mode)) 107 | 108 | (provide 'oscillare) 109 | -------------------------------------------------------------------------------- /scratch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import LambdaDesigner.Op 4 | import LambdaDesigner.ParsedOps 5 | import LambdaDesigner.Lib 6 | import LambdaDesigner.JSONOutput 7 | 8 | import Prelude hiding (floor, mod) 9 | 10 | import Control.Lens 11 | import Data.Char 12 | import Data.IORef 13 | import Data.Matrix 14 | import Data.Maybe 15 | import Data.List as L 16 | 17 | import Debug.Trace 18 | 19 | import qualified Data.Vector as V 20 | import qualified Data.ByteString.Char8 as BS 21 | 22 | go = 23 | let 24 | -- constctest = feedbackC (constantCHOP (constantCHOPvalue1 ?~ float 0.5) []) id (mathCHOP (mathCHOPpreoff ?~ float 4) . (:[])) & beatCHOP id . (:[]) 25 | flocking = tox0 "toxes/Visuals/flockingGpu.tox" [ ("Cohesion", ResolveP $ float 0.5) 26 | , ("Separation", ResolveP $ float 1) 27 | , ("Alignment", ResolveP $ float 0.5) 28 | , ("Speed", ResolveP $ float 4) 29 | ] 30 | -- aspect = audiospectrumCHOP id . (:[]) $ audiodeviceinCHOP id [] 31 | -- aspecttex = choptoTOP (choptoTOPchop ?~ aspect) 32 | in do 33 | putStrLn . show $ printMessages $ compile ( [] :: [Tree CHOP] ) [flocking :: Tree TOP] (mempty :: Messages) 34 | -- run r [ outT $ chopToT $ logic' (logicCombineChops ?~ int 1) [logic' (logicCombineChans ?~ int 6) [constC [float 5, floor (seconds !% float 10)]], constC [float 1]]] 35 | 36 | -- go = 37 | -- let 38 | -- modlights = scriptD' (datVars .~ [ ("behaviours", Resolve $ behavioursT) 39 | -- , ("lights", Resolve $ int numactors) 40 | -- , ("attrs", Resolve $ int numattrs) 41 | -- , ("set", Resolve $ fileD "scripts/setBehaviour.py") 42 | -- , ("delta", Resolve $ fileD "scripts/deltaBehaviour.py") 43 | -- , ("acc", Resolve $ fileD "scripts/accBehaviour.py") 44 | -- , ("move", Resolve $ fileD "scripts/moveBehaviour.py") 45 | -- , ("clamp", Resolve $ fileD "scripts/clampBehaviour.py") 46 | -- , ("attract", Resolve $ fileD "scripts/attractBehaviour.py") 47 | -- , ("copy", Resolve $ fileD "scripts/copyBehaviour.py") 48 | -- , ("backandforth", Resolve $ fileD "scripts/backAndForthBehaviour.py") 49 | -- , ("volume", Resolve $ analyze (int 6) ain) 50 | -- , ("noise", Resolve $ noiseC' ((noiseCTranslate._3 ?~ seconds !* float 20) . (noiseCAmplitude ?~ float 0.001) . (noiseCChannels ?~ str "chan0 chan1 chan2 chan3"))) 51 | -- ]) "scripts/behavioursScriptDAT.py" [] 52 | -- edat = executeD' ((datVars .~ [ ("modlights", Resolve $ modlights) 53 | -- ] 54 | -- ) . (executeDatFramestart ?~ "op(me.fetch(\"modlights\")[1:]).cook(force=True)")) [] 55 | -- -- step = 0.2 56 | -- -- steps = [0, step .. 1] 57 | -- -- band = chan0f . analyze (int 6) . flip bandPass ain 58 | -- -- input = Input audioIn 59 | -- -- ltranslate f = float (f * 1.2) !- float 0.6 60 | -- -- lightgeo f ins = geo' ((geoTranslate._1 ?~ castf (cell (int f, int pX) ins)) 61 | -- -- . (geoTranslate._2 ?~ castf (cell (int f, int pY) ins)) 62 | -- -- . (geoTranslate._3 ?~ float 3) 63 | -- -- . (geoUniformScale ?~ float (step * 0.1)) 64 | -- -- . (geoMat ?~ lmat (float $ fromIntegral f)) 65 | -- -- ) (outS $ tubeS' (tubeHeight ?~ float 10)) 66 | -- -- lrender = render' id ((\f -> lightgeo f modlights) <$> [0..(numactors - 1)]) cam & hsvT' (hsvAdjValMult ?~ float 1.3) 67 | -- -- palettecolor = croppalette buddhist 68 | -- -- chopcol l n = palettecolor (float l !+ (seconds !* float 0.3)) & topToC & chanf n 69 | -- -- lights l = light' ((lightColor .~ v3 (chopcol l 0) (chopcol l 1) (chopcol l 2)) 70 | -- -- . (lightTranslate._1 ?~ ltranslate l) 71 | -- -- . (lightAttenuated ?~ bool True) 72 | -- -- . (lightAttenuationStart ?~ float 0) 73 | -- -- . (lightAttenuationEnd ?~ float 12) 74 | -- -- . (lightAttenuationRolloff ?~ float 2) 75 | -- -- ) 76 | -- -- lmat l = pbrM' (pbrEmitColorMap ?~ (palettecolor (l !+ (seconds !* float 0.3)))) 77 | -- -- wallgeo = geo' ((geoMat ?~ pbrM' ((pbrMetallic ?~ float 0) . (pbrBaseColorMap ?~ movieFileIn (str "C:/Users/ulyssesp/Downloads/concrete_bare_2159_2638_Small.jpg")))) . (geoUniformScale ?~ float 2) . (geoTranslate._3 ?~ float (3)) . (geoScale._2 ?~ float 0.5) . (geoScale._3 ?~ float 2)) $ outS $ boxS' id 78 | -- -- wallrender = render' (renderLight .~ (lights <$> steps)) [wallgeo] cam 79 | -- input = Input audioIn 80 | -- ltranslate f = float (f * 1.2) !- float 0.6 81 | -- lightgeo f ins = geo' ((geoTranslate .~ v3 (bchan f pX ins) (bchan f pY ins) (bchan f pZ ins)) 82 | -- . (geoUniformScale ?~ float (0.02)) 83 | -- . (geoMat ?~ lmat (bchan f col ins)) 84 | -- ) (outS $ sphere) 85 | -- lrender = render' id ((\f -> lightgeo f modlights) <$> [0..(numactors - 1)]) rendercam & hsvT' (hsvAdjValMult ?~ float 1.3) 86 | -- palettecolor = croppalette tealcontrast 87 | -- chopcol l n = palettecolor l & topToC & chanf n 88 | -- lights ins l = light' ((lightColor .~ v3 (chopcol (bchan l col ins) 0) (chopcol (bchan l col ins) 1) (chopcol (bchan l col ins) 2)) 89 | -- . (lightTranslate .~ v3 (bchan l pX ins) (bchan l pY ins) (bchan l pZ ins)) 90 | -- . (lightAttenuated ?~ bool True) 91 | -- . (lightAttenuationStart ?~ float 0) 92 | -- . (lightAttenuationEnd ?~ float 3) 93 | -- . (lightAttenuationRolloff ?~ float 10) 94 | -- . (lightDimmer ?~ float 2) 95 | -- ) 96 | -- lmat l = pbrM' (pbrEmitColorMap ?~ (palettecolor l)) 97 | -- wallgeo = geo' ((geoMat ?~ pbrM' ((pbrMetallic ?~ float 0) . (pbrBaseColorMap ?~ movieFileIn (str "C:/Users/ulyssesp/Downloads/concrete_bare_2159_2638_Small.jpg")))) . (geoUniformScale ?~ float 2) . (geoScale._2 ?~ float 0.25) . (geoScale._3 ?~ float 1)) $ outS $ boxS' id 98 | -- centerCam t r l = cam' ((camTranslate .~ t) . (camPivot .~ v3mult (float (-1)) t) . (camRotate .~ r) . (camLookAt ?~ l)) 99 | -- rendercam = centerCam (v3 (float 3) (float 2) (float 3)) emptyV3 wallgeo 100 | -- wallrender = render' ((renderLight .~ (lights modlights <$> [0..(numactors - 1)])) . (renderCullFace ?~ int 2)) [wallgeo] rendercam 101 | -- in 102 | -- do r <- newIORef mempty 103 | -- run r [ outT $ compT 31 [compT 31 [lrender, lrender & blur (float 32)], wallrender] ] 104 | 105 | -- ain = math' (mathMult ?~ float 0.1) [audioIn] 106 | -- volume = chan0f $ analyze (int 6) ain 107 | -- op0 = opInput (int 0) 108 | -- vX = 0 109 | -- vY = 1 110 | -- vZ = 2 111 | -- pX = 3 112 | -- pY = 4 113 | -- pZ = 5 114 | -- col = 6 115 | -- numattrs = 7 116 | -- initLight = constC $ replicate numattrs (float 0) 117 | -- initLights = mergeC $ replicate numactors initLight 118 | -- modinputs = V.fromList $ flip chanf op0 <$> [0..(numattrs * numactors)] 119 | 120 | -- bchan :: Int -> Int -> Tree DAT -> Tree Float 121 | -- bchan i ch = castf . cell (int i, int ch) 122 | 123 | 124 | -- data Input = Input (Tree CHOP) 125 | -- data Behaviour = Set Int Float String 126 | -- | Delta Int Float Int String 127 | -- | Add Int Float 128 | -- | Clamp Int Int Float Float 129 | -- | BackAndForth Int Int Float String 130 | -- | Diminish Int Float 131 | -- | Acc Int Int 132 | -- | Attract Int Int Int Int Int Int Float Float 133 | -- | CopyNearest Int Int Int Int Float 134 | -- | Conshaviour Behaviour Behaviour 135 | 136 | -- posupdate = Conshaviour (Acc pX vX) 137 | -- $ Conshaviour (Diminish vX 0.99) 138 | -- $ Conshaviour (Acc pY vY) 139 | -- $ Conshaviour (Diminish vY 0.99) 140 | -- $ Conshaviour (Acc pZ vZ) 141 | -- $ Diminish vZ 0.99 142 | 143 | -- lightclamp = Conshaviour (Clamp pX vX (-0.5) 0.5) $ 144 | -- Conshaviour (Clamp pY vY (-0.2) 0.2) $ 145 | -- Clamp pZ vZ (-0.5) 0.5 146 | 147 | -- behaviours = [ [Delta vY 0.6 0 "volume", Add vY (-0.008), Delta vX 0.3 0 "noise", Delta vZ 0.3 1 "noise", Delta col 0.4 0 "volume", lightclamp, posupdate] 148 | -- , [BackAndForth pZ vZ 0.12 "volume", BackAndForth pX vX 3 "noise", lightclamp, posupdate] 149 | -- , [Attract pX pY pZ vX vY vZ 1 0.001, CopyNearest pX pY pZ col 0.02, lightclamp, posupdate] 150 | -- , [Attract pX pY pZ vX vY vZ 1 0.0001, CopyNearest pX pY pZ col 0.04, lightclamp, posupdate] 151 | -- , [Attract pX pY pZ vX vY vZ 1 0.0001, Attract pX pY pZ vX vY vZ 0.2 (-0.001), Add col 0.001, lightclamp, posupdate] 152 | -- ] 153 | 154 | -- numactors = length behaviours 155 | 156 | -- scriptCDAT :: String -> (DAT -> DAT) -> [Tree CHOP] -> Tree CHOP 157 | -- scriptCDAT file df = N <$> ScriptCHOP (fileD' df file) 158 | 159 | -- blist :: Int -> Behaviour -> [[BS.ByteString]] 160 | -- blist i (Set c v d) = (:[]) $ BS.pack <$> ["set", show i, show c, show v, d] 161 | -- blist i (Delta c v chan d) = (:[]) $ BS.pack <$> ["delta", show i, show c, show v, show chan, d] 162 | -- blist i (Acc a b) = (:[]) $ BS.pack <$> ["acc", show i, show a, show b] 163 | -- blist i (Add c v) = (:[]) $ BS.pack <$> ["move", show i, show c, show v] 164 | -- blist i (Clamp clamper clamped mn mx) = (:[]) $ BS.pack <$> ["clamp", show i, show clamper, show clamped, show mn, show mx] 165 | -- blist i (BackAndForth base change mult delta) = (:[]) $ BS.pack <$> ["backandforth", show i, show base, show change, show mult, delta] 166 | -- blist i (Attract x y z vx vy vz r v) = (:[]) $ BS.pack <$> ["attract", show i, show x, show y, show z, show vx, show vy, show vz, show r, show v] 167 | -- blist i (CopyNearest x y z t v) = (:[]) $ BS.pack <$> ["copy", show i, show x, show y, show z, show t, show v] 168 | -- blist i (Conshaviour b b') = blist i b ++ blist i b' 169 | -- blist _ _ = [] 170 | -- bslist i = fmap (blist i) 171 | 172 | 173 | -- padlist :: [BS.ByteString] -> [BS.ByteString] 174 | -- padlist l = l ++ replicate ((maximum $ length <$> behavioursM) - (length l)) "0" 175 | -- behavioursM = mconcat . mconcat $ zipWith bslist [0..] behaviours 176 | -- paddedBehavioursM = padlist <$> filter (not . null) behavioursM 177 | -- behavioursT = table $ fromLists paddedBehavioursM 178 | 179 | -- band :: Tree CHOP -> Tree Float -> Tree Float 180 | -- band ain = chan0f . analyze (int 6) . flip bandPass ain 181 | 182 | -- fade' f l o t = feedbackT t (\t' -> l $ compT 0 [t, levelT' (levelOpacity ?~ o) t']) f 183 | -- fade = fade' id id 184 | 185 | -- scr = (++) "scripts/" 186 | 187 | -- neon = Palette $ Hex <$> ["A9336B", "5F2F88", "CB673D", "87BB38"] 188 | -- fire = Palette $ Hex . BS.pack . fmap toUpper <$> ["f07f13", "800909", "f27d0c", "fdcf58"] 189 | -- buddhist = Palette $ Hex . BS.pack . fmap toUpper <$> ["0000FF", "FFFF00", "FF0000", "FFFFFF", "FF9800"] 190 | -- tealcontrast = Palette [RGB 188 242 246, RGB 50 107 113, RGB 211 90 30, RGB 209 122 43, RGB 188 242 246] 191 | -- purplish = Palette [RGB 150 110 100, RGB 223 143 67, RGB 76 73 100 , RGB 146 118 133, RGB 165 148 180] 192 | -- sunset = Palette [RGB 185 117 19, RGB 228 187 108, RGB 251 162 1, RGB 255 243 201] 193 | -- coolpink = Palette [RGB 215 40 26, RGB 157 60 121, RGB 179 83 154, RGB 187 59 98] 194 | -- darkestred = Palette [RGB 153 7 17, RGB 97 6 11, RGB 49 7 8, RGB 13 7 7, RGB 189 5 13] 195 | -- nature = Palette [RGB 63 124 7, RGB 201 121 66, RGB 213 101 23, RGB 177 201 80, RGB 180 207 127] 196 | 197 | -- colorToBS :: Int -> Int -> Color -> [BS.ByteString] 198 | -- colorToBS n i (Hex str) = 199 | -- let 200 | -- hexes = chunksOf 2 . drop 1 201 | -- todig = flip L.elemIndex "0123456789ABCDEF" 202 | -- toIntList = fmap todig 203 | -- toInt = foldr (\i acc -> acc * 16 + i) 0 204 | -- toHex = fmap toInt . sequence . toIntList 205 | -- hextorgb = fmap (BS.pack . show . (/ 256) . fromIntegral) 206 | -- in 207 | -- catMaybes $ (hextorgb <$> (toHex <$> hexes (show str))) ++ [Just "1.0", Just . BS.pack . show $ fromIntegral i / fromIntegral n] 208 | -- colorToBS n i (RGB r g b) = 209 | -- (++ [BS.pack . show $ fromIntegral i / fromIntegral n]) $ fmap (BS.pack . show . (/ 256) . fromIntegral) [r, g, b, 256] 210 | 211 | -- build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] 212 | -- build g = g (:) [] 213 | 214 | -- chunksOf :: Int -> [e] -> [[e]] 215 | -- chunksOf i ls = map (take i) (build (splitter ls)) where 216 | -- splitter :: [e] -> ([e] -> a -> a) -> a -> a 217 | -- splitter [] _ n = n 218 | -- splitter l c n = l `c` splitter (drop i l) c n 219 | 220 | -- data Palette = Palette [Color] 221 | -- data Color = Hex BS.ByteString | RGB Int Int Int 222 | -- palette (Palette colors) = ramp' (topResolution .~ iv2 (128, 0)) . table 223 | -- . fromLists $ ["r", "g", "b", "a", "pos"]:(zipWith (colorToBS (length colors)) [0..] colors) 224 | 225 | -- translate' f t = transformT' ((transformExtend ?~ int 3) . (transformTranslate .~ t) . f) 226 | -- croppalette p s = crop' ((cropLeft ?~ s) . (cropRight ?~ s)) $ palette p 227 | 228 | 229 | 230 | -- -- let 231 | -- -- step = 0.2 232 | -- -- steps = [0, step .. 1] 233 | -- -- band = chan0f . analyze (int 6) . flip bandPass ain 234 | -- -- input = Input audioIn 235 | -- -- ltranslate f = float (f * 1.2) !- float 0.6 236 | -- -- lightgeo f ins = geo' ((geoTranslate._1 ?~ chanf (f * numattrs + pX) ins) 237 | -- -- . (geoTranslate._2 ?~ chanf (f * numattrs + pY) ins) 238 | -- -- . (geoTranslate._3 ?~ float 3) 239 | -- -- . (geoUniformScale ?~ float (step * 0.1)) 240 | -- -- . (geoMat ?~ lmat (float $ fromIntegral f)) 241 | -- -- ) (outS $ tubeS' (tubeHeight ?~ float 10)) 242 | -- -- lrender = render' id ((\f -> lightgeo f modlights) <$> [0..(numactors - 1)]) cam & hsvT' (hsvAdjValMult ?~ float 1.3) 243 | -- -- palettecolor = croppalette buddhist 244 | -- -- chopcol l n = palettecolor (float l !+ (seconds !* float 0.3)) & topToC & chanf n 245 | -- -- lights l = light' ((lightColor .~ v3 (chopcol l 0) (chopcol l 1) (chopcol l 2)) 246 | -- -- . (lightTranslate._1 ?~ ltranslate l) 247 | -- -- . (lightAttenuated ?~ bool True) 248 | -- -- . (lightAttenuationStart ?~ float 0) 249 | -- -- . (lightAttenuationEnd ?~ float 12) 250 | -- -- . (lightAttenuationRolloff ?~ float 2) 251 | -- -- ) 252 | -- -- lmat l = pbrM' (pbrEmitColorMap ?~ (palettecolor (l !+ (seconds !* float 0.3)))) 253 | -- -- wallgeo = geo' ((geoMat ?~ pbrM' ((pbrMetallic ?~ float 0) . (pbrBaseColorMap ?~ movieFileIn (str "C:/Users/ulyssesp/Downloads/concrete_bare_2159_2638_Small.jpg")))) . (geoUniformScale ?~ float 2) . (geoTranslate._3 ?~ float (3)) . (geoScale._2 ?~ float 0.5) . (geoScale._3 ?~ float 2)) $ outS $ boxS' id 254 | -- -- wallrender = render' (renderLight .~ (lights <$> steps)) [wallgeo] cam 255 | -- -- in 256 | -- -- do r <- newIORef mempty 257 | -- -- run r [ outT $ compT 31 [compT 31 [lrender, lrender & blur (float 32)], wallrender] ] 258 | 259 | -- -- data Input = Input (Tree CHOP) 260 | -- -- data Behaviour = VolUp | GoDown | TopOut | StartX Float 261 | 262 | -- -- behaviours = [[VolUp, GoDown, TopOut], [StartX 0.2]] 263 | -- -- numactors = length behaviours 264 | 265 | -- -- replaceexprs :: [(Int, Tree Float)] -> (Tree CHOP -> Tree CHOP) 266 | -- -- replaceexprs rexp = expressionC (V.toList $ modinputs V.// rexp) . (:[]) 267 | 268 | -- -- modlights = fix "feedbacks" $ feedbackC (mergeC $ zipWith ($) (zipWith (\i bs -> foldr (.) id $ behaviourInit i <$> bs) [0..] behaviours) $ (\i -> selLight i initLights) <$> [0..(numactors-1)]) id id 269 | 270 | -- -- -- . expressionC (V.toList $ modinputs V.// (mconcat $ 271 | -- -- -- (\i -> [ (i * numattrs + pX, chanf (i * numattrs + pX) op0 !+ chanf (i * numattrs + vX) op0 ) 272 | -- -- -- , (i * numattrs + pY, chanf (i * numattrs + pY) op0 !+ chanf (i * numattrs + vY) op0 ) 273 | -- -- -- , (i * numattrs + vX, chanf (i * numattrs + vX) op0 !* float 0.99) 274 | -- -- -- , (i * numattrs + vY, chanf (i * numattrs + vY) op0 !* float 0.99) 275 | -- -- -- ]) <$> [0..(numactors - 1)]) 276 | -- -- -- ) . (:[])) 277 | 278 | -- -- selLight i = deleteCNum' (deleteCNonScoped ?~ bool True) (str $ mconcat ["[", show (i * numattrs), "-", show ((i + 1) * numattrs - 1),"]"]) 279 | 280 | -- -- replacechans :: [(Int, Tree CHOP -> Tree CHOP)] -> (Tree CHOP -> Tree CHOP) 281 | -- -- replacechans rexp = (\ins -> replaceC [ins, mergeC . (fmap ($ ins)) $ (\(i, e) -> e . selectCConnect' (selectCNames ?~ PyExpr (BS.concat $ ["me.inputs[0][", BS.pack $ show i, "].name"]))) <$> rexp]) 282 | 283 | -- -- bindex i ch = i * numattrs + ch 284 | -- -- bchan i ch = chanf (bindex i ch) modlights 285 | 286 | -- -- behaviourOp :: Int -> Behaviour -> (Tree CHOP -> Tree CHOP) 287 | -- -- behaviourOp i VolUp = replacechans [ (bindex i vY, math' (mathAdd .~ Just (volume !* float 0.02)) . (:[])) ] 288 | -- -- behaviourOp i GoDown = replacechans [ (bindex i vY, replaceexprs [(0, ternary (bchan i pY !> float (-0.2)) (bchan 0 0 !- float 0.008) (float 0))])] 289 | -- -- behaviourOp i TopOut = replacechans [ (bindex i vY, replaceexprs [(0, ternary (bchan i pY !> float (-0.2)) (bchan 0 0 !- float 0.008) (float 0))])] 290 | -- -- behaviourOp i _ = id 291 | 292 | -- -- behaviourInit :: Int -> Behaviour -> (Tree CHOP -> Tree CHOP) 293 | -- -- behaviourInit i (StartX x) = replaceexprs [ (2, float x) ] 294 | -- -- behaviourInit i _ = id 295 | 296 | -- -- ain = math' (mathMult ?~ float 1) [audioIn] 297 | -- -- volume = chan0f $ analyze (int 6) ain 298 | 299 | -- -- op0 = opInput (int 0) 300 | -- -- vX = 0 301 | -- -- vY = 1 302 | -- -- pX = 2 303 | -- -- pY = 3 304 | -- -- numattrs = 4 305 | -- -- initLight = constC $ replicate numattrs (float 0) 306 | -- -- initLights = mergeC $ replicate numactors initLight 307 | -- -- modinputs = V.fromList $ flip chanf op0 <$> [0..(numattrs * numactors)] 308 | 309 | -- -- band :: Tree CHOP -> Tree Float -> Tree Float 310 | -- -- band ain = chan0f . analyze (int 6) . flip bandPass ain 311 | 312 | -- -- fade' f l o t = feedbackT t (\t' -> l $ compT 0 [t, levelT' (levelOpacity ?~ o) t']) f 313 | -- -- fade = fade' id id 314 | 315 | -- -- data Palette = Palette [Color] 316 | -- -- data Color = Hex BS.ByteString | RGB Int Int Int 317 | -- -- palette (Palette colors) = ramp' (topResolution .~ iv2 (128, 0)) . table 318 | -- -- . fromLists $ ["r", "g", "b", "a", "pos"]:(zipWith (colorToBS (length colors)) [0..] colors) 319 | 320 | -- -- translate' f t = transformT' ((transformExtend ?~ int 3) . (transformTranslate .~ t) . f) 321 | -- -- croppalette p s = crop' ((cropLeft ?~ s) . (cropRight ?~ s)) $ palette p 322 | 323 | -- -- scr = (++) "scripts/" 324 | 325 | -- -- neon = Palette $ Hex <$> ["A9336B", "5F2F88", "CB673D", "87BB38"] 326 | -- -- fire = Palette $ Hex . BS.pack . fmap toUpper <$> ["f07f13", "800909", "f27d0c", "fdcf58"] 327 | -- -- buddhist = Palette $ Hex . BS.pack . fmap toUpper <$> ["0000FF", "FFFF00", "FF0000", "FFFFFF", "FF9800"] 328 | -- -- tealcontrast = Palette [RGB 188 242 246, RGB 50 107 113, RGB 211 90 30, RGB 209 122 43, RGB 188 242 246] 329 | -- -- purplish = Palette [RGB 150 110 100, RGB 223 143 67, RGB 76 73 100 , RGB 146 118 133, RGB 165 148 180] 330 | -- -- sunset = Palette [RGB 185 117 19, RGB 228 187 108, RGB 251 162 1, RGB 255 243 201] 331 | -- -- coolpink = Palette [RGB 215 40 26, RGB 157 60 121, RGB 179 83 154, RGB 187 59 98] 332 | -- -- darkestred = Palette [RGB 153 7 17, RGB 97 6 11, RGB 49 7 8, RGB 13 7 7, RGB 189 5 13] 333 | -- -- nature = Palette [RGB 63 124 7, RGB 201 121 66, RGB 213 101 23, RGB 177 201 80, RGB 180 207 127] 334 | 335 | -- -- colorToBS :: Int -> Int -> Color -> [BS.ByteString] 336 | -- -- colorToBS n i (Hex str) = 337 | -- -- let 338 | -- -- hexes = chunksOf 2 . drop 1 339 | -- -- todig = flip L.elemIndex "0123456789ABCDEF" 340 | -- -- toIntList = fmap todig 341 | -- -- toInt = foldr (\i acc -> acc * 16 + i) 0 342 | -- -- toHex = fmap toInt . sequence . toIntList 343 | -- -- hextorgb = fmap (BS.pack . show . (/ 256) . fromIntegral) 344 | -- -- in 345 | -- -- catMaybes $ (hextorgb <$> (toHex <$> hexes (show str))) ++ [Just "1.0", Just . BS.pack . show $ fromIntegral i / fromIntegral n] 346 | -- -- colorToBS n i (RGB r g b) = 347 | -- -- (++ [BS.pack . show $ fromIntegral i / fromIntegral n]) $ fmap (BS.pack . show . (/ 256) . fromIntegral) [r, g, b, 256] 348 | 349 | -- -- build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] 350 | -- -- build g = g (:) [] 351 | 352 | -- -- chunksOf :: Int -> [e] -> [[e]] 353 | -- -- chunksOf i ls = map (take i) (build (splitter ls)) where 354 | -- -- splitter :: [e] -> ([e] -> a -> a) -> a -> a 355 | -- -- splitter [] _ n = n 356 | -- -- splitter l c n = l `c` splitter (drop i l) c n 357 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-12.1 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | - location: 41 | git: git@github.com:ulyssesp/bytestring-trie.git 42 | commit: a44aaaa93ea50914c105f85c67c7c5aa8c8d36d8 43 | extra-dep: true 44 | # Dependency packages to be pulled from upstream that are not in the resolver 45 | # (e.g., acme-missiles-0.3) 46 | extra-deps: [] 47 | 48 | # Override default flag values for local packages and extra-deps 49 | flags: {} 50 | 51 | # Extra package databases containing global packages 52 | extra-package-dbs: [] 53 | 54 | # Control whether we use the GHC we find on the path 55 | # system-ghc: true 56 | # 57 | # Require a specific version of stack, using version ranges 58 | # require-stack-version: -any # Default 59 | # require-stack-version: ">=1.4" 60 | # 61 | # Override the architecture used by stack, especially useful on Windows 62 | # arch: i386 63 | # arch: x86_64 64 | # 65 | # Extra directories used by stack for building 66 | # extra-include-dirs: [/path/to/dir] 67 | # extra-lib-dirs: [/path/to/dir] 68 | # 69 | # Allow a newer minor version of GHC than the snapshot specifies 70 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------