-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE RankNTypes #-}
-- | The 'Track' type and supporting functions.
module Ui.Track where
import qualified Control.DeepSeq as DeepSeq

import qualified Util.Pretty as Pretty
import qualified App.Config as Config
import qualified Derive.ScoreT as ScoreT
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.Color as Color
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.Types as Types

import           Global
import           Types


-- * track

-- | An event track, which contains some configuration, and the actual
-- events that make up the score.
data Track = Track {
    Track -> Text
track_title :: !Text
    , Track -> Events
track_events :: !Events.Events
    -- | Similar to 'Event.Event.style', you can individually configure track
    -- bg color, but in practice I do it automatically at the low level with
    -- 'TrackBg'.
    , Track -> Color
track_bg :: !Color.Color
    , Track -> RenderConfig
track_render :: !RenderConfig
    -- | If True, and this track has im notes, display the waveform on the
    -- track.
    , Track -> Bool
track_waveform :: !Bool
    } deriving (Track -> Track -> Bool
(Track -> Track -> Bool) -> (Track -> Track -> Bool) -> Eq Track
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Track -> Track -> Bool
$c/= :: Track -> Track -> Bool
== :: Track -> Track -> Bool
$c== :: Track -> Track -> Bool
Eq, Int -> Track -> ShowS
[Track] -> ShowS
Track -> String
(Int -> Track -> ShowS)
-> (Track -> String) -> ([Track] -> ShowS) -> Show Track
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: Int -> Track -> ShowS
$cshowsPrec :: Int -> Track -> ShowS
Show, ReadPrec [Track]
ReadPrec Track
Int -> ReadS Track
ReadS [Track]
(Int -> ReadS Track)
-> ReadS [Track]
-> ReadPrec Track
-> ReadPrec [Track]
-> Read Track
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Track]
$creadListPrec :: ReadPrec [Track]
readPrec :: ReadPrec Track
$creadPrec :: ReadPrec Track
readList :: ReadS [Track]
$creadList :: ReadS [Track]
readsPrec :: Int -> ReadS Track
$creadsPrec :: Int -> ReadS Track
Read)

instance Pretty Track where
    format :: Track -> Doc
format (Track Text
title Events
events Color
_bg RenderConfig
render Bool
_waveform) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Track"
        [ (Text
"title", Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
title)
        , (Text
"render", RenderConfig -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RenderConfig
render)
        , (Text
"events", Events -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Events
events)
        ]

-- | Construct a new Track.
track :: Text -> Events.Events -> Track
track :: Text -> Events -> Track
track Text
title Events
events = Track
    { track_title :: Text
track_title = Text
title
    , track_events :: Events
track_events = Events
events
    , track_bg :: Color
track_bg = Color
Config.track_bg
    , track_render :: RenderConfig
track_render = RenderConfig
line_render
    , track_waveform :: Bool
track_waveform = Bool
True
    }

empty :: Track
empty :: Track
empty = Text -> Events -> Track
track Text
"" Events
Events.empty

instance DeepSeq.NFData Track where
    rnf :: Track -> ()
rnf Track
track = Events -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf (Track -> Events
track_events Track
track) () -> () -> ()
`seq` ()

modify_events :: (Events.Events -> Events.Events) -> Track -> Track
modify_events :: (Events -> Events) -> Track -> Track
modify_events Events -> Events
f track :: Track
track@(Track { track_events :: Track -> Events
track_events = Events
events }) =
    Track
track { track_events :: Events
track_events = Events -> Events
f Events
events }

set_events :: Events.Events -> Track -> Track
set_events :: Events -> Track -> Track
set_events Events
events = (Events -> Events) -> Track -> Track
modify_events (Events -> Events -> Events
forall a b. a -> b -> a
const Events
events)

type SetStyle = (TrackBg, Event.EventStyle)

-- | High level 'SetStyle', with information provided automatically.
--
-- It's a bit awkward to have two SetStyles, but some information can only be
-- supplied by "Ui.Sync".
data SetStyleHigh = SetStyleHigh {
    SetStyleHigh -> Track -> Color
_track_bg :: TrackBg
    -- | The arguments are what 'Cmd.Internal.event_style' needs to figure out
    -- a style.
    , SetStyleHigh
-> forall a.
   Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle
_set_event_style :: forall a. Id.Namespace -> Map BlockId a -> BlockId
        -> Bool -- has note track children?
        -> Event.EventStyle
    }
