Widget.hs

-- | Primitive GUI elements.
--
-- There is a convention that constructors take only parameters that 
-- specify the logic of the widget. The view is set for GUI-elements with 
-- other functions.
module Csound.Control.Gui.Widget (
    -- * Common properties 
    ValDiap(..), ValStep, ValScaleType(..), ValSpan(..),
    linSpan, expSpan, uspan, bspan, uspanExp,
    -- * Valuators
    count, countSig, joy, 
    knob, KnobType(..), setKnobType,
    roller, 
    slider, sliderBank, SliderType(..), setSliderType,
    numeric, TextType(..), setTextType,

    -- * Other widgets
    box, BoxType(..), setBoxType,
    button, ButtonType(..), setButtonType, 
    toggle, butBank, toggleSig, butBankSig,
    butBank1, butBankSig1, 
    radioButton, matrixButton, funnyRadio, funnyMatrix,
    setNumeric, meter,
    setKnob, setSlider,
    setToggle, setToggleSig,
    -- * Transformers
    setTitle,
    -- * Keyboard
    KeyEvt(..), Key(..), keyIn, charOn, charOff, strOn, strOff,

    -- * Easy to use widgets
    uknob, xknob, uslider, xslider, ujoy, 
    hradio, vradio, hradioSig, vradioSig,

    -- * Number selectors
    -- | Widgets for sample and hold functions
    hnumbers, vnumbers,

    -- * Range widgets
    Range,
    rangeKnob, rangeSlider, rangeKnobSig, rangeSliderSig,
    rangeJoy, rangeJoy2, rangeJoySig,

    -- * The 2D matrix of widgets
    knobPad, togglePad, buttonPad, genPad,

    -- * External control

    -- | The widgets can be controlled with external signals/event streams
    button', toggle', toggleSig', knob', slider', uknob', uslider',
    hradio', vradio', hradioSig', vradioSig'
) where

import Control.Monad

import Data.Monoid
import Data.List(transpose)
import Data.Boolean

import Csound.Typed.Gui
import Csound.Typed.Types
import Csound.Control.SE
import Csound.SigSpace(uon)
import Csound.Control.Evt(listAt, Tick, snaps2, dropE, devt, loadbang, evtToSig)
import Csound.Typed.Opcode(changed)

--------------------------------------------------------------------
-- aux widgets

readMatrix :: Int -> Int -> [a] -> [a]
readMatrix xn yn as = transp $ take (xn * yn) $ as ++ repeat (head as)
    where 
        transp xs = concat $ transpose $ parts yn xn xs
        parts x y qs 
            | x == 0    = []
            | otherwise = a : parts (x - 1) y b
            where (a, b) = splitAt y qs

-- | A radio button. It takes a list of values with labels.
radioButton :: Arg a => String -> [(String, a)] -> Int -> Source (Evt a)
radioButton title as initVal = source $ do
    (g, ind) <- butBank1 "" 1 (length as) (0, initVal)
    gnames   <- mapM box names
    let val = listAt vals ind    
    gui <- setTitle title $ padding 0 $ hor [sca 0.15 g, ver gnames]
    return (gui, val)
    where (names, vals) = unzip as

-- | A matrix of values.
matrixButton :: Arg a => String -> Int -> Int -> [a] -> (Int, Int) -> Source (Evt a)
matrixButton name xn yn vals initVal = source $ do
    (gui, ind) <- butBank1 name xn yn initVal
    let val = listAt allVals ind
    return (gui, val)
    where allVals = readMatrix xn yn vals

-- | Radio button that returns functions. Useful for picking a waveform or type of filter.
funnyRadio :: Tuple b => String -> [(String, a -> b)] -> Int -> Source (a -> b)
funnyRadio name as initVal = source $ do
    (gui, ind) <- radioButton name (zip names (fmap int [0 ..])) initVal
    contInd <- stepper (sig $ int initVal) $ fmap sig ind
    let instr x = guardedTuple (
                zipWith (\n f -> (contInd ==* (sig $ int n), f x)) [0 ..] funs
            ) (head funs x)
    return (gui, instr)
    where (names, funs) = unzip as

