diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal --- a/csound-expression-typed.cabal +++ b/csound-expression-typed.cabal @@ -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 diff --git a/src/Csound/Typed/GlobalState.hs b/src/Csound/Typed/GlobalState.hs --- a/src/Csound/Typed/GlobalState.hs +++ b/src/Csound/Typed/GlobalState.hs @@ -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 diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs --- a/src/Csound/Typed/GlobalState/Elements.hs +++ b/src/Csound/Typed/GlobalState/Elements.hs @@ -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 diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs --- a/src/Csound/Typed/GlobalState/GE.hs +++ b/src/Csound/Typed/GlobalState/GE.hs @@ -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) diff --git a/src/Csound/Typed/GlobalState/Instr.hs b/src/Csound/Typed/GlobalState/Instr.hs --- a/src/Csound/Typed/GlobalState/Instr.hs +++ b/src/Csound/Typed/GlobalState/Instr.hs @@ -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 diff --git a/src/Csound/Typed/GlobalState/Opcodes.hs b/src/Csound/Typed/GlobalState/Opcodes.hs --- a/src/Csound/Typed/GlobalState/Opcodes.hs +++ b/src/Csound/Typed/GlobalState/Opcodes.hs @@ -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, [])] [] diff --git a/src/Csound/Typed/GlobalState/SE.hs b/src/Csound/Typed/GlobalState/SE.hs --- a/src/Csound/Typed/GlobalState/SE.hs +++ b/src/Csound/Typed/GlobalState/SE.hs @@ -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 diff --git a/src/Csound/Typed/Gui.hs b/src/Csound/Typed/Gui.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui.hs @@ -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 + diff --git a/src/Csound/Typed/Gui/BoxModel.hs b/src/Csound/Typed/Gui/BoxModel.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui/BoxModel.hs @@ -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) } + diff --git a/src/Csound/Typed/Gui/Gui.hs b/src/Csound/Typed/Gui/Gui.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui/Gui.hs @@ -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 diff --git a/src/Csound/Typed/Gui/Widget.hs b/src/Csound/Typed/Gui/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui/Widget.hs @@ -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: +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: +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: +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: +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: +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: +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: +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: +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: +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: +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: +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: +changed :: [Sig] -> Sig +changed = Sig . fmap f . mapM unSig + where f = opcs "changed" [(Kr, repeat Kr)] + + + diff --git a/src/Csound/Typed/Render.hs b/src/Csound/Typed/Render.hs --- a/src/Csound/Typed/Render.hs +++ b/src/Csound/Typed/Render.hs @@ -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 diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs --- a/src/Csound/Typed/Types/Evt.hs +++ b/src/Csound/Typed/Types/Evt.hs @@ -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 diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs --- a/src/Csound/Typed/Types/Prim.hs +++ b/src/Csound/Typed/Types/Prim.hs @@ -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)