type TrackBg = Track -> Color.Color

-- * track signal

-- | Whether to draw a 'Signal.Display' on this track, and if so, how.
data RenderConfig = RenderConfig {
    RenderConfig -> RenderStyle
render_style :: !RenderStyle
    , RenderConfig -> Color
render_color :: !Color.Color
    } deriving (RenderConfig -> RenderConfig -> Bool
(RenderConfig -> RenderConfig -> Bool)
-> (RenderConfig -> RenderConfig -> Bool) -> Eq RenderConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenderConfig -> RenderConfig -> Bool
$c/= :: RenderConfig -> RenderConfig -> Bool
== :: RenderConfig -> RenderConfig -> Bool
$c== :: RenderConfig -> RenderConfig -> Bool
Eq, Int -> RenderConfig -> ShowS
[RenderConfig] -> ShowS
RenderConfig -> String
(Int -> RenderConfig -> ShowS)
-> (RenderConfig -> String)
-> ([RenderConfig] -> ShowS)
-> Show RenderConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenderConfig] -> ShowS
$cshowList :: [RenderConfig] -> ShowS
show :: RenderConfig -> String
$cshow :: RenderConfig -> String
showsPrec :: Int -> RenderConfig -> ShowS
$cshowsPrec :: Int -> RenderConfig -> ShowS
Show, ReadPrec [RenderConfig]
ReadPrec RenderConfig
Int -> ReadS RenderConfig
ReadS [RenderConfig]
(Int -> ReadS RenderConfig)
-> ReadS [RenderConfig]
-> ReadPrec RenderConfig
-> ReadPrec [RenderConfig]
-> Read RenderConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RenderConfig]
$creadListPrec :: ReadPrec [RenderConfig]
readPrec :: ReadPrec RenderConfig
$creadPrec :: ReadPrec RenderConfig
readList :: ReadS [RenderConfig]
$creadList :: ReadS [RenderConfig]
readsPrec :: Int -> ReadS RenderConfig
$creadsPrec :: Int -> ReadS RenderConfig
Read)

no_render :: RenderConfig
no_render :: RenderConfig
no_render = RenderStyle -> Color -> RenderConfig
RenderConfig RenderStyle
NoRender Color
Config.track_signal_color

line_render :: RenderConfig
line_render :: RenderConfig
line_render = RenderStyle -> Color -> RenderConfig
RenderConfig (Maybe RenderSource -> RenderStyle
Line Maybe RenderSource
forall a. Maybe a
Nothing) Color
Config.track_signal_color

instance Pretty RenderConfig where
    pretty :: RenderConfig -> Text
pretty (RenderConfig RenderStyle
style Color
color) = (RenderStyle, Color) -> Text
forall a. Pretty a => a -> Text
pretty (RenderStyle
style, Color
color)

-- | RenderStyles can take an optional source which says which control the
-- signal comes from.  This is only for note tracks, and will extract the
-- final signal from the events and display that.
--
-- Non-note tracks will ignore the RenderSource, and note tracks will ignore
-- a RenderStyle without a RenderSource.
--
-- This has no effect on the actual rendering, since it just draws a signal and
-- doesn't know where it came from, but is configuration for the code that goes
-- and looks for that signal.
data RenderStyle = NoRender | Line !(Maybe RenderSource)
    | Filled !(Maybe RenderSource)
    deriving (RenderStyle -> RenderStyle -> Bool
(RenderStyle -> RenderStyle -> Bool)
-> (RenderStyle -> RenderStyle -> Bool) -> Eq RenderStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenderStyle -> RenderStyle -> Bool
$c/= :: RenderStyle -> RenderStyle -> Bool
== :: RenderStyle -> RenderStyle -> Bool
$c== :: RenderStyle -> RenderStyle -> Bool
Eq, ReadPrec [RenderStyle]
ReadPrec RenderStyle
Int -> ReadS RenderStyle
ReadS [RenderStyle]
(Int -> ReadS RenderStyle)
-> ReadS [RenderStyle]
-> ReadPrec RenderStyle
-> ReadPrec [RenderStyle]
-> Read RenderStyle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RenderStyle]
$creadListPrec :: ReadPrec [RenderStyle]
readPrec :: ReadPrec RenderStyle
$creadPrec :: ReadPrec RenderStyle
readList :: ReadS [RenderStyle]
$creadList :: ReadS [RenderStyle]
readsPrec :: Int -> ReadS RenderStyle
$creadsPrec :: Int -> ReadS RenderStyle
Read, Int -> RenderStyle -> ShowS
[RenderStyle] -> ShowS
RenderStyle -> String
(Int -> RenderStyle -> ShowS)
-> (RenderStyle -> String)
-> ([RenderStyle] -> ShowS)
-> Show RenderStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenderStyle] -> ShowS
$cshowList :: [RenderStyle] -> ShowS
show :: RenderStyle -> String
$cshow :: RenderStyle -> String
showsPrec :: Int -> RenderStyle -> ShowS
$cshowsPrec :: Int -> RenderStyle -> ShowS
Show)