-- | Matrix of functional values.
funnyMatrix :: Tuple b => String -> Int -> Int -> [(a -> b)] -> (Int, Int) -> Source (a -> b)
funnyMatrix name xn yn funs initVal@(x0, y0) = source $ do
    (gui, ind) <- butBank1 name xn yn initVal
    contInd <- stepper flattenInitVal $ fmap sig ind
    let instr x = guardedTuple (
                zipWith (\n f -> (contInd ==* (sig $ int n), f x)) [0 ..] allFuns
            ) (head allFuns x)
    return (gui, instr)
    where 
        allFuns = readMatrix xn yn funs
        flattenInitVal = sig $ int $ y0 + x0 * yn


-- | Shortcut for press 'CharKey' events.
charOn :: Char -> Evt Unit
charOn  = keyIn . Press   . CharKey

-- | Shortcut for release 'CharKey' events.
charOff :: Char -> Evt Unit
charOff = keyIn . Release . CharKey

-- | Creates an event in the output stream when one of the chars is pressed.
strOn :: String -> Tick
strOn a = mconcat $ fmap charOn a

-- | Creates an event in the output stream when one of the chars is depressed.
strOff :: String -> Tick
strOff a = mconcat $ fmap charOff a

-- | Unipolar linear slider. The value belongs to the interval [0, 1].
-- The argument is for initial value.
uslider :: Double -> Source Sig
uslider = slider "" (linSpan 0 1)

-- | Unipolar linear knob. The value belongs to the interval [0, 1].
-- The argument is for initial value.
uknob :: Double -> Source Sig
uknob = knob "" (linSpan 0 1)

-- | Exponential slider (usefull for exploring frequencies or decibels). 
--
-- > xknob (min, max) initVal
--
-- The value belongs to the interval [min, max].
-- The last argument is for initial value.
xslider :: Range Double -> Double -> Source Sig
xslider (a, b) initVal = slider "" (expSpan a b) initVal

-- | Exponential knob (usefull for exploring frequencies or decibels). 
--
-- > xknob (min, max) initVal
--
-- The value belongs to the interval [min, max].
-- The last argument is for initial value.
xknob :: Range Double -> Double -> Source Sig
xknob (a, b) initVal = knob "" (expSpan a b) initVal

-- | Unit linear joystick.
ujoy :: (Double, Double) -> Source (Sig, Sig)
ujoy = joy (linSpan 0 1) (linSpan 0 1)

---------------------------------------------------------------
-- sample and hold

-- | The sample and hold widget. You can pick a value from the list of doubles.
-- The original value is a head of the list (the first element).
-- The visual grouping is horizontal (notice the prefix @h@).
-- It's common to use it with function @selector@.
hnumbers :: [Double] -> Source Sig
hnumbers = genNumbers hor

-- | The sample and hold widget. You can pick a value from the list of doubles.
-- The original value is a head of the list (the first element).
-- The visual grouping is vertical (notice the prefix @v@).
-- It's common to use it with function @selector@.
vnumbers :: [Double] -> Source Sig
vnumbers = genNumbers ver

genNumbers :: ([Gui] -> Gui) -> [Double] -> Source Sig
genNumbers gx as@(d:ds) = source $ do
    ref <- newGlobalSERef (sig $ double d)
    (gs, evts) <- fmap unzip $ mapM (button . show) as
    zipWithM_ (\x e -> runEvt e $ \_ -> writeSERef ref (sig $ double x)) as evts 
    res <- readSERef ref
    return (gx gs, res)


-------------------------------------------------------------------
-- 2D matrix of widgets

-- | The matrix of unipolar knobs.
--
-- > knobPad columnNum rowNum names initVals 
--
-- It takes in the dimensions of matrix, the names (we can leave it empty 
-- if names are not important) and list of init values.
-- It returns a function that takes in indices and produces the signal in
-- the corresponding cell.
knobPad :: Int -> Int -> [String] -> [Double] -> Source (Int -> Int -> Sig)
knobPad = genPad mkKnob 0.5
    where mkKnob name = knob name uspan 

