csound-expression-typed 0.2.1.0 → 0.2.2.0

raw patch · 23 files changed

+1032/−716 lines, 23 filesdep ~csound-expression-dynamicdep ~temporal-mediadep ~wl-pprintPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: csound-expression-dynamic, temporal-media, wl-pprint

API changes (from Hackage documentation)

Files

• csound-expression-typed.cabal +4/−2
• data/opcodes/MultiFX/TapeEcho.udo +24/−0
• src/Csound/Typed/Control/Api.hs +15/−15
• src/Csound/Typed/Control/Evt.hs +6/−6
• src/Csound/Typed/Control/Instr.hs +8/−8
• src/Csound/Typed/Control/Mix.hs +7/−8
• src/Csound/Typed/Control/Ref.hs +25/−25
• src/Csound/Typed/GlobalState/Elements.hs +8/−3
• src/Csound/Typed/GlobalState/GE.hs +1/−1
• src/Csound/Typed/GlobalState/InstrApi.hs +19/−7
• src/Csound/Typed/GlobalState/Options.hs +24/−9
• src/Csound/Typed/Gui/BoxModel.hs +55/−40
• src/Csound/Typed/Gui/Gui.hs +157/−506
• src/Csound/Typed/Gui/Pretty.hs +192/−0
• src/Csound/Typed/Gui/Types.hs +249/−0
• src/Csound/Typed/Gui/Widget.hs +29/−31
• src/Csound/Typed/Plugins.hs +1/−1
• src/Csound/Typed/Plugins/TapeEcho.hs +21/−9
• src/Csound/Typed/Types/Evt.hs +19/−3
• src/Csound/Typed/Types/MixSco.hs +29/−29
• src/Csound/Typed/Types/Prim.hs +72/−9
• src/Csound/Typed/Types/SigSpace.hs +54/−3
• src/Csound/Typed/Types/Tuple.hs +13/−1

@@ -1,5 +1,5 @@ Name:          csound-expression-typed-Version:       0.2.1.0+Version:       0.2.2.0 Cabal-Version: >= 1.22 License:       BSD3 License-file:  LICENSE@@ -64,7 +64,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, NumInstances, filepath, directory,-        wl-pprint, csound-expression-dynamic >= 0.3.2, temporal-media >= 0.6.0, hashable+        wl-pprint >= 1.2.1, csound-expression-dynamic >= 0.3.3, temporal-media >= 0.6.3, hashable   Hs-Source-Dirs:      src/   Exposed-Modules:     Csound.Typed@@ -118,6 +118,8 @@      Csound.Typed.Gui.Gui     Csound.Typed.Gui.Widget+    Csound.Typed.Gui.Pretty+    Csound.Typed.Gui.Types     Csound.Typed.Gui.BoxModel     Csound.Typed.Gui.Cabbage.CabbageLang     Csound.Typed.Gui.Cabbage.Cabbage

@@ -87,3 +87,27 @@   aProc bandpassCheby1 aOut * kFbGain, 95, 3000, iOrder, iRippleDb   delayw aIn + aProc * kFbGain endop++opcode tapeReadBatch, a, akkii+  aIn, kDelay, kRandomSpread, iSize, iStart xin++  if iStart <= iSize then+    acall tapeReadBatch aIn, kDelay, kRandomSpread, iSize, iStart + 1+  else+    acall = 0+  endif++  iScale = iStart+  aEcho tapeRead aIn, kDelay * iScale, kRandomSpread+  xout acall + aEcho / iScale+endop++opcode TapeEchoN, a, akkkkki+  aIn, kDelay, kEchoGain, kFbGain, kTone, kRandomSpread, iSize xin+  aDummy delayr (16 * iSize)+  aEcho tapeReadBatch aIn, kDelay, kRandomSpread, iSize, 1+  aOut = aIn + kEchoGain * aEcho+  tapeWrite aIn, aOut, kFbGain+  xout aOut+endop+

@@ -24,7 +24,7 @@ -- | Creates an instrument that can be triggered by name with Csound API. -- The arguments are determined from the structure of the input for the instrument. ----- With Csound API we can send messages +-- With Csound API we can send messages -- -- > i "name" time duration arg1 arg2 arg3 trigByName_ :: Arg a => String -> (a -> SE ()) -> SE ()@@ -34,14 +34,14 @@ -- The arguments are determined from the structure of the input for the instrument. -- If we have a tuple of arguments: @(D, D, Tab)@ -- The would be rendered to instrument arguments that strts from @p4@.--- @p1@ is the name of teh instrument, @p2@ is the start time of the note, +-- @p1@ is the name of teh instrument, @p2@ is the start time of the note, -- @p3@ is the duration of the note. Then @p4@ and @p5@ are going to be doubles and @p6@ -- is an integer that denotes a functional table. trigByName  :: (Arg a, Sigs b) => String -> (a -> SE b) -> SE b trigByName name instr = do     ref <- newClearableGlobalRef 0     trigByName_ name (go ref)-    readRef ref    +    readRef ref     where go ref x = mixRef ref =<< instr x  @@ -57,7 +57,7 @@             pchExpr      <- toGE pch             let instrIdExpr = D.instrIdE instrId + pchExpr / 1000             noteFlagExpr <- toGE noteFlag-            args <- fromTuple (pch, vol, other)            +            args <- fromTuple (pch, vol, other)             return $ do                     D.when1 D.Ir (noteFlagExpr ==* 1) $ do                         eventi (Event instrIdExpr 0 (-1) args)@@ -79,7 +79,7 @@ -- -- The instrument takes a triplet of @(pitchKey, volumeKey, auxilliaryTuple)@. -- The order does matter. Please don't pass the @volumeKey@ as the first argument.--- The instrument expects the pitch key to be a first argument. +-- The instrument expects the pitch key to be a first argument.  -- Under the hood -- it creates held notes that are indexed by pitch. If you know the Csound it creates@@ -95,10 +95,10 @@ trigByNameMidi name instr = do     ref <- newClearableGlobalRef 0     trigByNameMidi_ name (go ref)-    readRef ref    +    readRef ref     where go ref x = mixRef ref =<< instr x -namedMonoMsg ::String -> SE MonoArg+namedMonoMsg :: String -> SE MonoArg namedMonoMsg name = do     refPch <- newGlobalRef 0     refVol <- newGlobalRef 0@@ -116,18 +116,18 @@     let kgate = ifB onFlag 1 0         kamp = downsamp' volKey         kcps = downsamp' pchKey-        trig = changed [kamp, kcps] +        trig = changed [kamp, kcps]     return $ MonoArg kamp kcps kgate trig-    where        -        onNote = tabQueue2_append        +    where+        onNote = tabQueue2_append         offNote tab (pch, vol) = tabQueue2_delete tab pch  trigByNameMidiCbk :: String -> ((D, D) -> SE ())  -> ((D, D) -> SE ()) -> SE ()-trigByNameMidiCbk name noteOn noteOff = +trigByNameMidiCbk name noteOn noteOff =     trigByName_ name go     where         go :: (D, D, D) -> SE ()-        go (noteFlag, pch, vol) = do            +        go (noteFlag, pch, vol) = do             whenD1 (noteFlag ==* 1) $ noteOn (pch, vol)             whenD1 (noteFlag ==* 0) $ noteOff (pch, vol)             SE turnoff@@ -140,10 +140,10 @@  downsamp' :: Sig -> Sig downsamp' a = fromGE $ do-    a' <- toGE a    +    a' <- toGE a     return $ downsamp a' --- | +-- | -- Fast table opcodes. -- -- Fast table opcodes. Faster than@@ -163,7 +163,7 @@     where f a1 a2 a3 = opcs "tabw" [(Xr,[Kr,Kr,Ir,Ir])] [a1,a2,a3]  --- | +-- | -- Fast table opcodes. -- -- Fast table opcodes. Faster than

@@ -31,7 +31,7 @@ import Csound.Typed.Constants(infiniteDur) import Csound.Typed.InnerOpcodes -renderEvts :: Evt (Sco a) -> Evt [(D, D, a)]+renderEvts :: Evt (Sco a) -> Evt [(Sig, Sig, a)] renderEvts = fmap (fmap unEvt . T.render)     where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e) @@ -55,7 +55,7 @@ ------------------------------------------------- -- triggereing the events -saveEvtInstr :: Arg a => Int -> C.InstrId -> Evt [(D, D, a)] -> GE C.InstrId+saveEvtInstr :: Arg a => Int -> C.InstrId -> Evt [(Sig, Sig, a)] -> GE C.InstrId saveEvtInstr arity instrId evts = saveInstr $ do     aliveCountRef <- newRef (10 :: D)     evtMixInstr aliveCountRef@@ -68,14 +68,14 @@             aliveCount <- readRef aliveCountRef             fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount -        go :: Arg a => Ref D -> GE C.ChnRef -> Evt [(D, D, a)] -> SE ()+        go :: Arg a => Ref D -> GE C.ChnRef -> Evt [(Sig, Sig, a)] -> SE ()         go aliveCountRef mchnId events =             runEvt events $ \es -> do                 writeRef aliveCountRef $ int $ 2 * length es                 chnId <- geToSe mchnId                 fromDep_ $ mapM_ (event chnId) es -        event :: Arg a => C.ChnRef -> (D, D, a) -> Dep ()+        event :: Arg a => C.ChnRef -> (Sig, Sig, a) -> Dep ()         event chnId (start, dur, args) = hideGEinDep $ fmap C.event $             C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args) @@ -252,7 +252,7 @@             return $ C.autoOff dtE x  -saveEvtInstr_ :: Arg a => C.InstrId -> Evt [(D, D, a)] -> Dep ()+saveEvtInstr_ :: Arg a => C.InstrId -> Evt [(Sig, Sig, a)] -> Dep () saveEvtInstr_ instrId evts = unSE $ runEvt evts $ \es -> fromDep_ $ mapM_ event es     where event (start, dur, args) = hideGEinDep $ fmap C.event $ C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> toNote args @@ -289,7 +289,7 @@             I.writePort p (amp, cps, 0)             return $ MonoArg amp cps (ifB (gate `equalsTo` 0) 0 1) (changed [amp, cps, gate]) -runSco :: Arg a => Evt (Sco a) -> ((D,D,a) -> SE ()) -> SE ()+runSco :: Arg a => Evt (Sco a) -> ((Sig,Sig,a) -> SE ()) -> SE () runSco evts f = runEvt (renderEvts evts) $ mapM_ f  -- | Plays the note until next note comes or something happens on the second event stream.

@@ -1,10 +1,10 @@ -- | Converts to low-level instruments module Csound.Typed.Control.Instr(-    Arity(..), InsExp, EffExp, -    funArity, constArity, -    insExp, effExp, masterExp, midiExp, unitExp, +    Arity(..), InsExp, EffExp,+    funArity, constArity,+    insExp, effExp, masterExp, midiExp, unitExp,     apInstr, apInstr0-) where    +) where  import Data.Default import Csound.Dynamic(InstrId(..))@@ -24,12 +24,12 @@  constArity :: (Tuple a) => SE a -> Arity constArity a = Arity 0 (outArity a)-   -insExp :: (Arg a, Tuple b) => (a -> SE b) -> InsExp ++insExp :: (Arg a, Tuple b) => (a -> SE b) -> InsExp insExp instr = execGEinSE $ fmap fromTuple $ instr toArg  effExp :: (Tuple a, Tuple b) => (a -> SE b) -> EffExp-effExp instr = execGEinSE . fmap fromTuple . instr . toTuple . return +effExp instr = execGEinSE . fmap fromTuple . instr . toTuple . return  masterExp :: (Tuple a) => SE a -> InsExp masterExp = execGEinSE . fmap fromTuple@@ -42,7 +42,7 @@  apInstr :: (Arg a, Sigs b) => GE InstrId -> a -> b apInstr instrIdGE args = res-    where +    where         res = toTuple $ do             instrId <- instrIdGE             argList <- fromTuple args