data RenderSource = Control ScoreT.Control | Pitch ScoreT.PControl
    deriving (RenderSource -> RenderSource -> Bool
(RenderSource -> RenderSource -> Bool)
-> (RenderSource -> RenderSource -> Bool) -> Eq RenderSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenderSource -> RenderSource -> Bool
$c/= :: RenderSource -> RenderSource -> Bool
== :: RenderSource -> RenderSource -> Bool
$c== :: RenderSource -> RenderSource -> Bool
Eq, ReadPrec [RenderSource]
ReadPrec RenderSource
Int -> ReadS RenderSource
ReadS [RenderSource]
(Int -> ReadS RenderSource)
-> ReadS [RenderSource]
-> ReadPrec RenderSource
-> ReadPrec [RenderSource]
-> Read RenderSource
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RenderSource]
$creadListPrec :: ReadPrec [RenderSource]
readPrec :: ReadPrec RenderSource
$creadPrec :: ReadPrec RenderSource
readList :: ReadS [RenderSource]
$creadList :: ReadS [RenderSource]
readsPrec :: Int -> ReadS RenderSource
$creadsPrec :: Int -> ReadS RenderSource
Read, Int -> RenderSource -> ShowS
[RenderSource] -> ShowS
RenderSource -> String
(Int -> RenderSource -> ShowS)
-> (RenderSource -> String)
-> ([RenderSource] -> ShowS)
-> Show RenderSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenderSource] -> ShowS
$cshowList :: [RenderSource] -> ShowS
show :: RenderSource -> String
$cshow :: RenderSource -> String
showsPrec :: Int -> RenderSource -> ShowS
$cshowsPrec :: Int -> RenderSource -> ShowS
Show)

instance Pretty RenderSource where
    pretty :: RenderSource -> Text
pretty (Control Control
c) = Text
"Control " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Control -> Text
forall a. Pretty a => a -> Text
pretty Control
c
    pretty (Pitch PControl
c) = Text
"Pitch " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PControl -> Text
forall a. Pretty a => a -> Text
pretty PControl
c
instance Pretty RenderStyle where pretty :: RenderStyle -> Text
pretty = RenderStyle -> Text
forall a. Show a => a -> Text
showt

set_render_style :: RenderStyle -> Track -> Track
set_render_style :: RenderStyle -> Track -> Track
set_render_style RenderStyle
style Track
track =
    Track
track { track_render :: RenderConfig
track_render = (Track -> RenderConfig
track_render Track
track) { render_style :: RenderStyle
render_style = RenderStyle
style } }

-- | Each (BlockId, TrackId) pair can have a TrackSignal associated with it.
--
-- There's no particular reason a ruler couldn't also have a signal in it,
-- except that it might look a little crowded.  But RulerId isn't supported.
-- If there's ever a need I can add it.
type TrackSignals = Map (BlockId, TrackId) TrackSignal