-- | The matrix of toggle buttons.
--
-- > togglePad columnNum rowNum names initVals 
--
-- It takes in the dimensions of matrix, the names (we can leave it empty 
-- if names are not important) and list of init values (on/off booleans).
-- It returns a function that takes in indices and produces the event stream in
-- the corresponding cell.
togglePad :: Int -> Int -> [String] -> [Bool] -> Source (Int -> Int -> Evt D)
togglePad = genPad toggle False

-- | The matrix of buttons.
--
-- > buttonPad columnNum rowNum names
--
-- It takes in the dimensions of matrix, the names (we can leave it empty 
-- if names are not important).
-- It returns a function that takes in indices and produces the event stream in
-- the corresponding cell.
buttonPad :: Int -> Int -> [String] -> Source (Int -> Int -> Evt Unit)
buttonPad width height names = genPad mkButton False width height names []
    where mkButton name _ = button name

-- | A generic constructor for matrixes of sound source widgets.
-- It takes the constructor of the widget, a default initial value,
-- the dimensions of the matrix, the list of names and the list of initial values.
-- It produces the function that maps indices to corresponding values.
genPad :: (String -> a -> Source b) -> a -> Int -> Int -> [String] -> [a] -> Source (Int -> Int -> b)
genPad mk initVal width height names as = source $ do
    (gui, vals) <- fmap reGroupCol $ mapM mkRow inits
    let f x y = (vals !! y) !! x
    return $ (gui, f)
    where 
        mkRow xs = fmap reGroupRow $ mapM (uncurry mk) xs
        
        inits = split height width $ zip (names ++ repeat "") (as ++ repeat initVal)

        split m n xs = case m of
            0 -> []
            a -> (take n xs) : split (a - 1) n (drop n xs)

        reGroupCol = reGroup ver
        reGroupRow = reGroup hor

        reGroup f as = (f xs, ys)
            where (xs, ys) = unzip as


-- | Horizontal radio group.
hradio :: [String] -> Int -> Source (Evt D)
hradio = radioGroup hor

-- | Vertical radio group.
vradio :: [String] -> Int -> Source (Evt D)
vradio = radioGroup ver

-- | Horizontal radio group.
hradioSig :: [String] -> Int -> Source Sig
hradioSig = radioGroupSig hor

-- | Vertical radio group.
vradioSig :: [String] -> Int -> Source Sig
vradioSig = radioGroupSig ver

radioGroup :: ([Gui] -> Gui) -> [String] -> Int -> Source (Evt D)
radioGroup gcat names initVal = mapSource snaps $ radioGroupSig gcat names initVal

radioGroupSig  :: ([Gui] -> Gui) -> [String] -> Int -> Source Sig
radioGroupSig gcat names initVal = source $ do
    (guis, writes, reads) <- fmap unzip3 $ mapM (\(i, tag) -> flip setToggleSig (i == initVal) tag) $ zip [0 ..] names
    curRef <- newGlobalSERef (sig $ int initVal)
    current <- readSERef curRef    
    zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids
    zipWithM_ (\r i -> runEvt (snaps r) $ \x -> do              
        when1 (sig x ==* 1) $ do
            writeSERef curRef i
        when1 (sig x ==* 0 &&* current ==* i) $ do
           writeSERef curRef i    
        ) reads ids   

    res <- readSERef curRef
    return (gcat guis, res)
    where        
        ids = fmap (sig . int) [0 .. length names - 1]



-- | Pair of minimum and maximum values.
type Range a = (a, a)

-- | Creates a knob that outputs only integers in the given range.
-- It produces a signal of integer values.
--
-- > rangeKnobSig (min, max) initVal 
rangeKnobSig :: Range Int -> Int -> Source Sig
rangeKnobSig = rangeSig1 uknob

-- | Creates a slider that outputs only integers in the given range.
-- It produces a signal of integer values.
--
-- > rangeSliderSig (min, max) initVal 
rangeSliderSig :: Range Int -> Int -> Source Sig
rangeSliderSig = rangeSig1 uslider

