module TScore.Widgets where
import FRP.UISF
import FRP.UISF.UISF (conjoin)
import FRP.UISF.Graphics.Text
import Text.Read (readMaybe)
import Data.Maybe (isJust,maybeToList)
import Control.Monad (when)
import qualified Data.Map as Map (assocs)
import Reactive.Event
import Runtime.SymbolicTime
import Runtime.Multiplex
import Runtime.Player
import TScore.Midi
import Reactive.RTile
getInterval :: UISF () Interval
getInterval = title "Interval" $ topDown $
radio (map show intervals) 0 >>> arr (intervals!!)
where
intervals :: [Interval]
intervals = [Unison ..]
getTone :: UISF () Tone
getTone = title "Scale" $ topDown $
radio (map show $ fst (unzip tones)) 8 >>> arr (snd . (tones !!)) >>> spacer
where
tones :: [(PitchClass, MidiPitch)]
tones = zip pcl (fmap pitchClassToPitch pcl)
pcl = [Fb,Cb,Gb,Db,Ab,Eb,Bb,
F,C,G,D,A,E,B,
Fs,Cs,Gs,Ds,As,Es,Bs]
getWindow :: UISF () (MidiPitch, MidiPitch)
getWindow = title "Transpose Window" $ topDown $ proc () -> do
rec start <- label "Start Pitch" >>> textbox "0" -< start'
start_update <- unique -< start
start' <- delay Nothing -< fmap (show . check) (start_update >>= readMaybe)
rec stop <- label "Stop Pitch" >>> textbox "127" -< stop'
stop_update <- unique -< stop
stop' <- delay Nothing -< fmap (show . check) (stop_update >>= readMaybe)
returnA -< (str2pitch start, str2pitch stop)
where
check :: Int -> MidiPitch
check s | s < 0 = 0
| s > 127 = 127
| otherwise = s
str2pitch :: String -> MidiPitch
str2pitch s = read s :: MidiPitch
bpmWidget :: UISF () BPM
bpmWidget = title "Ticks" $ topDown $ proc _ -> do
arr BPM <<< (title "BPM" $ withDisplay $ hiSlider 1 (30,600) 60) -< ()
timelineWidget :: UISF (SEvent (), SEvent ()) ()
timelineWidget =
let g = realtimeGraph (makeLayout (Stretchy 10) (Stretchy 10)) 5 Red
in proc (t, tr) -> do
time <- accumTime -< ()
title "Time-line" g -< (case tr of {Nothing -> [(1,time)]; Just t -> [(0.5,time)]}) ++
(case t of {Nothing -> [(1,time)]; Just t -> [(0,time)]})
frequencyDivider :: UISF (Integer, SEvent ()) (SEvent ())
frequencyDivider = proc (n_ticks, input_s) -> do
rec counter <- delay 1 -< maybe counter (\x -> if counter >= n_ticks then 1 else counter+1) input_s
edge -< maybe False (\x -> counter == n_ticks) input_s
functionWidget :: (Show b) => [(a,b)] -> UISF () (Maybe a)
functionWidget fl = title "Mode" $ topDown $
arr ((map fst fl !!) <$>) <<< unique <<< spacer <<< radio (map (show . snd) fl) 0
entryRadioWidget :: String -> [(a,String)] -> UISF () (SEvent [Event a])
entryRadioWidget name list = title name $ topDown $ proc () ->
do i <- radio (map snd list) init -< ()
u <- unique -< i
last <- delay Nothing <<< arr Just -< i
arr (\(u,l) -> case (u,l) of
(Just newi, Just l) -> Just [Off (fst $ list !! l), On (fst $ list !! newi)]
(Just newi, Nothing) -> Just [On (fst $ list !! newi)]
_ -> Nothing) -< (u,last)
where init = 0
startStopEventWidget :: UISF () (Maybe (Event e))
startStopEventWidget = proc () ->
do s <- unique <<< stickyButton "start/stop" -< ()
init <- delay True -< False
returnA -< if init
then Nothing
else case s of
Just True -> Just Start
Just False -> Just Stop
Nothing -> Nothing
run_1input_1output
:: (Ord iv, Ord ov, Show iv, Show ov) =>
UISF (Maybe [Event ov]) (BPM, Maybe [Event iv], Maybe (Event iv))
-> (RTile Quarters iv iv -> RTile Quarters iv ov) -> UISF () ()
run_1input_1output interface t = proc () ->
do rec (bpm, inA, startStop) <- interface <<< delay (Nothing) -< outA
mergedInWithStartStop <- mergeStream -< (inA,(:[]) <$> startStop)
outA <- arrowizeTile t -< (mergedInWithStartStop, bpm)
returnA -< ()
run_0input_1output
:: (Ord ov, Show ov) =>
UISF (Maybe [Event ov]) (BPM, Maybe (Event ()))
-> (RTile Quarters () () -> RTile Quarters () ov) -> UISF () ()
run_0input_1output interface t = proc () ->
do rec (bpm, startStop) <- interface <<< delay (Nothing) -< outA
outA <- arrowizeTile t -< ((:[]) <$> startStop, bpm)
returnA -< ()
run_2input_1output
:: (Ord iva, Ord ivb, Ord ova, Show iva, Show ivb, Show ova) =>
UISF
(Maybe [Event ova])
(BPM,
Maybe [Event iva],
Maybe [Event ivb],
Maybe (Event (Either iva ivb)))
-> (RTile Quarters (Either iva ivb) (Either iva ivb)
-> RTile Quarters (Either iva ivb) ova)
-> UISF () ()
run_2input_1output interface t = proc () ->
do rec (bpm, inA, inB, startStop) <- interface <<< delay Nothing -< outA
mergedIn <- arr multiplex2 -< (inA,inB)
mergedInWithStartStop <- mergeStream -< (mergedIn,(:[]) <$> startStop)
outA <- arrowizeTile t -< (mergedInWithStartStop, bpm)
returnA -< ()
run_2input_2output
:: (Ord iva, Ord ivb, Ord ova, Ord ovb, Show iva, Show ivb, Show ova,
Show ovb) =>
UISF
(Maybe [Event ova], Maybe [Event ovb])
(BPM,
Maybe [Event iva],
Maybe [Event ivb],
Maybe (Event (Either iva ivb)))
-> (RTile Quarters (Either iva ivb) (Either iva ivb)
-> RTile Quarters (Either iva ivb) (Either ova ovb))
-> UISF () ()
run_2input_2output interface t = proc () ->
do rec (bpm, inA, inB, startStop) <- interface <<< delay (Nothing, Nothing) -< (outA, outB)
mergedIn <- arr multiplex2 -< (inA,inB)
mergedInWithStartStop <- mergeStream -< (mergedIn,(:[]) <$> startStop)
mergedOut <- arrowizeTile t -< (mergedInWithStartStop, bpm)
(outA,outB) <- arr deMultiplex2 -< mergedOut
returnA -< ()
mergeStream :: UISF (Maybe [a], Maybe [a]) (Maybe [a])
mergeStream = arr $ \(e,s) -> case (e,s) of
(Just e, Just s) -> Just (s++e)
(Just e, _ ) -> Just e
(_ , Just s) -> Just s
_ -> Nothing
eventize :: v -> UISF Bool [Event v]
eventize a = proc currentValue ->
do lastValue <- delay False -< currentValue
returnA -< case (lastValue, currentValue) of
(False,True) -> [On a]
(True,False) -> [Off a]
_ -> []
matrixToButtonMatrix :: (Int,Int) -> [[(String,a)]] -> UISF () (Maybe [Event a])
matrixToButtonMatrix (h,w) m =
let dim = (h `div` maximum (map length m)
,w `div` length m)
entryToButton (s,a) = setSize dim $ conjoin $ stickyButton (toUIText s) >>> eventize a
raw = leftRight . concatA . map entryToButton
column = topDown . concatA . map raw
in constA (repeat (repeat ())) >>> column m >>> arr (concat . concat) >>> arr (\l -> if null l then Nothing else Just l)
filterEventA :: Ord a => UISF (Maybe [Event a]) (Maybe [Event a])
filterEventA = proc e ->
do rec (s,out) <- delay (emptyWeight, []) <<< arr (uncurry filterEvent) -< (s,concat . maybeToList $ e)
returnA -< case out of
[] -> Nothing
l -> Just l