summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAntonKholomiov <>2018-04-25 10:58:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-04-25 10:58:00 (GMT)
commit5ed3190d3d9580559fec2e4bf708bfe183a128a9 (patch)
tree565038ff68b3e88a92e5815b6d4bbd30a457559e
parent3d71002699035083ed8229e7f79cd28d2b90d2be (diff)
version 0.2.2.0HEAD0.2.2.0master
-rw-r--r--csound-expression-typed.cabal6
-rw-r--r--data/opcodes/MultiFX/TapeEcho.udo24
-rw-r--r--src/Csound/Typed/Control/Api.hs30
-rw-r--r--src/Csound/Typed/Control/Evt.hs12
-rw-r--r--src/Csound/Typed/Control/Instr.hs16
-rw-r--r--src/Csound/Typed/Control/Mix.hs15
-rw-r--r--src/Csound/Typed/Control/Ref.hs50
-rw-r--r--src/Csound/Typed/GlobalState/Elements.hs11
-rw-r--r--src/Csound/Typed/GlobalState/GE.hs2
-rw-r--r--src/Csound/Typed/GlobalState/InstrApi.hs26
-rw-r--r--src/Csound/Typed/GlobalState/Options.hs33
-rw-r--r--src/Csound/Typed/Gui/BoxModel.hs95
-rw-r--r--src/Csound/Typed/Gui/Gui.hs663
-rw-r--r--src/Csound/Typed/Gui/Pretty.hs192
-rw-r--r--src/Csound/Typed/Gui/Types.hs249
-rw-r--r--src/Csound/Typed/Gui/Widget.hs60
-rw-r--r--src/Csound/Typed/Plugins.hs2
-rw-r--r--src/Csound/Typed/Plugins/TapeEcho.hs30
-rw-r--r--src/Csound/Typed/Types/Evt.hs22
-rw-r--r--src/Csound/Typed/Types/MixSco.hs58
-rw-r--r--src/Csound/Typed/Types/Prim.hs81
-rw-r--r--src/Csound/Typed/Types/SigSpace.hs57
-rw-r--r--src/Csound/Typed/Types/Tuple.hs14
23 files changed, 1032 insertions, 716 deletions
diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal
index 14c5de0..a5a64bc 100644
--- a/csound-expression-typed.cabal
+++ b/csound-expression-typed.cabal
@@ -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 @@ Library
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 @@ Library
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
diff --git a/data/opcodes/MultiFX/TapeEcho.udo b/data/opcodes/MultiFX/TapeEcho.udo
index 0079c2e..b00bdb4 100644
--- a/data/opcodes/MultiFX/TapeEcho.udo
+++ b/data/opcodes/MultiFX/TapeEcho.udo
@@ -87,3 +87,27 @@ opcode tapeWrite, 0, aak
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
+
diff --git a/src/Csound/Typed/Control/Api.hs b/src/Csound/Typed/Control/Api.hs
index 7cc2979..4110b92 100644
--- a/src/Csound/Typed/Control/Api.hs
+++ b/src/Csound/Typed/Control/Api.hs
@@ -24,7 +24,7 @@ import Csound.Typed.Plugins.TabQueue
-- | 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 @@ trigByName_ name instr = geToSe $ saveNamedInstr name =<< (execSE $ instr toArg)
-- 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 @@ trigByNameMidi_ name instr = do
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 @@ trigByNameMidi_ name instr = do
--
-- 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 :: (Arg a, Sigs b) => String -> ((D, D, a) -> SE b) -> SE b
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 @@ namedMonoMsg name = do
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 @@ port' a b = fromGE $ do
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 @@ tabw b1 b2 b3 = SE $ (depT_ =<<) $ lift $ f <$> unSig b1 <*> unSig b2 <*> unTab
where f a1 a2 a3 = opcs "tabw" [(Xr,[Kr,Kr,Ir,Ir])] [a1,a2,a3]
--- |
+-- |
-- Fast table opcodes.
--
-- Fast table opcodes. Faster than
diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs
index 29bc107..ad87cc5 100644
--- a/src/Csound/Typed/Control/Evt.hs
+++ b/src/Csound/Typed/Control/Evt.hs
@@ -31,7 +31,7 @@ import Csound.Typed.Control.Ref
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 @@ schedBy instr evts args = flip apInstr args $ do
-------------------------------------------------
-- 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 @@ saveEvtInstr arity instrId evts = saveInstr $ do
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 @@ autoOff dt sigs = fmap toTuple $ fromDep $ hideGEinDep $ phi =<< fromTuple sigs
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 @@ monoSched evts = evtPort instr evts read
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.
diff --git a/src/Csound/Typed/Control/Instr.hs b/src/Csound/Typed/Control/Instr.hs
index ac45cff..8623d23 100644
--- a/src/Csound/Typed/Control/Instr.hs
+++ b/src/Csound/Typed/Control/Instr.hs
@@ -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 @@ funArity instr = Arity (tupleArity a) (tupleArity b)
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 @@ unitExp = execGEinSE . fmap unUnit
apInstr :: (Arg a, Sigs b) => GE InstrId -> a -> b
apInstr instrIdGE args = res
- where
+ where
res = toTuple $ do
instrId <- instrIdGE
argList <- fromTuple args
diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs
index fd01dc9..abcc666 100644
--- a/src/Csound/Typed/Control/Mix.hs
+++ b/src/Csound/Typed/Control/Mix.hs
@@ -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 @@ module Csound.Typed.Control.Mix(
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.GlobalState hiding (notes)
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 @@ singleCsdEvent (start, duration, content) = del start $ str duration $ temp cont
-- 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)
diff --git a/src/Csound/Typed/Control/Ref.hs b/src/Csound/Typed/Control/Ref.hs
index 5ed1668..10f74b8 100644
--- a/src/Csound/Typed/Control/Ref.hs
+++ b/src/Csound/Typed/Control/Ref.hs
@@ -42,18 +42,18 @@ writeRef (Ref vars) a = fromDep_ $ hideGEinDep $ do
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 @@ mixRef ref asig = modifyRef ref (+ asig)
-- | 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 @@ sensorsSE a = do
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 @@ globalSensorsSE a = do
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 @@ newClearableGlobalRef t = fmap Ref $ newClearableGlobalVars (tupleRates t) (from
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 @@ newGlobalTab size = do
-- 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 :: D -> D -> D -> D -> D -> [D] -> SE Tab
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 @@ ftgentmp b1 b2 b3 b4 b5 b6 = fmap ( Tab . return) $ SE $ (depT =<<) $ lift $ f <
{-
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 @@ whileRef initVal cond body = do
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 @@ whileRefD initVal cond body = do
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 ()
diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs
index 474d8fe..49ba9c7 100644
--- a/src/Csound/Typed/GlobalState/Elements.hs
+++ b/src/Csound/Typed/GlobalState/Elements.hs
@@ -19,7 +19,7 @@ module Csound.Typed.GlobalState.Elements(
-- * 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 @@ data AllocVar = AllocVar
{ 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 ->
diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs
index 14022bf..72b2f7d 100644
--- a/src/Csound/Typed/GlobalState/GE.hs
+++ b/src/Csound/Typed/GlobalState/GE.hs
@@ -3,7 +3,7 @@ module Csound.Typed.GlobalState.GE(
GE, Dep, History(..), withOptions, withHistory, getOptions, evalGE, execGE,
getHistory, putHistory,
-- * Globals
- onGlobals,
+ onGlobals, bpmVar,
-- * Midi
MidiAssign(..), Msg(..), renderMidiAssign, saveMidi, saveToMidiInstr,
MidiCtrl(..), saveMidiCtrl, renderMidiCtrl,
diff --git a/src/Csound/Typed/GlobalState/InstrApi.hs b/src/Csound/Typed/GlobalState/InstrApi.hs
index a1824af..7451203 100644
--- a/src/Csound/Typed/GlobalState/InstrApi.hs
+++ b/src/Csound/Typed/GlobalState/InstrApi.hs
@@ -20,33 +20,45 @@ import Csound.Typed.GlobalState.Port
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 :: forall a. Arg a => (a -> SE ()) -> SE (InstrId a)
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
diff --git a/src/Csound/Typed/GlobalState/Options.hs b/src/Csound/Typed/GlobalState/Options.hs
index caba920..745f321 100644
--- a/src/Csound/Typed/GlobalState/Options.hs
+++ b/src/Csound/Typed/GlobalState/Options.hs
@@ -1,3 +1,4 @@
+{-# Language CPP #-}
module Csound.Typed.GlobalState.Options (
Options(..),
defGain, defSampleRate, defBlockSize, defTabFi, defScaleUI,
@@ -50,16 +51,30 @@ data Options = Options
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
+
+#else
+
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
+ 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
diff --git a/src/Csound/Typed/Gui/BoxModel.hs b/src/Csound/Typed/Gui/BoxModel.hs
index b14b1a0..de6c1bd 100644
--- a/src/Csound/Typed/Gui/BoxModel.hs
+++ b/src/Csound/Typed/Gui/BoxModel.hs
@@ -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 Control.Monad.Trans.State.Strict
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 @@ fromRect r = (Interval (px r) (width r), Interval (py r) (height r))
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
+
+#else
+
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
+ 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 @@ instance Monad (Scene ctx) where
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 @@ appendContext ctx x = case x of
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 -> Scene ctx a -> AbsScene ctx a
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 @@ intervals off total scales = evalState (mapM next scales') (start total')
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 @@ maybeScale x = case x of
-----------------------------------------------
-- 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 @@ boundingRect x = case x of
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 @@ boundingRect x = case x of
, 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
diff --git a/src/Csound/Typed/Gui/Gui.hs b/src/Csound/Typed/Gui/Gui.hs
index 12f0b3d..ef7b0d2 100644
--- a/src/Csound/Typed/Gui/Gui.hs
+++ b/src/Csound/Typed/Gui/Gui.hs
@@ -6,12 +6,12 @@ module Csound.Typed.Gui.Gui (
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 @@ module Csound.Typed.Gui.Gui (
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.Names(white, gray)
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
+import Csound.Typed.Gui.Types
+import Csound.Typed.Gui.Pretty
-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
-
--- | 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 @@ panelIsKeybdSensitive x = case x of
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 @@ data GuiNode = GuiNode
{ 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 :: ElemOuts -> [InitMe] -> Elem -> Gui
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 :: ([LowGui] -> LowGui) -> ([Gui] -> Gui)
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 @@ space = Gui Box.space
-- 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 @@ space = Gui Box.space
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,39 +233,39 @@ guiStmt :: Monad m => ScaleFactor -> [Panel] -> DepT m ()
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
@@ -417,20 +281,20 @@ panelRect defaultScaleUI rs x = case x of
    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)]
@@ -440,69 +304,69 @@ tabsRects defaultScaleUI x = case x of
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,18 +378,18 @@ drawElemDef ctx rectWithoutLabel el = case elemContent el of
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
@@ -533,8 +397,8 @@ drawElemDef ctx rectWithoutLabel el = case elemContent el of
-- 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 @@ drawElemDef ctx rectWithoutLabel el = case elemContent el of
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 @@ drawElemDef ctx rectWithoutLabel el = case elemContent el of
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 @@ setKnobType = setProp . SetKnobType
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 @@ mapWithOrientAndScale defaultScaleUI f = iter Hor defaultScaleUI
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 @@ yLabelBox fontSize = fontSize - 5
-- 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 @@ flSetTextType = flSetProp "FLsetTextType" ctxLabelType getLabelType
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 @@ getPropHandle xs = case xs of
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
diff --git a/src/Csound/Typed/Gui/Pretty.hs b/src/Csound/Typed/Gui/Pretty.hs
new file mode 100644
index 0000000..7e08f79
--- /dev/null
+++ b/src/Csound/Typed/Gui/Pretty.hs
@@ -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
diff --git a/src/Csound/Typed/Gui/Types.hs b/src/Csound/Typed/Gui/Types.hs
new file mode 100644
index 0000000..39f37e3
--- /dev/null
+++ b/src/Csound/Typed/Gui/Types.hs
@@ -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
diff --git a/src/Csound/Typed/Gui/Widget.hs b/src/Csound/Typed/Gui/Widget.hs
index c8a6826..ae9e265 100644
--- a/src/Csound/Typed/Gui/Widget.hs
+++ b/src/Csound/Typed/Gui/Widget.hs
@@ -7,7 +7,7 @@ module Csound.Typed.Gui.Widget(
-- * 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 @@ noInner = return ()
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 @@ widget x = go =<< x
-- | 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 :: String -> Gui -> SE Gui
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 @@ setSourceTitle name (Source ma) = source $ do
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 @@ singleOut v0 el = Source $ geToSe $ do
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 @@ singleIn outs v0 el = Sink $ geToSe $ do
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 @@ count diap step1 mValStep2 v0 = mapSource snaps $ countSig diap step1 mValStep2
--
-- 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 @@ slider name sp v0 = setLabelSource name $ singleOut (Just v0) $ Slider sp
-- 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 @@ numeric name diap step v0 = setLabelSource name $ singleOut (Just v0) $ Text dia
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 @@ box label
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 @@ button name = setLabelSource name $ source $ do
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 @@ setToggleSig name initVal = setLabelSnkSource name $ singleInOut setVal (initTog
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 @@ flPrintk2 val handle = SE $ (depT_ =<<) $ lift $ f <$> toGE val <*> toGE handle
-----------------------------------------------------
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))
diff --git a/src/Csound/Typed/Plugins.hs b/src/Csound/Typed/Plugins.hs
index 9413809..cf16356 100644
--- a/src/Csound/Typed/Plugins.hs
+++ b/src/Csound/Typed/Plugins.hs
@@ -37,7 +37,7 @@ module Csound.Typed.Plugins(
fxPanTrem, fxMonoTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong,
-- * Tape echo
- tapeRead, tapeWrite,
+ tapeRead, tapeWrite, tapeEcho,
-- utilities
delay1k
diff --git a/src/Csound/Typed/Plugins/TapeEcho.hs b/src/Csound/Typed/Plugins/TapeEcho.hs
index ac739e6..184e94e 100644
--- a/src/Csound/Typed/Plugins/TapeEcho.hs
+++ b/src/Csound/Typed/Plugins/TapeEcho.hs
@@ -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.Types
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 @@ tapeRead ain kdel kRandomSpread = fmap (Sig . return) $ SE $ (depT =<<) $ lift $
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 @@ tapeWrite ain aout kFeedback = SE $ (depT_ =<<) $ lift $ do
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]
--} \ No newline at end of file
+-- | 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]
diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs
index 706907d..fb077d9 100644
--- a/src/Csound/Typed/Types/Evt.hs
+++ b/src/Csound/Typed/Types/Evt.hs
@@ -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 @@ type Bam a = a -> SE ()
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
diff --git a/src/Csound/Typed/Types/MixSco.hs b/src/Csound/Typed/Types/MixSco.hs
index 21d2db0..35f1881 100644
--- a/src/Csound/Typed/Types/MixSco.hs
+++ b/src/Csound/Typed/Types/MixSco.hs
@@ -16,46 +16,46 @@ import Csound.Typed.Types.Prim
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 @@ rescaleCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt)
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
diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs
index af31198..81f8ee4 100644
--- a/src/Csound/Typed/Types/Prim.hs
+++ b/src/Csound/Typed/Types/Prim.hs
@@ -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 @@ module Csound.Typed.Types.Prim(
-- ** constants
idur, getSampleRate, getControlRate, getBlockSize, getZeroDbfs,
+ getBpm, setBpm,
-- ** converters
ar, kr, ir, sig,
@@ -50,6 +51,7 @@ import Control.Monad.Trans.Reader
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,9 +141,23 @@ newtype Unit = Unit { unUnit :: GE () }
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 @@ int = PrimD . fromIntegral
text :: String -> Str
text = fromE . D.str
+instance IsString Str where
+ fromString = text
+
-------------------------------------------------------------------------------
-- constants
@@ -317,24 +336,40 @@ getBlockSize = fromE $ readOnlyVar (VarVerbatim Ir "ksmps")
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 @@ instance Default TabList where def = fromE 0
-------------------------------------------------------------------------------
-- 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
diff --git a/src/Csound/Typed/Types/SigSpace.hs b/src/Csound/Typed/Types/SigSpace.hs
index 4a7cf7c..ed9b34d 100644
--- a/src/Csound/Typed/Types/SigSpace.hs
+++ b/src/Csound/Typed/Types/SigSpace.hs
@@ -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 @@ cfds = genCfds 0 cfd
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 (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6
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
----------------------------------------------------------------------------------------------------------
diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs
index 7332d42..954e27f 100644
--- a/src/Csound/Typed/Types/Tuple.hs
+++ b/src/Csound/Typed/Types/Tuple.hs
@@ -2,7 +2,8 @@
{-# Language
TypeFamilies,
FlexibleContexts,
- FlexibleInstances #-}
+ FlexibleInstances,
+ CPP #-}
module Csound.Typed.Types.Tuple(
-- ** Tuple
Tuple(..), TupleMethods, makeTupleMethods,
@@ -154,6 +155,8 @@ class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a) => Sigs a where
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 (a1, a2, a3, a4,
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