-- | Creates a knob that outputs only integers in the given range.
-- It produces an event stream of integer values. It can be used with
-- list access functions @listAt@, @atTuple@, @atArg@.
--
-- > rangeKnob needInit (min, max) initVal
--
-- The first argument is a boolean. If it's true than the initial value
-- is put in the output stream. If it\s False the initial value is skipped.
rangeKnob :: Bool -> Range Int -> Int -> Source (Evt D)
rangeKnob = rangeEvt1 uknob

-- | Creates a slider that outputs only integers in the given range.
-- It produces an event stream of integer values. It can be used with
-- list access functions @listAt@, @atTuple@, @atArg@.
--
-- > rangeSlider needInit (min, max) initVal
--
-- The first argument is a boolean. If it's true than the initial value
-- is put in the output stream. If it\s False the initial value is skipped.
rangeSlider :: Bool -> Range Int -> Int -> Source (Evt D)
rangeSlider = rangeEvt1 uslider

rangeSig1 :: (Double -> Source Sig) -> Range Int -> Int -> Source Sig
rangeSig1 widget range initVal = mapSource (fromRelative range) $ widget $ toRelativeInitVal range initVal

rangeEvt1 :: (Double -> Source Sig) -> Bool -> Range Int -> Int -> Source (Evt D)
rangeEvt1 widget isInit range initVal = mapSource (addInit . snaps) $ rangeSig1 widget range initVal
    where
        addInit
            | isInit    = ((devt (int initVal) loadbang) <> )
            | otherwise = id

-- | 2d range range slider. Outputs a pair of event streams. 
-- Each stream  contains changes in the given direction (Ox or Oy).
--
-- > rangeJoy needsInit rangeX rangeY (initX, initY)
--
-- The first argument is a boolean. If it's true than the initial value
-- is put in the output stream. If it\s False the initial value is skipped.
rangeJoy :: Bool -> Range Int -> Range Int -> (Int, Int) -> Source (Evt D, Evt D)
rangeJoy isInit rangeX rangeY initVals = mapSource (addInit . f) $ rangeJoySig rangeX rangeY initVals
    where 
        f (x, y) = (snaps x, snaps y)           
        addInit
            | isInit    = id
            | otherwise = \(a, b) -> (dropE 1 a, dropE 1 b)

-- | 2d range range slider. It produces a single event stream. 
-- The event fires when any signal changes.
--
-- > rangeJoy2 needsInit rangeX rangeY (initX, initY)
--
-- The first argument is a boolean. If it's true than the initial value
-- is put in the output stream. If it\s False the initial value is skipped.
rangeJoy2 :: Bool -> Range Int -> Range Int -> (Int, Int) -> Source (Evt (D, D))
rangeJoy2 isInit rangeX rangeY initVals = mapSource (addInit . snaps2) $ rangeJoySig rangeX rangeY initVals
    where
        addInit
            | isInit    = id
            | otherwise = dropE 1

-- | 2d range range slider. It produces the pair of integer signals
rangeJoySig :: Range Int -> Range Int -> (Int, Int) -> Source (Sig, Sig)
rangeJoySig rangeX rangeY (initValX, initValY) = mapSource f $ 
    ujoy (toRelativeInitVal rangeX initValX, toRelativeInitVal rangeY initValY)
    where f (x, y) = (fromRelative rangeX x, fromRelative rangeY y)

toRelativeInitVal :: Range Int -> Int -> Double
toRelativeInitVal (kmin, kmax) initVal = (fromIntegral $ initVal - kmin) / (fromIntegral $ (kmax - 1) - kmin) 

fromRelative :: Range Int -> Sig -> Sig
fromRelative (kmin, kmax) = floor' . uon (f kmin) (f kmax - 0.01)
    where f = sig . int


------------------------------------------------------------
-- external control of widgets

-- | It's like simple @button@, but it can be controlled with external control.
-- The first argument is for external control.
button' :: Tick -> String -> Source Tick
button' ctrl name = mapSource (mappend ctrl) $ button name