@@ -1,4 +1,4 @@-{-# Language FlexibleContexts, ScopedTypeVariables #-}+{-# Language FlexibleContexts, ScopedTypeVariables, CPP #-} module Csound.Typed.Control.Mix(     Mix,     sco, eff, mix, mixBy, monoSco,@@ -8,17 +8,12 @@  import Data.Boolean -import Control.Applicative import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad-import Data.Traversable import System.Mem.StableName  import Temporal.Media  import Csound.Dynamic hiding (Instr, Sco, str)-import qualified Csound.Typed.GlobalState.Elements as C  import Csound.Typed.Types import Csound.Typed.Types.MixSco@@ -26,10 +21,14 @@ import Csound.Typed.Control.Instr import Csound.Typed.InnerOpcodes +#if __GLASGOW_HASKELL__ < 710+import Data.Traversable+#endif+ toCsdEventList :: Sco a -> CsdEventList a toCsdEventList = id -singleCsdEvent :: (D, D, a) -> Sco a+singleCsdEvent :: (Sig, Sig, a) -> Sco a singleCsdEvent (start, duration, content) = del start $ str duration $ temp content  -- | Special type that represents a scores of sound signals.@@ -37,7 +36,7 @@ -- in the value of this type. newtype Mix a = Mix { unMix :: GE M } -type Sco a = Track D a+type Sco a = Track Sig a  wrapSco :: Sco a -> (CsdEventList a -> GE M) -> Sco (Mix b) wrapSco notes getContent = singleCsdEvent (0, csdEventListDur evts, Mix $ getContent evts)

@@ -42,18 +42,18 @@ readRef  :: Tuple a => Ref a -> SE a readRef (Ref vars) = SE $ fmap (toTuple . return) $ mapM readVar vars --- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. +-- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. -- A reference can contain a tuple of variables. newRef :: Tuple a => a -> SE (Ref a)-newRef t = fmap Ref $ newLocalVars (tupleRates t) (fromTuple t)    -   --- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. +newRef t = fmap Ref $ newLocalVars (tupleRates t) (fromTuple t)++-- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. -- A reference can contain a tuple of variables. -- It contains control signals (k-rate) and constants for numbers (i-rates). newCtrlRef :: Tuple a => a -> SE (Ref a)-newCtrlRef t = fmap Ref $ newLocalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t) -        -toCtrlRate x = case x of +newCtrlRef t = fmap Ref $ newLocalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t)++toCtrlRate x = case x of     Ar -> Kr     Kr -> Ir     _  -> x@@ -79,7 +79,7 @@ -- | Modifies the Ref value with given function. modifyRef :: Tuple a => Ref a -> (a -> a) -> SE () modifyRef ref f = do-    v <- readRef ref      +    v <- readRef ref     writeRef ref (f v)  -- | An alias for the function @newRef@. It returns not the reference@@ -89,16 +89,16 @@     ref <- newRef a     return $ (readRef ref, writeRef ref) --- | Allocates a new global mutable value and initializes it with value. +-- | Allocates a new global mutable value and initializes it with value. -- A reference can contain a tuple of variables. newGlobalRef :: Tuple a => a -> SE (Ref a)-newGlobalRef t = fmap Ref $ newGlobalVars (tupleRates t) (fromTuple t)    +newGlobalRef t = fmap Ref $ newGlobalVars (tupleRates t) (fromTuple t) --- | Allocates a new global mutable value and initializes it with value. +-- | Allocates a new global mutable value and initializes it with value. -- A reference can contain a tuple of variables. -- It contains control signals (k-rate) and constants for numbers (i-rates). newGlobalCtrlRef :: Tuple a => a -> SE (Ref a)-newGlobalCtrlRef t = fmap Ref $ newGlobalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t)   +newGlobalCtrlRef t = fmap Ref $ newGlobalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t)  -- | An alias for the function @newRef@. It returns not the reference -- to mutable value but a pair of reader and writer functions.@@ -107,12 +107,12 @@     ref <- newRef a     return $ (readRef ref, writeRef ref) --- | Allocates a new clearable global mutable value and initializes it with value. +-- | Allocates a new clearable global mutable value and initializes it with value. -- A reference can contain a tuple of variables. -- The variable is set to zero at the end of every iteration. -- It's useful for accumulation of audio values from several instruments. newClearableGlobalRef :: Tuple a => a -> SE (Ref a)-newClearableGlobalRef t = fmap Ref $ newClearableGlobalVars (tupleRates t) (fromTuple t) +newClearableGlobalRef t = fmap Ref $ newClearableGlobalVars (tupleRates t) (fromTuple t)  ------------------------------------------------------------------------------- -- writable tables@@ -124,18 +124,18 @@ newTab :: D -> SE Tab newTab size = ftgentmp 0 0 size 7 0 [size, 0] --- | Creates a new global table. +-- | Creates a new global table. -- It's generated only once. It's persisted between instrument calls. -- -- > newGlobalTab identifier size newGlobalTab :: Int -> SE Tab-newGlobalTab size = do +newGlobalTab size = do     ref <- newGlobalCtrlRef ((fromGE $ saveWriteTab size) :: D)     fmap (fromGE . toGE) $ readRef ref  {-     identifier <- geToSe $ getNextGlobalGenId-    ref <- newGlobalRef (0 :: D)        +    ref <- newGlobalRef (0 :: D)     tabId <- ftgenonce 0 (Csound.Typed.Types.Prim.int identifier) size 7 0 [size, 0]     writeRef ref (fromGE $ toGE tabId)     fmap (fromGE . toGE) $ readRef ref@@ -145,10 +145,10 @@ -- some opcodes that I have to define upfront  --- | +-- | -- Generate a function table from within an instrument definition, without duplication of data. ----- Enables the creation of function tables entirely inside +-- Enables the creation of function tables entirely inside --       instrument definitions, without any duplication of data. -- -- > ifno  ftgenonce  ip1, ip2dummy, isize, igen, iarga, iargb, ...@@ -158,7 +158,7 @@ ftgenonce b1 b2 b3 b4 b5 b6 = fmap ( Tab . return) $ SE $ (depT =<<) $ lift $ f <$> unD b1 <*> unD b2 <*> unD b3 <*> unD b4 <*> unD b5 <*> mapM unD b6     where f a1 a2 a3 a4 a5 a6 = opcs "ftgenonce" [(Ir,(repeat Ir))] ([a1,a2,a3,a4,a5] ++ a6) --- | +-- | -- Generate a score function table from within the orchestra, which is deleted at the end of the note. -- -- Generate a score function table from within the orchestra,@@ -175,7 +175,7 @@  {- whileSE :: SE BoolSig -> SE () -> SE ()-whileSE mcond body = do      +whileSE mcond body = do     ref <- newCtrlRef $ (0 :: Sig)     writeCond ref     whileRefBegin ref@@ -205,8 +205,8 @@     writeRef refSt   =<< body    =<< readRef refSt     writeRef refCond =<< condSig =<< readRef refSt     fromDep_ whileEnd-    where  -        condSig :: st -> SE Sig               +    where+        condSig :: st -> SE Sig         condSig   = fmap (\b -> ifB b 1 0) . cond  @@ -218,8 +218,8 @@     writeRef refSt   =<< body    =<< readRef refSt     writeRef refCond =<< condSig =<< readRef refSt     fromDep_ whileEnd-    where   -        condSig :: st -> SE D              +    where+        condSig :: st -> SE D         condSig   = fmap (\b -> ifB b 1 0) . cond  whileRefBegin :: SigOrD a => Ref a -> SE ()

@@ -19,7 +19,7 @@     -- * Global variables     Globals(..), newPersistentGlobalVar, newClearableGlobalVar,     newPersistentGloabalArrVar,-    renderGlobals,+    renderGlobals, bpmVarName, bpmVar,     -- * Instruments     Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds,     -- * Named instruments@@ -351,12 +351,17 @@         { allocArrVar :: Var         , allocArrVarSizes :: [E] } - data GlobalVarType = PersistentGlobalVar | ClearableGlobalVar     deriving (Eq)  instance Default Globals where-    def = Globals def def+    def = Globals 0 [AllocVar PersistentGlobalVar bpmVar 110]++bpmVar :: Var+bpmVar = Var GlobalVar Kr bpmVarName++bpmVarName :: String+bpmVarName = "gBpmVar"  newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var newGlobalVar ty rate initVal = state $ \s ->

@@ -3,7 +3,7 @@     GE, Dep, History(..), withOptions, withHistory, getOptions, evalGE, execGE,     getHistory, putHistory,     -- * Globals-    onGlobals,+    onGlobals, bpmVar,     -- * Midi     MidiAssign(..), Msg(..), renderMidiAssign, saveMidi, saveToMidiInstr,     MidiCtrl(..), saveMidiCtrl, renderMidiCtrl,

@@ -20,33 +20,45 @@  import qualified Csound.Typed.GlobalState.Opcodes as Opcodes(Event(..), event, eventi, turnoff2, turnoff, initSig, activeKr) -data InstrId a +data InstrId a     = InstrId { unInstrId :: GE E }     | InstrLinkedId { instrLivenessPort :: PortCtrl Sig, unInstrId :: GE E }  newInstr :: Arg a => (a -> SE ()) -> InstrId a newInstr instr = InstrId $ fmap instrIdE $ saveInstr (instr toArg) -event :: Arg a => InstrId a -> (D,D,a) -> SE ()+event :: Arg a => InstrId a -> (Sig,Sig,a) -> SE () event idx note = do     e <- getEvent idx note     SE $ Opcodes.event e  eventi :: Arg a => InstrId a -> (D,D,a) -> SE () eventi idx note = do-    e <- getEvent idx note+    e <- getEventi idx note     SE $ Opcodes.eventi e -getEvent :: Tuple a => InstrId a -> (D, D, a) -> SE Opcodes.Event+getEvent :: Tuple a => InstrId a -> (Sig, Sig, a) -> SE Opcodes.Event getEvent (InstrId idx) (start, dur, args) = SE $ lift $ do             i <- idx             s <- toGE start             d <- toGE dur             as <- fromTuple args             return $ Opcodes.Event i s d as-getEvent (InstrLinkedId port idx) (start, dur, arg) = do    +getEvent (InstrLinkedId port idx) (start, dur, arg) = do     getEvent (InstrId idx) (start, dur, (arg, port)) ++getEventi :: Tuple a => InstrId a -> (D, D, a) -> SE Opcodes.Event+getEventi (InstrId idx) (start, dur, args) = SE $ lift $ do+            i <- idx+            s <- toGE start+            d <- toGE dur+            as <- fromTuple args+            return $ Opcodes.Event i s d as+getEventi (InstrLinkedId port idx) (start, dur, arg) = do+    getEventi (InstrId idx) (start, dur, (arg, port))++ turnoff2 :: InstrId a -> SE () turnoff2 (InstrId expr) = SE $ Opcodes.turnoff2 =<< lift expr @@ -57,8 +69,8 @@ newInstrLinked instr = do     p <- freePortCtrl     writePort p 10-    let instrId = fmap instrIdE $ saveInstr (instr' toArg)        -    let resInstrId = InstrLinkedId p instrId    +    let instrId = fmap instrIdE $ saveInstr (instr' toArg)+    let resInstrId = InstrLinkedId p instrId     writePort p $ (fromGE $ fmap Opcodes.activeKr instrId) + 1     return resInstrId     where

