csound-expression-typed 0.0.0 → 0.0.1
raw patch · 14 files changed
+1944/−39 lines, 14 filesdep +colourdep +wl-pprintdep ~csound-expression-dynamic
Dependencies added: colour, wl-pprint
Dependency ranges changed: csound-expression-dynamic
Files
- csound-expression-typed.cabal +7/−3
- src/Csound/Typed/GlobalState.hs +2/−1
- src/Csound/Typed/GlobalState/Elements.hs +5/−4
- src/Csound/Typed/GlobalState/GE.hs +215/−3
- src/Csound/Typed/GlobalState/Instr.hs +1/−4
- src/Csound/Typed/GlobalState/Opcodes.hs +14/−3
- src/Csound/Typed/GlobalState/SE.hs +4/−1
- src/Csound/Typed/Gui.hs +8/−0
- src/Csound/Typed/Gui/BoxModel.hs +206/−0
- src/Csound/Typed/Gui/Gui.hs +978/−0
- src/Csound/Typed/Gui/Widget.hs +439/−0
- src/Csound/Typed/Render.hs +22/−11
- src/Csound/Typed/Types/Evt.hs +40/−9
- src/Csound/Typed/Types/Prim.hs +3/−0
csound-expression-typed.cabal view
@@ -1,5 +1,5 @@ Name: csound-expression-typed-Version: 0.0.0+Version: 0.0.1 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE@@ -24,8 +24,8 @@ Library Ghc-Options: -Wall Build-Depends:- base >= 4, base < 5, ghc-prim, containers, transformers, Boolean >= 0.1.0, data-default,- stable-maps >= 0.0.3.3, csound-expression-dynamic+ base >= 4, base < 5, ghc-prim, containers, transformers, Boolean >= 0.1.0, colour >= 2.3, data-default,+ wl-pprint, stable-maps >= 0.0.3.3, csound-expression-dynamic >= 0.0.1 Hs-Source-Dirs: src/ Exposed-Modules: Csound.Typed@@ -34,6 +34,7 @@ Csound.Typed.Control Csound.Typed.Render + Csound.Typed.Gui Csound.Typed.Types.Prim Csound.Typed.Types.Evt@@ -60,3 +61,6 @@ Csound.Typed.Control.SERef Csound.Typed.Control.Instr + Csound.Typed.Gui.Gui+ Csound.Typed.Gui.Widget+ Csound.Typed.Gui.BoxModel
src/Csound/Typed/GlobalState.hs view
@@ -7,7 +7,7 @@ -- * Reexports dynamic BandLimited(..), readBandLimited, renderBandLimited, Instrs(..), IdMap(..),- getIn, chnUpdateUdo, renderGlobals+ getIn, chnUpdateUdo, renderGlobals, turnoff ) where import Csound.Typed.GlobalState.Options@@ -16,3 +16,4 @@ import Csound.Typed.GlobalState.Instr import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements+import Csound.Typed.GlobalState.Opcodes
src/Csound/Typed/GlobalState/Elements.hs view
@@ -19,7 +19,7 @@ InstrBody, getIn, sendOut, sendChn, sendGlobal, Event(..), ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo,- subinstr, subinstr_, event_i, event, safeOut, autoOff+ subinstr, subinstr_, event_i, event, safeOut, autoOff, changed ) where @@ -153,10 +153,11 @@ data AllocVar = AllocVar { allocVarType :: GlobalVarType , allocVar :: Var- , allocVarInit :: E }+ , allocVarInit :: E + } deriving (Show) data GlobalVarType = PersistentGlobalVar | ClearableGlobalVar- deriving (Eq)+ deriving (Eq, Show) instance Default Globals where def = Globals def def@@ -193,7 +194,7 @@ } instance Default Instrs where- def = Instrs DM.empty 17 []+ def = Instrs DM.empty 18 [] type CacheName = DM.DynamicStableName
src/Csound/Typed/GlobalState/GE.hs view
@@ -1,5 +1,6 @@ module Csound.Typed.GlobalState.GE( GE, Dep, History(..), withOptions, withHistory, getOptions, evalGE, execGE,+ getHistory, putHistory, -- * Globals onGlobals, -- * Midi@@ -15,12 +16,20 @@ -- * Strings saveStr, -- * Cache- GetCache, SetCache, withCache+ GetCache, SetCache, withCache,+ -- * Guis+ newGuiHandle, saveGuiRoot, appendToGui, + newGuiVar, getPanels, guiHandleToVar,+ guiInstrExp,+ listenKeyEvt, Key(..), KeyEvt(..),+ getKeyEventListener ) where import Control.Applicative import Control.Monad+import Data.Boolean import Data.Default+import qualified Data.IntMap as IM import Control.Monad.IO.Class import Control.Monad.Trans.Class@@ -33,6 +42,8 @@ import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements +import Csound.Typed.Gui.Gui(Panel, GuiNode, GuiHandle(..), restoreTree, guiMap, mapGuiOnPanel)+ type Dep a = DepT GE a -- global side effects@@ -71,10 +82,11 @@ , alwaysOnInstrs :: [InstrId] , userInstr0 :: Dep () , bandLimitedMap :: BandLimitedMap- , cache :: Cache GE }+ , cache :: Cache GE+ , guis :: Guis } instance Default History where- def = History def def def def def def def (return ()) def def+ def = History def def def def def def def (return ()) def def def data Msg = Msg data MidiAssign = MidiAssign MidiType Channel InstrId@@ -152,12 +164,21 @@ getOptions :: GE Options getOptions = withOptions id +getHistory :: GE History+getHistory = GE $ lift get++putHistory :: History -> GE ()+putHistory h = GE $ lift $ put h+ withHistory :: (History -> a) -> GE a withHistory f = GE $ lift $ fmap f get modifyHistory :: (History -> History) -> GE () modifyHistory = GE . lift . modify +modifyWithHistory :: (History -> (a, History)) -> GE a+modifyWithHistory f = GE $ lift $ state f+ -- update fields onHistory :: (History -> a) -> (a -> History -> History) -> State a b -> GE b@@ -200,4 +221,195 @@ setTotalDur dur return res +--------------------------------------------------------+-- guis++data Guis = Guis+ { guiStateNewId :: Int+ , guiStateInstr :: DepT GE ()+ , guiStateToDraw :: [GuiNode] + , guiStateRoots :: [Panel]+ , guiKeyEvents :: KeyCodeMap }++-- it maps integer key codes to global variables +-- that acts like sensors.+type KeyCodeMap = IM.IntMap Var++instance Default Guis where + def = Guis 0 (return ()) [] [] def++newGuiHandle :: GE GuiHandle +newGuiHandle = modifyWithHistory $ \h -> + let (n, g') = bumpGuiStateId $ guis h+ in (GuiHandle n, h{ guis = g' })++guiHandleToVar :: GuiHandle -> Var+guiHandleToVar (GuiHandle n) = Var GlobalVar Ir ('h' : show n)++newGuiVar :: GE (Var, GuiHandle)+newGuiVar = liftA2 (,) (onGlobals $ newPersistentGlobalVar Kr 0) newGuiHandle++modifyGuis :: (Guis -> Guis) -> GE ()+modifyGuis f = modifyHistory $ \h -> h{ guis = f $ guis h }++appendToGui :: GuiNode -> DepT GE () -> GE ()+appendToGui gui act = modifyGuis $ \st -> st+ { guiStateToDraw = gui : guiStateToDraw st+ , guiStateInstr = guiStateInstr st >> act }++saveGuiRoot :: Panel -> GE ()+saveGuiRoot g = modifyGuis $ \st -> + st { guiStateRoots = g : guiStateRoots st }++bumpGuiStateId :: Guis -> (Int, Guis)+bumpGuiStateId s = (guiStateNewId s, s{ guiStateNewId = succ $ guiStateNewId s })++getPanels :: History -> [Panel]+getPanels h = fmap (mapGuiOnPanel (restoreTree m)) $ guiStateRoots $ guis h + where m = guiMap $ guiStateToDraw $ guis h++-- have to be executed after all instruments+guiInstrExp :: GE (DepT GE ())+guiInstrExp = withHistory (guiStateInstr . guis) +++-- key codes++-- | Keyboard events.+data KeyEvt = Press Key | Release Key+ deriving (Show, Eq)++-- | Keys.+data Key + = CharKey Char+ | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8 | F9 | F10 | F11 | F12 | Scroll+ | CapsLook | LeftShift | RightShift | LeftCtrl | RightCtrl | Enter | LeftAlt | RightAlt | LeftWinKey | RightWinKey + | Backspace | ArrowUp | ArrowLeft | ArrowRight | ArrowDown + | Insert | Home | PgUp | Delete | End | PgDown+ | NumLock | NumDiv | NumMul | NumSub | NumHome | NumArrowUp + | NumPgUp | NumArrowLeft | NumSpace | NumArrowRight | NumEnd + | NumArrowDown | NumPgDown | NumIns | NumDel | NumEnter | NumPlus + | Num7 | Num8 | Num9 | Num4 | Num5 | Num6 | Num1 | Num2 | Num3 | Num0 | NumDot + deriving (Show, Eq)++keyToCode :: Key -> Int+keyToCode x = case x of+ CharKey a -> fromEnum a+ F1 -> 446+ F2 -> 447+ F3 -> 448 + F4 -> 449+ F5 -> 450+ F6 -> 451+ F7 -> 452+ F8 -> 453+ F9 -> 454+ F10 -> 456+ F11 -> 457+ F12 -> 458+ Scroll-> 276+ CapsLook -> 485 + LeftShift -> 481+ RightShift -> 482+ LeftCtrl -> 483+ RightCtrl -> 484+ Enter -> 269+ LeftAlt -> 489+ RightAlt -> 490+ LeftWinKey -> 491+ RightWinKey -> 492+ Backspace -> 264 + ArrowUp -> 338+ ArrowLeft -> 337+ ArrowRight -> 339+ ArrowDown -> 340+ Insert -> 355+ Home -> 336+ PgUp -> 341+ Delete -> 511+ End -> 343+ PgDown -> 342++ NumLock -> 383+ NumDiv -> 431+ NumMul -> 426+ NumSub -> 429+ NumHome -> 436+ NumArrowUp -> 438+ NumPgUp -> 341+ NumArrowLeft -> 337+ NumSpace -> 267+ NumArrowRight -> 339+ NumEnd -> 343+ NumArrowDown -> 340+ NumPgDown -> 342+ NumIns -> 355+ NumDel -> 511+ NumEnter -> 397+ NumPlus -> 427++ Num7 -> 439+ Num8 -> 440+ Num9 -> 441+ Num4 -> 436+ Num5 -> 437+ Num6 -> 438+ Num1 -> 433+ Num2 -> 434+ Num3 -> 435+ Num0 -> 432+ NumDot -> 430++keyEvtToCode :: KeyEvt -> Int+keyEvtToCode x = case x of+ Press k -> keyToCode k+ Release k -> negate $ keyToCode k++listenKeyEvt :: KeyEvt -> GE Var+listenKeyEvt evt = do+ hist <- getHistory+ let g = guis hist+ keyMap = guiKeyEvents g+ code = keyEvtToCode evt++ case IM.lookup code keyMap of+ Just var -> return var+ Nothing -> do+ var <- onGlobals $ newClearableGlobalVar Kr 0+ hist2 <- getHistory+ let newKeyMap = IM.insert code var keyMap + newG = g { guiKeyEvents = newKeyMap }+ hist3 = hist2 { guis = newG }+ putHistory hist3+ return var++-- assumes that first instrument id is 18 and 17 is free to use.+keyEventInstrId :: InstrId+keyEventInstrId = intInstrId 17++keyEventInstrBody :: KeyCodeMap -> GE InstrBody+keyEventInstrBody keyMap = execDepT $ do+ let keys = flKeyIn+ isChange = changed keys ==* 1+ when1 isChange $ do+ whens (fmap (uncurry $ listenEvt keys) events) doNothing+ where + doNothing = return ()++ listenEvt keySig keyCode var = (keySig ==* int keyCode, writeVar var 1)++ events = IM.toList keyMap++ flKeyIn :: E+ flKeyIn = opcs "FLkeyIn" [(Kr, [])] []++getKeyEventListener :: GE (Maybe Instr)+getKeyEventListener = do+ h <- getHistory+ if (IM.null $ guiKeyEvents $ guis h) + then return Nothing+ else do+ saveAlwaysOnInstr keyEventInstrId+ body <- keyEventInstrBody $ guiKeyEvents $ guis h+ return $ Just (Instr keyEventInstrId body)
src/Csound/Typed/GlobalState/Instr.hs view
@@ -51,10 +51,7 @@ saveMasterInstr :: Arity -> InsExp -> GE () saveMasterInstr arity sigs = do gainLevel <- fmap defGain getOptions - saveAlwaysOnInstr =<< - (saveInstr $ (SE . C.sendOut (arityOuts arity) . C.safeOut gainLevel) =<< sigs)- expr2 <- getSysExpr - saveAlwaysOnInstr =<< saveInstr (SE expr2)+ saveAlwaysOnInstr =<< (saveInstr $ (SE . C.sendOut (arityOuts arity) . C.safeOut gainLevel) =<< sigs) saveMidiInstr :: MidiType -> Channel -> Arity -> InsExp -> GE [E] saveMidiInstr midiType channel arity instr = do
src/Csound/Typed/GlobalState/Opcodes.hs view
@@ -4,11 +4,13 @@ ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo, -- * trigger an instrument- Event(..), event, event_i, appendChn, subinstr, subinstr_,+ Event(..), event, event_i, appendChn, subinstr, subinstr_, changed, -- * output- out, outs, safeOut, autoOff,+ out, outs, safeOut, autoOff, turnoff, -- * vco2- oscili, oscilikt, vco2ft, vco2ift, vco2init, ftgen+ oscili, oscilikt, vco2ft, vco2ift, vco2init, ftgen,+ -- * times+ times ) where import Control.Monad(zipWithM_)@@ -110,6 +112,9 @@ (repeat Ar, Ir : repeat Kr) (prim (PrimInstrId instrId) : args) +changed :: E -> E+changed x = opcs "changed" [(Kr, [Kr])] [x]+ -- output out :: Monad m => E -> DepT m ()@@ -186,4 +191,10 @@ vco2init :: [E] -> E vco2init = opcs "vco2init" [(Ir, repeat Ir)]++----------------------+-- times++times :: Monad m => DepT m E+times = depT $ opcs "times" [(Ir, []), (Kr, [])] []
src/Csound/Typed/GlobalState/SE.hs view
@@ -1,7 +1,7 @@ module Csound.Typed.GlobalState.SE( SE(..), LocalHistory(..), runSE, execSE, evalSE, execGEinSE, hideGEinDep, - fromDep, fromDep_, + fromDep, fromDep_, geToSe, newLocalVar, newLocalVars ) where @@ -51,6 +51,9 @@ evalSE :: SE a -> GE a evalSE = fmap fst . runSE++geToSe :: GE a -> SE a+geToSe = SE . lift ---------------------------------------------------------------------- -- allocation of the local vars
+ src/Csound/Typed/Gui.hs view
@@ -0,0 +1,8 @@+module Csound.Typed.Gui (+ module Csound.Typed.Gui.Gui,+ module Csound.Typed.Gui.Widget+) where++import Csound.Typed.Gui.Gui+import Csound.Typed.Gui.Widget+
+ src/Csound/Typed/Gui/BoxModel.hs view
@@ -0,0 +1,206 @@+{-# Language DeriveFunctor #-}+module Csound.Typed.Gui.BoxModel(+ Rect(..), Offset(..), AbsScene(..), Scene(..), + draw,+ hor, ver, sca, margin, padding, space, prim,+ appendContext, cascade, boundingRect, zeroRect+) where++import Control.Monad.Trans.State.Strict+import Data.Default+import Data.Monoid++data Interval = Interval + { start :: Int+ , leng :: Int + } deriving (Show)+ +-- | A rectangle.+data Rect = Rect + { px :: Int+ , py :: Int+ , width :: Int+ , height :: Int+ } deriving (Show)++fromRect :: Rect -> (Interval, Interval)+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 + = Elem Rect a+ | EmptyScene + | Group [AbsScene ctx a]+ | Ctx Rect ctx (AbsScene ctx a)+ deriving (Show)+ +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]+ +data Scene ctx a+ = Prim a+ | Space + | Scale Double (Scene ctx a)+ | Hor Offset [Scene ctx a]+ | Ver Offset [Scene ctx a]+ | Context ctx (Scene ctx a)+ deriving (Show, Functor)++instance Monad (Scene ctx) where+ return = Prim+ ma >>= mf = joinScene $ fmap mf ma+ where+ joinScene :: Scene ctx (Scene ctx a) -> Scene ctx a+ joinScene x = case x of+ Prim rec -> rec+ Space -> Space+ Scale d a -> Scale d (joinScene a)+ Hor o a -> Hor o (fmap joinScene a)+ Ver o a -> Ver o (fmap joinScene a)+ Context c a -> Context c (joinScene a)++data Offset = Offset + { offsetOuter :: Int+ , offsetInner :: Int + } deriving (Show)++instance Default Offset where+ def = Offset + { offsetOuter = 5+ , offsetInner = 25 }++appendContext :: Monoid ctx => ctx -> Scene ctx a -> Scene ctx a+appendContext ctx x = case x of+ Context oldCtx a -> Context (mappend ctx oldCtx) a+ _ -> Context ctx x++hor, ver :: [Scene a b] -> Scene a b+space :: Scene a b+prim :: a -> Scene ctx a ++sca :: Double -> Scene a b -> Scene a b+margin, padding :: Int -> Scene a b -> Scene a b++hor = Hor def+ver = Ver def+sca = Scale+space = Space+prim = Prim++margin n = withOffset (\x -> x{ offsetOuter = n })+padding n = withOffset (\x -> x{ offsetInner = n })++withOffset :: (Offset -> Offset) -> Scene ctx a -> Scene ctx a+withOffset f x = case x of+ Hor off as -> Hor (f off) as+ Ver off as -> Ver (f off) as+ _ -> x++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 + -- 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 + composite getRects off as = mconcat $ zipWith draw (getRects off $ factors as) (fmap stripScale as)+ + horRects r off scales = fmap (flip toRect commonSide) is + where commonSide = withoutMargin off iy+ is = intervals off ix scales + (ix, iy) = fromRect r++ verRects r off scales = fmap (toRect commonSide) is + where commonSide = withoutMargin off ix+ is = intervals off iy scales + (ix, iy) = fromRect r ++intervals :: Offset -> Interval -> [Double] -> [Interval]+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+ s = sum scales++ 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+withoutMargin off a = Interval (start a + offsetOuter off) (leng a - 2 * offsetOuter off)++factors :: [Scene a b] -> [Double]+factors = fmap factor+ where factor = maybe 1 fst . maybeScale++stripScale :: Scene a b -> Scene a b+stripScale x = maybe x snd $ maybeScale x++maybeScale :: Scene a b -> Maybe (Double, Scene a b)+maybeScale x = case x of+ Scale d a -> Just (d, a)+ _ -> Nothing++-----------------------------------------------+-- cascading update of the context++cascade :: + (totalCtx -> Rect -> a -> res) + -> res + -> ([res] -> res)+ -> (Rect -> ctx -> res -> res)+ -> (ctx -> totalCtx -> totalCtx)+ -> totalCtx -> AbsScene ctx a -> res+cascade onElem onEmptyScene onGroup onCtx updateCtx ctx x = case x of+ Elem r a -> onElem ctx r a+ EmptyScene -> onEmptyScene+ Group as -> onGroup (fmap (rec ctx) as)+ Ctx r c a -> onCtx r c $ rec (updateCtx c ctx) a+ where rec = cascade onElem onEmptyScene onGroup onCtx updateCtx++-----------------------------------------------+-- calculate bounding rect++zeroRect :: Rect+zeroRect = Rect 0 0 0 0++boundingRect :: Scene ctx Rect -> Rect+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 + Context _ a -> boundingRect a+ where+ appHorOffset n offset r = r { width = appOffset n offset (width r)+ , height = appOffset 1 offset (height r) }++ appVerOffset n offset r = r { height = appOffset n offset (height r)+ , width = appOffset 1 offset (width r) }++ appOffset n offset a = a+ + 2 * offsetOuter offset + + (max (n - 1) 0) * offsetInner offset++ horMerge = foldr iter zeroRect+ where iter r1 r2 = r1 { width = width r1 + width r2+ , height = max (height r1) (height r2) }++ verMerge = foldr iter zeroRect+ where iter r1 r2 = r1 { height = height r1 + height r2+ , width = max (width r1) (width r2) }+
+ src/Csound/Typed/Gui/Gui.hs view
@@ -0,0 +1,978 @@+module Csound.Typed.Gui.Gui (+ Panel(..), Win(..), GuiNode(..), GuiHandle(..), Gui(..),+ Elem(..), InitMe(..),+ restoreTree, guiMap, mapGuiOnPanel, fromElem, fromGuiHandle,+ guiStmt,++ -- * Layout+ hor, ver, space, sca, horSca, verSca, + padding, margin,+ -- * Props+ props, forceProps,+ Prop(..), BorderType(..), Color,+ Rect(..), FontType(..), Emphasis(..), + Material(..), Orient(..), LabelType(..),+ -- ** Setters+ -- | Handy short-cuts for the function @props@.+ setBorder, setLabel, setMaterial, setLabelType,+ setColor1, setColor2, setColors, setTextColor,+ setFontSize, setFontType, setEmphasis, setOrient,++ -- * Widgets+ ValDiap(..), ValStep, ValScaleType(..), ValSpan(..),+ linSpan, expSpan, uspan, bspan, uspanExp,+ KnobType(..), setKnobType,+ SliderType(..), setSliderType,+ TextType(..), setTextType,+ BoxType(..), setBoxType,+ ButtonType(..), setButtonType+) where++import Prelude hiding(elem, span)++import Control.Applicative((<|>))+import Data.Default+import Data.Char(toLower)+import Data.Maybe(isNothing)+import Data.Monoid++import Data.Colour+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 Csound.Dynamic(DepT, depT_, Var(..), VarType(..), Rate(..), noRate, MainExp(..), InstrId(..))++import qualified Csound.Typed.Gui.BoxModel as Box+import Csound.Typed.Gui.BoxModel(Rect(..))++newtype GuiHandle = GuiHandle { unGuiHandle :: Int }++-- | The Csound colours. +type Color = Colour Double++-- | The orientation of the widget (slider, roller). This property is +-- never needs to be set in practice. If this property is not set then +-- default orientation is calculated from the bounding box of the widget.+-- If the width is greater than the height then we need to use a horizontal+-- widget otherwise it should be a vertical one.+data Orient = Hor | Ver++-- | A value span is a diapason of the value and a type +-- of the scale (can be linear or exponential).+data ValSpan = ValSpan + { valSpanDiap :: ValDiap+ , valSpanScale :: ValScaleType }++-- | Makes a linear @ValSpan@ with specified boundaries.+--+-- > linSpan minVal maxVal+linSpan :: Double -> Double -> ValSpan+linSpan a b = ValSpan (ValDiap a b) Linear++-- | Makes an exponential @ValSpan@ with specified boundaries.+--+-- > expSpan minVal maxVal+expSpan :: Double -> Double -> ValSpan +expSpan a b = ValSpan (ValDiap (checkBound a) b) Exponential+ where+ checkBound x+ | x <= 0 = 0.00001+ | otherwise = x++-- | Unit span. A special case:+--+-- > uspan = linSpan 0 1+uspan :: ValSpan+uspan = linSpan 0 1++-- | Bipolar unit span. A special case:+--+-- > uspan = linSpan (-1) 1+bspan :: ValSpan+bspan = linSpan (-1) 1++-- | An exponential unit span. A special case:+--+-- > uspan = expSpan 0 1+uspanExp :: ValSpan+uspanExp = linSpan 0 1++-- | The diapason of the continuous value.+data ValDiap = ValDiap + { valDiapMin :: Double + , valDiapMax :: Double }++data ValScaleType = Linear | Exponential++type ValStep = Double++data FontType = Helvetica | Courier | Times | Symbol | Screen | Dingbats+data Emphasis = NoEmphasis | Italic | Bold | BoldItalic+data KnobType = ThreeD (Maybe Int) | Pie | Clock | Flat+data SliderType = Fill | Engraved | Nice+data TextType = NormalText | NoDrag | NoEdit++-- | The type of the material of the element. It affects sliders and buttons.+data Material = NoPlastic | Plastic++-- | Some values are not implemented on the Csound level.+data LabelType = NormalLabel | NoLabel | SymbolLabel + | ShadowLabel | EngravedLabel | EmbossedLabel++-- | The type of the box. Some values are not implemented on the Csound level.+data BoxType + = FlatBox | UpBox | DownBox | ThinUpBox | ThinDownBox + | EngravedBox | EmbossedBox | BorderBox | ShadowBox+ | Roundedbox | RoundedShadowBox | RoundedFlatBox+ | RoundedUpBox | RoundedDownBox | DiamondUpBox + | DiamondDownBox | OvalBox | OvalShadowBox | OvalFlatBox+ deriving (Enum)++data BorderType+ = NoBorder | DownBoxBorder | UpBoxBorder | EngravedBorder + | EmbossedBorder | BlackLine | ThinDown | ThinUp+ deriving (Enum)++-- | The type of the button. It affects toggle buttons and button banks.+--+-- In Csound buttons and toggle buttons+-- are constructed with the same function (but with different button types). +-- But in this library they are contructed by different functions (@button@ and @toggle@). +-- Normal button is a plain old button, but other values specify toggle buttons.+-- So this property doesn't affect the buttons (since they could be only normal buttons).+data ButtonType = NormalButton | LightButton | CheckButton | RoundButton++defFontSize :: Int+defFontSize = 15++instance Default FontType where def = Courier+instance Default Emphasis where def = NoEmphasis+instance Default SliderType where def = Fill+instance Default KnobType where def = Flat+instance Default TextType where def = NormalText+instance Default ButtonType where def = NormalButton+instance Default BoxType where def = FlatBox+instance Default Material where def = Plastic+instance Default LabelType where def = NormalLabel++data InitMe = InitMe + { initHandle :: Var+ , initValue :: Double }++data Elem + = GuiVar GuiHandle + + -- valuators+ | Count ValDiap ValStep (Maybe ValStep)+ | Joy ValSpan ValSpan+ | Knob ValSpan+ | Roller ValSpan ValStep+ | Slider ValSpan+ | Text ValDiap ValStep++ -- other widgets + | Box String+ | ButBank Int Int+ | Button InstrId+ | Toggle + | Value+ | Vkeybd++data Props = Props + { propsBorder :: Maybe BorderType+ , otherProps :: [Prop] }++instance Monoid Props where+ mempty = Props Nothing []+ mappend a b = Props { propsBorder = (propsBorder a) <|> (propsBorder b)+ , otherProps = mappend (otherProps a) (otherProps b) }++-- | 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++-- | A visual representation of the GUI-element.+newtype Gui = Gui { unGui :: LowGui }++type LowGui = Box.Scene Props ElemWithOuts++data Panel + = Single + { singleContent :: Win+ , singleIsKeybdSensitive :: Bool }+ | Tabs + { tabsTitle :: String + , tabsRect :: Maybe Rect+ , tabsContent :: [Win]+ , tabsIsKeybdSensitive :: Bool }++data Win = Win + { winTitle :: String + , winRect :: Maybe Rect+ , winGui :: Gui }++data GuiNode = GuiNode+ { guiNodeElem :: Gui+ , guiNodeHandle :: GuiHandle }++data ElemWithOuts = ElemWithOuts + { elemOuts :: [Var]+ , elemInits :: [InitMe]+ , elemContent :: Elem }++type ElemOuts = [Var]++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 ++mapGuiOnPanel :: (Gui -> Gui) -> Panel -> Panel+mapGuiOnPanel f x = case x of+ Single w isKey -> Single (mapWin w) isKey+ Tabs title rect ws isKey -> Tabs title rect (fmap mapWin ws) isKey+ where mapWin a = a{ winGui = f $ winGui a }++onLowGuis :: ([LowGui] -> LowGui) -> ([Gui] -> Gui)+onLowGuis f = Gui . f . fmap unGui++onLowGui1 :: (LowGui -> LowGui) -> (Gui -> Gui)+onLowGui1 f = Gui . f . unGui ++-- | 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 ++-- | Vertical groupping of the elements. All elements are +-- placed in the stright vertical line and aligned by X-coordinate+-- and width.+ver :: [Gui] -> Gui+ver = onLowGuis Box.ver++-- | An empty space.+space :: Gui+space = Gui Box.space++-- | Scales an element within the group. It depends on the type+-- of the alignment (horizontal or vertical) which side of the bounding+-- 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 +-- 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! +--+-- An example:+--+-- One element is twice as large as the other two:+--+-- > hor [a, b, sca 2 c]+--+-- Why is it so? Let's look at the hidden scaling factors:+--+-- > hor [sca 1 a, sca 1 b, sca 2 c]+--+-- During rendering we scale all the scaling fators so that+-- total sum equals to one:+--+-- > hor [sca 0.25 a, sca 0.25 b, sca 0.5 c]+sca :: Double -> Gui -> Gui+sca d = onLowGui1 (Box.sca d)++-- | 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. +-- It takes a list of scaling factors and elements.+verSca :: [(Double, Gui)] -> Gui+verSca ps = ver $ fmap (uncurry sca) ps++-- | Sets the padding of the element. How much empty space+-- to reserve outside the element.+padding :: Int -> Gui -> Gui+padding n = onLowGui1 (Box.padding n)++-- | Sets the margin of the element. How much empty space+-- to reserve between the elements within the group. It affects+-- only compound elements.+margin :: Int -> Gui -> Gui+margin n = onLowGui1 (Box.margin n)++-- | Sets the properties for a GUI element.+props :: [Prop] -> Gui -> Gui+props ps = onLowGui1 (Box.appendContext (Props Nothing ps))++-- | Sets the properties for a GUI element on all levels.+forceProps :: [Prop] -> Gui -> Gui+forceProps = error "forceProps: TODO"++setBorder :: BorderType -> Gui -> Gui+setBorder a = onLowGui1 (Box.appendContext (Props (Just a) []))++type GuiMap = IM.IntMap Gui++guiMap :: [GuiNode] -> GuiMap+guiMap = IM.fromList . fmap (\(GuiNode elem (GuiHandle n)) -> (n, elem))++restoreTree :: GuiMap -> Gui -> Gui+restoreTree m x = Gui $ (unGui x) >>= rec+ where rec elem = case elemContent elem of+ GuiVar h -> unGui $ restoreTree m $ m IM.! unGuiHandle h+ _ -> return elem+++guiStmt :: Monad m => [Panel] -> DepT m ()+guiStmt panels = depT_ $ noRate phi+ where phi+ | null panels = EmptyExp+ | otherwise = Verbatim $ show $ vcat [vcat $ fmap drawGui panels, text "FLrun"]++drawGui :: Panel -> Doc+drawGui 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 + where boundingRect = panelRect (fmap fst tabsRs) x+ tabsRs = tabsRects x + (mainTabRect, shift) = mainTabRectAndShift boundingRect+ + tabPanelRect = Rect + { px = 100+ , py = 100+ , width = width mainTabRect + 20+ , height = height mainTabRect + 20 + }++ panel = onPanel (panelTitle x)++ onPanel title isKeybdSensitive rect body = 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 ]+ , body+ , ppProc "FLpanelEnd" []]++ onTabs rect body = vcat + [ ppProc "FLtabs" $ rectToFrame rect+ , body+ , ppProc "FLtabsEnd" []]+ ++panelTitle :: Panel -> String+panelTitle x = case x of+ Single w _ -> winTitle w+ Tabs title _ _ _ -> title++panelRect :: [Rect] -> Panel -> Rect+panelRect rs x = case x of+ Single w _ -> winBoundingRect w+ Tabs _ mrect _ _ -> case rs of+ [] -> Box.zeroRect+ _ -> maybe (foldr boundingRect (head rs) rs) id mrect+ 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) ++mainTabRectAndShift :: Rect -> (Rect, (Int, Int))+mainTabRectAndShift r = (res, (dx, dy))+ where res = Rect + { px = 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 :: Panel -> [(Rect, Win)]+tabsRects x = case x of+ Single _ _ -> []+ Tabs _ _ ws _ -> zip (fmap winBoundingRect ws) ws++winBoundingRect :: Win -> Rect+winBoundingRect w = maybe (shiftBy 50 $ bestRect $ winGui w) id $ winRect w+ 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+ , body+ , ppProc "FLgroupEnd" []]++ 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] ++drawWin :: Rect -> Win -> Doc+drawWin rect w = renderAbsScene $ Box.draw rect $ unGui $ winGui w+ where+ renderAbsScene = Box.cascade drawPrim empty 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]+ , a+ , ppProc "FLgroupEnd" []]+ where borderAsInt = int . fromEnum+ frame = rectToFrame rect + +drawPrim :: PropCtx -> Rect -> ElemWithOuts -> Doc+drawPrim ctx rect elem = vcat + [ drawElemDef ctx rect elem+ , drawAppearance ctx elem+ , drawInitVal elem ]++drawAppearance :: PropCtx -> ElemWithOuts -> Doc+drawAppearance ctx el = maybe empty (flip flSetAll ctx)+ $ getPropHandle $ elemOuts el++drawInitVal :: ElemWithOuts -> Doc+drawInitVal = 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 ++ -- other widgets + Box label -> drawBox label+ ButBank xn yn -> drawButBank xn yn + Button instrId -> drawButton instrId+ Toggle -> drawToggle+ Value -> drawValue + Vkeybd -> drawVkeybd ++ -- error+ GuiVar guiHandle -> orphanGuiVar guiHandle+ where+ rect = clearSpaceForLabel $ rectWithoutLabel+ clearSpaceForLabel a+ | label == "" = a+ | otherwise = a { height = max 20 $ height a - yLabelBox (getIntFontSize ctx) }+ where label = getLabel ctx++ f = fWithLabel (getLabel ctx)+ fWithLabel label name args = ppMoOpc (fmap ppVar $ elemOuts el) name ((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+ drawSpan (ValSpan diap scale) = [imin diap, imax diap, getScale scale]+ + imin = double . valDiapMin+ imax = double . valDiapMax++ -----------------------------------------------------------------------+ -- valuators++ -- FLcount+ drawCount diap step1 mValStep2 = f "FLcount" $+ [ imin diap, imax diap+ , double step1, double step2+ , int itype ] + ++ frame ++ [noOpc]+ where (step2, itype) = case mValStep2 of+ -- type 1 FLcount with 2 steps+ Just n -> (n, 1)+ -- type 2 FLcount with a single step+ Nothing -> (step1, 2)++ -- FLjoy+ drawJoy (ValSpan dX sX) (ValSpan dY sY) = f "FLjoy" $+ [ imin dX, imax dX, imin dY, imax dY+ , getScale sX, getScale sY+ , noDisp, noDisp + ] ++ frame++ -- FLknob+ drawKnob span = f "FLknob" $ + drawSpan span ++ [getKnobType ctx, noDisp] + ++ fmap int knobFrame ++ getKnobCursorSize ctx + where + knobFrame+ | w < h = [w, x, y + d]+ | otherwise = [h, x + d, y]+ h = height rect+ w = width rect+ x = px rect+ y = py rect+ d = div (abs $ h - w) 2 ++ -- FLroller+ drawRoller (ValSpan d s) step = f "FLroller" $+ [ imin d, imax d, double step+ , getScale s, getRollerType (getDefOrient rect) ctx, noDisp+ ] ++ frame++ -- FLslider+ 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++ -----------------------------------------------------------------------+ -- 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] ++ -- FLbutton's+ drawButton instrId = f "FLbutton" $ [int 1, int 0, getButtonType ctx] ++ frameWithoutLabel ++ (onOpc instrId [0, -1])+ + drawToggle = f "FLbutton" $ [int 1, int 0, getToggleType ctx] ++ frameWithoutLabel ++ [noOpc]++ -- FLvalue+ 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 ++-----------------------------------------------------------------+-- handy shortcuts+ +setProp :: Prop -> Gui -> Gui+setProp p = props [p]++setLabel :: String -> Gui -> Gui+setLabel = setProp . SetLabel++setLabelType :: LabelType -> Gui -> Gui+setLabelType = setProp . SetLabelType++setMaterial :: Material -> Gui -> Gui+setMaterial = setProp . SetMaterial++setBoxType :: BoxType -> Gui -> Gui+setBoxType = setProp . SetBoxType++setColor1 :: Color -> Gui -> Gui+setColor1 = setProp . SetColor1++setColor2 :: Color -> Gui -> Gui+setColor2 = setProp . SetColor2++setColors :: Color -> Color -> Gui -> Gui+setColors primary secondary = setColor1 primary . setColor2 secondary++setTextColor :: Color -> Gui -> Gui+setTextColor = setProp . SetTextColor++setFontSize :: Int -> Gui -> Gui+setFontSize = setProp . SetFontSize++setFontType :: FontType -> Gui -> Gui+setFontType = setProp . SetFontType++setEmphasis :: Emphasis -> Gui -> Gui+setEmphasis = setProp . SetEmphasis++setSliderType :: SliderType -> Gui -> Gui+setSliderType = setProp . SetSliderType++setTextType :: TextType -> Gui -> Gui+setTextType = setProp . SetTextType++setButtonType :: ButtonType -> Gui -> Gui+setButtonType = setProp . SetButtonType++setOrient :: Orient -> Gui -> Gui+setOrient = setProp . SetOrient++setKnobType :: KnobType -> Gui -> Gui+setKnobType = setProp . SetKnobType++------------------------------------------------------------------+-- best rectangles for the elements+--++winMargin :: Int+winMargin = 10+ +appendWinMargin :: Rect -> Rect+appendWinMargin r = r + { width = 2 * winMargin + width r+ , height = 2 * winMargin + height r + }++withWinMargin :: Rect -> Rect+withWinMargin r = r + { px = winMargin+ , py = winMargin + , height = height r - 2 * winMargin+ , width = width r - 2 * winMargin + }++withRelWinMargin :: Rect -> Rect+withRelWinMargin r = r + { px = winMargin + px r+ , py = winMargin + py r+ , height = height r - 2 * winMargin+ , width = width r - 2 * winMargin + }++bestRect :: Gui -> Rect+bestRect + = appendWinMargin . Box.boundingRect + . mapWithOrient (\curOrient x -> uncurry noShiftRect $ bestElemSizes curOrient $ elemContent x)+ . unGui+ where noShiftRect w h = Rect { px = 0, py = 0, width = w, height = h }+ +mapWithOrient :: (Orient -> a -> b) -> Box.Scene ctx a -> Box.Scene ctx b+mapWithOrient f = iter Hor+ where + iter curOrient x = case x of+ Box.Prim a -> Box.Prim $ f curOrient a+ Box.Space -> Box.Space+ Box.Scale d a -> Box.Scale d $ iter curOrient a+ Box.Hor offs as -> Box.Hor offs $ fmap (iter Hor) as+ Box.Ver offs as -> Box.Ver offs $ fmap (iter Ver) as+ Box.Context ctx a -> Box.Context ctx $ iter curOrient a+ +bestElemSizes :: Orient -> Elem -> (Int, Int)+bestElemSizes orient x = case x of+ -- valuators+ Count _ _ _ -> (150, 35)+ Joy _ _ -> (350, 350) + Knob _ -> (170, 170)+ Roller _ _ -> inVer (250, 35)+ Slider _ -> inVer (300, 35)+ Text _ _ -> (120, 35)++ -- other widgets + Box label -> + let symbolsPerLine = 60+ numOfLines = succ $ div (length label) symbolsPerLine+ in (xBox 15 symbolsPerLine, yBox 15 numOfLines) ++ ButBank xn yn -> (xn * 80, yn * 35)+ Button _ -> (80, 35) + Toggle -> (80, 35) + Value -> (100, 35)+ Vkeybd -> (1280, 240)+ + -- error+ GuiVar h -> orphanGuiVar h+ where inVer (a, b) = case orient of+ Ver -> (a, b)+ Hor -> (b, a)++------------------------------------------------------------+-- FLbox font coefficients++xBox, yBox :: Int -> Int -> Int++xBox fontSize xn = round $ fromIntegral fontSize * (0.6 :: Double) * fromIntegral (1 + xn)++yBox fontSize yn = (fontSize + 12) * (1 + yn)++yLabelBox :: Int -> Int+yLabelBox fontSize = fontSize - 5++------------------------------------------------------------+-- set properties++flSetAll :: Var -> PropCtx -> Doc+flSetAll handle ctx = vcat $ fmap (\f -> f handle ctx)+ [ flSetColor, flSetColor2, flSetTextColor+ , flSetTextSize, flSetTextType, flSetFont ]++flSetColor, flSetColor2, flSetTextColor, flSetTextSize, flSetTextType, + flSetFont :: Var -> 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] ++flSetColor = flSetProp "FLsetColor" ctxColor1 getColor1+flSetColor2 = flSetProp "FLsetColor2" ctxColor2 getColor2+flSetTextColor = flSetProp "FLsetTextColor" ctxTextColor getTextColor+flSetTextSize = flSetProp "FLsetTextSize" (const $ Just (15 :: Int)) getFontSize+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]++------------------------------------------------------------+-- extract handle.Hor++getPropHandle :: [Var] -> Maybe Var+getPropHandle xs = case xs of+ [] -> Nothing+ _ -> Just (last xs)++------------------------------------------------------------+-- error messages++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
+ src/Csound/Typed/Gui/Widget.hs view
@@ -0,0 +1,439 @@+module Csound.Typed.Gui.Widget(+ -- * Panels+ panel, keyPanel, tabs, keyTabs, panels, + keyPanels, panelBy, keyPanelBy, tabsBy, keyTabsBy,++ -- * Types+ Input, Output, Inner,+ noInput, noOutput, noInner,+ Widget, widget, Source, source, Sink, sink, Display, display,++ -- * Widgets+ count, countSig, joy, knob, roller, slider, sliderBank, numeric, meter, box,+ button, butBank, butBankSig, butBank1, butBankSig1, toggle, toggleSig,+ value, + -- * Transformers+ setTitle,+ -- * Keyboard + KeyEvt(..), Key(..), keyIn+) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Trans.Class++import Data.Boolean++import Csound.Dynamic hiding (int)+import qualified Csound.Typed.GlobalState.Elements as C++import Csound.Typed.Gui.Gui+import Csound.Typed.GlobalState+import Csound.Typed.Types hiding (whens)++-- | Renders a list of panels.+panels :: [Gui] -> SE ()+panels = mapM_ panel++-- | Renders a list of panels. Panels are sensitive to keyboard events.+keyPanels :: [Gui] -> SE ()+keyPanels = mapM_ keyPanel++-- | Renders the GUI elements on the window. Rectangle is calculated+-- automatically (window doesn't listens for keyboard events).+panel :: Gui -> SE ()+panel = genPanel False++-- | Renders the GUI elements on the window. Rectangle is calculated+-- automatically (window listens for keyboard events).+keyPanel :: Gui -> SE ()+keyPanel = genPanel True++genPanel :: Bool -> Gui -> SE ()+genPanel isKeybd g = geToSe $ saveGuiRoot $ Single (Win "" Nothing g) isKeybd++-- | Renders the GUI elements with tabs. Rectangles are calculated+-- automatically.+tabs :: [(String, Gui)] -> SE ()+tabs = genTabs False++-- | Renders the GUI elements with tabs. Rectangles are calculated+-- automatically.+keyTabs :: [(String, Gui)] -> SE ()+keyTabs = genTabs True++genTabs :: Bool -> [(String, Gui)] -> SE ()+genTabs isKey xs = geToSe $ saveGuiRoot $ Tabs "" Nothing (fmap (\(title, gui) -> Win title Nothing gui) xs) isKey++-- | Renders the GUI elements on the window. We can specify the window title+-- and rectangle of the window.+panelBy :: String -> Maybe Rect -> Gui -> SE ()+panelBy = genPanelBy False++-- | Renders the GUI elements on the window. We can specify the window title+-- and rectangle of the window. Panesls are sensitive to keyboard events.+keyPanelBy :: String -> Maybe Rect -> Gui -> SE ()+keyPanelBy = genPanelBy False++genPanelBy :: Bool -> String -> Maybe Rect -> Gui -> SE ()+genPanelBy isKeybd title mrect gui = geToSe $ saveGuiRoot $ Single (Win title mrect gui) isKeybd++-- | Renders the GUI elements with tabs. We can specify the window title and+-- rectangles for all tabs and for the main window.+tabsBy :: String -> Maybe Rect -> [(String, Maybe Rect, Gui)] -> SE ()+tabsBy = genTabsBy False++-- | Renders the GUI elements with tabs. We can specify the window title and+-- rectangles for all tabs and for the main window. Tabs are sensitive to keyboard events.+keyTabsBy :: String -> Maybe Rect -> [(String, Maybe Rect, Gui)] -> SE ()+keyTabsBy = genTabsBy True++genTabsBy :: Bool -> String -> Maybe Rect -> [(String, Maybe Rect, Gui)] -> SE ()+genTabsBy isKeybd title mrect gui = geToSe $ saveGuiRoot $ Tabs title mrect (fmap (\(a, b, c) -> Win a b c) gui) isKeybd++-- | Widgets that produce something has inputs.+type Input a = a++-- | Widgets that consume something has outputs.+type Output a = a -> SE ()++-- | Widgets that just do something inside them or have an inner state.+type Inner = SE ()++-- | A value for widgets that consume nothing.+noOutput :: Output ()+noOutput = return ++-- | A value for widgets that produce nothing.+noInput :: Input ()+noInput = ()++-- | A value for stateless widgets.+noInner :: Inner+noInner = return ()++-- | A widget consists of visible element (Gui), value consumer (Output) +-- and producer (Input) and an inner state (Inner).+type Widget a b = SE (Gui, Output a, Input b, Inner)++-- | A consumer of the values.+type Sink a = SE (Gui, Output a)++-- | A producer of the values.+type Source a = SE (Gui, Input a)++-- | A static element. We can only look at it.+type Display = SE Gui++-- | A handy function for transforming the value of producers.+mapSource :: (a -> b) -> Source a -> Source b+mapSource f = fmap $ \(gui, ins) -> (gui, f ins) ++-- | A widget constructor.+widget :: SE (Gui, Output a, Input b, Inner) -> Widget a b+widget x = go =<< x+ where+ go :: (Gui, Output a, Input b, Inner) -> Widget a b+ go (gui, outs, ins, inner) = geToSe $ do + handle <- newGuiHandle+ appendToGui (GuiNode gui handle) (unSE inner)+ return (fromGuiHandle handle, outs, ins, inner)++-- | A producer constructor.+source :: SE (Gui, Input a) -> Source a+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 = fmap select $ widget $ fmap append x+ where + select (g, o, _, _) = (g, o)+ append (g, o) = (g, o, noInput, noInner)++-- | A display constructor.+display :: SE Gui -> Display +display x = fmap select $ widget $ fmap append x+ where + select (g, _, _, _) = g+ append g = (g, noOutput, noInput, noInner) ++----------------------------------------------------------------------------- +-- primitive elements++-- | Appends a title to a group of widgets.+setTitle :: String -> Gui -> SE Gui+setTitle name g + | null name = return g+ | otherwise = do+ gTitle <- box name+ return $ ver [sca 0.01 gTitle, g]++setSourceTitle :: String -> Source a -> Source a+setSourceTitle name ma = source $ do+ (gui, val) <- ma+ newGui <- setTitle name gui+ return (newGui, val)++setLabelSource :: String -> Source a -> Source a+setLabelSource a + | null a = id+ | otherwise = fmap (first $ setLabel a)++setLabelSink :: String -> Sink a -> Sink a+setLabelSink a + | null a = id+ | otherwise = fmap (first $ setLabel a)++singleOut :: Maybe Double -> Elem -> Source Sig +singleOut v0 el = geToSe $ do+ (var, handle) <- newGuiVar+ let handleVar = guiHandleToVar handle+ inits = maybe [] (return . InitMe handleVar) v0+ gui = fromElem [var, handleVar] inits el+ appendToGui (GuiNode gui handle) (unSE noInner)+ return (fromGuiHandle handle, readSig var)++singleIn :: (GuiHandle -> Output Sig) -> Maybe Double -> Elem -> Sink Sig +singleIn outs v0 el = geToSe $ do+ (_, handle) <- newGuiVar+ let handleVar = guiHandleToVar handle + inits = maybe [] (return . InitMe handleVar) v0+ gui = fromElem [handleVar] inits el+ appendToGui (GuiNode gui handle) (unSE noInner)+ return (fromGuiHandle handle, outs handle)++-- | A variance on the function 'Csound.Gui.Widget.count', but it produces +-- a signal of piecewise constant function. +countSig :: ValDiap -> ValStep -> Maybe ValStep -> Double -> Source Sig+countSig diap step1 mValStep2 v0 = singleOut (Just v0) $ Count diap step1 mValStep2++-- | Allows the user to increase/decrease a value with mouse +-- clicks on a corresponding arrow button. Output is an event stream that contains +-- values when counter changes.+-- +-- > count diapason fineValStep maybeCoarseValStep initValue +-- +-- doc: http://www.csounds.com/manual/html/FLcount.html+count :: ValDiap -> ValStep -> Maybe ValStep -> Double -> Source (Evt D)+count diap step1 mValStep2 v0 = mapSource snaps $ countSig diap step1 mValStep2 v0++-- | It is a squared area that allows the user to modify two output values +-- at the same time. It acts like a joystick. +-- +-- > joy valueSpanX valueSpanY (initX, initY) +--+-- doc: <http://www.csounds.com/manual/html/FLjoy.html>+joy :: ValSpan -> ValSpan -> (Double, Double) -> Source (Sig, Sig)+joy sp1 sp2 (x, y) = geToSe $ do+ (var1, handle1) <- newGuiVar+ (var2, handle2) <- newGuiVar+ let handleVar1 = guiHandleToVar handle1+ handleVar2 = guiHandleToVar handle2+ outs = [var1, var2, handleVar1, handleVar2]+ inits = [InitMe handleVar1 x, InitMe handleVar2 y]+ gui = fromElem outs inits (Joy sp1 sp2)+ appendToGui (GuiNode gui handle1) (unSE noInner)+ return ( fromGuiHandle handle1, (readSig var1, readSig var2))++-- | A FLTK widget opcode that creates a knob.+--+-- > knob valueSpan initValue+--+-- doc: <http://www.csounds.com/manual/html/FLknob.html>+knob :: String -> ValSpan -> Double -> Source Sig+knob name sp v0 = setLabelSource name $ singleOut (Just v0) $ Knob sp++-- | FLroller is a sort of knob, but put transversally. +--+-- > roller valueSpan step initVal+--+-- doc: <http://www.csounds.com/manual/html/FLroller.html>+roller :: String -> ValSpan -> ValStep -> Double -> Source Sig+roller name sp step v0 = setLabelSource name $ singleOut (Just v0) $ Roller sp step++-- | FLslider puts a slider into the corresponding container.+--+-- > slider valueSpan initVal +--+-- doc: <http://www.csounds.com/manual/html/FLslider.html>+slider :: String -> ValSpan -> Double -> Source Sig+slider name sp v0 = setLabelSource name $ singleOut (Just v0) $ Slider sp++-- | Constructs a list of linear unit sliders (ranges in [0, 1]). It takes a list+-- of init values.+sliderBank :: String -> [Double] -> Source [Sig]+sliderBank name ds = source $ do+ (gs, vs) <- fmap unzip $ zipWithM (\n d -> slider (show n) uspan d) [(1::Int) ..] ds + gui <- setTitle name $ hor gs+ return (gui, vs)++-- | numeric (originally FLtext in the Csound) allows the user to modify +-- a parameter value by directly typing it into a text field.+--+-- > numeric diapason step initValue +--+-- doc: <http://www.csounds.com/manual/html/FLtext.html>+numeric :: String -> ValDiap -> ValStep -> Double -> Source Sig+numeric name diap step v0 = setLabelSource name $ singleOut (Just v0) $ Text diap step ++-- | A FLTK widget that displays text inside of a box.+-- If the text is longer than 255 characters the text+-- is split on several parts (Csound limitations).+--+-- > box text+--+-- doc: <http://www.csounds.com/manual/html/FLbox.html>+box :: String -> Display+box label + | length label < lim = rawBox label+ | otherwise = fmap (padding 0 . ver) $ mapM rawBox $ parts lim label+ where + parts n xs + | length xs < n = [xs]+ | otherwise = a : parts n b+ where (a, b) = splitAt n xs+ lim = 255++rawBox :: String -> Display+rawBox label = geToSe $ do+ (_, handle) <- newGuiVar+ let gui = fromElem [guiHandleToVar handle] [] (Box label)+ appendToGui (GuiNode gui handle) (unSE noInner)+ return $ fromGuiHandle handle++-- | A FLTK widget opcode that creates a button. +--+-- > button text+-- +-- doc: <http://www.csounds.com/manual/html/FLbutton.html>+button :: String -> Source (Evt Unit)+button name = setLabelSource name $ source $ do+ flag <- geToSe $ onGlobals $ C.newPersistentGlobalVar Kr 0+ instrId <- geToSe $ saveInstr $ instr flag+ (g, _) <- singleOut Nothing (Button instrId)+ val <- fmap fromGE $ fromDep $ readVar flag+ return (g, sigToEvt $ changed [val])+ where+ instr ref = SE $ do+ val <- readVar ref+ whens + [ (val ==* 0, writeVar ref 1)+ ] (writeVar ref 0)+ turnoff+ + +-- | A FLTK widget opcode that creates a toggle button.+--+-- > button text+-- +-- doc: <http://www.csounds.com/manual/html/FLbutton.html>+toggle :: String -> Source (Evt D)+toggle name = mapSource snaps $ toggleSig name++-- | A variance on the function 'Csound.Gui.Widget.toggle', but it produces +-- a signal of piecewise constant function. +toggleSig :: String -> Source Sig+toggleSig name = setLabelSource name $ singleOut Nothing Toggle++-- | A FLTK widget opcode that creates a bank of buttons.+-- Result is (x, y) coordinate of the triggered button.+-- +-- > butBank xNumOfButtons yNumOfButtons+-- +-- doc: <http://www.csounds.com/manual/html/FLbutBank.html>+butBank :: String -> Int -> Int -> (Int, Int) -> Source (Evt (D, D))+butBank name xn yn inits = mapSource (fmap split2 . snaps) $ butBankSig1 name xn yn inits+ where+ split2 a = (floor' $ a / y, mod' a x)+ x = int xn+ y = int yn++-- | A variance on the function 'Csound.Gui.Widget.butBank', but it produces +-- a signal of piecewise constant function. +-- Result is (x, y) coordinate of the triggered button.+butBankSig :: String -> Int -> Int -> (Int, Int) -> Source (Sig, Sig)+butBankSig name xn yn inits = mapSource split2 $ butBankSig1 name xn yn inits+ where + split2 a = (floor' $ a / y, mod' a x)+ x = sig $ int xn+ y = sig $ int yn++-- | A FLTK widget opcode that creates a bank of buttons.+-- +-- > butBank xNumOfButtons yNumOfButtons+-- +-- doc: <http://www.csounds.com/manual/html/FLbutBank.html>+butBank1 :: String -> Int -> Int -> (Int, Int) -> Source (Evt D)+butBank1 name xn yn inits = mapSource snaps $ butBankSig1 name xn yn inits+ +butBankSig1 :: String -> Int -> Int -> (Int, Int) -> Source Sig +butBankSig1 name xn yn (x0, y0) = setSourceTitle name $ singleOut (Just n) $ ButBank xn yn+ where n = fromIntegral $ y0 + x0 * yn++-- | FLvalue shows current the value of a valuator in a text field.+--+-- > value initVal+--+-- doc: <http://www.csounds.com/manual/html/FLvalue.html>+value :: String -> Double -> Sink Sig +value name v = setLabelSink name $ singleIn printk2 (Just v) Value++-- | A slider that serves as indicator. It consumes values instead of producing.+--+-- > meter valueSpan initValue+meter :: String -> ValSpan -> Double -> Sink Sig+meter name sp v = setLabelSink name $ singleIn setVal (Just v) (Slider sp)++-------------------------------------------------------------+-- keyboard++-- | The stream of keyboard press/release events.+keyIn :: KeyEvt -> Evt Unit+keyIn evt = boolToEvt $ asig ==* 1 + where asig = Sig $ fmap readOnlyVar $ listenKeyEvt evt++-- Outputs++readD :: Var -> SE D+readD v = fmap (D . return) $ SE $ readVar v ++readSig :: Var -> Sig+readSig v = Sig $ return $ readOnlyVar v +++refHandle :: GuiHandle -> SE D+refHandle h = readD (guiHandleToVar h)++setVal :: GuiHandle -> Sig -> SE ()+setVal handle val = flSetVal (changed [val]) val =<< refHandle handle++printk2 :: GuiHandle -> Sig -> SE ()+printk2 handle val = flPrintk2 val =<< refHandle handle++-------------------------------------------------------------+-- set gui value++flSetVal :: Sig -> Sig -> D -> SE ()+flSetVal trig val handle = SE $ (depT_ =<<) $ lift $ f <$> unSig trig <*> unSig val <*> unD handle+ where f a b c = opcs "FLsetVal" [(Xr, [Kr, Kr, Ir])] [a, b, c]++flPrintk2 :: Sig -> D -> SE ()+flPrintk2 val handle = SE $ (depT_ =<<) $ lift $ f <$> unSig val <*> unD handle+ where f a b = opcs "FLprintk2" [(Xr, [Kr, Ir])] [a, b]++-- | This opcode outputs a trigger signal that informs when any one of its k-rate +-- arguments has changed. Useful with valuator widgets or MIDI controllers.+--+-- > ktrig changed kvar1 [, kvar2,..., kvarN]+--+-- doc: <http://www.csounds.com/manual/html/changed.html>+changed :: [Sig] -> Sig+changed = Sig . fmap f . mapM unSig+ where f = opcs "changed" [(Kr, repeat Kr)]+++
src/Csound/Typed/Render.hs view
@@ -11,7 +11,6 @@ import Data.Default import Data.Maybe import Data.Tuple-import Control.Monad import Csound.Dynamic hiding (csdFlags) import Csound.Typed.Types@@ -21,10 +20,12 @@ import Csound.Typed.Control(getIns) import Csound.Dynamic.Types.Flags +import Csound.Typed.Gui.Gui(guiStmt)+ toCsd :: Tuple a => Options -> SE a -> GE Csd toCsd options sigs = do saveMasterInstr (constArity sigs) (masterExp sigs)- join $ withHistory $ renderHistory (outArity sigs) options+ renderHistory (outArity sigs) options renderOut_ :: SE () -> IO String renderOut_ = renderOutBy_ def @@ -44,18 +45,26 @@ renderEffBy :: (Sigs a, Sigs b) => Options -> (a -> SE b) -> IO String renderEffBy options eff = renderOutBy options $ eff =<< getIns -renderHistory :: Int -> Options -> History -> GE Csd-renderHistory nchnls opt hist = do- instr0 <- execDepT $ getInstr0 nchnls opt hist- let orc = Orc instr0 (fmap (uncurry Instr) $ instrsContent $ instrs hist) +renderHistory :: Int -> Options -> GE Csd+renderHistory nchnls opt = do+ keyEventListener <- getKeyEventListener+ hist1 <- getHistory+ instr0 <- execDepT $ getInstr0 nchnls opt hist1+ expr2 <- getSysExpr + saveAlwaysOnInstr =<< saveInstr (SE expr2)+ expr3 <- guiInstrExp + saveAlwaysOnInstr =<< saveInstr (SE expr3)+ hist2 <- getHistory+ let orc = Orc instr0 (maybeAppend keyEventListener $ fmap (uncurry Instr) $ instrsContent $ instrs hist2) + hist3 <- getHistory + let flags = reactOnMidi hist3 $ csdFlags opt+ sco = Sco (Just $ getTotalDur opt $ totalDur hist3) + (renderGens $ genMap hist3) $+ (fmap alwaysOn $ alwaysOnInstrs hist3) return $ Csd flags orc sco where- flags = reactOnMidi hist $ csdFlags opt- sco = Sco (Just $ getTotalDur opt $ totalDur hist) - (renderGens $ genMap hist) $- (fmap alwaysOn $ alwaysOnInstrs hist)- renderGens = fmap swap . M.toList . idMapContent + maybeAppend ma = maybe id (:) ma getInstr0 :: Int -> Options -> History -> Dep () getInstr0 nchnls opt hist = do@@ -65,6 +74,7 @@ renderBandLimited (genMap hist) (bandLimitedMap hist) userInstr0 hist chnUpdateUdo + guiStmt $ getPanels hist where globalConstants = do setSr $ defSampleRate opt@@ -75,6 +85,7 @@ midiAssigns = mapM_ renderMidiAssign $ midis hist initGlobals = fst $ renderGlobals $ globals $ hist+ reactOnMidi :: History -> Flags -> Flags reactOnMidi h flags
src/Csound/Typed/Types/Evt.hs view
@@ -1,22 +1,22 @@ {-# Language TypeFamilies, FlexibleContexts #-} module Csound.Typed.Types.Evt(- Evt(..), Bam, + Evt(..), Bam, sync, boolToEvt, evtToBool, sigToEvt, stepper, filterE, filterSE, accumSE, accumE, filterAccumE, filterAccumSE, Snap, snapshot, snaps, readSnap ) where import Data.Monoid-+import Data.Default import Data.Boolean -import qualified Csound.Dynamic as C- import Csound.Typed.Types.Prim import Csound.Typed.Types.Tuple import Csound.Typed.GlobalState import Csound.Typed.Control.SERef +import qualified Csound.Typed.GlobalState.Opcodes as C+ -- | A stream of events. We can convert a stream of events to -- the procedure with the function @runEvt@. It waits for events -- and invokes the given procedure when the event happens.@@ -33,11 +33,11 @@ mappend a b = Evt $ \bam -> runEvt a bam >> runEvt b bam -- | Converts booleans to events.-boolToEvt :: BoolSig -> Evt ()-boolToEvt b = Evt $ \bam -> when1 b $ bam ()+boolToEvt :: BoolSig -> Evt Unit+boolToEvt b = Evt $ \bam -> when1 b $ bam unit -- | Triggers an event when signal equals to 1.-sigToEvt :: Sig -> Evt ()+sigToEvt :: Sig -> Evt Unit sigToEvt = boolToEvt . ( ==* 1) . kr -- | Filters events with predicate.@@ -95,8 +95,7 @@ snaps :: Sig -> Evt D snaps asig = snapshot const asig trigger where - trigger = sigToEvt $ fromGE $ fmap changed $ toGE asig- changed x = C.opcs "changed" [(C.Kr, [C.Kr])] [x]+ trigger = sigToEvt $ fromGE $ fmap C.changed $ toGE asig ------------------------------------------------------------------- -- snap @@ -147,4 +146,36 @@ (readSt, writeSt) <- sensorsSE v0 runEvt evt $ \a -> writeSt a readSt ++-------------------------------------------------------------+-- synchronization++-- | Executes actions synchronized with global tempo (in Hz).+-- +-- > runEvtSync tempoCps evt proc+sync :: (Default a, Tuple a) => D -> Evt a -> Evt a+sync dt evt = Evt $ \bam -> do+ initGlobalTime <- times+ refCounter <- newSERef $ frac' $ initGlobalTime * dt+ refVal <- newSERef def+ refFire <- newSERef (0 :: D)++ runEvt evt $ \a -> do+ writeSERef refVal a+ writeSERef refFire 1++ updCounter <- readSERef refCounter+ writeSERef refCounter (updCounter - 1 / getControlRate)++ counter <- readSERef refCounter+ fire <- readSERef refFire+ when1 (sig counter <=* 0 &&* sig fire ==* 1) $ do+ val <- readSERef refVal+ bam val+ writeSERef refFire 0+ + when1 (sig counter <=* 0) $ do+ writeSERef refCounter (1 / dt)+ where + times = fmap D $ fromDep C.times
src/Csound/Typed/Types/Prim.hs view
@@ -82,6 +82,9 @@ mempty = Unit (return ()) mappend a b = Unit $ (unUnit a) >> (unUnit b) +instance Default Unit where+ def = unit+ -- tables -- | Tables (or arrays)