-- | It's like simple @toggle@, but it can be controlled with external control.
-- The first argument is for external control.
toggle' :: Evt D -> String -> Bool -> Source (Evt D)
toggle' ctrl name initVal = source $ do
    (gui, output, input) <- setToggle name initVal
    output ctrl
    return $ (gui, mappend ctrl input)

toggleSig' :: Sig -> String -> Bool -> Source Sig
toggleSig' ctrl name initVal = 
    ctrlSig (if initVal then 1 else 0) ctrl $ setToggleSig name initVal

-- | It's like simple @uknob@, but it can be controlled with external control.
-- The first argument is for external control.
uknob' :: Sig -> Double -> Source Sig   
uknob' ctrl initVal = ctrlSig (double initVal) ctrl $ setKnob "" uspan initVal 

-- | It's like simple @uslider@, but it can be controlled with external control.
-- The first argument is for external control.
uslider' :: Sig -> Double -> Source Sig 
uslider' ctrl initVal = ctrlSig (double initVal) ctrl $ setSlider "" uspan initVal 

-- | It's like simple @knob@, but it can be controlled with external control.
-- The first argument is for external control.
knob' :: Sig -> String -> ValSpan -> Double -> Source Sig
knob' ctrl name span initVal = ctrlSig (double initVal) ctrl $ setKnob name span initVal

-- | It's like simple @slider@, but it can be controlled with external control.
-- The first argument is for external control.
slider' :: Sig -> String -> ValSpan -> Double -> Source Sig
slider' ctrl name span initVal = ctrlSig (double initVal) ctrl $ setSlider name span initVal

-- | It's like simple @hradioSig@, but it can be controlled with external control.
-- The first argument is for external control.
hradioSig' :: Sig -> [String] -> Int -> Source Sig
hradioSig' = radioGroupSig' hor 

-- | It's like simple @vradioSig@, but it can be controlled with external control.
-- The first argument is for external control.
vradioSig' :: Sig -> [String] -> Int -> Source Sig
vradioSig' = radioGroupSig' ver

-- | It's like simple @hradio@, but it can be controlled with external control.
-- The first argument is for external control.
hradio' :: Evt D -> [String] -> Int -> Source (Evt D) 
hradio' = radioGroup' hor 

-- | It's like simple @vradio@, but it can be controlled with external control.
-- The first argument is for external control.
vradio' :: Evt D -> [String] -> Int -> Source (Evt D)
vradio' = radioGroup' ver

radioGroup'  :: ([Gui] -> Gui) -> Evt D -> [String] -> Int -> Source (Evt D)
radioGroup' gcat ctrl names initVal =  mapSource snaps $ radioGroupSig' gcat (evtToSig (int initVal) ctrl) names initVal

radioGroupSig'  :: ([Gui] -> Gui) -> Sig -> [String] -> Int -> Source Sig
radioGroupSig' gcat ctrl names initVal = source $ do
    (guis, writes, reads) <- fmap unzip3 $ mapM (\(i, tag) -> flip setToggleSig (i == initVal) tag) $ zip [0 ..] names
    curRef <- newGlobalSERef (sig $ int initVal)   

    when1 (changed [ctrl] ==* 1) $ writeSERef curRef ctrl

    current <- readSERef curRef    
    zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids
    zipWithM_ (\r i -> runEvt (snaps r) $ \x -> do              
        when1 (sig x ==* 1) $ do
            writeSERef curRef i
        when1 (sig x ==* 0 &&* current ==* i) $ do
           writeSERef curRef i    
        ) reads ids   

    res <- readSERef curRef
    return (gcat guis, res)
    where        
        ids = fmap (sig . int) [0 .. length names - 1]


ctrlSig :: D -> Sig -> SinkSource Sig -> Source Sig
ctrlSig initVal ctrl v = source $ do
    (gui, output, input) <- v
    ref <- newGlobalSERef (sig initVal)
    when1 (changed [ctrl] ==* 1) $ writeSERef ref ctrl  
    when1 (changed [input] ==* 1) $ writeSERef ref input    
    res <- readSERef ref
    output res
    return (gui, res)