csound-expression-typed 0.0.6.1 → 0.0.7.0
raw patch · 16 files changed
+388/−87 lines, 16 filesdep ~csound-expression-dynamicPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: csound-expression-dynamic
API changes (from Hackage documentation)
- Csound.Typed.Types.Tuple: instance Sigs ((Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig), (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig))
- Csound.Typed.Types.Tuple: instance Sigs ((Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig), (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig), (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig), (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig))
+ Csound.Typed: infiniteDur :: Num a => a
+ Csound.Typed.Control: evtLoop :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a
+ Csound.Typed.Control: evtLoopOnce :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a
+ Csound.Typed.Control: retrigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [a] -> b
+ Csound.Typed.Gui: defText :: String -> Gui
+ Csound.Typed.Gui: panelIsKeybdSensitive :: Panel -> Bool
+ Csound.Typed.Types.Prim: instance Num (Sig, Sig)
+ Csound.Typed.Types.Prim: instance Num (Sig, Sig, Sig)
+ Csound.Typed.Types.Prim: instance Num (Sig, Sig, Sig, Sig)
+ Csound.Typed.Types.Prim: instance Num (Sig, Sig, Sig, Sig, Sig, Sig)
+ Csound.Typed.Types.Prim: instance Num (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)
- Csound.Typed.Types.Tuple: class Tuple a => Sigs a
+ Csound.Typed.Types.Tuple: class (Tuple a, Num a) => Sigs a
Files
- csound-expression-typed.cabal +4/−2
- src/Csound/Typed.hs +3/−1
- src/Csound/Typed/Constants.hs +6/−0
- src/Csound/Typed/Control/Evt.hs +165/−3
- src/Csound/Typed/Control/Midi.hs +1/−9
- src/Csound/Typed/GlobalState.hs +8/−1
- src/Csound/Typed/GlobalState/Cache.hs +3/−44
- src/Csound/Typed/GlobalState/Elements.hs +19/−1
- src/Csound/Typed/GlobalState/GE.hs +21/−9
- src/Csound/Typed/GlobalState/Instr.hs +28/−5
- src/Csound/Typed/GlobalState/Opcodes.hs +43/−2
- src/Csound/Typed/Gui/Gui.hs +11/−1
- src/Csound/Typed/Gui/Widget.hs +10/−4
- src/Csound/Typed/Render.hs +15/−2
- src/Csound/Typed/Types/Prim.hs +48/−1
- src/Csound/Typed/Types/Tuple.hs +3/−2
csound-expression-typed.cabal view
@@ -1,5 +1,5 @@ Name: csound-expression-typed-Version: 0.0.6.1+Version: 0.0.7.0 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE@@ -25,7 +25,7 @@ Ghc-Options: -Wall Build-Depends: base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq,- wl-pprint, stable-maps >= 0.0.3.3, csound-expression-dynamic >= 0.1.0+ wl-pprint, stable-maps >= 0.0.3.3, csound-expression-dynamic >= 0.1.1 Hs-Source-Dirs: src/ Exposed-Modules: Csound.Typed@@ -67,3 +67,5 @@ Csound.Typed.Gui.Gui Csound.Typed.Gui.Widget Csound.Typed.Gui.BoxModel++ Csound.Typed.Constants
src/Csound/Typed.hs view
@@ -1,9 +1,11 @@ module Csound.Typed( module Csound.Typed.Types, module Csound.Typed.Control,- module Csound.Typed.Render + module Csound.Typed.Render,+ module Csound.Typed.Constants ) where import Csound.Typed.Types import Csound.Typed.Control import Csound.Typed.Render+import Csound.Typed.Constants
+ src/Csound/Typed/Constants.hs view
@@ -0,0 +1,6 @@+module Csound.Typed.Constants(+ infiniteDur+) where++infiniteDur :: Num a => a+infiniteDur = 7 * 24 * 60 * 60 -- a week
src/Csound/Typed/Control/Evt.hs view
@@ -1,13 +1,16 @@ {-# Language FlexibleContexts #-} module Csound.Typed.Control.Evt(- trigs, scheds, schedHarps, + trigs, scheds, schedHarps, retrigs, evtLoop, evtLoopOnce, trigsBy, schedsBy, schedHarpsBy, trigs_, scheds_, ) where import System.Mem.StableName +import Data.Boolean+ import Control.Applicative+import Control.Monad import Control.Monad.IO.Class import qualified Csound.Dynamic as C@@ -18,6 +21,7 @@ import Csound.Typed.Control.Instr import Csound.Typed.Control.SERef+import Csound.Typed.Constants(infiniteDur) ------------------------------------------------- -- triggereing the events@@ -67,7 +71,155 @@ event chnId (start, dur, args) = hideGEinDep $ fmap C.event $ C.Event instrId <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args) +retrigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [a] -> b+retrigs instr evts = apInstr0 $ do+ key <- evtKey evts instr+ withCache InfiniteDur getEvtKey saveEvtKey key $ do+ cacheName <- liftIO $ C.makeCacheName instr+ instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig cacheName (funArity instr) (insExp instr)+ saveRetrigEvtInstr (arityOuts $ funArity instr) instrId evts+ +saveRetrigEvtInstr :: Arg a => Int -> C.InstrId -> Evt [a] -> GE C.InstrId+saveRetrigEvtInstr arity instrId evts = saveInstr $ do+ aliveCountRef <- newSERef (10 :: D)+ retrigWatchRef <- newSERef (0 :: D)+ evtMixInstr aliveCountRef retrigWatchRef+ where+ evtMixInstr :: SERef D -> SERef D -> SE ()+ evtMixInstr aliveCountRef retrigWatchRef = do+ chnId <- fromDep $ C.chnRefAlloc arity+ go aliveCountRef retrigWatchRef chnId evts+ fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId + aliveCount <- readSERef aliveCountRef+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount + go :: Arg a => SERef D -> SERef D -> GE C.ChnRef -> Evt [a] -> SE ()+ go aliveCountRef retrigWatchRef mchnId events = + runEvt events $ \es -> do+ writeSERef aliveCountRef $ int $ 2 * length es + modifySERef retrigWatchRef (+ 1)+ chnId <- geToSe mchnId+ currentRetrig <- readSERef retrigWatchRef+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig + fromDep_ $ mapM_ (event chnId currentRetrig) es+ + event :: Arg a => C.ChnRef -> D -> a -> Dep ()+ event chnId currentRetrig args = hideGEinDep $ fmap C.event $ do+ currentRetrigExp <- toGE currentRetrig+ C.Event instrId 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args) ++evtLoop :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a+evtLoop = evtLoopGen True++evtLoopOnce :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a+evtLoopOnce = evtLoopGen False++evtLoopGen :: (Num a, Tuple a, Sigs a) => Bool -> Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a+evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do+ key <- evtKey evts instr+ withCache InfiniteDur getEvtKey saveEvtKey key $ do+ cacheName <- liftIO $ C.makeCacheName instr + (instrId, evtInstrId) <- saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop cacheName (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts)+ saveEvtLoopInstr mustLoop loopLength maybeOffEvt (arityOuts $ constArity instr) instrId evtInstrId+ where + loopLength = int $ lcm (length instrs) (length evts)+ instr = toSingleInstr instrs++ toInstrExp :: a -> (Unit -> a)+ toInstrExp = const++ toSingleInstr :: (Num a, Tuple a) => [SE a] -> SE a+ toSingleInstr as = do+ let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length as)+ ref <- newSERef 0+ zipWithM_ (f ref n) (fmap (sig . int) [0 .. ]) as+ readSERef ref+ where + f ref n ix a = when1 (n ==* ix) $ writeSERef ref =<< a++ toSingleEvt :: [Evt Unit] -> SE ()+ toSingleEvt evts = do+ let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length evts)+ zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts+ where + f n ix evt = when1 (n ==* ix) $ evtLoopInstr evt++evtLoopInstr :: Evt Unit -> SE ()+evtLoopInstr evts = do+ runEvt evts $ const $ fromDep_ $ servantUpdateChnEvtLoop (C.chnPargId $ 0)++saveEvtLoopInstr :: Bool -> D -> Maybe (Evt Unit) -> Int -> C.InstrId -> C.InstrId -> GE C.InstrId+saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = saveInstr $ do+ aliveCountRef <- newSERef (10 :: D)+ retrigWatchRef <- newSERef (0 :: D) + evtMixInstr aliveCountRef retrigWatchRef+ where+ evtMixInstr :: SERef D -> SERef D -> SE ()+ evtMixInstr aliveCountRef retrigWatchRef = do+ chnId <- fromDep $ C.chnRefAlloc arity+ initStartInstrs chnId+ isOn <- fmap sig $ case maybeOffEvt of+ Nothing -> return 1+ Just offEvt -> do+ isOn <- newSERef (1 :: D) + runEvt offEvt $ const $ do+ writeSERef isOn 0+ modifySERef retrigWatchRef (+ 1)+ currentRetrig <- readSERef retrigWatchRef+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig chnId $ toGE currentRetrig + readSERef isOn ++ masterEvt <- fmap (sigToEvt . (* isOn) . fromGE . fmap C.changed . toGE) $ readServantEvt chnId+ go aliveCountRef retrigWatchRef chnId masterEvt+ fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId + aliveCount <- readSERef aliveCountRef+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount ++ go = goBy (+ 1) ++ goBy :: (D -> D) -> SERef D -> SERef D -> GE C.ChnRef -> Evt Unit -> SE ()+ goBy updateRetrig aliveCountRef retrigWatchRef mchnId events = + runEvt events $ \es -> do + modifySERef retrigWatchRef updateRetrig+ chnId <- geToSe mchnId+ currentRetrig <- readSERef retrigWatchRef+ if not mustLoop + then do+ when1 (sig currentRetrig >=* (sig loopLength)) $ do+ fromDep_ turnoff+ else return ()+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig + audioEvent chnId currentRetrig+ evtEvent chnId currentRetrig ++++ fireEventFor :: (C.ChnRef -> E -> C.Event) -> C.ChnRef -> D -> SE ()+ fireEventFor f chnId currentRetrig = fromDep_ $ hideGEinDep $ fmap C.event $ do+ currentRetrigExp <- toGE currentRetrig+ return $ f chnId currentRetrigExp ++ audioEvent = fireEventFor eventForAudioInstr+ evtEvent = fireEventFor eventForEvtInstr++ startEvtInstr chnId currentRetrig = C.event $ eventForEvtInstr chnId currentRetrig++ initStartInstrs mchnId = fromDep_ $ hideGEinDep $ do+ chnId <- mchnId+ return $ initStartEvtInstr chnId >> initStartAudioInstr chnId++ initStartEvtInstr chnId = C.event_i $ eventForEvtInstr chnId 0 + initStartAudioInstr chnId = C.event_i $ eventForAudioInstr chnId 0++ eventForEvtInstr = eventFor evtInstrId+ eventForAudioInstr = eventFor instrId++ eventFor idx chnId currentRetrig = + C.Event idx 0 infiniteDur [C.chnRefId chnId, currentRetrig] ++ readServantEvt :: GE C.ChnRef -> SE Sig+ readServantEvt chnId = SE $ fmap fromE $ hideGEinDep $ fmap readChnEvtLoop chnId+ -- | It's like the function @trigs@, but delay is set to zero. scheds :: (Arg a, Sigs b) => (a -> SE b) -> Evt [(D, a)] -> b scheds instr evts = apInstr0 $ do@@ -99,7 +251,7 @@ cacheName <- liftIO $ C.makeCacheName instr instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr) saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) evts)- where phi a = (0, -1, a)+ where phi a = (0, infiniteDur, a) -- | A closure to trigger an instrument inside the body of another instrument. schedHarpsBy :: (Arg a, Sigs b, Arg c) => D -> (a -> SE b) -> (c -> Evt [a]) -> (c -> b)@@ -109,7 +261,7 @@ cacheName <- liftIO $ C.makeCacheName instr instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr) saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) $ evts toArg)- where phi a = (0, -1, a)+ where phi a = (0, infiniteDur, a) autoOff :: Sigs a => D -> a -> SE a autoOff dt sigs = fmap toTuple $ fromDep $ hideGEinDep $ phi =<< fromTuple sigs@@ -148,4 +300,14 @@ evtKey :: a -> b -> GE EvtKey evtKey a b = liftIO $ EvtKey <$> hash a <*> hash b where hash x = hashStableName <$> makeStableName x+++-------------------------------------------------------------------+-- sample level triggering++samNext :: (Sigs a) => Evt Unit -> a -> a -> a+samNext = undefined++samLoop :: (Sigs a) => Evt Unit -> a -> a+samLoop = undefined
src/Csound/Typed/Control/Midi.hs view
@@ -52,15 +52,7 @@ pgmidi_ mchn = genMidi_ (Pgmassign mchn) genMidi_ :: MidiType -> Channel -> (Msg -> SE ()) -> SE ()-genMidi_ midiType chn instr = fromDep_ $ hideGEinDep $ do- key <- midiKey midiType chn instr- withCache InfiniteDur getMidiProcKey saveMidiProcKey key $ - saveMidiInstr_ midiType chn (unitExp $ fmap (const unit) $ instr Msg)---------------------------------------------------------------------midiKey :: MidiType -> Channel -> a -> GE MidiKey-midiKey ty chn a = liftIO $ MidiKey ty chn . hashStableName <$> makeStableName a +genMidi_ midiType chn instr = geToSe $ saveToMidiInstr midiType chn (unSE $ instr Msg) ----------------------------------------------------------------- -- midi ctrls
src/Csound/Typed/GlobalState.hs view
@@ -10,10 +10,17 @@ getIn, chnUpdateUdo, renderGlobals, turnoff, turnoff2, exitnow, oscListen, oscInit, oscSend, chnSet, chnGet, + readChnEvtLoop, masterUpdateChnAlive, servantUpdateChnAlive,+ masterUpdateChnRetrig,+ servantUpdateChnRetrig,+ servantUpdateChnEvtLoop,+ getRetrigVal, SfFluid(..), SfSpec(..), renderSf, sfVar,- sfSetList+ sfSetList,+ -- * Midis+ MidiType(..), Channel ) where import Csound.Typed.GlobalState.Options
src/Csound/Typed/GlobalState/Cache.hs view
@@ -1,13 +1,5 @@ module Csound.Typed.GlobalState.Cache(- Cache(..), HashKey,-- -- * Midi- -- ** Functions- CacheMidi, MidiKey(..), Channel, MidiType(..),- saveMidiKey, getMidiKey,- -- ** Procedures- CacheMidiProc, - saveMidiProcKey, getMidiProcKey,+ Cache(..), HashKey, -- * Mix -- ** Functions CacheMix, MixKey(..),@@ -30,15 +22,13 @@ import Csound.Dynamic data Cache m = Cache - { cacheMidi :: CacheMidi - , cacheMidiProc :: CacheMidiProc m- , cacheMix :: CacheMix+ { cacheMix :: CacheMix , cacheMixProc :: CacheMixProc m , cacheEvt :: CacheEvt , cacheEvtProc :: CacheEvtProc m } instance Default (Cache m) where- def = Cache def def def def def def+ def = Cache def def def def type HashKey = Int @@ -50,37 +40,6 @@ saveKeyMap :: (Ord key) => (Cache m -> M.Map key val) -> (M.Map key val -> Cache m -> Cache m) -> SaveKey m key val saveKeyMap getter setter key val cache = setter (M.insert key val $ getter cache) cache--------------------------------------------------------------- Midi--type Channel = Int--data MidiType = Massign | Pgmassign (Maybe Int)- deriving (Eq, Ord)--data MidiKey = MidiKey MidiType Channel HashKey- deriving (Eq, Ord)---- Midi functions--type CacheMidi = M.Map MidiKey [E]--getMidiKey :: GetKey m MidiKey [E]-getMidiKey = getKeyMap cacheMidi--saveMidiKey :: SaveKey m MidiKey [E]-saveMidiKey = saveKeyMap cacheMidi (\a x -> x { cacheMidi = a })---- Midi procedures--type CacheMidiProc m = M.Map MidiKey (DepT m ())--getMidiProcKey :: GetKey m MidiKey (DepT m ())-getMidiProcKey = getKeyMap cacheMidiProc--saveMidiProcKey :: SaveKey m MidiKey (DepT m ())-saveMidiProcKey = saveKeyMap cacheMidiProc (\a x -> x { cacheMidiProc = a }) ---------------------------------------------------------- -- Mix
src/Csound/Typed/GlobalState/Elements.hs view
@@ -12,6 +12,8 @@ readBandLimited, readBandLimitedConstCps, -- ** String arguments StringMap, newString,+ -- * Midi+ MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr, -- * Global variables Globals(..), newPersistentGlobalVar, newClearableGlobalVar, renderGlobals,@@ -185,7 +187,23 @@ readBandLimitedConstCps :: Int -> E -> E readBandLimitedConstCps n cps = oscili 1 cps (vco2ift cps (int n))- ++----------------------------------------------------------+-- Midi++type Channel = Int++data MidiType = Massign | Pgmassign (Maybe Int)+ deriving (Show, Eq, Ord)++data MidiKey = MidiKey MidiType Channel+ deriving (Show, Eq, Ord)++type MidiMap m = M.Map MidiKey (DepT m ())++saveMidiInstr :: Monad m => MidiType -> Channel -> DepT m () -> MidiMap m -> MidiMap m+saveMidiInstr ty chn body = M.insertWith (flip (>>)) (MidiKey ty chn) body+ -- global variables data Globals = Globals
src/Csound/Typed/GlobalState/GE.hs view
@@ -4,13 +4,13 @@ -- * Globals onGlobals, -- * Midi- MidiAssign(..), Msg(..), renderMidiAssign, saveMidi, + MidiAssign(..), Msg(..), renderMidiAssign, saveMidi, saveToMidiInstr, MidiCtrl(..), saveMidiCtrl, renderMidiCtrl, -- * Instruments saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr, -- * Total duration TotalDur(..), pureGetTotalDurForF0, getTotalDurForTerminator, - setDurationForce, setDuration, setDurationToInfinite,+ setDurationForce, setDuration, setDurationToInfinite, -- * Notes addNote, -- * GEN routines@@ -24,10 +24,10 @@ -- * Cache GetCache, SetCache, withCache, -- * Guis- newGuiHandle, saveGuiRoot, appendToGui, + newGuiHandle, saveGuiRoot, saveDefKeybdPanel, appendToGui, newGuiVar, getPanels, guiHandleToVar, guiInstrExp,- listenKeyEvt, Key(..), KeyEvt(..),+ listenKeyEvt, Key(..), KeyEvt(..), Guis(..), getKeyEventListener ) where @@ -48,8 +48,9 @@ import Csound.Typed.GlobalState.Options import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements+import Csound.Typed.Constants(infiniteDur) -import Csound.Typed.Gui.Gui(Panel, GuiNode, GuiHandle(..), restoreTree, guiMap, mapGuiOnPanel)+import Csound.Typed.Gui.Gui(Panel(..), Win(..), GuiNode, GuiHandle(..), restoreTree, guiMap, mapGuiOnPanel, defText) type Dep a = DepT GE a @@ -83,6 +84,7 @@ { genMap :: GenMap , stringMap :: StringMap , sfMap :: SfMap+ , midiMap :: MidiMap GE , globals :: Globals , instrs :: Instrs , midis :: [MidiAssign]@@ -96,7 +98,7 @@ , guis :: Guis } instance Default History where- def = History def def def def def def def def def def (return ()) def def def+ def = History def def def def def def def def def def def (return ()) def def def data Msg = Msg data MidiAssign = MidiAssign MidiType Channel InstrId@@ -136,9 +138,6 @@ InfiniteDur -> infiniteDur ExpDur e -> e -infiniteDur :: Num a => a-infiniteDur = 7 * 24 * 60 * 60 -- a week - setDurationToInfinite :: GE () setDurationToInfinite = setTotalDur InfiniteDur @@ -178,6 +177,10 @@ saveMidi ma = onMidis $ modify (ma: ) where onMidis = onHistory midis (\a h -> h { midis = a }) +saveToMidiInstr :: MidiType -> Channel -> Dep () -> GE ()+saveToMidiInstr ty chn expr = onMidiMap (saveMidiInstr ty chn expr)+ where onMidiMap = modifyHistoryField midiMap (\a h -> h { midiMap = a })+ saveMidiCtrl :: MidiCtrl -> GE () saveMidiCtrl ma = onMidis $ modify (ma: ) where onMidis = onHistory midiCtrls (\a h -> h { midiCtrls = a })@@ -230,6 +233,9 @@ modifyHistory :: (History -> History) -> GE () modifyHistory = GE . lift . modify +modifyHistoryField :: (History -> a) -> (a -> History -> History) -> (a -> a) -> GE ()+modifyHistoryField getter setter f = modifyHistory (\h -> setter (f $ getter h) h)+ modifyWithHistory :: (History -> (a, History)) -> GE a modifyWithHistory f = GE $ lift $ state f @@ -314,6 +320,12 @@ saveGuiRoot :: Panel -> GE () saveGuiRoot g = modifyGuis $ \st -> st { guiStateRoots = g : guiStateRoots st }++saveDefKeybdPanel :: GE ()+saveDefKeybdPanel = saveGuiRoot $ Single (Win "" Nothing g) isKeybd+ where + g = defText "keyboard listener"+ isKeybd = True bumpGuiStateId :: Guis -> (Int, Guis) bumpGuiStateId s = (guiStateNewId s, s{ guiStateNewId = succ $ guiStateNewId s })
src/Csound/Typed/GlobalState/Instr.hs view
@@ -1,6 +1,7 @@ module Csound.Typed.GlobalState.Instr where import Control.Monad+import Data.Map import Csound.Dynamic import qualified Csound.Typed.GlobalState.Elements as C@@ -10,7 +11,7 @@ import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Options import Csound.Typed.GlobalState.Cache-import Csound.Typed.GlobalState.Opcodes(turnoff2, exitnow, servantUpdateChnAlive)+import Csound.Typed.GlobalState.Opcodes(turnoff2, exitnow, servantUpdateChnAlive, servantUpdateChnRetrig) import Csound.Typed.GlobalState.Elements(getInstrIds) data Arity = Arity@@ -30,12 +31,30 @@ livenessWatch :: Arity -> SE () livenessWatch arity = fromDep_ $ servantUpdateChnAlive (C.chnPargId $ arityIns arity) +retrigWatch :: Arity -> SE ()+retrigWatch arity = fromDep_ $ servantUpdateChnRetrig (C.chnPargId $ arityIns arity)+ saveSourceInstrCachedWithLivenessWatch :: C.CacheName -> Arity -> InsExp -> GE InstrId saveSourceInstrCachedWithLivenessWatch cacheName arity instr = saveCachedInstr cacheName $ do toOut =<< instr livenessWatch arity where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) +saveSourceInstrCachedWithLivenessWatchAndRetrig :: C.CacheName -> Arity -> InsExp -> GE InstrId+saveSourceInstrCachedWithLivenessWatchAndRetrig cacheName arity instr = saveCachedInstr cacheName $ do+ toOut =<< instr+ retrigWatch arity+ livenessWatch arity + where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity)++saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop :: C.CacheName -> Arity -> InsExp -> UnitExp -> GE (InstrId, InstrId)+saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop cacheName arity instr evtInstr = do + instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig cacheName arity instr+ evtInstrId <- saveInstr (evtInstr >> retrigWatch evtInstrArity >> livenessWatch evtInstrArity)+ return (instrId, evtInstrId)+ where + evtInstrArity = Arity 0 0+ saveSourceInstrCached :: C.CacheName -> Arity -> InsExp -> GE InstrId saveSourceInstrCached cacheName arity instr = saveCachedInstr cacheName $ toOut =<< instr where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity)@@ -68,7 +87,7 @@ gainLevel <- fmap defGain getOptions saveAlwaysOnInstr =<< (saveInstr $ (SE . C.sendOut (arityOuts arity) . C.safeOut gainLevel) =<< sigs) -saveMidiInstr :: MidiType -> Channel -> Arity -> InsExp -> GE [E]+saveMidiInstr :: C.MidiType -> C.Channel -> Arity -> InsExp -> GE [E] saveMidiInstr midiType channel arity instr = do setDurationToInfinite vars <- onGlobals $ sequence $ replicate (arityOuts arity) (C.newClearableGlobalVar Ar 0)@@ -77,11 +96,15 @@ saveMidi $ MidiAssign midiType channel instrId return $ fmap readOnlyVar vars -saveMidiInstr_ :: MidiType -> Channel -> UnitExp -> GE (Dep ())+saveMidiMap :: GE ()+saveMidiMap = do+ m <- fmap midiMap getHistory+ mapM_ (\(C.MidiKey midiType channel, instrExpr) -> saveMidiInstr_ midiType channel (SE instrExpr)) $ toList m++saveMidiInstr_ :: C.MidiType -> C.Channel -> UnitExp -> GE () saveMidiInstr_ midiType channel instr = do instrId <- onInstr . C.saveInstr =<< execSE instr- saveMidi $ MidiAssign midiType channel instrId- return $ return ()+ saveMidi $ MidiAssign midiType channel instrId saveIns0 :: Int -> [Rate] -> SE [E] -> GE [E] saveIns0 arity rates as = do
src/Csound/Typed/GlobalState/Opcodes.hs view
@@ -2,9 +2,12 @@ sprintf, -- * channel opcodes ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, + readChnEvtLoop, chnUpdateUdo, masterUpdateChnAlive, servantUpdateChnAlive,+ masterUpdateChnRetrig, servantUpdateChnRetrig,+ servantUpdateChnEvtLoop, getRetrigVal, -- * trigger an instrument- Event(..), event, event_i, appendChn, subinstr, subinstr_, changed,+ Event(..), event, event_i, appendChn, subinstr, subinstr_, changed, diff, delay1, -- * output out, outs, safeOut, autoOff, turnoff, turnoff2, exitnow, -- * vco2@@ -61,18 +64,50 @@ masterUpdateChnAlive :: Monad m => ChnRef -> E -> DepT m () masterUpdateChnAlive ref count = chnsetK count (chnAliveName $ chnRefId ref) +masterUpdateChnRetrig :: Monad m => ChnRef -> E -> DepT m ()+masterUpdateChnRetrig ref count = chnsetK count (chnRetrigName $ chnRefId ref) + servantUpdateChnAlive :: Monad m => Int -> DepT m () servantUpdateChnAlive pargId = do let sName = chnAliveName (pn pargId) kAlive <- chngetK sName- when1 (kAlive <* 0) $ do+ when1 (kAlive <* -10) $ do turnoff chnsetK (kAlive - 1) sName +getRetrigVal :: Int -> E+getRetrigVal pargId = pn $ pargId + 1++servantUpdateChnRetrig :: Monad m => Int -> DepT m ()+servantUpdateChnRetrig pargId = do+ let sName = chnRetrigName (pn pargId) + let retrigVal = pn $ pargId + 1+ kRetrig <- chngetK sName+ when1 (kRetrig /=* retrigVal) $ do+ turnoff ++servantUpdateChnEvtLoop :: Monad m => Int -> DepT m ()+servantUpdateChnEvtLoop pargId = do+ let sName = chnEvtLoopName (pn pargId) + kEvtLoop <- chngetK sName+ chnsetK (ifB (kEvtLoop ==* 0) 1 0) sName+ turnoff++readChnEvtLoop :: Monad m => ChnRef -> DepT m E+readChnEvtLoop ref = chngetK $ chnEvtLoopName (chnRefId ref)+ chnAliveName :: E -> E chnAliveName chnId = sprintf formatString [chnId] where formatString = str $ "alive" ++ "_" ++ "%d" +chnRetrigName :: E -> E+chnRetrigName chnId = sprintf formatString [chnId]+ where formatString = str $ "retrig" ++ "_" ++ "%d"++chnEvtLoopName :: E -> E+chnEvtLoopName chnId = sprintf formatString [chnId]+ where formatString = str $ "evtLoop" ++ "_" ++ "%d"+ sprintf :: E -> [E] -> E sprintf a as = opcs "sprintf" [(Sr, Sr:repeat Ir)] (a:as) @@ -143,6 +178,12 @@ changed :: E -> E changed x = opcs "changed" [(Kr, [Kr])] [x]++diff :: E -> E+diff x = opcs "diff" [(Kr, [Kr])] [x]++delay1 :: E -> E+delay1 x = opcs "delay1" [(Ar, [Ar])] [x] -- output
src/Csound/Typed/Gui/Gui.hs view
@@ -2,6 +2,7 @@ Panel(..), Win(..), GuiNode(..), GuiHandle(..), Gui(..), Elem(..), InitMe(..), restoreTree, guiMap, mapGuiOnPanel, fromElem, fromGuiHandle,+ panelIsKeybdSensitive, defText, guiStmt, -- * Layout@@ -49,6 +50,7 @@ import qualified Csound.Typed.Gui.BoxModel as Box import Csound.Typed.Gui.BoxModel(Rect(..))+import Csound.Typed.Constants(infiniteDur) newtype GuiHandle = GuiHandle { unGuiHandle :: Int } @@ -221,6 +223,11 @@ , tabsContent :: [Win] , tabsIsKeybdSensitive :: Bool } +panelIsKeybdSensitive :: Panel -> Bool+panelIsKeybdSensitive x = case x of+ Single _ res -> res+ Tabs _ _ _ res -> res+ data Win = Win { winTitle :: String , winRect :: Maybe Rect@@ -237,6 +244,9 @@ type ElemOuts = [Var] +defText :: String -> Gui+defText str = Gui $ Box.Prim (ElemWithOuts [Var LocalVar Ir "keybd"] [] $ Box str)+ fromElem :: ElemOuts -> [InitMe] -> Elem -> Gui fromElem outs inits el = Gui $ Box.prim (ElemWithOuts outs inits el) @@ -570,7 +580,7 @@ [getButtonBankType ctx, int xn, int yn] ++ frameWithoutLabel ++ [noOpc] -- FLbutton's- drawButton instrId = f "FLbutton" $ [int 1, int 0, getButtonType ctx] ++ frameWithoutLabel ++ (onOpc instrId [0, -1])+ drawButton instrId = f "FLbutton" $ [int 1, int 0, getButtonType ctx] ++ frameWithoutLabel ++ (onOpc instrId [0, infiniteDur]) drawToggle = f "FLbutton" $ [int 1, int 0, getToggleType ctx] ++ frameWithoutLabel ++ [noOpc]
src/Csound/Typed/Gui/Widget.hs view
@@ -30,6 +30,7 @@ import Csound.Dynamic hiding (int, when1) import qualified Csound.Typed.GlobalState.Elements as C+import qualified Csound.Typed.GlobalState.Opcodes as C import Csound.Typed.Gui.Gui import Csound.Typed.GlobalState@@ -360,18 +361,23 @@ button :: String -> Source (Evt Unit) button name = setLabelSource name $ source $ do flag <- geToSe $ onGlobals $ C.newPersistentGlobalVar Kr 0+ flagChanged <- geToSe $ onGlobals $ C.newPersistentGlobalVar Kr 0 instrId <- geToSe $ saveInstr $ instr flag+ geToSe $ (saveAlwaysOnInstr =<< ) $ saveInstr $ instrCh flag flagChanged (g, _) <- singleOut Nothing (Button instrId)- val <- fmap fromGE $ fromDep $ readVar flag- return (g, sigToEvt $ changed [val])+ val <- fmap fromGE $ fromDep $ readVar flagChanged+ return (g, sigToEvt val) where instr ref = SE $ do val <- readVar ref whens [ (val ==* 0, writeVar ref 1)- ] (writeVar ref 0)+ ] (writeVar ref 0) turnoff- ++ instrCh ref refCh = SE $ do+ val <- readVar ref+ writeVar refCh (C.changed val) -- | A FLTK widget opcode that creates a toggle button. --
src/Csound/Typed/Render.hs view
@@ -13,6 +13,7 @@ import Data.Tuple import Data.Ord import Data.List(sortBy, groupBy)+import qualified Data.IntMap as IM import Csound.Dynamic hiding (csdFlags) import Csound.Typed.Types@@ -22,13 +23,25 @@ import Csound.Typed.Control(getIns) import Csound.Dynamic.Types.Flags -import Csound.Typed.Gui.Gui(guiStmt)+import Csound.Typed.Gui.Gui(guiStmt, panelIsKeybdSensitive) + toCsd :: Tuple a => Options -> SE a -> GE Csd toCsd options sigs = do saveMasterInstr (constArity sigs) (masterExp sigs)+ saveMidiMap -- save midi innstruments+ handleMissingKeyPannel renderHistory (outArity sigs) options +handleMissingKeyPannel :: GE ()+handleMissingKeyPannel = do+ st <- fmap guis $ getHistory+ if (not $ IM.null $ guiKeyEvents st) && (null $ filter panelIsKeybdSensitive $ guiStateRoots st)+ then do+ saveDefKeybdPanel+ else do+ return ()+ renderOut_ :: SE () -> IO String renderOut_ = renderOutBy_ def @@ -56,7 +69,7 @@ expr2 <- getSysExpr terminatorInstrId saveAlwaysOnInstr =<< saveInstr (SE expr2) expr3 <- guiInstrExp - saveAlwaysOnInstr =<< saveInstr (SE expr3)+ saveAlwaysOnInstr =<< saveInstr (SE expr3) hist2 <- getHistory let orc = Orc instr0 (maybeAppend keyEventListener $ fmap (uncurry Instr) $ instrsContent $ instrs hist2) hist3 <- getHistory
src/Csound/Typed/Types/Prim.hs view
@@ -1,4 +1,4 @@-{-# Language TypeFamilies #-}+{-# Language TypeFamilies, FlexibleInstances #-} module Csound.Typed.Types.Prim( Sig(..), D(..), Tab(..), unTab, Str(..), Spec(..), Wspec(..), BoolSig(..), BoolD(..), Unit(..), unit, Val(..), hideGE, SigOrD,@@ -456,3 +456,50 @@ ftcps :: Tab -> D ftcps = on1 $ opr1 "ftcps" +-------------------------------------------------+-- numeric instances++instance Num (Sig, Sig) where+ (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2)+ (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2)+ negate (a1, a2) = (negate a1, negate a2)++ fromInteger n = (fromInteger n, fromInteger n)+ signum (a1, a2) = (signum a1, signum a2)+ abs (a1, a2) = (abs a1, abs a2)++instance Num (Sig, Sig, Sig) where+ (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3)+ (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3)+ negate (a1, a2, a3) = (negate a1, negate a2, negate a3)++ fromInteger n = (fromInteger n, fromInteger n, fromInteger n)+ signum (a1, a2, a3) = (signum a1, signum a2, signum a3)+ abs (a1, a2, a3) = (abs a1, abs a2, abs a3)++instance Num (Sig, Sig, Sig, Sig) where+ (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4)+ (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4)+ negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4)++ fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n)+ signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4)+ abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4)++instance Num (Sig, Sig, Sig, Sig, Sig, Sig) where+ (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6)+ (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6)+ negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6)++ fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)+ signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6)+ abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6)++instance Num (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where+ (a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7, a8 + b8)+ (a1, a2, a3, a4, a5, a6, a7, a8) * (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 + b7, a8 + b8)+ negate (a1, a2, a3, a4, a5, a6, a7, a8) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7, negate a8)++ fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)+ signum (a1, a2, a3, a4, a5, a6, a7, a8) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7, signum a8)+ abs (a1, a2, a3, a4, a5, a6, a7, a8) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7, abs a8)
src/Csound/Typed/Types/Tuple.hs view
@@ -141,13 +141,14 @@ -- out instances -- | The tuples of signals.-class (Tuple a) => Sigs a where+class (Tuple a, Num a) => Sigs a where instance Sigs Sig instance Sigs (Sig, Sig) instance Sigs (Sig, Sig, Sig, Sig) instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig) instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+{- instance Sigs ( (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) ) @@ -155,7 +156,7 @@ , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) )-+-} outArity :: Tuple a => SE a -> Int outArity = tupleArity . proxy where