{- |
Module      :  $Header$
Description :  Module that contains several widgets
Copyright   :  (c) Jaime Arias, David Janin, 2015
License     :  see the LICENSE file in the distribution

Maintainer  :  jaime.arias@inria.fr
Stability   :  experimental

This module provides several widgets to build Musical User Interfaces
-}

{-# LANGUAGE Arrows #-}

module TScore.Widgets where

import FRP.UISF
import FRP.UISF.UISF (conjoin)
-- import FRP.UISF.Render.GLUT as G
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

{-
-- | Widget that asks to the user the direction of the transposition
getDirection :: UISF () Direction
getDirection = title "Direction" $ topDown $
               radio (map show directions) 1 >>> arr (directions!!)
               where
                 directions :: [Direction]
                 directions = [Lower ..]
-}

-- | Widget that asks to the user for the interval of the transposition
getInterval :: UISF () Interval
getInterval = title "Interval" $ topDown $
              radio (map show intervals) 0 >>> arr (intervals!!)
              where
                intervals :: [Interval]
                intervals = [Unison ..]

-- | Widget that shows a checkbox list for choosing a tone
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]
                  

-- | Widget that asks to the user for two pitches in order to define a
-- window in which the transposition will be applied
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

-- | Widget that asks to the user for the tempo of the application.
-- Moreover, it aks to the user for a number to divide the tempo
bpmWidget :: UISF () BPM
bpmWidget = title "Ticks" $ topDown $ proc _ -> do
  arr BPM <<< (title "BPM" $ withDisplay $ hiSlider 1 (30,600) 60) -< ()


-- | Widget that shows the time-line
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)]})

-- | Signal function that takes a tick signal and divides its frequency by
-- a number of ticks
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

-- | Widget that sends a function as an event each time it changes
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

-- | Widget that sends a on/off stream of its value
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


-- | Make a widget that add start/stop event in stream
startStopEventWidget :: UISF () (Maybe (Event e))
startStopEventWidget = proc () ->
  do s <- unique <<< stickyButton "start/stop" -< ()
     init <- delay True -< False 
     returnA  -< if init
                 then Nothing -- remove the firt "Stop"
                 else case s of
                            Just True  -> Just Start
                            Just False -> Just Stop
                            Nothing -> Nothing
     


-- -- | Widget that display a MIDI curve
-- keyboardGraph :: String -> Color -> UISF (Maybe [Event Midi]) ()
-- keyboardGraph titlegraph color =
--   let g = realtimeGraph (makeLayout (Stretchy 10) (Stretchy 10)) 5 color
--   in proc le -> do
--     time <- accumTime -< ()
--     title titlegraph $ g -< let eToPitch = fromIntegral. pitchMidi
--                                 -- midi pitch : 21 108
--                                 pitchToPoint :: Int -> Double
--                                 pitchToPoint p =  (-4)* ((fromIntegral p - 127/2) / 127)
--                              in case le of
--                              Nothing -> [] -- [(1,time)]
--                              Just l -> concatMap (\e -> case e of
--                                   On  e -> [(1,time),(pitchToPoint $eToPitch e,time),(1,time)]
--                                   Off e -> [] -- (pitchToPoint $eToPitch e,time),(1,time),(pitchToPoint $eToPitch e,time)]
--                                   ) l

-- -- | Widget that shows the state of the environment
-- uiTest :: UISF Environment ()
-- uiTest = topDown $ title "Check" $ proc env ->
--    display <<< label "Weight Pitch"  -< Map.assocs (weight env)
-- 
-- -- | Widget to control de visualization in INScore
-- uiRollVisualization :: DeltaT -> Double -> ColorRGB -> ColorRGB -> Int -> Int -> Int -> Int -> MidiPitch -> MidiPitch -> UISF (SEvent [EventMidi], SEvent [EventMidi]) ()
-- uiRollVisualization refresh_rate speed color_input color_output alpha_input alpha_output blur_input blur_output min_pitch max_pitch =
--   setLayout (makeLayout (Fixed 300) (Stretchy 5)) $ title "INScore" $ proc (input, output) -> do
-- 
--     (s,c) <- (| leftRight (do
--       c <- setLayout (makeLayout (Fixed 80) (Stretchy 30)) $ checkbox "piano" True -< ()
--       s <- setLayout (makeLayout (Fixed 220) (Stretchy 30)) $ hSlider (0,10) speed -< ()
--       returnA -< (s,c)) |)
-- 
--     t <- spacer <<< edge <<< button "Load" -< () -- Load Button
-- 
--     liftAIO (\(pulse,v) -> when (isJust pulse) (showPiano v)) <<< unique &&& arr id -< c -- hide piano
--     liftAIO (\pulse -> when (isJust pulse) $ drawPianoRoll min_pitch max_pitch) -< t -- load piano roll
-- 
--     clock_inscore <- timer -< refresh_rate
--     pianoRoll refresh_rate "output" color_output alpha_output blur_output -< (output, clock_inscore, s)
--     pianoRoll refresh_rate "input" color_input alpha_input blur_input -< (input, clock_inscore, s)


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) -- add start/stop to stream
         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) -- add start/stop to stream
         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) -- add start/stop to stream
         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]
                 _            -> []
                    

-- | Produce a matrix of stickyButtons of the dimension given as first parameter
-- this arrow produce a well parenthised stream of pressed buttons
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)

-- | Arrow that ensure that a stream of events is well parethesized
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

--
--graphical color string dim = proc g ->
--  do w <- initialAIO (openWindow color string dim) (\w -> terminalAIO (G.getWindow w >>= \mw -> case mw of
--                                                                          Nothing -> return ()
--                                                                          Just w -> closeWindow w) >>> constA w) -< ()
--     returnA -< ()
--