@@ -1,3 +1,4 @@+{-# Language CPP #-} module Csound.Typed.GlobalState.Options (     Options(..),     defGain, defSampleRate, defBlockSize, defTabFi, defScaleUI,@@ -50,16 +51,30 @@ instance Default Options where     def = Options def def def def def def def +#if MIN_VERSION_base(4,11,0)+instance Semigroup Options where+    (<>) = mappendOptions+ instance Monoid Options where-    mempty = def-    mappend a b = Options-        { csdFlags          = mappend (csdFlags a) (csdFlags b)-        , csdSampleRate     = csdSampleRate a <|> csdSampleRate b-        , csdBlockSize      = csdBlockSize a <|> csdBlockSize b-        , csdGain           = csdGain a <|> csdGain b-        , csdTabFi          = csdTabFi a <|> csdTabFi b-        , csdScaleUI        = csdScaleUI a <|> csdScaleUI b-        , csdJacko          = csdJacko a <|> csdJacko b }+    mempty  = def++#else++instance Monoid Options where+    mempty  = def+    mappend = mappendOptions++#endif++mappendOptions :: Options -> Options -> Options+mappendOptions a b = Options+    { csdFlags          = mappend (csdFlags a) (csdFlags b)+    , csdSampleRate     = csdSampleRate a <|> csdSampleRate b+    , csdBlockSize      = csdBlockSize a <|> csdBlockSize b+    , csdGain           = csdGain a <|> csdGain b+    , csdTabFi          = csdTabFi a <|> csdTabFi b+    , csdScaleUI        = csdScaleUI a <|> csdScaleUI b+    , csdJacko          = csdJacko a <|> csdJacko b }  defScaleUI :: Options -> (Double, Double) defScaleUI = maybe (1, 1) id . csdScaleUI

@@ -1,6 +1,6 @@-{-# Language DeriveFunctor #-}+{-# Language DeriveFunctor, CPP #-} module Csound.Typed.Gui.BoxModel(-    Rect(..), Offset(..), AbsScene(..), Scene(..),        +    Rect(..), Offset(..), AbsScene(..), Scene(..),     draw,     hor, ver, sca, margin, padding, space, prim,     appendContext, cascade, boundingRect, zeroRect@@ -12,13 +12,13 @@ import Data.Default import Data.Monoid -data Interval = Interval +data Interval = Interval     { start :: Int-    , leng  :: Int +    , leng  :: Int     } deriving (Show)-   + -- | A rectangle.-data Rect = Rect +data Rect = Rect     { px        :: Int     , py        :: Int     , width     :: Int@@ -30,27 +30,42 @@  toRect :: Interval -> Interval -> Rect toRect a b = Rect (start a) (start b) (leng a) (leng b)-  -data AbsScene ctx a ++data AbsScene ctx a     = Elem Rect a-    | EmptyScene +    | EmptyScene     | Group [AbsScene ctx a]     | Ctx Rect ctx (AbsScene ctx a)     deriving (Show)-     +++#if MIN_VERSION_base(4,11,0)+instance Semigroup (AbsScene ctx a) where+    (<>) = mappendAbsScene+ instance Monoid (AbsScene ctx a) where-    mempty = EmptyScene-    mappend a b = case (a, b) of-        (EmptyScene, _) -> b-        (_, EmptyScene) -> a        -        (Elem _ _, Group bs) -> Group (a:bs)-        (Group as, Elem _ _) -> Group (as ++ [b])-        (Group as, Group bs)   -> Group (as ++ bs)-        (_, _) -> Group [a, b]-   +    mempty  = EmptyScene++#else++instance Monoid (AbsScene ctx a) where+    mempty  = EmptyScene+    mappend = mappendAbsScene++#endif++mappendAbsScene :: AbsScene ctx a -> AbsScene ctx a -> AbsScene ctx a+mappendAbsScene a b = case (a, b) of+    (EmptyScene, _) -> b+    (_, EmptyScene) -> a+    (Elem _ _, Group bs) -> Group (a:bs)+    (Group as, Elem _ _) -> Group (as ++ [b])+    (Group as, Group bs)   -> Group (as ++ bs)+    (_, _) -> Group [a, b]+ data Scene ctx a     = Prim a-    | Space   +    | Space     | Scale Double (Scene ctx a)     | Hor Offset [Scene ctx a]     | Ver Offset [Scene ctx a]@@ -74,13 +89,13 @@                 Ver     o a -> Ver     o (fmap joinScene a)                 Context c a -> Context c (joinScene a) -data Offset = Offset +data Offset = Offset     { offsetOuter :: Int-    , offsetInner :: Int +    , offsetInner :: Int     } deriving (Show)  instance Default Offset where-    def = Offset +    def = Offset             { offsetOuter = 5             , offsetInner = 25 } @@ -91,7 +106,7 @@  hor, ver    :: [Scene a b] -> Scene a b space       :: Scene a b-prim        :: a -> Scene ctx a +prim        :: a -> Scene ctx a  sca :: Double -> Scene a b -> Scene a b margin, padding :: Int -> Scene a b -> Scene a b@@ -115,26 +130,26 @@ draw rect x = case x of     Space  -> mempty     Prim a -> Elem rect a-    Scale _ a -> draw rect a  -- no need to scale the rect we use +    Scale _ a -> draw rect a  -- no need to scale the rect we use                               -- scaling factor in the groups (hor/ver)     Hor off as -> composite (horRects rect) off as     Ver off as -> composite (verRects rect) off as     Context ctx a -> Ctx rect ctx (draw rect a)-    where +    where         composite getRects off as = mconcat $ zipWith draw (getRects off $ factors as) (fmap stripScale as)-   -        horRects r off scales = fmap (flip toRect commonSide) is ++        horRects r off scales = fmap (flip toRect commonSide) is             where commonSide = withoutMargin off iy-                  is = intervals off ix scales  +                  is = intervals off ix scales                   (ix, iy) = fromRect r -        verRects r off scales = fmap (toRect commonSide) is +        verRects r off scales = fmap (toRect commonSide) is             where commonSide = withoutMargin off ix-                  is = intervals off iy scales  -                  (ix, iy) = fromRect r  +                  is = intervals off iy scales+                  (ix, iy) = fromRect r  intervals :: Offset -> Interval -> [Double] -> [Interval]-intervals off total scales = evalState (mapM next scales') (start total') +intervals off total scales = evalState (mapM next scales') (start total')     where total'  = withoutMargin off total           leng'   = fromIntegral $ withoutPaddings off (length scales) (leng total')           scales' = fmap ( / s) scales@@ -142,7 +157,7 @@            next d  = state $ \soFar -> let l = round $ d * leng'                                       in  (Interval soFar l, soFar + l + offsetInner off)-            +           withoutPaddings offset n a = a - offsetInner offset * (n - 1)  withoutMargin :: Offset -> Interval -> Interval@@ -163,9 +178,9 @@ ----------------------------------------------- -- cascading update of the context -cascade :: -       (totalCtx -> Rect -> a -> res) -    -> res +cascade ::+       (totalCtx -> Rect -> a -> res)+    -> res     -> ([res] -> res)     -> (Rect -> ctx -> res -> res)     -> (ctx -> totalCtx -> totalCtx)@@ -188,8 +203,8 @@     Prim a      -> a     Space       -> zeroRect     Scale _ a   -> boundingRect a-    Hor ofs as  -> appHorOffset (length as) ofs $ horMerge $ fmap boundingRect as    -    Ver ofs as  -> appVerOffset (length as) ofs $ verMerge $ fmap boundingRect as    +    Hor ofs as  -> appHorOffset (length as) ofs $ horMerge $ fmap boundingRect as+    Ver ofs as  -> appVerOffset (length as) ofs $ verMerge $ fmap boundingRect as     Context _ a -> boundingRect a     where         appHorOffset n offset r = r { width  = appOffset n offset (width r)@@ -199,7 +214,7 @@                                     , width  = appOffset 1 offset (width r) }          appOffset n offset a = a-              + 2 * offsetOuter offset +              + 2 * offsetOuter offset               + (max (n - 1) 0) * offsetInner offset          horMerge = foldr iter zeroRect

@@ -6,12 +6,12 @@     guiStmt,      -- * Layout-    hor, ver, space, sca, horSca, verSca,     +    hor, ver, space, sca, horSca, verSca,     padding, margin, ScaleFactor, resizeGui,     -- * Props     props, forceProps,     Prop(..), BorderType(..), Color,-    Rect(..), FontType(..), Emphasis(..), +    Rect(..), FontType(..), Emphasis(..),     Material(..), Orient(..), LabelType(..),     -- ** Setters     -- | Handy short-cuts for the function @props@.@@ -31,7 +31,7 @@  import Prelude hiding(elem, span) -import Control.Applicative((<|>))+import Control.Applicative(Alternative(..)) import Data.Default import Data.Char(toLower) import Data.Maybe(isNothing)@@ -42,190 +42,31 @@ import Data.Colour.SRGB  import qualified Data.IntMap as IM-import Text.PrettyPrint.Leijen(Doc, int, double, vcat, hcat, hsep, punctuate, comma, empty, text, char, (<+>))---- import Csound.Render.Pretty(Doc, int, double, vcat, hcat, punctuate, comma)+import Text.PrettyPrint.Leijen(Doc)  import Csound.Dynamic(DepT, depT_, Var(..), VarType(..), Rate(..), noRate, MainExp(..), InstrId(..)) +import qualified Text.PrettyPrint.Leijen as P(int, double, vcat, hcat, hsep, punctuate, comma, empty, text, char, (<+>)) import qualified Csound.Typed.Gui.BoxModel as Box import Csound.Typed.Gui.BoxModel(Rect(..)) import Csound.Typed.Constants(infiniteDur) -newtype GuiHandle = GuiHandle { unGuiHandle :: Int }---- | The Csound colours. -type Color = Colour Double---- | The orientation of the widget (slider, roller). This property is --- never needs to be set in practice. If this property is not set then --- default orientation is calculated from the bounding box of the widget.--- If the width is greater than the height then we need to use a horizontal--- widget otherwise it should be a vertical one.-data Orient = Hor | Ver---- | A value span is a diapason of the value and a type --- of the scale (can be linear or exponential).-data ValSpan = ValSpan -    { valSpanDiap  :: ValDiap-    , valSpanScale :: ValScaleType }---- | Makes a linear @ValSpan@ with specified boundaries.------ > linSpan minVal maxVal-linSpan :: Double -> Double -> ValSpan-linSpan a b = ValSpan (ValDiap a b) Linear---- | Makes an exponential @ValSpan@ with specified boundaries.------ > expSpan minVal maxVal-expSpan :: Double -> Double -> ValSpan -expSpan a b = ValSpan (ValDiap (checkBound a) b) Exponential-    where-        checkBound x-            | x <= 0    = 0.00001-            | otherwise = x---- | Unit span. A special case:------ > uspan = linSpan 0 1-uspan :: ValSpan-uspan = linSpan 0 1---- | Bipolar unit span. A special case:------ > uspan = linSpan (-1) 1-bspan :: ValSpan-bspan = linSpan (-1) 1---- | An exponential unit span. A special case:------ > uspan = expSpan 0 1-uspanExp :: ValSpan-uspanExp = linSpan 0 1---- | The diapason of the continuous value.-data ValDiap = ValDiap -    { valDiapMin   :: Double -    , valDiapMax   :: Double }--data ValScaleType = Linear | Exponential--type ValStep = Double--data FontType       = Helvetica | Courier | Times | Symbol | Screen | Dingbats-data Emphasis       = NoEmphasis | Italic | Bold | BoldItalic-data KnobType       = ThreeD (Maybe Int) | Pie | Clock | Flat-data SliderType     = Fill | Engraved | Nice-data TextType       = NormalText | NoDrag | NoEdit---- | The type of the material of the element. It affects sliders and buttons.-data Material       = NoPlastic | Plastic---- | Some values are not implemented on the Csound level.-data LabelType      = NormalLabel | NoLabel | SymbolLabel -                    | ShadowLabel | EngravedLabel | EmbossedLabel---- | The type of the box. Some values are not implemented on the Csound level.-data BoxType    -    = FlatBox | UpBox | DownBox | ThinUpBox | ThinDownBox -    | EngravedBox | EmbossedBox | BorderBox | ShadowBox-    | Roundedbox | RoundedShadowBox | RoundedFlatBox-    | RoundedUpBox | RoundedDownBox | DiamondUpBox -    | DiamondDownBox | OvalBox | OvalShadowBox | OvalFlatBox-    deriving (Enum)--data BorderType-    = NoBorder | DownBoxBorder | UpBoxBorder | EngravedBorder -    | EmbossedBorder | BlackLine | ThinDown | ThinUp-    deriving (Enum)---- | The type of the button. It affects toggle buttons and button banks.------ In Csound buttons and toggle buttons--- are constructed with the same function (but with different button types). --- But in this library they are contructed by different functions (@button@ and @toggle@). --- Normal button is a plain old button, but other values specify toggle buttons.--- So this property doesn't affect the buttons (since they could be only normal buttons).-data ButtonType = NormalButton | LightButton | CheckButton | RoundButton--defFontSize :: Int-defFontSize = 15--instance Default FontType       where def = Courier-instance Default Emphasis       where def = NoEmphasis-instance Default SliderType     where def = Fill-instance Default KnobType       where def = Flat-instance Default TextType       where def = NormalText-instance Default ButtonType     where def = NormalButton-instance Default BoxType        where def = FlatBox-instance Default Material       where def = Plastic-instance Default LabelType      where def = NormalLabel--data InitMe = InitMe -    { initHandle :: Var-    , initValue  :: Double }--data Elem -    = GuiVar GuiHandle -    -    -- valuators-    | Count  ValDiap ValStep (Maybe ValStep)-    | Joy    ValSpan ValSpan-    | Knob   ValSpan-    | Roller ValSpan ValStep-    | Slider ValSpan-    | Text   ValDiap ValStep--    -- other widgets  -    | Box String-    | ButBank Int Int-    | Button InstrId-    | Toggle -    | Value-    | Vkeybd--data Props = Props -    { propsBorder   :: Maybe BorderType-    , propsScaleFactor :: Maybe ScaleFactor-    , otherProps    :: [Prop] }--type ScaleFactor = (Double, Double)--instance Monoid Props where-    mempty = Props Nothing Nothing []-    mappend a b = Props { propsBorder = propsBorder a <|> propsBorder b-                        , propsScaleFactor = propsScaleFactor a <|> propsScaleFactor b-                        , otherProps  = mappend (otherProps a) (otherProps b) }--instance Default Props where-    def = mempty+import Csound.Typed.Gui.Types+import Csound.Typed.Gui.Pretty --- | Properties of the widgets.-data Prop-    = SetLabel String-    | SetMaterial Material-    | SetBoxType BoxType-    | SetColor1 Color | SetColor2 Color | SetTextColor Color-    | SetFontSize Int | SetFontType FontType | SetEmphasis Emphasis-    | SetSliderType SliderType    -    | SetTextType TextType-    | SetButtonType ButtonType -    | SetOrient Orient-    | SetKnobType KnobType-    | SetLabelType LabelType+newtype GuiHandle = GuiHandle { unGuiHandle :: Int }  -- | A visual representation of the GUI-element. newtype Gui = Gui { unGui :: LowGui }  type LowGui = Box.Scene Props ElemWithOuts -data Panel -    = Single +data Panel+    = Single         { singleContent :: Win         , singleIsKeybdSensitive :: Bool }-    | Tabs -        { tabsTitle     :: String +    | Tabs+        { tabsTitle     :: String         , tabsRect      :: Maybe Rect         , tabsContent   :: [Win]         , tabsIsKeybdSensitive :: Bool }@@ -235,8 +76,8 @@     Single _ res -> res     Tabs _ _ _ res -> res -data Win = Win -    { winTitle :: String +data Win = Win+    { winTitle :: String     , winRect  :: Maybe Rect     , winGui   :: Gui } @@ -244,11 +85,34 @@     { guiNodeElem   :: Gui     , guiNodeHandle :: GuiHandle } -data ElemWithOuts = ElemWithOuts +data ElemWithOuts = ElemWithOuts     { elemOuts      :: [Var]     , elemInits     :: [InitMe]     , elemContent   :: Elem } +data InitMe = InitMe+    { initHandle :: Var+    , initValue  :: Double }++data Elem+    = GuiVar GuiHandle++    -- valuators+    | Count  ValDiap ValStep (Maybe ValStep)+    | Joy    ValSpan ValSpan+    | Knob   ValSpan+    | Roller ValSpan ValStep+    | Slider ValSpan+    | Text   ValDiap ValStep++    -- other widgets+    | Box String+    | ButBank Int Int+    | Button InstrId+    | Toggle+    | Value+    | Vkeybd+ type ElemOuts = [Var]  defText :: String -> Gui@@ -258,7 +122,7 @@ fromElem outs inits el = Gui $ Box.prim (ElemWithOuts outs inits el)  fromGuiHandle :: GuiHandle -> Gui-fromGuiHandle = Gui . Box.prim . ElemWithOuts [] [] . GuiVar +fromGuiHandle = Gui . Box.prim . ElemWithOuts [] [] . GuiVar  mapGuiOnPanel :: (Gui -> Gui) -> Panel -> Panel mapGuiOnPanel f x = case x of@@ -270,15 +134,15 @@ onLowGuis f = Gui . f . fmap unGui  onLowGui1 :: (LowGui -> LowGui) -> (Gui -> Gui)-onLowGui1 f = Gui . f . unGui +onLowGui1 f = Gui . f . unGui --- | Horizontal groupping of the elements. All elements are +-- | Horizontal groupping of the elements. All elements are -- placed in the stright horizontal line and aligned by Y-coordinate -- and height. hor :: [Gui] -> Gui-hor = onLowGuis Box.hor +hor = onLowGuis Box.hor --- | Vertical groupping of the elements. All elements are +-- | Vertical groupping of the elements. All elements are -- placed in the stright vertical line and aligned by X-coordinate -- and width. ver :: [Gui] -> Gui@@ -293,12 +157,12 @@ -- box is scaled. If it's a horizontal group then the width is scaled -- and height is scaled otherwise. ----- Every element in the group has a scaling factor. By +-- Every element in the group has a scaling factor. By -- default it equals to one. During rendering all scaling factors are summed--- and divided on the sum of all factors. So that factors become weights --- or proportions. This process is called normalization. --- Scaling one element affects not only this element but --- all other elements in the group! +-- and divided on the sum of all factors. So that factors become weights+-- or proportions. This process is called normalization.+-- Scaling one element affects not only this element but+-- all other elements in the group! -- -- An example: --@@ -317,12 +181,12 @@ sca :: Double -> Gui -> Gui sca d = onLowGui1 (Box.sca d) --- | Weighted horizontal grouping. +-- | Weighted horizontal grouping. -- It takes a list of scaling factors and elements. horSca :: [(Double, Gui)] -> Gui horSca ps = hor $ fmap (uncurry sca) ps --- | Weighted vertical grouping. +-- | Weighted vertical grouping. -- It takes a list of scaling factors and elements. verSca :: [(Double, Gui)] -> Gui verSca ps = ver $ fmap (uncurry sca) ps@@ -369,40 +233,40 @@ guiStmt defaultScaleUI panels = depT_ $ noRate (phi defaultScaleUI)     where phi scaleUI             | null panels = EmptyExp-            | otherwise   = Verbatim $ show $ vcat [vcat $ fmap (drawGui scaleUI) panels, text "FLrun"]+            | otherwise   = Verbatim $ show $ P.vcat [P.vcat $ fmap (drawGui scaleUI) panels, P.text "FLrun"]  drawGui :: ScaleFactor -> Panel -> Doc drawGui defaultScaleUI x = case x of     Single w    isKeybd -> panel isKeybd boundingRect $ drawWin (withWinMargin boundingRect) w-    Tabs _ _ ws isKeybd -> panel isKeybd tabPanelRect $ case ws of -        [] -> empty-        _  -> onTabs mainTabRect $ vcat $ fmap (uncurry $ drawTab shift) tabsRs        +    Tabs _ _ ws isKeybd -> panel isKeybd tabPanelRect $ case ws of+        [] -> P.empty+        _  -> onTabs mainTabRect $ P.vcat $ fmap (uncurry $ drawTab shift) tabsRs     where boundingRect = panelRect defaultScaleUI (fmap fst tabsRs) x-          tabsRs = tabsRects defaultScaleUI x  +          tabsRs = tabsRects defaultScaleUI x           (mainTabRect, shift) = mainTabRectAndShift boundingRect-    -          tabPanelRect = Rect ++          tabPanelRect = Rect             { px = 100             , py = 100             , width = width mainTabRect + 20-            , height = height mainTabRect + 20 +            , height = height mainTabRect + 20             }            panel = onPanel (panelTitle x) -          onPanel title isKeybdSensitive rect body = vcat +          onPanel title isKeybdSensitive rect body = P.vcat             -- panel with default position no border and capture of keyboard events-            [ ppProc "FLpanel" [ text $ show title, int $ width rect, int $ height rect, int (-1), int (-1), int 0-                               , int $ if isKeybdSensitive then 1 else 0 ]+            [ ppProc "FLpanel" [ P.text $ show title, P.int $ width rect, P.int $ height rect, P.int (-1), P.int (-1), P.int 0+                               , P.int $ if isKeybdSensitive then 1 else 0 ]             , body             , ppProc "FLpanelEnd" []] -          onTabs rect body = vcat +          onTabs rect body = P.vcat             [ ppProc "FLtabs" $ rectToFrame rect             , body             , ppProc "FLtabsEnd" []]-             + panelTitle :: Panel -> String panelTitle x = case x of     Single w _       -> winTitle w@@ -417,22 +281,22 @@     where boundingRect a b = Rect { px = x1, py = y1, width = x2 - x1, height = y2 - y1 }               where x1 = min (px a) (px b)                     y1 = min (py a) (py b)-                    x2 = max (px a + width a) (px b + width b) -                    y2 = max (py a + height a) (py b + height b)   +                    x2 = max (px a + width a) (px b + width b)+                    y2 = max (py a + height a) (py b + height b)  mainTabRectAndShift :: Rect -> (Rect, (Int, Int)) mainTabRectAndShift r = (res, (dx, dy))-    where res = Rect +    where res = Rect             { px     = 5-            , py     = 5    +            , py     = 5             , width  = px r + width r + 10             , height = py r + height r + yBox 15 2 + 10-            } +            }           dx = 10           dy = yBox 15 2 + 10-      + tabsRects :: ScaleFactor -> Panel -> [(Rect, Win)] tabsRects defaultScaleUI x = case x of     Single _ _    -> []@@ -440,69 +304,69 @@  winBoundingRect :: ScaleFactor -> Win -> Rect winBoundingRect defaultScaleUI w = maybe (shiftBy 50 $ bestRect defaultScaleUI $ winGui w) id $ winRect w-    where shiftBy n r = r { px = n + px r, py = n + py r }      +    where shiftBy n r = r { px = n + px r, py = n + py r }  drawTab :: (Int, Int) -> Rect -> Win -> Doc drawTab shift r w = group (winTitle w) r $ drawWin (withRelWinMargin $ shiftRect shift r) w-    where group title rect body = vcat -            [ ppProc "FLgroup" $ (text $ show title) : rectToFrame rect+    where group title rect body = P.vcat+            [ ppProc "FLgroup" $ (P.text $ show title) : rectToFrame rect             , body             , ppProc "FLgroupEnd" []] -          shiftRect (dx, dy) rect = rect +          shiftRect (dx, dy) rect = rect             { px = dx + px rect             , py = dy + py rect }-       + rectToFrame :: Rect -> [Doc]-rectToFrame rect = fmap int [width rect, height rect, px rect, py rect]                             +rectToFrame rect = fmap P.int [width rect, height rect, px rect, py rect]  drawWin :: Rect -> Win -> Doc drawWin rect w = renderAbsScene $ Box.draw rect $ unGui $ winGui w     where-        renderAbsScene = Box.cascade drawPrim empty vcat onCtx setProps def+        renderAbsScene = Box.cascade drawPrim P.empty P.vcat onCtx setProps def             where                 setProps ps = appEndo $ mconcat $ fmap (Endo . setPropCtx) (otherProps ps)-                +                 onCtx r ps res = maybe res (\borderType -> drawBorder borderType r res) (propsBorder ps)  drawBorder :: BorderType -> Rect -> Doc -> Doc-drawBorder borderType rect a = vcat -    [ ppProc "FLgroup" $ ((text $ show "") : frame) ++ [borderAsInt borderType]+drawBorder borderType rect a = P.vcat+    [ ppProc "FLgroup" $ ((P.text $ show "") : frame) ++ [borderAsInt borderType]     , a     , ppProc "FLgroupEnd" []]-    where borderAsInt = int . fromEnum-          frame = rectToFrame rect   -                +    where borderAsInt = P.int . fromEnum+          frame = rectToFrame rect+ drawPrim :: PropCtx -> Rect -> ElemWithOuts -> Doc-drawPrim ctx rect elem = vcat +drawPrim ctx rect elem = P.vcat     [ drawElemDef ctx rect elem     , drawAppearance ctx elem     , drawInitVal elem ]  drawAppearance :: PropCtx -> ElemWithOuts -> Doc-drawAppearance ctx el = maybe empty (flip flSetAll ctx)+drawAppearance ctx el = maybe P.empty (flip flSetAll ctx)     $ getPropHandle $ elemOuts el  drawInitVal :: ElemWithOuts -> Doc-drawInitVal = vcat . fmap flSetVal_i . elemInits +drawInitVal = P.vcat . fmap flSetVal_i . elemInits  drawElemDef :: PropCtx -> Rect -> ElemWithOuts -> Doc drawElemDef ctx rectWithoutLabel el = case elemContent el of     -- valuators     Count  diap step1 step2 -> drawCount diap step1 step2-    Joy    span1 span2      -> drawJoy span1 span2 -    Knob   span             -> drawKnob span -    Roller span step        -> drawRoller span step -    Slider span             -> drawSlider span -    Text   diap step        -> drawText diap step +    Joy    span1 span2      -> drawJoy span1 span2+    Knob   span             -> drawKnob span+    Roller span step        -> drawRoller span step+    Slider span             -> drawSlider span+    Text   diap step        -> drawText diap step -    -- other widgets  +    -- other widgets     Box label               -> drawBox label-    ButBank xn yn           -> drawButBank xn yn +    ButBank xn yn           -> drawButBank xn yn     Button instrId          -> drawButton instrId     Toggle                  -> drawToggle-    Value                   -> drawValue -    Vkeybd                  -> drawVkeybd +    Value                   -> drawValue+    Vkeybd                  -> drawVkeybd      -- error     GuiVar guiHandle        -> orphanGuiVar guiHandle@@ -514,27 +378,27 @@             where label = getLabel ctx          f = fWithLabel (getLabel ctx)-        fWithLabel label name args = ppMoOpc (fmap ppVar $ elemOuts el) name ((text $ show $ label) : args)+        fWithLabel label name args = ppMoOpc (fmap ppVar $ elemOuts el) name ((P.text $ show $ label) : args)         fNoLabel name args = ppMoOpc (fmap ppVar $ elemOuts el) name args         frame = frameBy rect         frameWithoutLabel = frameBy rectWithoutLabel-        frameBy x = fmap int [width x, height x, px x, py x]       -        noDisp = int (-1)-        noOpc  = int (-1)-        onOpc instrId xs = int 0 : int (instrIdCeil instrId) : fmap double xs+        frameBy x = fmap P.int [width x, height x, px x, py x]+        noDisp = P.int (-1)+        noOpc  = P.int (-1)+        onOpc instrId xs = P.int 0 : P.int (instrIdCeil instrId) : fmap P.double xs         drawSpan (ValSpan diap scale) = [imin diap, imax diap, getScale scale]-   -        imin = double . valDiapMin-        imax = double . valDiapMax +        imin = P.double . valDiapMin+        imax = P.double . valDiapMax+         -----------------------------------------------------------------------         -- valuators          -- FLcount         drawCount diap step1 mValStep2 = f "FLcount" $             [ imin diap, imax diap-            , double step1, double step2-            , int itype ] +            , P.double step1, P.double step2+            , P.int itype ]             ++ frame ++ [noOpc]             where (step2, itype) = case mValStep2 of                     -- type 1 FLcount with 2 steps@@ -546,14 +410,14 @@         drawJoy (ValSpan dX sX) (ValSpan dY sY) = f "FLjoy" $             [ imin dX, imax dX, imin dY, imax dY             , getScale sX, getScale sY-            , noDisp, noDisp +            , noDisp, noDisp             ] ++ frame          -- FLknob-        drawKnob span = f "FLknob" $ -            drawSpan span ++ [getKnobType ctx, noDisp] -            ++ fmap int knobFrame ++ getKnobCursorSize ctx            -            where +        drawKnob span = f "FLknob" $+            drawSpan span ++ [getKnobType ctx, noDisp]+            ++ fmap P.int knobFrame ++ getKnobCursorSize ctx+            where                 knobFrame                     | w < h     = [w, x, y + d]                     | otherwise = [h, x + d, y]@@ -561,231 +425,49 @@                 w = width rect                 x = px rect                 y = py rect-                d = div (abs $ h - w) 2 +                d = div (abs $ h - w) 2          -- FLroller         drawRoller (ValSpan d s) step = f "FLroller" $-            [ imin d, imax d, double step+            [ imin d, imax d, P.double step             , getScale s, getRollerType (getDefOrient rect) ctx, noDisp             ] ++ frame          -- FLslider-        drawSlider span = f "FLslider" $ -            drawSpan span -            ++ [getSliderType (getDefOrient rect) ctx, noDisp] +        drawSlider span = f "FLslider" $+            drawSpan span+            ++ [getSliderType (getDefOrient rect) ctx, noDisp]             ++ frame          -- FLtext-        drawText diap step = f "FLtext" $ -            [imin diap, imax diap, double step, getTextType ctx] ++ frame+        drawText diap step = f "FLtext" $+            [imin diap, imax diap, P.double step, getTextType ctx] ++ frame          -----------------------------------------------------------------------         -- other widgets-        +         -- FLbox         drawBox label = fWithLabel label "FLbox" $             [ getBoxType ctx, getFontType ctx, getFontSize ctx ] ++ frameWithoutLabel-        +         -- FLbutBank-        drawButBank xn yn = fNoLabel "FLbutBank" $ -            [getButtonBankType ctx, int xn, int yn] ++ frameWithoutLabel ++ [noOpc] +        drawButBank xn yn = fNoLabel "FLbutBank" $+            [getButtonBankType ctx, P.int xn, P.int yn] ++ frameWithoutLabel ++ [noOpc]          -- FLbutton's-        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]+        drawButton instrId = f "FLbutton" $ [P.int 1, P.int 0, getButtonType ctx] ++ frameWithoutLabel ++ (onOpc instrId [0, infiniteDur]) +        drawToggle = f "FLbutton" $ [P.int 1, P.int 0, getToggleType ctx] ++ frameWithoutLabel ++ [noOpc]+         -- FLvalue-        drawValue = f "FLvalue" frame +        drawValue = f "FLvalue" frame          -- FLvkeybd-        drawVkeybd = fWithLabel "" "FLvkeybd" frame  ---------------------------------------------------------------- cascading context, here we group properties by type--data PropCtx = PropCtx -    { ctxLabel        :: Maybe String-    , ctxMaterial     :: Maybe Material-    , ctxLabelType    :: Maybe LabelType-    , ctxBoxType      :: Maybe BoxType-    , ctxColor1       :: Maybe Color-    , ctxColor2       :: Maybe Color-    , ctxTextColor    :: Maybe Color-    , ctxFontSize     :: Maybe Int-    , ctxFontType     :: Maybe FontType-    , ctxEmphasis     :: Maybe Emphasis-    , ctxOrient       :: Maybe Orient-    , ctxSliderType   :: Maybe SliderType-    , ctxButtonType   :: Maybe ButtonType-    , ctxTextType     :: Maybe TextType-    , ctxKnobType     :: Maybe KnobType }-    -instance Default PropCtx where-    def = PropCtx Nothing Nothing Nothing Nothing Nothing Nothing-                  Nothing Nothing Nothing Nothing Nothing Nothing-                  Nothing Nothing Nothing -   -setPropCtx :: Prop -> PropCtx -> PropCtx -setPropCtx p x = case p of-            SetLabel        a -> x { ctxLabel  = Just a }-            SetMaterial     a -> x { ctxMaterial = Just a }-            SetLabelType    a -> x { ctxLabelType = Just a }-            SetBoxType      a -> x { ctxBoxType = Just a }-            SetColor1       a -> x { ctxColor1 = Just a }-            SetColor2       a -> x { ctxColor2 = Just a }-            SetTextColor    a -> x { ctxTextColor = Just a }-            SetFontSize     a -> x { ctxFontSize = Just a }-            SetFontType     a -> x { ctxFontType = Just a }-            SetEmphasis     a -> x { ctxEmphasis = Just a }-            SetOrient       a -> x { ctxOrient = Just a }-            SetSliderType   a -> x { ctxSliderType = Just a }-            SetButtonType   a -> x { ctxButtonType = Just a }-            SetTextType     a -> x { ctxTextType = Just a }-            SetKnobType     a -> x { ctxKnobType = Just a } --getLabel :: PropCtx -> String-getLabel = maybe "" id . ctxLabel----------------------------------------------------------------------- Converting readable properties to integer codes--maybeDef :: Default a => Maybe a -> a-maybeDef = maybe def id--intProp :: Default a => (PropCtx -> Maybe a) -> (a -> Int) -> (PropCtx -> Doc)-intProp select convert = int . convert . maybeDef . select --getScale :: ValScaleType -> Doc-getScale x = int $ case x of-    Linear      -> 0-    Exponential -> -1--getLabelType :: PropCtx -> Doc-getLabelType = intProp ctxLabelType $ \x -> case x of-    NormalLabel     -> 0-    NoLabel         -> 1-    SymbolLabel     -> 2-    ShadowLabel     -> 3-    EngravedLabel   -> 4-    EmbossedLabel   -> 5--getDefOrient :: Rect -> Orient-getDefOrient r -    | height r < width r    = Hor-    | otherwise             = Ver--getOrient :: Orient -> PropCtx -> Orient-getOrient defOrient = maybe defOrient id . ctxOrient--getKnobType :: PropCtx -> Doc-getKnobType = intProp ctxKnobType $ \x -> case x of-    Flat        -> 4-    Pie         -> 2-    Clock       -> 3-    ThreeD _    -> 1-  -getKnobCursorSize :: PropCtx -> [Doc]-getKnobCursorSize ctx = case maybeDef $ ctxKnobType ctx of-    ThreeD (Just n) -> [int n]-    _               -> []--getRollerType :: Orient -> PropCtx -> Doc-getRollerType defOrient ctx = int $ case getOrient defOrient ctx of-    Hor -> 1-    Ver -> 2-    -getSliderType :: Orient -> PropCtx -> Doc-getSliderType defOrient ctx = int $ appMaterial ctx $ -    case (getOrient defOrient ctx, maybeDef $ ctxSliderType ctx) of-        (Hor, Fill)         -> 1-        (Ver, Fill)         -> 2-        (Hor, Engraved)     -> 3-        (Ver, Engraved)     -> 4-        (Hor, Nice)         -> 5-        (Ver, Nice)         -> 6--getTextType :: PropCtx -> Doc-getTextType = intProp ctxTextType $ \x -> case x of  -    NormalText  -> 1-    NoDrag      -> 2-    NoEdit      -> 3--getBoxType :: PropCtx -> Doc-getBoxType = intProp ctxBoxType $ succ . fromEnum--getFontSize :: PropCtx -> Doc -getFontSize  = int . getIntFontSize --getIntFontSize :: PropCtx -> Int-getIntFontSize ctx = maybe defFontSize id $ ctxFontSize ctx--getFontType :: PropCtx -> Doc-getFontType ctx = int $ -    case (maybeDef $ ctxFontType ctx, maybeDef $ ctxEmphasis ctx) of-        (Helvetica, NoEmphasis)         -> 1-        (Helvetica, Bold)               -> 2-        (Helvetica, Italic)             -> 3-        (Helvetica, BoldItalic)         -> 4-        (Courier, NoEmphasis)           -> 5-        (Courier, Bold)                 -> 6-        (Courier, Italic)               -> 7-        (Courier, BoldItalic)           -> 8-        (Times, NoEmphasis)             -> 9-        (Times, Bold)                   -> 10-        (Times, Italic)                 -> 11-        (Times, BoldItalic)             -> 12-        (Symbol, _)                     -> 13-        (Screen, Bold)                  -> 15-        (Screen, _)                     -> 14-        (Dingbats, _)                   -> 16-       -getButtonType :: PropCtx -> Doc-getButtonType ctx = int $ appMaterial ctx 1--getButtonBankType :: PropCtx -> Doc-getButtonBankType ctx = ($ ctx) $ intProp ctxButtonType $ \x -> -    reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of-        NormalButton    -> 1-        LightButton     -> 2-        CheckButton     -> 3-        RoundButton     -> 4   -    where reactOnNoPlasticForRoundBug x = case x of-            24 -> 4-            _  -> x-       -getToggleType :: PropCtx -> Doc-getToggleType ctx = ($ ctx) $ intProp ctxButtonType $ \x -> -    reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of-        NormalButton    -> 2-        LightButton     -> 2-        CheckButton     -> 3-        RoundButton     -> 4   -    where reactOnNoPlasticForRoundBug x = case x of-            24 -> 4-            _  -> x---appMaterial :: PropCtx -> Int -> Int-appMaterial ctx = case maybeDef $ ctxMaterial ctx of-    Plastic   -> (+ 20)-    NoPlastic -> id-  -getColor1, getColor2, getTextColor :: PropCtx -> Doc--getColor1       = genGetColor gray  ctxColor1-getColor2       = genGetColor white ctxColor2-getTextColor    = genGetColor black ctxTextColor--genGetColor :: Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc-genGetColor defColor select ctx = colorToDoc $ maybe defColor id $ select ctx-    where colorToDoc col = hcat $ punctuate comma -            $ fmap (channelToDoc col) [channelRed, channelGreen, channelBlue]        -          channelToDoc col chn = int $ fromEnum $ chn $ toSRGB24 $ col  +        drawVkeybd = fWithLabel "" "FLvkeybd" frame  ----------------------------------------------------------------- -- handy shortcuts-    + setProp :: Prop -> Gui -> Gui setProp p = props [p] @@ -843,39 +525,39 @@  winMargin :: Int winMargin = 10-     + appendWinMargin :: Rect -> Rect-appendWinMargin r = r +appendWinMargin r = r     { width  = 2 * winMargin + width r-    , height = 2 * winMargin + height r +    , height = 2 * winMargin + height r     }  withWinMargin :: Rect -> Rect-withWinMargin r = r +withWinMargin r = r     { px = winMargin-    , py = winMargin +    , py = winMargin     , height = height r - 2 * winMargin-    , width  = width  r - 2 * winMargin +    , width  = width  r - 2 * winMargin     }  withRelWinMargin :: Rect -> Rect-withRelWinMargin r = r +withRelWinMargin r = r     { px = winMargin + px r     , py = winMargin + py r     , height = height r - 2 * winMargin-    , width  = width  r - 2 * winMargin +    , width  = width  r - 2 * winMargin     }  bestRect :: ScaleFactor -> Gui -> Rect bestRect defaultScaleUI-    = appendWinMargin . Box.boundingRect +    = appendWinMargin . Box.boundingRect     . mapWithOrientAndScale defaultScaleUI (\curOrient curScaleFactor x -> uncurry noShiftRect $ bestElemSizesRescaled curScaleFactor $ bestElemSizes curOrient $ elemContent x)     . unGui     where noShiftRect w h = Rect { px = 0, py = 0, width = w, height = h }-        + mapWithOrientAndScale :: ScaleFactor -> (Orient -> ScaleFactor -> a -> b) -> Box.Scene Props a -> Box.Scene Props b mapWithOrientAndScale defaultScaleUI f = iter Hor defaultScaleUI-    where +    where         iter curOrient curScale x = case x of             Box.Prim a          -> Box.Prim $ f curOrient curScale a             Box.Space           -> Box.Space@@ -885,35 +567,35 @@             Box.Context ctx a   -> case propsScaleFactor ctx of                     Nothing -> Box.Context ctx $ iter curOrient curScale a                     Just newScale -> Box.Context ctx $ iter curOrient (mulFactors curScale newScale) a-            where +            where                 mulFactors (x1, y1) (x2, y2) = (x1 * x2, y1 * y2)-       + bestElemSizesRescaled :: ScaleFactor -> (Int, Int) -> (Int, Int)-bestElemSizesRescaled (scaleX, scaleY) (sizeX, sizeY) = (mul scaleX sizeX, mul scaleY sizeY) -    where mul double int = round $ double * fromIntegral int+bestElemSizesRescaled (scaleX, scaleY) (sizeX, sizeY) = (mul scaleX sizeX, mul scaleY sizeY)+    where mul d n = round $ d * fromIntegral n  bestElemSizes :: Orient -> Elem -> (Int, Int) bestElemSizes orient x = case x of     -- valuators     Count   _ _ _   -> (120, 30)-    Joy     _ _     -> (200, 200)  +    Joy     _ _     -> (200, 200)     Knob    _       -> (80, 80)     Roller  _ _     -> inVer (150, 30)     Slider  _       -> inVer (150, 25)     Text    _ _     -> (100, 35) -    -- other widgets  -    Box     label    -> +    -- other widgets+    Box     label    ->         let symbolsPerLine = 60             numOfLines = succ $ div (length label) symbolsPerLine-        in  (xBox 15 symbolsPerLine, yBox 15 numOfLines)            +        in  (xBox 15 symbolsPerLine, yBox 15 numOfLines)      ButBank xn yn   -> (xn * 70, yn * 35)-    Button _        -> (75, 35) -    Toggle          -> (75, 35) +    Button _        -> (75, 35)+    Toggle          -> (75, 35)     Value           -> (80, 35)     Vkeybd          -> (1080, 240)-    +     -- error     GuiVar h        -> orphanGuiVar h     where inVer (a, b) = case orient of@@ -936,20 +618,20 @@ -- set properties  flSetAll :: Var -> PropCtx -> Doc-flSetAll handle ctx = vcat $ fmap (\f -> f handle ctx)+flSetAll handle ctx = P.vcat $ fmap (\f -> f handle ctx)     [ flSetColor, flSetColor2, flSetTextColor     , flSetTextSize, flSetTextType, flSetFont ] -flSetColor, flSetColor2, flSetTextColor, flSetTextSize, flSetTextType,     +flSetColor, flSetColor2, flSetTextColor, flSetTextSize, flSetTextType,     flSetFont :: Var -> PropCtx -> Doc -flSetProp :: String -    -> (PropCtx -> Maybe a) -    -> (PropCtx -> Doc) +flSetProp :: String+    -> (PropCtx -> Maybe a)+    -> (PropCtx -> Doc)     -> Var -> PropCtx -> Doc-flSetProp name isDef select handle ctx -    | isNothing $ isDef ctx = empty-    | otherwise             = ppProc name [select ctx, ppVar handle]    +flSetProp name isDef select handle ctx+    | isNothing $ isDef ctx = P.empty+    | otherwise             = ppProc name [select ctx, ppVar handle]  flSetColor        = flSetProp "FLsetColor"        ctxColor1       getColor1 flSetColor2       = flSetProp "FLsetColor2"       ctxColor2       getColor2@@ -959,7 +641,7 @@ flSetFont         = flSetProp "FLsetFont"         ctxFontType     getFontType  flSetVal_i :: InitMe -> Doc-flSetVal_i (InitMe handle v0) = ppProc "FLsetVal_i" [double v0, ppVar handle]+flSetVal_i (InitMe handle v0) = ppProc "FLsetVal_i" [P.double v0, ppVar handle]  ------------------------------------------------------------ -- extract handle.Hor@@ -974,34 +656,3 @@  orphanGuiVar :: GuiHandle -> a orphanGuiVar (GuiHandle n) = error $ "orphan GuiHandle: " ++ show n------------------------------------------------------------------ pretty printers--ppProc :: String -> [Doc] -> Doc-ppProc name xs = text name <+> (hsep $ punctuate comma xs)--ppMoOpc :: [Doc] -> String -> [Doc] -> Doc-ppMoOpc outs name ins = f outs <+> text name <+> f ins-    where f = hsep . punctuate comma--ppVar :: Var -> Doc-ppVar v = case v of-    Var ty rate name   -> hcat [ppVarType ty, ppRate rate, text (varPrefix ty : name)]-    VarVerbatim _ name -> text name--varPrefix :: VarType -> Char-varPrefix x = case x of-    LocalVar  -> 'l'-    GlobalVar -> 'g'--ppVarType :: VarType -> Doc-ppVarType x = case x of-    LocalVar  -> empty-    GlobalVar -> char 'g'--ppRate :: Rate -> Doc-ppRate x = case x of-    Sr -> char 'S'-    _  -> phi x-    where phi = text . map toLower . show 

@@ -0,0 +1,192 @@+module Csound.Typed.Gui.Pretty (+  ppProc, ppMoOpc, ppVar, varPrefix, ppVarType, ppRate,++  intProp, getScale, getLabelType, getDefOrient, getOrient, getKnobType,+  getKnobCursorSize, getRollerType, getSliderType, getTextType, getBoxType,+  getFontSize, getIntFontSize, getFontType, getButtonType, getButtonBankType,+  getToggleType, appMaterial, getColor1, getColor2, getTextColor, genGetColor+) where++import Data.Char+import Data.Default+import Data.Colour.Names(white, gray, black)+import Data.Colour.SRGB++import Text.PrettyPrint.Leijen(Doc, int, hcat, hsep, punctuate, comma, text, char)+import qualified Text.PrettyPrint.Leijen as P((<+>), empty)++import Csound.Dynamic(Var(..), VarType(..), Rate(..))++import Csound.Typed.Gui.Types++-------------------------------------------------------------+-- pretty printers++ppProc :: String -> [Doc] -> Doc+ppProc name xs = text name P.<+> (hsep $ punctuate comma xs)++ppMoOpc :: [Doc] -> String -> [Doc] -> Doc+ppMoOpc outs name ins = f outs P.<+> text name P.<+> f ins+    where f = hsep . punctuate comma++ppVar :: Var -> Doc+ppVar v = case v of+    Var ty rate name   -> hcat [ppVarType ty, ppRate rate, text (varPrefix ty : name)]+    VarVerbatim _ name -> text name++varPrefix :: VarType -> Char+varPrefix x = case x of+    LocalVar  -> 'l'+    GlobalVar -> 'g'++ppVarType :: VarType -> Doc+ppVarType x = case x of+    LocalVar  -> P.empty+    GlobalVar -> char 'g'++ppRate :: Rate -> Doc+ppRate x = case x of+    Sr -> char 'S'+    _  -> phi x+    where phi = text . map toLower . show++------------------------------------------------------------------+-- Converting readable properties to integer codes++maybeDef :: Default a => Maybe a -> a+maybeDef = maybe def id++intProp :: Default a => (PropCtx -> Maybe a) -> (a -> Int) -> (PropCtx -> Doc)+intProp select convert = int . convert . maybeDef . select++getScale :: ValScaleType -> Doc+getScale x = int $ case x of+    Linear      -> 0+    Exponential -> -1++getLabelType :: PropCtx -> Doc+getLabelType = intProp ctxLabelType $ \x -> case x of+    NormalLabel     -> 0+    NoLabel         -> 1+    SymbolLabel     -> 2+    ShadowLabel     -> 3+    EngravedLabel   -> 4+    EmbossedLabel   -> 5++getDefOrient :: Rect -> Orient+getDefOrient r+    | height r < width r    = Hor+    | otherwise             = Ver++getOrient :: Orient -> PropCtx -> Orient+getOrient defOrient = maybe defOrient id . ctxOrient++getKnobType :: PropCtx -> Doc+getKnobType = intProp ctxKnobType $ \x -> case x of+    Flat        -> 4+    Pie         -> 2+    Clock       -> 3+    ThreeD _    -> 1++getKnobCursorSize :: PropCtx -> [Doc]+getKnobCursorSize ctx = case maybeDef $ ctxKnobType ctx of+    ThreeD (Just n) -> [int n]+    _               -> []++getRollerType :: Orient -> PropCtx -> Doc+getRollerType defOrient ctx = int $ case getOrient defOrient ctx of+    Hor -> 1+    Ver -> 2++getSliderType :: Orient -> PropCtx -> Doc+getSliderType defOrient ctx = int $ appMaterial ctx $+    case (getOrient defOrient ctx, maybeDef $ ctxSliderType ctx) of+        (Hor, Fill)         -> 1+        (Ver, Fill)         -> 2+        (Hor, Engraved)     -> 3+        (Ver, Engraved)     -> 4+        (Hor, Nice)         -> 5+        (Ver, Nice)         -> 6++getTextType :: PropCtx -> Doc+getTextType = intProp ctxTextType $ \x -> case x of+    NormalText  -> 1+    NoDrag      -> 2+    NoEdit      -> 3++getBoxType :: PropCtx -> Doc+getBoxType = intProp ctxBoxType $ (+1) . fromEnum++getFontSize :: PropCtx -> Doc+getFontSize  = int . getIntFontSize++getIntFontSize :: PropCtx -> Int+getIntFontSize ctx = maybe defFontSize id $ ctxFontSize ctx++getFontType :: PropCtx -> Doc+getFontType ctx = int $+    case (maybeDef $ ctxFontType ctx, maybeDef $ ctxEmphasis ctx) of+        (Helvetica, NoEmphasis)         -> 1+        (Helvetica, Bold)               -> 2+        (Helvetica, Italic)             -> 3+        (Helvetica, BoldItalic)         -> 4+        (Courier, NoEmphasis)           -> 5+        (Courier, Bold)                 -> 6+        (Courier, Italic)               -> 7+        (Courier, BoldItalic)           -> 8+        (Times, NoEmphasis)             -> 9+        (Times, Bold)                   -> 10+        (Times, Italic)                 -> 11+        (Times, BoldItalic)             -> 12+        (Symbol, _)                     -> 13+        (Screen, Bold)                  -> 15+        (Screen, _)                     -> 14+        (Dingbats, _)                   -> 16++++getButtonType :: PropCtx -> Doc+getButtonType ctx = int $ appMaterial ctx 1++getButtonBankType :: PropCtx -> Doc+getButtonBankType ctx = ($ ctx) $ intProp ctxButtonType $ \x ->+    reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of+        NormalButton    -> 1+        LightButton     -> 2+        CheckButton     -> 3+        RoundButton     -> 4++getToggleType :: PropCtx -> Doc+getToggleType ctx = ($ ctx) $ intProp ctxButtonType $ \x ->+    reactOnNoPlasticForRoundBug $ appMaterial ctx $ case x of+        NormalButton    -> 2+        LightButton     -> 2+        CheckButton     -> 3+        RoundButton     -> 4++reactOnNoPlasticForRoundBug :: Int -> Int+reactOnNoPlasticForRoundBug x+  | x == 24 = 4+  | otherwise = x++appMaterial :: PropCtx -> Int -> Int+appMaterial ctx = case maybeDef $ ctxMaterial ctx of+    Plastic   -> (+ 20)+    NoPlastic -> id++getColor1 :: PropCtx -> Doc+getColor1       = genGetColor gray  ctxColor1++getColor2 :: PropCtx -> Doc+getColor2       = genGetColor white ctxColor2++getTextColor :: PropCtx -> Doc+getTextColor    = genGetColor black ctxTextColor++genGetColor :: Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc+genGetColor defColor select ctx = colorToDoc $ maybe defColor id $ select ctx+    where+      colorToDoc col = hcat $ punctuate comma+            $ fmap (channelToDoc col) [channelRed, channelGreen, channelBlue]++      channelToDoc col chn = int $ fromEnum $ chn $ toSRGB24 $ col

@@ -0,0 +1,249 @@+{-# Language CPP #-}+module Csound.Typed.Gui.Types (+    Props(..),+    Prop(..), BorderType(..), Color,+    Rect(..), FontType(..), Emphasis(..),+    Material(..), Orient(..), LabelType(..),+    ScaleFactor,++    ValDiap(..), ValStep, ValScaleType(..), ValSpan(..),+    linSpan, expSpan, uspan, bspan, uspanExp,+    KnobType(..),+    SliderType(..),+    TextType(..),+    BoxType(..),+    ButtonType(..),++    defFontSize,++    PropCtx(..), setPropCtx, getLabel+) where++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif++import Control.Applicative(Alternative(..))+import Data.Default+import Data.Colour++import Csound.Typed.Gui.BoxModel(Rect(..))++-- | The Csound colours.+type Color = Colour Double++-- | The orientation of the widget (slider, roller). This property is+-- never needs to be set in practice. If this property is not set then+-- default orientation is calculated from the bounding box of the widget.+-- If the width is greater than the height then we need to use a horizontal+-- widget otherwise it should be a vertical one.+data Orient = Hor | Ver++-- | A value span is a diapason of the value and a type+-- of the scale (can be linear or exponential).+data ValSpan = ValSpan+    { valSpanDiap  :: ValDiap+    , valSpanScale :: ValScaleType }++-- | Makes a linear @ValSpan@ with specified boundaries.+--+-- > linSpan minVal maxVal+linSpan :: Double -> Double -> ValSpan+linSpan a b = ValSpan (ValDiap a b) Linear++-- | Makes an exponential @ValSpan@ with specified boundaries.+--+-- > expSpan minVal maxVal+expSpan :: Double -> Double -> ValSpan+expSpan a b = ValSpan (ValDiap (checkBound a) b) Exponential+    where+        checkBound x+            | x <= 0    = 0.00001+            | otherwise = x++-- | Unit span. A special case:+--+-- > uspan = linSpan 0 1+uspan :: ValSpan+uspan = linSpan 0 1++-- | Bipolar unit span. A special case:+--+-- > uspan = linSpan (-1) 1+bspan :: ValSpan+bspan = linSpan (-1) 1++-- | An exponential unit span. A special case:+--+-- > uspan = expSpan 0 1+uspanExp :: ValSpan+uspanExp = linSpan 0 1++-- | The diapason of the continuous value.+data ValDiap = ValDiap+    { valDiapMin   :: Double+    , valDiapMax   :: Double }++data ValScaleType = Linear | Exponential++type ValStep = Double++data FontType       = Helvetica | Courier | Times | Symbol | Screen | Dingbats+data Emphasis       = NoEmphasis | Italic | Bold | BoldItalic+data KnobType       = ThreeD (Maybe Int) | Pie | Clock | Flat+data SliderType     = Fill | Engraved | Nice+data TextType       = NormalText | NoDrag | NoEdit++-- | The type of the material of the element. It affects sliders and buttons.+data Material       = NoPlastic | Plastic++-- | Some values are not implemented on the Csound level.+data LabelType      = NormalLabel | NoLabel | SymbolLabel+                    | ShadowLabel | EngravedLabel | EmbossedLabel++-- | The type of the box. Some values are not implemented on the Csound level.+data BoxType+    = FlatBox+    | UpBox+    | DownBox+    | ThinUpBox+    | ThinDownBox+    | EngravedBox+    | EmbossedBox+    | BorderBox+    | ShadowBox+    | Roundedbox+    | RoundedShadowBox+    | RoundedFlatBox+    | RoundedUpBox+    | RoundedDownBox+    | DiamondUpBox+    | DiamondDownBox+    | OvalBox+    | OvalShadowBox+    | OvalFlatBox+    deriving (Enum)++data BorderType+    = NoBorder+    | DownBoxBorder+    | UpBoxBorder+    | EngravedBorder+    | EmbossedBorder+    | BlackLine+    | ThinDown+    | ThinUp+    deriving (Enum)++-- | The type of the button. It affects toggle buttons and button banks.+--+-- In Csound buttons and toggle buttons+-- are constructed with the same function (but with different button types).+-- But in this library they are contructed by different functions (@button@ and @toggle@).+-- Normal button is a plain old button, but other values specify toggle buttons.+-- So this property doesn't affect the buttons (since they could be only normal buttons).+data ButtonType = NormalButton | LightButton | CheckButton | RoundButton++defFontSize :: Int+defFontSize = 15++instance Default FontType       where def = Courier+instance Default Emphasis       where def = NoEmphasis+instance Default SliderType     where def = Fill+instance Default KnobType       where def = Flat+instance Default TextType       where def = NormalText+instance Default ButtonType     where def = NormalButton+instance Default BoxType        where def = FlatBox+instance Default Material       where def = Plastic+instance Default LabelType      where def = NormalLabel++data Props = Props+    { propsBorder   :: Maybe BorderType+    , propsScaleFactor :: Maybe ScaleFactor+    , otherProps    :: [Prop] }++type ScaleFactor = (Double, Double)++#if MIN_VERSION_base(4,11,0)+instance Semigroup Props where+    (<>) = mappendProps++instance Monoid Props where+    mempty  = def++#else++instance Monoid Props where+    mempty  = def+    mappend = mappendProps++#endif+++mappendProps :: Props -> Props -> Props+mappendProps a b = Props { propsBorder = propsBorder a <|> propsBorder b+                    , propsScaleFactor = propsScaleFactor a <|> propsScaleFactor b+                    , otherProps  = mappend (otherProps a) (otherProps b) }++instance Default Props where+    def = Props Nothing Nothing []++-- | Properties of the widgets.+data Prop+    = SetLabel String+    | SetMaterial Material+    | SetBoxType BoxType+    | SetColor1 Color | SetColor2 Color | SetTextColor Color+    | SetFontSize Int | SetFontType FontType | SetEmphasis Emphasis+    | SetSliderType SliderType+    | SetTextType TextType+    | SetButtonType ButtonType+    | SetOrient Orient+    | SetKnobType KnobType+    | SetLabelType LabelType++-----------------------------------------------------------+-- cascading context, here we group properties by type++data PropCtx = PropCtx+    { ctxLabel        :: Maybe String+    , ctxMaterial     :: Maybe Material+    , ctxLabelType    :: Maybe LabelType+    , ctxBoxType      :: Maybe BoxType+    , ctxColor1       :: Maybe Color+    , ctxColor2       :: Maybe Color+    , ctxTextColor    :: Maybe Color+    , ctxFontSize     :: Maybe Int+    , ctxFontType     :: Maybe FontType+    , ctxEmphasis     :: Maybe Emphasis+    , ctxOrient       :: Maybe Orient+    , ctxSliderType   :: Maybe SliderType+    , ctxButtonType   :: Maybe ButtonType+    , ctxTextType     :: Maybe TextType+    , ctxKnobType     :: Maybe KnobType }++instance Default PropCtx where+    def = PropCtx Nothing Nothing Nothing Nothing Nothing Nothing+                  Nothing Nothing Nothing Nothing Nothing Nothing+                  Nothing Nothing Nothing++setPropCtx :: Prop -> PropCtx -> PropCtx+setPropCtx p x = case p of+            SetLabel        a -> x { ctxLabel  = Just a }+            SetMaterial     a -> x { ctxMaterial = Just a }+            SetLabelType    a -> x { ctxLabelType = Just a }+            SetBoxType      a -> x { ctxBoxType = Just a }+            SetColor1       a -> x { ctxColor1 = Just a }+            SetColor2       a -> x { ctxColor2 = Just a }+            SetTextColor    a -> x { ctxTextColor = Just a }+            SetFontSize     a -> x { ctxFontSize = Just a }+            SetFontType     a -> x { ctxFontType = Just a }+            SetEmphasis     a -> x { ctxEmphasis = Just a }+            SetOrient       a -> x { ctxOrient = Just a }+            SetSliderType   a -> x { ctxSliderType = Just a }+            SetButtonType   a -> x { ctxButtonType = Just a }+            SetTextType     a -> x { ctxTextType = Just a }+            SetKnobType     a -> x { ctxKnobType = Just a }++getLabel :: PropCtx -> String+getLabel = maybe "" id . ctxLabel

@@ -7,7 +7,7 @@     -- * Types     Input(..), Output(..), Inner(..),     noInput, noOutput, noInner,-    Widget, widget, Source(..), source, Sink(..), sink, Display(..), display, SinkSource(..), sinkSource, sourceSlice, sinkSlice,+    Widget, widget, Source, source, Sink, sink, Display, display, SinkSource, sinkSource, sourceSlice, sinkSlice,     mapSource, mapGuiSource, mhor, mver, msca,      -- * Widgets@@ -124,29 +124,27 @@ type Widget a b = SE (Gui, Output a, Input b, Inner)  -- | A consumer of the values.-newtype Sink   a = Sink { unSink :: SE (Gui, Output a) }+type Sink   a = SE (Gui, Output a)  -- | A producer of the values.-newtype Source a = Source { unSource :: SE (Gui, Input a) }-    deriving (Functor)+type Source a = SE (Gui, Input a) -newtype SinkSource a = SinkSource { unSinkSource :: SE (Gui, Output a, Input a) }+type SinkSource a = SE (Gui, Output a, Input a)  -- | A static element. We can only look at it.-newtype Display  = Display { unDisplay :: SE Gui }-+type Display  = SE Gui  -- | A handy function for transforming the value of producers. mapSource :: (a -> b) -> Source a -> Source b-mapSource = fmap+mapSource f x = fmap (second f) x  -- | A handy function for transforming the GUIs of producers. mapGuiSource :: (Gui -> Gui) -> Source a -> Source a-mapGuiSource f (Source x) = Source $ fmap (\(gui, ins) -> (f gui, ins)) x+mapGuiSource f x = fmap (\(gui, ins) -> (f gui, ins)) x  mGroup :: Monoid a => ([Gui] -> Gui) -> [Source a] -> Source a-mGroup guiGroup as = Source $ do-    (gs, fs) <- fmap unzip $ sequence $ fmap unSource as+mGroup guiGroup as = do+    (gs, fs) <- fmap unzip $ sequence as     return (guiGroup gs, mconcat fs)  -- | Horizontal grouping of widgets that can produce monoidal values.@@ -173,27 +171,27 @@  -- | A producer constructor. source :: SE (Gui, Input a) -> Source a-source x = Source $ fmap select $ widget $ fmap append x+source x = fmap select $ widget $ fmap append x     where         select (g, _, i, _) = (g, i)         append (g, i) = (g, noOutput, i, noInner)  -- | A consumer constructor. sink :: SE (Gui, Output a) -> Sink a-sink x = Sink $ fmap select $ widget $ fmap append x+sink x = fmap select $ widget $ fmap append x     where         select (g, o, _, _) = (g, o)         append (g, o) = (g, o, noInput, noInner)  sinkSource :: SE (Gui, Output a, Input a) -> SinkSource a-sinkSource x = SinkSource $ fmap select $ widget $ fmap append x+sinkSource x = fmap select $ widget $ fmap append x     where         select (g, o, i, _) = (g, o, i)         append (g, o, i) = (g, o, i, noInner)  -- | A display constructor. display :: SE Gui -> Display-display x = Display $ fmap select $ widget $ fmap append x+display x = fmap select $ widget $ fmap append x     where         select (g, _, _, _) = g         append g = (g, noOutput, noInput, noInner)@@ -206,11 +204,11 @@ setTitle name g     | null name = return g     | otherwise = do-        gTitle <- unDisplay $ box name+        gTitle <- box name         return $ ver [sca 0.01 gTitle, g]  setSourceTitle :: String -> Source a -> Source a-setSourceTitle name (Source ma) = source $ do+setSourceTitle name ma = source $ do     (gui, val) <- ma     newGui <- setTitle name gui     return (newGui, val)@@ -218,20 +216,20 @@ setLabelSource :: String -> Source a -> Source a setLabelSource a     | null a    = id-    | otherwise = Source . fmap (first $ setLabel a) . unSource+    | otherwise = fmap (first $ setLabel a)  setLabelSink :: String -> Sink a -> Sink a setLabelSink a     | null a    = id-    | otherwise = Sink . fmap (first $ setLabel a) . unSink+    | otherwise = fmap (first $ setLabel a)  setLabelSnkSource :: String -> SinkSource a -> SinkSource a setLabelSnkSource a     | null a    = id-    | otherwise = SinkSource . fmap (\(x, y, z) -> (setLabel a x, y, z)) . unSinkSource+    | otherwise = fmap (\(x, y, z) -> (setLabel a x, y, z))  singleOut :: Maybe Double -> Elem -> Source Sig-singleOut v0 el = Source $ geToSe $ do+singleOut v0 el = geToSe $ do     (var, handle) <- newGuiVar     let handleVar = guiHandleToVar handle         inits = maybe [] (return . InitMe handleVar) v0@@ -240,7 +238,7 @@     return (fromGuiHandle handle, readSig var)  singleIn :: (GuiHandle -> Output Sig) -> Maybe Double -> Elem -> Sink Sig-singleIn outs v0 el = Sink $ geToSe $ do+singleIn outs v0 el = geToSe $ do     (var, handle) <- newGuiVar     let handleVar = guiHandleToVar handle         inits = maybe [] (return . InitMe handleVar) v0@@ -249,7 +247,7 @@     return (fromGuiHandle handle, outs handle)  singleInOut :: (GuiHandle -> Output Sig) -> Maybe Double -> Elem -> SinkSource Sig-singleInOut outs v0 el = SinkSource $ geToSe $ do+singleInOut outs v0 el = geToSe $ do     (var, handle) <- newGuiVar     let handleVar = guiHandleToVar handle         inits = maybe [] (return . InitMe handleVar) v0@@ -279,7 +277,7 @@ -- -- doc: <http://www.csounds.com/manual/html/FLjoy.html> joy :: ValSpan -> ValSpan -> (Double, Double) -> Source (Sig, Sig)-joy sp1 sp2 (x, y) = Source $ geToSe $ do+joy sp1 sp2 (x, y) = geToSe $ do     (var1, handle1) <- newGuiVar     (var2, handle2) <- newGuiVar     let handleVar1 = guiHandleToVar handle1@@ -318,7 +316,7 @@ -- of init values. sliderBank :: String -> [Double] -> Source [Sig] sliderBank name ds = source $ do-    (gs, vs) <- fmap unzip $ zipWithM (\n d -> unSource $ slider (show n) uspan d) [(1::Int) ..] ds+    (gs, vs) <- fmap unzip $ zipWithM (\n d -> slider (show n) uspan d) [(1::Int) ..] ds     gui <- setTitle name  $ hor gs     return (gui, vs) @@ -341,7 +339,7 @@ box :: String -> Display box label     | length label < lim = rawBox label-    | otherwise          = Display $ fmap (padding 0 . ver) $ mapM (unDisplay . rawBox) $ parts lim label+    | otherwise          = fmap (padding 0 . ver) $ mapM rawBox $ parts lim label     where         parts n xs             | length xs < n = [xs]@@ -350,7 +348,7 @@         lim = 255  rawBox :: String -> Display-rawBox label = Display $ geToSe $ do+rawBox label = geToSe $ do     (_, handle) <- newGuiVar     let gui = fromElem [guiHandleToVar handle] [] (Box label)     appendToGui (GuiNode gui handle) (unSE noInner)@@ -367,7 +365,7 @@     flagChanged <- geToSe $ onGlobals $ C.newPersistentGlobalVar Kr 0     instrId <- geToSe $ saveInstr $ instr flag     geToSe $ (saveAlwaysOnInstr =<< ) $ saveInstr $ instrCh flag flagChanged-    (g, _) <- unSource $ singleOut Nothing (Button instrId)+    (g, _) <- singleOut Nothing (Button instrId)     val <- fmap fromGE $ fromDep $ readVar flagChanged     return (g, sigToEvt val)     where@@ -451,7 +449,7 @@  setToggle :: String -> Bool -> SinkSource (Evt D) setToggle name initVal = sinkSource $ do-    (g, outs, ins) <- unSinkSource $ setToggleSig name initVal+    (g, outs, ins) <- setToggleSig name initVal     let evtOuts a = outs =<< stepper 0 (fmap sig a)     return (g, evtOuts, snaps ins) @@ -505,8 +503,8 @@ -----------------------------------------------------  sourceSlice :: SinkSource a -> Source a-sourceSlice = Source . (fmap (\(gui, _, a) -> (gui, a))) . unSinkSource+sourceSlice = fmap (\(gui, _, a) -> (gui, a))  sinkSlice :: SinkSource a -> Sink a-sinkSlice = Sink . (fmap (\(gui, a, _) -> (gui, a))) . unSinkSource+sinkSlice = fmap (\(gui, a, _) -> (gui, a)) 

@@ -37,7 +37,7 @@     fxPanTrem, fxMonoTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong,      -- * Tape echo-    tapeRead, tapeWrite,+    tapeRead, tapeWrite, tapeEcho,      -- utilities     delay1k

@@ -1,6 +1,7 @@ module Csound.Typed.Plugins.TapeEcho(     tapeRead   , tapeWrite+  , tapeEcho ) where  import Control.Monad.Trans.Class@@ -12,9 +13,9 @@ import Csound.Typed.GlobalState import qualified Csound.Typed.GlobalState.Elements as E(tapeEchoPlugin) ---  Function to read from tape.+-- | Function to read from tape. -----  tapeRead aIn, kDelay, kRandomSpread+--  > tapeRead aIn, kDelay, kRandomSpread -- -- The function is used in the same manner as deltapi --  first init the delay buffer and the use tapeRead.@@ -31,9 +32,9 @@   where f ain kdel krand = opcs "tapeRead" [(Ar, [Ar, Kr, Kr])] [ain, kdel, krand]  --- function to write to tape+-- | Function to write to tape ----- tapeWrite aIn, aOut, kFbGain+-- > tapeWrite aIn, aOut, kFbGain -- -- It should be though of as delayw for magnetic tape. --@@ -45,8 +46,19 @@   f <$> toGE ain <*> toGE aout <*> toGE kFeedback   where f ain aout kfb = opcs "tapeWrite" [(Xr, [Ar, Ar, Kr])] [ain, aout, kfb] -{--addUdoPlugin E.pitchShifterDelayPlugin-    f <$> toGE ain <*> toGE ktrans <*> toGE kdlt <*> toGE kFB1 <*> toGE kFB2 <*> toGE imaxdlt-    where f ain ktrans kdlt kFB1 kFB2 imaxdlt = opcs "PitchShifterDelay" [(Ar, [Ar, Kr, Kr, Kr, Kr, Ir])] [ain, ktrans, kdlt, kFB1, kFB2, imaxdlt]--}+-- | Generic multi-tap echo opcode.+--+-- > tapeEcho iSize kDelay kEchoGain kFbGain kTone kRandomSpread aIn+--+-- * iSize - how many units of echo+-- * kDelay - delay time+-- * kEchoGain - gain of the echoes+-- * kFbGain - feedback+-- * kTone - low pass filter frequency+-- * kRandomSpread - quality of the tape [0, Inf], the higher the worser the quality of the tape.+-- * aIn - input signal+tapeEcho :: D -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig+tapeEcho iSize kDelay kEchoGain kFbGain kTone kRandomSpread aIn = fromGE $ do+  addUdoPlugin E.tapeEchoPlugin+  f <$> toGE aIn <*> toGE kDelay <*> toGE kEchoGain <*> toGE kFbGain <*> toGE kTone <*> toGE kRandomSpread <*> toGE iSize+  where f aIn kDelay kEchoGain kFbGain kTone kRandomSpread iSize = opcs "TapeEchoN" [(Ar, [Ar, Kr, Kr, Kr, Kr, Kr, Ir])] [aIn, kDelay, kEchoGain, kFbGain, kTone, kRandomSpread, iSize]

@@ -1,4 +1,4 @@-{-# Language TypeFamilies, FlexibleContexts #-}+{-# Language TypeFamilies, FlexibleContexts, CPP #-} module Csound.Typed.Types.Evt(     Evt(..), Bam, sync,     boolToEvt, evtToBool, sigToEvt, stepper,@@ -28,9 +28,25 @@ instance Functor Evt where     fmap f a = Evt $ \bam -> runEvt a (bam . f) +instance Default (Evt a) where+    def = Evt $ const $ return ()++#if MIN_VERSION_base(4,11,0)+instance Semigroup (Evt a) where+    (<>) = mappendEvt+ instance Monoid (Evt a) where-    mempty = Evt $ const $ return ()-    mappend a b = Evt $ \bam -> runEvt a bam >> runEvt b bam+    mempty  = def++#else++instance Monoid (Evt a) where+    mempty  = def+    mappend = mappendEvt++#endif++mappendEvt a b = Evt $ \bam -> runEvt a bam >> runEvt b bam  -- | Converts booleans to events. boolToEvt :: BoolSig -> Evt Unit

@@ -16,46 +16,46 @@  import qualified Temporal.Media as T -type CsdEventList a = T.Track D a+type CsdEventList a = T.Track Sig a -csdEventListNotes :: CsdEventList a -> [(D, D, a)]+csdEventListNotes :: CsdEventList a -> [(Sig, Sig, a)] csdEventListNotes a = fmap (\(T.Event start dur content) -> (start, dur, content)) $ T.render a -csdEventListDur :: CsdEventList a -> D+csdEventListDur :: CsdEventList a -> Sig csdEventListDur = T.dur -rescaleCsdEventList :: D -> CsdEventList a -> CsdEventList a+rescaleCsdEventList :: Sig -> CsdEventList a -> CsdEventList a rescaleCsdEventList = T.str -delayCsdEventList :: D -> CsdEventList a -> CsdEventList a+delayCsdEventList :: Sig -> CsdEventList a -> CsdEventList a delayCsdEventList = T.del   type TupleMonoArg = (E,E,E,E) type RawMonoInstr = TupleMonoArg -> Dep [E] -data M +data M     = Snd InstrId (CsdEventList [E])     | MonoSnd { monoSndInstr :: InstrId, monoSndArgs :: InstrId, monoSndNotes :: (CsdEventList [E]) }-    | Eff InstrId (CsdEventList M) Int   +    | Eff InstrId (CsdEventList M) Int  delayAndRescaleCsdEventListM :: CsdEventList M -> CsdEventList M delayAndRescaleCsdEventListM = delayCsdEventListM . rescaleCsdEventListM  delayCsdEventListM :: CsdEventList M -> CsdEventList M-delayCsdEventListM = T.mapEvents delayCsdEventM    +delayCsdEventListM = T.mapEvents delayCsdEventM -delayCsdEventM :: T.Event D M -> T.Event D M+delayCsdEventM :: T.Event Sig M -> T.Event Sig M delayCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt)     where phi x = case x of             Snd n evts                  -> Snd n $ delayCsdEventList start evts             MonoSnd instrId argId evts  -> MonoSnd instrId argId  $ delayCsdEventList start evts-            Eff n evts arityIn          -> Eff n (delayCsdEventListM $ delayCsdEventList start evts) arityIn        +            Eff n evts arityIn          -> Eff n (delayCsdEventListM $ delayCsdEventList start evts) arityIn  rescaleCsdEventListM :: CsdEventList M -> CsdEventList M-rescaleCsdEventListM = T.mapEvents rescaleCsdEventM    +rescaleCsdEventListM = T.mapEvents rescaleCsdEventM -rescaleCsdEventM :: T.Event D M -> T.Event D M+rescaleCsdEventM :: T.Event Sig M -> T.Event Sig M rescaleCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt)     where phi x = case x of             Snd n evts                  -> Snd n $ rescaleCsdEventList (dur/localDur) evts@@ -68,65 +68,65 @@  renderMixSco :: Int -> CsdEventList M -> Dep [E] renderMixSco arity evts = do-    chnId <- chnRefAlloc arity  -    aliveCountRef <- unSE $ newRef (10 :: D)      -    go aliveCountRef chnId evts    +    chnId <- chnRefAlloc arity+    aliveCountRef <- unSE $ newRef (10 :: D)+    go aliveCountRef chnId evts     readChn chnId-    where +    where         go :: Ref D -> ChnRef -> CsdEventList M -> Dep ()         go aliveCountRef outId xs = do             mapM_ (onEvent aliveCountRef outId) notes             unSE $ writeRef aliveCountRef $ int $ 2 * length notes             aliveCount <- unSE $ readRef aliveCountRef-            hideGEinDep $ liftA2 masterUpdateChnAlive (return chnId) $ toGE aliveCount -            where +            hideGEinDep $ liftA2 masterUpdateChnAlive (return chnId) $ toGE aliveCount+            where                 notes = csdEventListNotes xs                 chnId = outId -        onEvent :: Ref D -> ChnRef -> (D, D, M) -> Dep ()+        onEvent :: Ref D -> ChnRef -> (Sig, Sig, M) -> Dep ()         onEvent aliveCountRef outId (start, dur, x) = case x of             Snd instrId es          -> onSnd aliveCountRef instrId outId es-            MonoSnd instr arg es    -> onMonoSnd instr arg start dur outId es +            MonoSnd instr arg es    -> onMonoSnd instr arg start dur outId es             Eff instrId es arityIn  -> onEff aliveCountRef instrId start dur outId es arityIn -        onSnd _ instrId outId es = forM_ (csdEventListNotes es) $ \(start, dur, args) -> +        onSnd _ instrId outId es = forM_ (csdEventListNotes es) $ \(start, dur, args) ->             mkEvent instrId start dur (args ++ [chnRefId outId])          onEff aliveCountRef instrId start dur outId es arityIn = do             inId <- chnRefAlloc arityIn-            mkEvent instrId start dur [chnRefId inId, chnRefId outId]            +            mkEvent instrId start dur [chnRefId inId, chnRefId outId]             go aliveCountRef inId es          onMonoSnd instrId argId start dur outId es = do             inId <- chnRefAlloc arityMonoIn -            forM_ (csdEventListNotes es) $ \(startLocal, durLocal, args) -> +            forM_ (csdEventListNotes es) $ \(startLocal, durLocal, args) ->                 mkEvent argId startLocal durLocal (args ++ [chnRefId inId])-            +             mkEvent instrId start dur [chnRefId inId, chnRefId outId]-            where arityMonoIn = 3 +            where arityMonoIn = 3   renderMixSco_ :: CsdEventList M -> Dep () renderMixSco_ evts = mapM_ onEvent $ csdEventListNotes evts     where-        onEvent :: (D, D, M) -> Dep ()+        onEvent :: (Sig, Sig, M) -> Dep ()         onEvent (start, dur, x) = case x of             Snd instrId es       -> onSnd instrId es             MonoSnd instr arg es -> onMonoSnd instr arg es             Eff instrId es _     -> onEff instrId start dur es -        onSnd instrId es = forM_ (csdEventListNotes es) $ \(start, dur, args) -> +        onSnd instrId es = forM_ (csdEventListNotes es) $ \(start, dur, args) ->             mkEvent instrId start dur args          onEff instrId start dur es = do-            mkEvent instrId start dur [] +            mkEvent instrId start dur []             renderMixSco_ es          onMonoSnd instr arg es = undefined  -mkEvent :: InstrId -> D -> D -> [E] -> Dep ()+mkEvent :: InstrId -> Sig -> Sig -> [E] -> Dep () mkEvent instrId startD durD args =  hideGEinDep $ do         start <- toGE startD         dur   <- toGE durD

@@ -1,4 +1,4 @@-{-# Language TypeFamilies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, Rank2Types #-}+{-# Language TypeFamilies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, Rank2Types, CPP #-} module Csound.Typed.Types.Prim(     Sig(..), unSig, D(..), unD, Tab(..), unTab, Str(..), Spec(..), Wspec(..), renderTab,     BoolSig(..), unBoolSig, BoolD(..), unBoolD, Unit(..), unit, Val(..), hideGE, SigOrD,@@ -17,6 +17,7 @@      -- ** constants     idur, getSampleRate, getControlRate, getBlockSize, getZeroDbfs,+    getBpm, setBpm,      -- ** converters     ar, kr, ir, sig,@@ -50,6 +51,7 @@  import Data.Default import Data.Boolean+import Data.String  import Csound.Dynamic hiding (double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, untilDo, whileBegin, whileEnd, whileDo) import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, whileBegin, whileEnd)@@ -139,10 +141,24 @@ unit :: Unit unit = Unit $ return () +#if MIN_VERSION_base(4,11,0)+instance Semigroup Unit where+    (<>) = mappendUnit+ instance Monoid Unit where-    mempty = Unit (return ())-    mappend a b = Unit $ (unUnit a) >> (unUnit b)+    mempty  = def +#else++instance Monoid Unit where+    mempty  = def+    mappend = mappendUnit++#endif++mappendUnit :: Unit -> Unit -> Unit+mappendUnit a b = Unit $ (unUnit a) >> (unUnit b)+ instance Default Unit where     def = unit @@ -298,6 +314,9 @@ text :: String -> Str text = fromE . D.str +instance IsString Str where+    fromString = text+ ------------------------------------------------------------------------------- -- constants @@ -317,24 +336,40 @@ getZeroDbfs :: D getZeroDbfs = fromE $ readOnlyVar (VarVerbatim Ir "0dbfs") +-- | Gets the global BPM value.+getBpm :: Sig+getBpm = fromE $ readOnlyVar bpmVar++-- | Sets the global BPM value.+setBpm :: Sig -> SE ()+setBpm x = fromDep_ $ hideGEinDep $ fmap (writeVar bpmVar) (toGE x)+ ------------------------------------------------------------------------------- -- converters  -- | Sets a rate of the signal to audio rate. ar :: Sig -> Sig-ar = on1 $ setRate Ar+ar x = case x of+    PrimSig a -> PrimSig a+    Sig exp   -> Sig $ fmap (setRate Ar) exp  -- | Sets a rate of the signal to control rate. kr :: Sig -> Sig-kr = on1 $ setRate Kr+kr x = case x of+    PrimSig a -> PrimSig a+    Sig exp   -> Sig $ fmap (setRate Kr) exp  -- | Converts a signal to the number (initial value of the signal). ir :: Sig -> D-ir = on1 $ setRate Ir+ir x = case x of+    PrimSig a -> PrimD a+    Sig a -> D $ fmap (setRate Ir) a  -- | Makes a constant signal from the number. sig :: D -> Sig-sig = on1 $ setRate Kr+sig x = case x of+    PrimD a -> PrimSig a+    D exp   -> Sig $ fmap (setRate Kr) exp  ------------------------------------------------------------------------------- -- single wrapper@@ -435,8 +470,36 @@ ------------------------------------------------------------------------------- -- monoid -instance Monoid Sig     where { mempty = on0 mempty     ; mappend = on2 mappend }-instance Monoid D       where { mempty = on0 mempty     ; mappend = on2 mappend }+#if MIN_VERSION_base(4,11,0)+instance Semigroup Sig where+    (<>) = on2 mappend++instance Monoid Sig where+    mempty = on0 mempty++#else++instance Monoid Sig where+    mempty  = on0 mempty+    mappend = on2 mappend++#endif+++#if MIN_VERSION_base(4,11,0)+instance Semigroup D where+    (<>) = on2 mappend++instance Monoid D where+    mempty = on0 mempty++#else++instance Monoid D where+    mempty  = on0 mempty+    mappend = on2 mappend++#endif  ------------------------------------------------------------------------------- -- numeric

@@ -3,7 +3,8 @@         TypeFamilies,         MultiParamTypeClasses,         FlexibleInstances,-        FlexibleContexts #-}+        FlexibleContexts,+        CPP #-} module Csound.Typed.Types.SigSpace(     SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..),     cfd, genCfds, cfd4, cfds,@@ -105,6 +106,7 @@ instance SigSpace Sig   where  mapSig = id instance BindSig  Sig   where  bindSig = id +#if __GLASGOW_HASKELL__ >= 710 instance (SigSpace a1, SigSpace a2) => SigSpace (a1, a2) where  mapSig  f (a1, a2) = (mapSig f a1, mapSig f a2) instance (BindSig a1, BindSig a2) => BindSig  (a1, a2) where  bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2 @@ -126,8 +128,57 @@ instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6, SigSpace a7, SigSpace a8) => SigSpace (a1, a2, a3, a4, a5, a6, a7, a8) where mapSig  f (a1, a2, a3, a4, a5, a6, a7, a8) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7, mapSig f a8) instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6, BindSig a7, BindSig a8) => BindSig  (a1, a2, a3, a4, a5, a6, a7, a8) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7 <*> bindSig f a8 -instance SigSpace a => SigSpace (SE a) where  mapSig  f = fmap (mapSig f)-instance BindSig  a => BindSig  (SE a) where  bindSig f = fmap (bindSig f)+instance {-# OVERLAPPABLE #-} SigSpace a => SigSpace (SE a) where  mapSig  f = fmap (mapSig f)+instance {-# OVERLAPPABLE #-} BindSig a  => BindSig  (SE a) where  bindSig f = fmap (bindSig f)+#endif++#if __GLASGOW_HASKELL__ < 710++instance SigSpace (Sig, Sig) where  mapSig  f (a1, a2) = (mapSig f a1, mapSig f a2)+instance BindSig  (Sig, Sig) where  bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2++instance SigSpace (Sig, Sig, Sig) where mapSig  f (a1, a2, a3) = (mapSig f a1, mapSig f a2, mapSig f a3)+instance BindSig  (Sig, Sig, Sig) where bindSig f (a1, a2, a3) = (,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3++instance SigSpace (Sig, Sig, Sig, Sig) where mapSig  f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4)+instance BindSig  (Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4++instance SigSpace (Sig, Sig, Sig, Sig, Sig) where mapSig  f (a1, a2, a3, a4, a5) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5)+instance BindSig  (Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5++instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig) where mapSig  f (a1, a2, a3, a4, a5, a6) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6)+instance BindSig  (Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6++instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig  f (a1, a2, a3, a4, a5, a6, a7) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7)+instance BindSig  (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7++instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig  f (a1, a2, a3, a4, a5, a6, a7, a8) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7, mapSig f a8)+instance BindSig  (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7 <*> bindSig f a8++instance SigSpace (SE Sig) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE Sig) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig)) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig, Sig)) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig, Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig, Sig, Sig)) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig, Sig, Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig, Sig, Sig, Sig)) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig, Sig, Sig, Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig, Sig, Sig, Sig, Sig)) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig, Sig, Sig, Sig, Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig, Sig, Sig, Sig, Sig, Sig)) where  bindSig f = fmap (bindSig f)++instance SigSpace (SE (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)) where  mapSig  f = fmap (mapSig f)+instance BindSig  (SE (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)) where  bindSig f = fmap (bindSig f)+#endif  ---------------------------------------------------------------------------------------------------------- 

@@ -2,7 +2,8 @@ {-# Language         TypeFamilies,         FlexibleContexts,-        FlexibleInstances #-}+        FlexibleInstances,+        CPP #-} module Csound.Typed.Types.Tuple(     -- ** Tuple     Tuple(..), TupleMethods, makeTupleMethods,@@ -154,6 +155,8 @@ class (Sigs a, SigSpace2 a, BindSig2 a) => Sig2s a where  instance Sigs Sig++#if __GLASGOW_HASKELL__ >= 710 instance (Sigs a1, Sigs a2) => Sigs (a1, a2) instance (Sigs a1, Sigs a2, Sigs a3) => Sigs (a1, a2, a3) instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4) => Sigs (a1, a2, a3, a4)@@ -161,6 +164,15 @@ instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6) => Sigs (a1, a2, a3, a4, a5, a6) instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7) => Sigs (a1, a2, a3, a4, a5, a6, a7) instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7, Sigs a8) => Sigs (a1, a2, a3, a4, a5, a6, a7, a8)+#else+instance Sigs (Sig, Sig)+instance Sigs (Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+#endif  instance Sig2s Sig instance Sig2s Sig2