-- | Similar to "Derive.TrackWarp", the signal generated by signal
-- tracks is stashed away in TrackSignals during derivation so it can be sent
-- to the UI for display.
--
-- Signals are in real time, but the UI wants to display them in score time.
-- If the block happens to have a linear warp then the mapping is trivial, and
-- I don't have to bother generating another signal just for display.  However,
-- if there is a non-trivial warp, the signal will have to be unwarped back
-- to ScoreTime.
data TrackSignal = TrackSignal {
    TrackSignal -> Display
ts_signal :: !Signal.Display
    , TrackSignal -> ScoreTime
ts_shift :: !ScoreTime
    , TrackSignal -> ScoreTime
ts_stretch :: !ScoreTime
    } deriving (Int -> TrackSignal -> ShowS
[TrackSignal] -> ShowS
TrackSignal -> String
(Int -> TrackSignal -> ShowS)
-> (TrackSignal -> String)
-> ([TrackSignal] -> ShowS)
-> Show TrackSignal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackSignal] -> ShowS
$cshowList :: [TrackSignal] -> ShowS
show :: TrackSignal -> String
$cshow :: TrackSignal -> String
showsPrec :: Int -> TrackSignal -> ShowS
$cshowsPrec :: Int -> TrackSignal -> ShowS
Show, TrackSignal -> TrackSignal -> Bool
(TrackSignal -> TrackSignal -> Bool)
-> (TrackSignal -> TrackSignal -> Bool) -> Eq TrackSignal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrackSignal -> TrackSignal -> Bool
$c/= :: TrackSignal -> TrackSignal -> Bool
== :: TrackSignal -> TrackSignal -> Bool
$c== :: TrackSignal -> TrackSignal -> Bool
Eq)

empty_track_signal :: TrackSignal
empty_track_signal :: TrackSignal
empty_track_signal = Display -> ScoreTime -> ScoreTime -> TrackSignal
TrackSignal Display
forall a. Monoid a => a
mempty ScoreTime
0 ScoreTime
1

instance Pretty TrackSignal where
    format :: TrackSignal -> Doc
format (TrackSignal Display
sig ScoreTime
shift ScoreTime
stretch) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record (Doc
"TrackSignal" Doc -> Doc -> Doc
Pretty.<+> (ScoreTime, ScoreTime) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (ScoreTime
shift, ScoreTime
stretch))
            [(Text
"signal", Display -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Display
sig)]

instance DeepSeq.NFData TrackSignal where
    rnf :: TrackSignal -> ()
rnf (TrackSignal Display
sig ScoreTime
_ ScoreTime
_) = Display -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Display
sig

signal_at :: ScoreTime -> TrackSignal -> Signal.Y
signal_at :: ScoreTime -> TrackSignal -> Y
signal_at ScoreTime
x (TrackSignal Display
sig ScoreTime
shift ScoreTime
stretch) = X -> Display -> Y
forall {k} (kind :: k). X -> Signal kind -> Y
Signal.at X
warped Display
sig
    where warped :: X
warped = ScoreTime -> X
RealTime.from_score (ScoreTime -> X) -> ScoreTime -> X
forall a b. (a -> b) -> a -> b
$ ScoreTime
x ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
* ScoreTime
stretch ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
shift

-- * waveform

data WaveformChunk = WaveformChunk {
    WaveformChunk -> String
_filename :: !FilePath
    , WaveformChunk -> Int
_chunknum :: Types.ChunkNum
    , WaveformChunk -> ScoreTime
_start :: !TrackTime
    , WaveformChunk -> [Y]
_ratios :: ![Double]
    } deriving (Int -> WaveformChunk -> ShowS
[WaveformChunk] -> ShowS
WaveformChunk -> String
(Int -> WaveformChunk -> ShowS)
-> (WaveformChunk -> String)
-> ([WaveformChunk] -> ShowS)
-> Show WaveformChunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WaveformChunk] -> ShowS
$cshowList :: [WaveformChunk] -> ShowS
show :: WaveformChunk -> String
$cshow :: WaveformChunk -> String
showsPrec :: Int -> WaveformChunk -> ShowS
$cshowsPrec :: Int -> WaveformChunk -> ShowS
Show)

instance Pretty WaveformChunk where
    format :: WaveformChunk -> Doc
format (WaveformChunk String
filename Int
chunknum ScoreTime
start [Y]
ratios) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"WaveformChunk"
            [ (Text
"filename", String -> Doc
forall a. Pretty a => a -> Doc
Pretty.format String
filename)
            , (Text
"chunknum", Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
chunknum)
            , (Text
"start", ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
start)
            , (Text
"ratios", [Y] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Y]
ratios)
            ]