-- 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

module Ui.Block (
    -- * Block
    Block(..)
    , Skeleton(..)
    , Meta, TrackDestinations(..), ScoreDestinations, NoteDestination(..)
    , dest_track_ids, note_dest_track_ids, empty_destination
    , Source(..), destination_to_source
    , ManualDestinations, SourceKey
    , EventIndex, short_event_index
    , integrate_skeleton
    , block_tracklike_ids, block_track_ids, block_ruler_ids
    , block
    , Config(..), default_config
    , Box(..)
    -- * Track
    , Track(..), track_id, track
    , modify_id
    , divider
    , is_collapsed
    , track_selectable, track_wants_signal
    -- ** DisplayTrack
    , DisplayTrack(..), Status(..), empty_status, TrackFlag(..)
    , block_display_tracks
    , display_track_width
    , flags_to_status, flag_char
    -- ** TracklikeId
    , TracklikeId(..)
    , track_id_of, track_ids_of, ruler_id_of, ruler_ids_of
    , set_ruler_id
    , Tracklike(..)
    , track_of, tracks_of, ruler_of, rulers_of
    , Divider(..)
    -- * View
    , View(..)
    , view
    , Padding(..)
    , status_color, show_status
    , visible_track, visible_time
    , track_rect, set_track_rect
    , view_visible_time, view_visible_track
    , screen_pixels
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified GHC.Generics as Generics

import qualified Util.Lists as Lists
import qualified Util.Pretty as Pretty
import qualified Util.Rect as Rect

import qualified App.Config as Config
import qualified Ui.Color as Color
import qualified Ui.Event as Event
import qualified Ui.Ruler as Ruler
import qualified Ui.Sel as Sel
import qualified Ui.Skeleton as Skeleton
import qualified Ui.Track as Track
import qualified Ui.Types as Types
import qualified Ui.Zoom as Zoom

import           Global
import           Types


-- * block

-- | This is the data behind a single block.
data Block = Block {
    Block -> Text
block_title :: !Text
    , Block -> Config
block_config :: !Config
    , Block -> [Track]
block_tracks :: ![Track]
    , Block -> Skeleton
block_skeleton :: !Skeleton.Skeleton
    -- | Present if this block was integrated from another.  If the
    -- TrackDestinations is empty, then this is an empty block that was created
    -- to receive integration.
    , Block -> Maybe (BlockId, TrackDestinations)
block_integrated :: !(Maybe (BlockId, TrackDestinations))

    -- | Each pair is a set of tracks integrated from a source TrackId.
    -- A single source can have multiple destination sets.  Similar to
    -- block_integrated, if the TrackDestinations is empty, then new integrated
    -- tracks should be created.
    , Block -> [(TrackId, TrackDestinations)]
block_integrated_tracks :: ![(TrackId, TrackDestinations)]
    , Block -> ManualDestinations
block_integrated_manual :: !ManualDestinations
    , Block -> Meta
block_meta :: !Meta
    } deriving (Block -> Block -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq, Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show, forall x. Rep Block x -> Block
forall x. Block -> Rep Block x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Block x -> Block
$cfrom :: forall x. Block -> Rep Block x
Generics.Generic)

instance Pretty Block where format :: Block -> Doc
format = forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_

instance DeepSeq.NFData Block where
    rnf :: Block -> ()
rnf = forall a. NFData a => a -> ()
DeepSeq.rnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Text
block_title

data Skeleton = Explicit | Implicit
    deriving (Skeleton -> Skeleton -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Skeleton -> Skeleton -> Bool
$c/= :: Skeleton -> Skeleton -> Bool
== :: Skeleton -> Skeleton -> Bool
$c== :: Skeleton -> Skeleton -> Bool
Eq, Int -> Skeleton -> ShowS
[Skeleton] -> ShowS
Skeleton -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Skeleton] -> ShowS
$cshowList :: [Skeleton] -> ShowS
show :: Skeleton -> String
$cshow :: Skeleton -> String
showsPrec :: Int -> Skeleton -> ShowS
$cshowsPrec :: Int -> Skeleton -> ShowS
Show)
instance Pretty Skeleton where pretty :: Skeleton -> Text
pretty = forall a. Show a => a -> Text
showt

{- | Block metadata is extra data that doesn't affect normal derivation, but
    may be of interest to cmds.

    Previously this was used to mark blocks for automatic lilypond derivation,
    currently tscore uses it to mark sub-blocks.
-}
type Meta = Map Text Text

data Source =
    -- | Integrated from a manually-invoked integration.  A single SourceKey
    -- can have destinations on multiple tracks within the block.
    ManualSource !SourceKey
    | TrackSource !TrackId
    | BlockSource !BlockId
    deriving (Source -> Source -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c== :: Source -> Source -> Bool
Eq, Eq Source
Source -> Source -> Bool
Source -> Source -> Ordering
Source -> Source -> Source
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Source -> Source -> Source
$cmin :: Source -> Source -> Source
max :: Source -> Source -> Source
$cmax :: Source -> Source -> Source
>= :: Source -> Source -> Bool
$c>= :: Source -> Source -> Bool
> :: Source -> Source -> Bool
$c> :: Source -> Source -> Bool
<= :: Source -> Source -> Bool
$c<= :: Source -> Source -> Bool
< :: Source -> Source -> Bool
$c< :: Source -> Source -> Bool
compare :: Source -> Source -> Ordering
$ccompare :: Source -> Source -> Ordering
Ord, Int -> Source -> ShowS
[Source] -> ShowS
Source -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Source] -> ShowS
$cshowList :: [Source] -> ShowS
show :: Source -> String
$cshow :: Source -> String
showsPrec :: Int -> Source -> ShowS
$cshowsPrec :: Int -> Source -> ShowS
Show)

instance Pretty Source where
    pretty :: Source -> Text
pretty (ManualSource Text
key) = Text
key
    pretty (TrackSource TrackId
tid) = forall a. Pretty a => a -> Text
pretty TrackId
tid
    pretty (BlockSource BlockId
bid) = forall a. Pretty a => a -> Text
pretty BlockId
bid

-- | TODO I intended to unify all the integration muddle into one dest to
-- source map, and maybe I stil can, but meanwhile, here's what it could look
-- like.
destination_to_source :: Block -> [(TrackId, (Source, EventIndex))]
destination_to_source :: Block -> [(TrackId, (Source, EventIndex))]
destination_to_source Block
block = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ case Block -> Maybe (BlockId, TrackDestinations)
block_integrated Block
block of
        Maybe (BlockId, TrackDestinations)
Nothing -> []
        Just (BlockId
source_block, TrackDestinations
tdests) ->
            Source -> TrackDestinations -> [(TrackId, (Source, EventIndex))]
track_dests (BlockId -> Source
BlockSource BlockId
source_block) TrackDestinations
tdests
    , [(TrackId, TrackDestinations)] -> [(TrackId, (Source, EventIndex))]
integrated_tracks (Block -> [(TrackId, TrackDestinations)]
block_integrated_tracks Block
block)
    , forall {t :: * -> *}.
Foldable t =>
Map Text (t NoteDestination) -> [(TrackId, (Source, EventIndex))]
integrated_manual (Block -> ManualDestinations
block_integrated_manual Block
block)
    ]
    where
    integrated_tracks :: [(TrackId, TrackDestinations)] -> [(TrackId, (Source, EventIndex))]
integrated_tracks [(TrackId, TrackDestinations)]
itracks = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Source -> TrackDestinations -> [(TrackId, (Source, EventIndex))]
track_dests (TrackId -> Source
TrackSource TrackId
source_track) TrackDestinations
tdests
        | (TrackId
source_track, TrackDestinations
tdests) <- [(TrackId, TrackDestinations)]
itracks
        ]
    integrated_manual :: Map Text (t NoteDestination) -> [(TrackId, (Source, EventIndex))]
integrated_manual Map Text (t NoteDestination)
manual = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a}. a -> NoteDestination -> [(TrackId, (a, EventIndex))]
note_dest (Text -> Source
ManualSource Text
source_key)) t NoteDestination
ndests
        | (Text
source_key, t NoteDestination
ndests) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Text (t NoteDestination)
manual
        ]
    track_dests :: Source -> TrackDestinations -> [(TrackId, (Source, EventIndex))]
track_dests Source
source (DeriveDestinations [NoteDestination]
ndests) =
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a}. a -> NoteDestination -> [(TrackId, (a, EventIndex))]
note_dest Source
source) [NoteDestination]
ndests
    track_dests Source
_source (ScoreDestinations ScoreDestinations
sdests) =
        [ (TrackId
dest_track, (TrackId -> Source
TrackSource TrackId
source_track, EventIndex
index))
        | (TrackId
source_track, (TrackId
dest_track, EventIndex
index)) <- ScoreDestinations
sdests
        ]
    note_dest :: a -> NoteDestination -> [(TrackId, (a, EventIndex))]
note_dest a
source (NoteDestination Text
_key (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) =
        (forall a b. (a, b) -> a
fst (TrackId, EventIndex)
note, (a
source, forall a b. (a, b) -> b
snd (TrackId, EventIndex)
note))
            forall a. a -> [a] -> [a]
: [(TrackId
tid, (a
source, EventIndex
index)) | (TrackId
tid, EventIndex
index) <- forall k a. Map k a -> [a]
Map.elems Map Text (TrackId, EventIndex)
controls]

data TrackDestinations =
    -- | A derive integrate can produce multiple note tracks, and each one gets
    -- its own NoteDestination.  The TrackIds in here should point to tracks
    -- within the block that contains the TrackDestinations.
    DeriveDestinations ![NoteDestination]
    -- | A score integrate is always just one track along with its descendents.
    -- It's not necessarily a note track.
    | ScoreDestinations !ScoreDestinations
    deriving (TrackDestinations -> TrackDestinations -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrackDestinations -> TrackDestinations -> Bool
$c/= :: TrackDestinations -> TrackDestinations -> Bool
== :: TrackDestinations -> TrackDestinations -> Bool
$c== :: TrackDestinations -> TrackDestinations -> Bool
Eq, Int -> TrackDestinations -> ShowS
[TrackDestinations] -> ShowS
TrackDestinations -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackDestinations] -> ShowS
$cshowList :: [TrackDestinations] -> ShowS
show :: TrackDestinations -> String
$cshow :: TrackDestinations -> String
showsPrec :: Int -> TrackDestinations -> ShowS
$cshowsPrec :: Int -> TrackDestinations -> ShowS
Show)

dest_track_ids :: TrackDestinations -> [TrackId]
dest_track_ids :: TrackDestinations -> [TrackId]
dest_track_ids = \case
    DeriveDestinations [NoteDestination]
dests -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NoteDestination -> [TrackId]
note_dest_track_ids [NoteDestination]
dests
    ScoreDestinations ScoreDestinations
dests -> forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) ScoreDestinations
dests

{- | Score derivation creates destination tracks 1:1 with their source tracks,
    so I can key them with their source TrackIds.

    (source_track_id, (destination_track_id, index))

    For 'block_integrated', the source_track_id should point to a track in the
    source block.  For 'block_integrated_tracks' it should point to a track
    within its own block.  The destination_track_id should always point to
    a track in the same block.
-}
type ScoreDestinations = [(TrackId, (TrackId, EventIndex))]

-- | Destinations for a manually-invoked integration.  A single SourceKey
-- can have destinations on multiple tracks within the block.
type ManualDestinations = Map SourceKey [NoteDestination]

-- | Arbitrary text used to identify the source of this integration.  Unlike
-- automatic integrations, which come from another block or track, a manual
-- integration can bring in events from anywhere, so it needs a unique key
-- to identify the source.
type SourceKey = Text

instance Pretty TrackDestinations where
    format :: TrackDestinations -> Doc
format (DeriveDestinations [NoteDestination]
dests) =
        Doc
"DeriveDestinations" Doc -> Doc -> Doc
Pretty.<+> forall a. Pretty a => a -> Doc
Pretty.format [NoteDestination]
dests
    format (ScoreDestinations ScoreDestinations
dests) =
        Doc
"ScoreDestinations" Doc -> Doc -> Doc
Pretty.<+> forall a. Pretty a => a -> Doc
Pretty.format ScoreDestinations
dests

-- | This holds the 'EventIndex' for one note track, along with its dependent
-- control tracks.
data NoteDestination = NoteDestination {
    -- | The key should uniquely identify this particular destination.  The next
    -- time there is a merge, the source tracks can match by key.  Otherwise,
    -- they just have to blindly zip sources and dests, and can't detect
    -- deletions or moves.
    NoteDestination -> Text
dest_key :: !Text
    -- | (dest_track, index)
    , NoteDestination -> (TrackId, EventIndex)
dest_note :: !(TrackId, EventIndex)
    -- | Map from control name to the track which was created for it.
    , NoteDestination -> Map Text (TrackId, EventIndex)
dest_controls :: !(Map Text (TrackId, EventIndex))
    } deriving (NoteDestination -> NoteDestination -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteDestination -> NoteDestination -> Bool
$c/= :: NoteDestination -> NoteDestination -> Bool
== :: NoteDestination -> NoteDestination -> Bool
$c== :: NoteDestination -> NoteDestination -> Bool
Eq, Int -> NoteDestination -> ShowS
[NoteDestination] -> ShowS
NoteDestination -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteDestination] -> ShowS
$cshowList :: [NoteDestination] -> ShowS
show :: NoteDestination -> String
$cshow :: NoteDestination -> String
showsPrec :: Int -> NoteDestination -> ShowS
$cshowsPrec :: Int -> NoteDestination -> ShowS
Show)

note_dest_track_ids :: NoteDestination -> [TrackId]
note_dest_track_ids :: NoteDestination -> [TrackId]
note_dest_track_ids (NoteDestination Text
_ (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) =
    forall a b. (a, b) -> a
fst (TrackId, EventIndex)
note forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall k a. Map k a -> [a]
Map.elems Map Text (TrackId, EventIndex)
controls)

-- | Create an empty destination for the first integration.
empty_destination :: Text -> TrackId -> [(Text, TrackId)] -> NoteDestination
empty_destination :: Text -> TrackId -> [(Text, TrackId)] -> NoteDestination
empty_destination Text
key TrackId
note [(Text, TrackId)]
controls = NoteDestination
    { dest_key :: Text
dest_key = Text
key
    , dest_note :: (TrackId, EventIndex)
dest_note = (TrackId
note, forall a. Monoid a => a
mempty)
    , dest_controls :: Map Text (TrackId, EventIndex)
dest_controls = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (,forall a. Monoid a => a
mempty)) [(Text, TrackId)]
controls
    }

-- | This is a picture of the integrated events that were used to create an
-- integrated block or track.  By taking its difference against the current
-- contents of the block I can figure out user edits.
type EventIndex = Map Event.IndexKey Event.Event

short_event_index :: EventIndex -> Text
short_event_index :: EventIndex -> Text
short_event_index EventIndex
index
    | forall k a. Map k a -> Bool
Map.null EventIndex
index = Text
"((empty))"
    | Bool
otherwise = forall a. Monoid a => [a] -> a
mconcat
        [ Text
"((index size:", forall a. Show a => a -> Text
showt (forall k a. Map k a -> Int
Map.size EventIndex
index)
        , Text
" ", forall a. Pretty a => a -> Text
pretty (forall a b. (a, b) -> a
fst (forall k a. Map k a -> (k, a)
Map.findMin EventIndex
index))
        , Text
"--", forall a. Pretty a => a -> Text
pretty (forall a b. (a, b) -> a
fst (forall k a. Map k a -> (k, a)
Map.findMax EventIndex
index))
        , Text
"))"
        ]

instance Pretty NoteDestination where
    format :: NoteDestination -> Doc
format (NoteDestination Text
key (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"NoteDestination"
        [ (Text
"key", forall a. Pretty a => a -> Doc
Pretty.format Text
key)
        , (Text
"note", forall a. Pretty a => a -> Doc
Pretty.format (TrackId, EventIndex)
note)
        , (Text
"controls", forall a. Pretty a => a -> Doc
Pretty.format Map Text (TrackId, EventIndex)
controls)
        ]

-- | Arrows that should be drawn to indicate integrate relationships.
integrate_skeleton :: Block -> [(Color.Color, [(TrackNum, TrackNum)])]
integrate_skeleton :: Block -> [(Color, [(Int, Int)])]
integrate_skeleton Block
block = forall a b. (a -> b) -> [a] -> [b]
map (TrackId, TrackDestinations) -> (Color, [(Int, Int)])
integrate_edges (Block -> [(TrackId, TrackDestinations)]
block_integrated_tracks Block
block)
    where
    integrate_edges :: (TrackId, TrackDestinations) -> (Color, [(Int, Int)])
integrate_edges (TrackId
source_id, ScoreDestinations ScoreDestinations
dests) =
        (,) Color
Config.score_integrate_skeleton forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ do
            (TrackId
_, (TrackId
dest_id, EventIndex
_)) <- forall a. [a] -> Maybe a
Lists.head ScoreDestinations
dests
            Int
dest <- TrackId -> Maybe Int
tracknum_of TrackId
dest_id
            Int
source <- TrackId -> Maybe Int
tracknum_of TrackId
source_id
            forall (m :: * -> *) a. Monad m => a -> m a
return (Int
source, Int
dest)
    integrate_edges (TrackId
source_id, DeriveDestinations [NoteDestination]
dests) =
        (Color
Config.integrate_skeleton, TrackId -> [NoteDestination] -> [(Int, Int)]
edges_of TrackId
source_id [NoteDestination]
dests)
    edges_of :: TrackId -> [NoteDestination] -> [(Int, Int)]
edges_of TrackId
source_id [NoteDestination]
dests = do
        Int
source <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ TrackId -> Maybe Int
tracknum_of TrackId
source_id
        Int
dest <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrackId -> Maybe Int
tracknum_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDestination -> (TrackId, EventIndex)
dest_note) [NoteDestination]
dests
        forall (m :: * -> *) a. Monad m => a -> m a
return (Int
source, Int
dest)
    tracknum_of :: TrackId -> Maybe Int
tracknum_of = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map TrackId Int
tracknums
    tracknums :: Map TrackId Int
tracknums = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (TrackId
track_id, Int
tracknum)
        | (Int
tracknum, Just TrackId
track_id) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
            (forall a b. (a -> b) -> [a] -> [b]
map Track -> Maybe TrackId
track_id (Block -> [Track]
block_tracks Block
block))
        ]

block_tracklike_ids :: Block -> [TracklikeId]
block_tracklike_ids :: Block -> [TracklikeId]
block_tracklike_ids = forall a b. (a -> b) -> [a] -> [b]
map Track -> TracklikeId
tracklike_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Track]
block_tracks

block_track_ids :: Block -> [TrackId]
block_track_ids :: Block -> [TrackId]
block_track_ids = [TracklikeId] -> [TrackId]
track_ids_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [TracklikeId]
block_tracklike_ids

block_ruler_ids :: Block -> [RulerId]
block_ruler_ids :: Block -> [RulerId]
block_ruler_ids = [TracklikeId] -> [RulerId]
ruler_ids_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [TracklikeId]
block_tracklike_ids

block :: Config -> Text -> [Track] -> Block
block :: Config -> Text -> [Track] -> Block
block Config
config Text
title [Track]
tracks = Block
    { block_title :: Text
block_title = Text
title
    , block_config :: Config
block_config = Config
config
    , block_tracks :: [Track]
block_tracks = [Track]
tracks
    , block_skeleton :: Skeleton
block_skeleton = Skeleton
Skeleton.empty
    , block_integrated :: Maybe (BlockId, TrackDestinations)
block_integrated = forall a. Maybe a
Nothing
    , block_integrated_tracks :: [(TrackId, TrackDestinations)]
block_integrated_tracks = []
    , block_integrated_manual :: ManualDestinations
block_integrated_manual = forall a. Monoid a => a
mempty
    , block_meta :: Meta
block_meta = forall k a. Map k a
Map.empty
    }

-- | Per-block configuration.
data Config = Config {
    Config -> Box
config_skel_box :: !Box
    , Config -> Box
config_track_box :: !Box
    , Config -> Box
config_sb_box :: !Box
    , Config -> Skeleton
config_skeleton :: !Skeleton
    } deriving (Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show, forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generics.Generic)

default_config :: Config
default_config :: Config
default_config = Config
    { config_skel_box :: Box
config_skel_box = (Color, Char) -> Box
box (Color, Char)
Config.bconfig_box
    , config_track_box :: Box
config_track_box = (Color, Char) -> Box
box (Color, Char)
Config.bconfig_box
    , config_sb_box :: Box
config_sb_box = (Color, Char) -> Box
box (Color, Char)
Config.bconfig_box
    , config_skeleton :: Skeleton
config_skeleton = Skeleton
Implicit
    } where box :: (Color, Char) -> Box
box = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Color -> Char -> Box
Box

instance Pretty Config where format :: Config -> Doc
format = forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_

-- | One of those colored boxes wedged into the corners of the block window.
data Box = Box { Box -> Color
box_color :: !Color.Color, Box -> Char
box_char :: !Char }
    deriving (Box -> Box -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Box -> Box -> Bool
$c/= :: Box -> Box -> Bool
== :: Box -> Box -> Bool
$c== :: Box -> Box -> Bool
Eq, Int -> Box -> ShowS
[Box] -> ShowS
Box -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Box] -> ShowS
$cshowList :: [Box] -> ShowS
show :: Box -> String
$cshow :: Box -> String
showsPrec :: Int -> Box -> ShowS
$cshowsPrec :: Int -> Box -> ShowS
Show)

instance Pretty Box where
    pretty :: Box -> Text
pretty (Box Color
color Char
c) =
        forall a. Pretty a => a -> Text
pretty Color
color forall a. Semigroup a => a -> a -> a
<> if Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' then Text
"" else Text
" '" forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text
"'"

-- | Like 'Track.Track', this has per-track data, but unlike Track.Track,
-- this is data that can vary per-block.
--
-- This is the higher level track that is visible at the haskell level, as
-- opposed to 'DisplayTrack', which is what is visible in the UI.
data Track = Track {
    Track -> TracklikeId
tracklike_id :: !TracklikeId
    -- | Formerly the width was in the view since each view could have
    -- a different width and this was just the default width, but that turned
    -- out to be too much of a hassle, so now all occurences of a track have
    -- the same width.
    , Track -> Int
track_width :: !Types.Width
    -- | This is a width suggested by fltk that should be enough to show all
    -- the text.  Unlike the other fields in Track, it's derived from the track
    -- contents and is automatically updated by the UI.
    , Track -> Int
track_suggested_width :: !Types.Width
    -- | Track display state flags.
    , Track -> Set TrackFlag
track_flags :: !(Set TrackFlag)
    -- | Other tracks are displayed behind this one.  Useful to merge a pitch
    -- track into its note track.
    , Track -> Set TrackId
track_merged :: !(Set TrackId)
    } deriving (Track -> Track -> Bool
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
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)

track_id :: Track -> Maybe TrackId
track_id :: Track -> Maybe TrackId
track_id = TracklikeId -> Maybe TrackId
track_id_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> TracklikeId
tracklike_id

instance Pretty Track where
    pretty :: Track -> Text
pretty (Track TracklikeId
tid Int
width Int
suggested Set TrackFlag
flags Set TrackId
merged) = forall a. Pretty a => a -> Text
pretty TracklikeId
tid forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords
            [forall a. Pretty a => a -> Text
pretty Int
width, forall a. Pretty a => a -> Text
pretty Int
suggested, forall a. Pretty a => a -> Text
pretty Set TrackFlag
flags, forall a. Pretty a => a -> Text
pretty Set TrackId
merged]

-- | Construct a 'Track' with defaults.
track :: TracklikeId -> Types.Width -> Track
track :: TracklikeId -> Int -> Track
track TracklikeId
tracklike_id Int
width = Track
    { tracklike_id :: TracklikeId
tracklike_id = TracklikeId
tracklike_id
    , track_width :: Int
track_width = Int
width
    , track_suggested_width :: Int
track_suggested_width = Int
width
    , track_flags :: Set TrackFlag
track_flags = forall a. Monoid a => a
mempty
    , track_merged :: Set TrackId
track_merged = forall a. Monoid a => a
mempty
    }

modify_id :: (TracklikeId -> TracklikeId) -> Track -> Track
modify_id :: (TracklikeId -> TracklikeId) -> Track -> Track
modify_id TracklikeId -> TracklikeId
f Track
track = Track
track { tracklike_id :: TracklikeId
tracklike_id = TracklikeId -> TracklikeId
f (Track -> TracklikeId
tracklike_id Track
track) }

colored_divider :: Color.Color -> Track
colored_divider :: Color -> Track
colored_divider Color
color = TracklikeId -> Int -> Track
track (Divider -> TracklikeId
DId (Color -> Divider
Divider Color
color)) Int
3

-- | A generic divider to insert manually as a visual aid.  Imitates the
-- background color.
divider :: Track
divider :: Track
divider = Color -> Track
colored_divider (Double -> Double -> Double -> Color
Color.rgb Double
0.8 Double
0.8 Double
0.8)

is_collapsed :: Set TrackFlag -> Bool
is_collapsed :: Set TrackFlag -> Bool
is_collapsed Set TrackFlag
flags = forall a. Ord a => a -> Set a -> Bool
Set.member TrackFlag
Collapse Set TrackFlag
flags Bool -> Bool -> Bool
|| forall a. Ord a => a -> Set a -> Bool
Set.member TrackFlag
Merge Set TrackFlag
flags

track_selectable :: Track -> Bool
track_selectable :: Track -> Bool
track_selectable track :: Track
track@(Track { tracklike_id :: Track -> TracklikeId
tracklike_id = TId TrackId
_ RulerId
_}) =
    Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Set TrackFlag -> Bool
is_collapsed (Track -> Set TrackFlag
track_flags Track
track)
track_selectable Track
_ = Bool
False

-- | Don't send a track signal to a track unless it actually wants to draw it.
track_wants_signal :: Set TrackFlag -> Track.Track -> Bool
track_wants_signal :: Set TrackFlag -> Track -> Bool
track_wants_signal Set TrackFlag
flags Track
track =
    RenderConfig -> RenderStyle
Track.render_style (Track -> RenderConfig
Track.track_render Track
track) forall a. Eq a => a -> a -> Bool
/= RenderStyle
Track.NoRender
    Bool -> Bool -> Bool
&& TrackFlag
Collapse forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackFlag
flags
    Bool -> Bool -> Bool
&& TrackFlag
Merge forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackFlag
flags

-- | This is the low-level representation of a track, which directly
-- corresponds with what is displayed by the UI.  The DisplayTracks should be
-- derivable from a 'Block' deterministically.
data DisplayTrack = DisplayTrack {
    DisplayTrack -> TracklikeId
dtracklike_id :: !TracklikeId
    , DisplayTrack -> Int
dtrack_width :: !Types.Width
    , DisplayTrack -> Set TrackId
dtrack_merged :: !(Set TrackId)
    , DisplayTrack -> Status
dtrack_status :: !Status
    , DisplayTrack -> Double
dtrack_event_brightness :: !Double
    } deriving (DisplayTrack -> DisplayTrack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DisplayTrack -> DisplayTrack -> Bool
$c/= :: DisplayTrack -> DisplayTrack -> Bool
== :: DisplayTrack -> DisplayTrack -> Bool
$c== :: DisplayTrack -> DisplayTrack -> Bool
Eq, Int -> DisplayTrack -> ShowS
[DisplayTrack] -> ShowS
DisplayTrack -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DisplayTrack] -> ShowS
$cshowList :: [DisplayTrack] -> ShowS
show :: DisplayTrack -> String
$cshow :: DisplayTrack -> String
showsPrec :: Int -> DisplayTrack -> ShowS
$cshowsPrec :: Int -> DisplayTrack -> ShowS
Show)

instance Pretty DisplayTrack where
    format :: DisplayTrack -> Doc
format (DisplayTrack TracklikeId
tlike_id Int
width Set TrackId
merged Status
status Double
_bright) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"DisplayTrack"
            [ (Text
"tracklike_id", forall a. Pretty a => a -> Doc
Pretty.format TracklikeId
tlike_id)
            , (Text
"width", forall a. Pretty a => a -> Doc
Pretty.format Int
width)
            , (Text
"merged", forall a. Pretty a => a -> Doc
Pretty.format Set TrackId
merged)
            , (Text
"status", forall a. Pretty a => a -> Doc
Pretty.format Status
status)
            ]

-- | This has a 2 character string to display above the track, and a background
-- color.  TODO change to Char Char
data Status = Status !String !Color.Color
    deriving (Status -> Status -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show)

instance Pretty Status where pretty :: Status -> Text
pretty (Status String
cs Color
color) = forall a. Pretty a => a -> Text
pretty (String
cs, Color
color)

empty_status :: Status
empty_status :: Status
empty_status = String -> Color -> Status
Status String
"" Color
Color.black

-- | Most of these only make sense for event tracks.
data TrackFlag =
    -- | Track is collapsed to take up less space.
    Collapse
    | Merge
    -- | UI shows solo indication.  If any tracks are soloed on a block, only
    -- those tracks are played.
    | Solo
    -- | UI shows muted indication, player should filter out events from this
    -- track.
    | Mute
    -- | This is like Mute, except that the track is entirely omitted from
    -- derivation.  Since Mute and Solo work after derivation, they don't
    -- require a rederive but also can't mute a single control track.
    | Disable
    deriving (TrackFlag -> TrackFlag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrackFlag -> TrackFlag -> Bool
$c/= :: TrackFlag -> TrackFlag -> Bool
== :: TrackFlag -> TrackFlag -> Bool
$c== :: TrackFlag -> TrackFlag -> Bool
Eq, Eq TrackFlag
TrackFlag -> TrackFlag -> Bool
TrackFlag -> TrackFlag -> Ordering
TrackFlag -> TrackFlag -> TrackFlag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TrackFlag -> TrackFlag -> TrackFlag
$cmin :: TrackFlag -> TrackFlag -> TrackFlag
max :: TrackFlag -> TrackFlag -> TrackFlag
$cmax :: TrackFlag -> TrackFlag -> TrackFlag
>= :: TrackFlag -> TrackFlag -> Bool
$c>= :: TrackFlag -> TrackFlag -> Bool
> :: TrackFlag -> TrackFlag -> Bool
$c> :: TrackFlag -> TrackFlag -> Bool
<= :: TrackFlag -> TrackFlag -> Bool
$c<= :: TrackFlag -> TrackFlag -> Bool
< :: TrackFlag -> TrackFlag -> Bool
$c< :: TrackFlag -> TrackFlag -> Bool
compare :: TrackFlag -> TrackFlag -> Ordering
$ccompare :: TrackFlag -> TrackFlag -> Ordering
Ord, Int -> TrackFlag
TrackFlag -> Int
TrackFlag -> [TrackFlag]
TrackFlag -> TrackFlag
TrackFlag -> TrackFlag -> [TrackFlag]
TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag]
$cenumFromThenTo :: TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag]
enumFromTo :: TrackFlag -> TrackFlag -> [TrackFlag]
$cenumFromTo :: TrackFlag -> TrackFlag -> [TrackFlag]
enumFromThen :: TrackFlag -> TrackFlag -> [TrackFlag]
$cenumFromThen :: TrackFlag -> TrackFlag -> [TrackFlag]
enumFrom :: TrackFlag -> [TrackFlag]
$cenumFrom :: TrackFlag -> [TrackFlag]
fromEnum :: TrackFlag -> Int
$cfromEnum :: TrackFlag -> Int
toEnum :: Int -> TrackFlag
$ctoEnum :: Int -> TrackFlag
pred :: TrackFlag -> TrackFlag
$cpred :: TrackFlag -> TrackFlag
succ :: TrackFlag -> TrackFlag
$csucc :: TrackFlag -> TrackFlag
Enum, TrackFlag
forall a. a -> a -> Bounded a
maxBound :: TrackFlag
$cmaxBound :: TrackFlag
minBound :: TrackFlag
$cminBound :: TrackFlag
Bounded, Int -> TrackFlag -> ShowS
[TrackFlag] -> ShowS
TrackFlag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackFlag] -> ShowS
$cshowList :: [TrackFlag] -> ShowS
show :: TrackFlag -> String
$cshow :: TrackFlag -> String
showsPrec :: Int -> TrackFlag -> ShowS
$cshowsPrec :: Int -> TrackFlag -> ShowS
Show)

instance Pretty TrackFlag where pretty :: TrackFlag -> Text
pretty = forall a. Show a => a -> Text
showt

-- | Convert logical block level tracks to display tracks.
block_display_tracks :: Block -> [DisplayTrack]
block_display_tracks :: Block -> [DisplayTrack]
block_display_tracks = [DisplayTrack] -> [DisplayTrack]
join_collapsed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Track -> DisplayTrack
display_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Track]
block_tracks

-- | Merge consecutive collapsed tracks.
join_collapsed :: [DisplayTrack] -> [DisplayTrack]
join_collapsed :: [DisplayTrack] -> [DisplayTrack]
join_collapsed = forall a. a -> a
id
-- TODO I tried this and it looks nice but I'd need to also eliminate the
-- tracks from a Block.display_skeleton and Block.display_integrate_skeleton
-- and I'm not sure it's worth it.
-- join_collapsed = mapMaybe Lists.head
--     . List.groupBy (\a b -> a == collapsed_track && b == collapsed_track)

-- | This is not exported so callers are forced to go through
-- 'block_display_tracks'.
display_track :: Track -> DisplayTrack
display_track :: Track -> DisplayTrack
display_track Track
track
    | TrackFlag -> Bool
has_flag TrackFlag
Merge = DisplayTrack
merged_track
    | TrackFlag -> Bool
has_flag TrackFlag
Collapse = DisplayTrack
collapsed_track
    | Bool
otherwise = DisplayTrack
        { dtracklike_id :: TracklikeId
dtracklike_id = Track -> TracklikeId
tracklike_id Track
track
        , dtrack_width :: Int
dtrack_width = Track -> Int
track_width Track
track
        , dtrack_merged :: Set TrackId
dtrack_merged = Track -> Set TrackId
track_merged Track
track
        , dtrack_status :: Status
dtrack_status = Status
status
        , dtrack_event_brightness :: Double
dtrack_event_brightness = Double
brightness
        }
    where
    (Status
status, Double
brightness) = Set TrackFlag -> (Status, Double)
flags_to_status (Track -> Set TrackFlag
track_flags Track
track)
    has_flag :: TrackFlag -> Bool
has_flag TrackFlag
flag = forall a. Ord a => a -> Set a -> Bool
Set.member TrackFlag
flag (Track -> Set TrackFlag
track_flags Track
track)

-- | Collapsed tracks are replaced with a divider.
collapsed_track :: DisplayTrack
collapsed_track :: DisplayTrack
collapsed_track = DisplayTrack
    { dtracklike_id :: TracklikeId
dtracklike_id = Divider -> TracklikeId
DId forall a b. (a -> b) -> a -> b
$ Color -> Divider
Divider forall a b. (a -> b) -> a -> b
$
        Double -> Color -> Color
Color.brightness Double
0.5 Color
Config.abbreviation_color
    , dtrack_width :: Int
dtrack_width = Int
Config.collapsed_width -- TODO maybe a bit wider?
    , dtrack_merged :: Set TrackId
dtrack_merged = forall a. Monoid a => a
mempty
    , dtrack_status :: Status
dtrack_status = Status
empty_status
    , dtrack_event_brightness :: Double
dtrack_event_brightness = Double
1
    }

merged_track :: DisplayTrack
merged_track :: DisplayTrack
merged_track = DisplayTrack
    { dtracklike_id :: TracklikeId
dtracklike_id = Divider -> TracklikeId
DId (Color -> Divider
Divider Color
Config.abbreviation_color)
    , dtrack_width :: Int
dtrack_width = Int
Config.collapsed_width
    , dtrack_merged :: Set TrackId
dtrack_merged = forall a. Monoid a => a
mempty
    , dtrack_status :: Status
dtrack_status = Status
empty_status
    , dtrack_event_brightness :: Double
dtrack_event_brightness = Double
1
    }

display_track_width :: Track -> Types.Width
display_track_width :: Track -> Int
display_track_width = DisplayTrack -> Int
dtrack_width forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> DisplayTrack
display_track

flags_to_status :: Set TrackFlag -> (Status, Double)
flags_to_status :: Set TrackFlag -> (Status, Double)
flags_to_status Set TrackFlag
flags
    | TrackFlag
Disable forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags =
        (String -> Color -> Status
Status (TrackFlag -> String
chars TrackFlag
Disable) Color
Config.mute_color, Double
0.7)
    | TrackFlag
Solo forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags = (String -> Color -> Status
Status (TrackFlag -> String
chars TrackFlag
Solo) Color
Config.solo_color, Double
1)
    | TrackFlag
Mute forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags = (String -> Color -> Status
Status (TrackFlag -> String
chars TrackFlag
Mute) Color
Config.mute_color, Double
0.85)
    | Bool
otherwise = (Status
empty_status, Double
1)
    where
    chars :: TrackFlag -> String
chars TrackFlag
flag = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
' ') forall a b. (a -> b) -> a -> b
$ TrackFlag -> Char
flag_char TrackFlag
flag
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
Char.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackFlag -> Char
flag_char) (forall a. Set a -> [a]
Set.toList (forall a. Ord a => a -> Set a -> Set a
Set.delete TrackFlag
flag Set TrackFlag
flags))

flag_char :: TrackFlag -> Char
flag_char :: TrackFlag -> Char
flag_char TrackFlag
status = case TrackFlag
status of
    TrackFlag
Disable -> Char
'D'
    TrackFlag
Solo -> Char
'S'
    TrackFlag
Mute -> Char
'M'
    TrackFlag
Collapse -> Char
' '
    TrackFlag
Merge -> Char
' '

data TracklikeId =
    -- | Tracks may have a Ruler overlay
    TId TrackId RulerId
    | RId RulerId
    | DId Divider
    deriving (TracklikeId -> TracklikeId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TracklikeId -> TracklikeId -> Bool
$c/= :: TracklikeId -> TracklikeId -> Bool
== :: TracklikeId -> TracklikeId -> Bool
$c== :: TracklikeId -> TracklikeId -> Bool
Eq, Eq TracklikeId
TracklikeId -> TracklikeId -> Bool
TracklikeId -> TracklikeId -> Ordering
TracklikeId -> TracklikeId -> TracklikeId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TracklikeId -> TracklikeId -> TracklikeId
$cmin :: TracklikeId -> TracklikeId -> TracklikeId
max :: TracklikeId -> TracklikeId -> TracklikeId
$cmax :: TracklikeId -> TracklikeId -> TracklikeId
>= :: TracklikeId -> TracklikeId -> Bool
$c>= :: TracklikeId -> TracklikeId -> Bool
> :: TracklikeId -> TracklikeId -> Bool
$c> :: TracklikeId -> TracklikeId -> Bool
<= :: TracklikeId -> TracklikeId -> Bool
$c<= :: TracklikeId -> TracklikeId -> Bool
< :: TracklikeId -> TracklikeId -> Bool
$c< :: TracklikeId -> TracklikeId -> Bool
compare :: TracklikeId -> TracklikeId -> Ordering
$ccompare :: TracklikeId -> TracklikeId -> Ordering
Ord, Int -> TracklikeId -> ShowS
[TracklikeId] -> ShowS
TracklikeId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TracklikeId] -> ShowS
$cshowList :: [TracklikeId] -> ShowS
show :: TracklikeId -> String
$cshow :: TracklikeId -> String
showsPrec :: Int -> TracklikeId -> ShowS
$cshowsPrec :: Int -> TracklikeId -> ShowS
Show)

instance Pretty TracklikeId where
    pretty :: TracklikeId -> Text
pretty TracklikeId
tlike_id = case TracklikeId
tlike_id of
        TId TrackId
tid RulerId
rid -> forall a. Pretty a => a -> Text
pretty TrackId
tid forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RulerId
rid
        RId RulerId
rid -> forall a. Pretty a => a -> Text
pretty RulerId
rid
        DId Divider
divider -> forall a. Show a => a -> Text
showt Divider
divider

track_id_of :: TracklikeId -> Maybe TrackId
track_id_of :: TracklikeId -> Maybe TrackId
track_id_of (TId TrackId
tid RulerId
_) = forall a. a -> Maybe a
Just TrackId
tid
track_id_of TracklikeId
_ = forall a. Maybe a
Nothing

track_ids_of :: [TracklikeId] -> [TrackId]
track_ids_of :: [TracklikeId] -> [TrackId]
track_ids_of = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TracklikeId -> Maybe TrackId
track_id_of

ruler_id_of :: TracklikeId -> Maybe RulerId
ruler_id_of :: TracklikeId -> Maybe RulerId
ruler_id_of (TId TrackId
_ RulerId
rid) = forall a. a -> Maybe a
Just RulerId
rid
ruler_id_of (RId RulerId
rid) = forall a. a -> Maybe a
Just RulerId
rid
ruler_id_of TracklikeId
_ = forall a. Maybe a
Nothing

ruler_ids_of :: [TracklikeId] -> [RulerId]
ruler_ids_of :: [TracklikeId] -> [RulerId]
ruler_ids_of = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TracklikeId -> Maybe RulerId
ruler_id_of

set_ruler_id :: RulerId -> TracklikeId -> TracklikeId
set_ruler_id :: RulerId -> TracklikeId -> TracklikeId
set_ruler_id RulerId
rid (TId TrackId
tid RulerId
_) = TrackId -> RulerId -> TracklikeId
TId TrackId
tid RulerId
rid
set_ruler_id RulerId
rid (RId RulerId
_) = RulerId -> TracklikeId
RId RulerId
rid
set_ruler_id RulerId
_ TracklikeId
t = TracklikeId
t

data Tracklike =
    T Track.Track Ruler.Ruler
    | R Ruler.Ruler
    | D Divider
    deriving (Int -> Tracklike -> ShowS
[Tracklike] -> ShowS
Tracklike -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tracklike] -> ShowS
$cshowList :: [Tracklike] -> ShowS
show :: Tracklike -> String
$cshow :: Tracklike -> String
showsPrec :: Int -> Tracklike -> ShowS
$cshowsPrec :: Int -> Tracklike -> ShowS
Show)

track_of :: Tracklike -> Maybe Track.Track
track_of :: Tracklike -> Maybe Track
track_of (T Track
track Ruler
_) = forall a. a -> Maybe a
Just Track
track
track_of Tracklike
_ = forall a. Maybe a
Nothing

tracks_of :: [Tracklike] -> [Track.Track]
tracks_of :: [Tracklike] -> [Track]
tracks_of = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tracklike -> Maybe Track
track_of

ruler_of :: Tracklike -> Maybe Ruler.Ruler
ruler_of :: Tracklike -> Maybe Ruler
ruler_of (T Track
_ Ruler
ruler) = forall a. a -> Maybe a
Just Ruler
ruler
ruler_of (R Ruler
ruler) = forall a. a -> Maybe a
Just Ruler
ruler
ruler_of Tracklike
_ = forall a. Maybe a
Nothing

rulers_of :: [Tracklike] -> [Ruler.Ruler]
rulers_of :: [Tracklike] -> [Ruler]
rulers_of = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tracklike -> Maybe Ruler
ruler_of

-- | A divider separating tracks.  Defined here in Block since it's so trivial.
newtype Divider = Divider Color.Color deriving (Divider -> Divider -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Divider -> Divider -> Bool
$c/= :: Divider -> Divider -> Bool
== :: Divider -> Divider -> Bool
$c== :: Divider -> Divider -> Bool
Eq, Eq Divider
Divider -> Divider -> Bool
Divider -> Divider -> Ordering
Divider -> Divider -> Divider
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Divider -> Divider -> Divider
$cmin :: Divider -> Divider -> Divider
max :: Divider -> Divider -> Divider
$cmax :: Divider -> Divider -> Divider
>= :: Divider -> Divider -> Bool
$c>= :: Divider -> Divider -> Bool
> :: Divider -> Divider -> Bool
$c> :: Divider -> Divider -> Bool
<= :: Divider -> Divider -> Bool
$c<= :: Divider -> Divider -> Bool
< :: Divider -> Divider -> Bool
$c< :: Divider -> Divider -> Bool
compare :: Divider -> Divider -> Ordering
$ccompare :: Divider -> Divider -> Ordering
Ord, Int -> Divider -> ShowS
[Divider] -> ShowS
Divider -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Divider] -> ShowS
$cshowList :: [Divider] -> ShowS
show :: Divider -> String
$cshow :: Divider -> String
showsPrec :: Int -> Divider -> ShowS
$cshowsPrec :: Int -> Divider -> ShowS
Show)

-- * block view

-- | A view is a single window on screen.  Views are destroyed when the window
-- is closed.
data View = View {
    -- | view_block should never change.
    View -> BlockId
view_block :: !BlockId
    , View -> Rect
view_rect :: !Rect.Rect
    , View -> Padding
view_padding :: !Padding
    -- | Contents of the status line.  Map (sort_order, name) contents.  This
    -- is formatted with 'show_status' and goes in the bar at the bottom of the
    -- window.
    , View -> Map (Int, Text) Text
view_status :: !(Map (Int, Text) Text)
    , View -> Int
view_track_scroll :: !Types.Width
    , View -> Zoom
view_zoom :: !Zoom.Zoom
    , View -> Map Int Selection
view_selections :: !(Map Sel.Num Sel.Selection)
    } deriving (View -> View -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: View -> View -> Bool
$c/= :: View -> View -> Bool
== :: View -> View -> Bool
$c== :: View -> View -> Bool
Eq, Eq View
View -> View -> Bool
View -> View -> Ordering
View -> View -> View
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: View -> View -> View
$cmin :: View -> View -> View
max :: View -> View -> View
$cmax :: View -> View -> View
>= :: View -> View -> Bool
$c>= :: View -> View -> Bool
> :: View -> View -> Bool
$c> :: View -> View -> Bool
<= :: View -> View -> Bool
$c<= :: View -> View -> Bool
< :: View -> View -> Bool
$c< :: View -> View -> Bool
compare :: View -> View -> Ordering
$ccompare :: View -> View -> Ordering
Ord, Int -> View -> ShowS
[View] -> ShowS
View -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [View] -> ShowS
$cshowList :: [View] -> ShowS
show :: View -> String
$cshow :: View -> String
showsPrec :: Int -> View -> ShowS
$cshowsPrec :: Int -> View -> ShowS
Show)

instance Pretty View where
    format :: View -> Doc
format (View BlockId
block Rect
rect Padding
padding Map (Int, Text) Text
status Int
tscroll Zoom
zoom Map Int Selection
sels) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"View"
            [ (Text
"block", forall a. Pretty a => a -> Doc
Pretty.format BlockId
block)
            , (Text
"rect", forall a. Pretty a => a -> Doc
Pretty.format Rect
rect)
            , (Text
"padding", forall a. Pretty a => a -> Doc
Pretty.format Padding
padding)
            , (Text
"status", forall a. Pretty a => a -> Doc
Pretty.format Map (Int, Text) Text
status)
            , (Text
"scroll/zoom", forall a. Pretty a => a -> Doc
Pretty.format (Int
tscroll, Zoom
zoom))
            , (Text
"selections", forall a. Pretty a => a -> Doc
Pretty.format Map Int Selection
sels)
            ]

instance DeepSeq.NFData View where
    rnf :: View -> ()
rnf (View BlockId
bid Rect
rect Padding
padding Map (Int, Text) Text
status Int
scroll Zoom
zoom Map Int Selection
selections) =
        BlockId
bid seq :: forall a b. a -> b -> b
`seq` Rect
rect seq :: forall a b. a -> b -> b
`seq` Padding
padding seq :: forall a b. a -> b -> b
`seq` Map (Int, Text) Text
status seq :: forall a b. a -> b -> b
`seq` Int
scroll
        seq :: forall a b. a -> b -> b
`seq` Zoom
zoom seq :: forall a b. a -> b -> b
`seq` Map Int Selection
selections seq :: forall a b. a -> b -> b
`seq` ()

-- | Construct a View, using default values for most of its fields.
-- Don't construct views using View directly since 'State.create_view'
-- overwrites view_tracks, and maybe more in the future.
view :: Block -> BlockId -> Rect.Rect -> Zoom.Zoom -> View
view :: Block -> BlockId -> Rect -> Zoom -> View
view Block
block BlockId
block_id Rect
rect Zoom
zoom = View
    { view_block :: BlockId
view_block = BlockId
block_id
    , view_rect :: Rect
view_rect = Rect
rect
    -- These will be filled in when the new view emits its initial resize msg,
    -- but it should start off with the defaults.
    , view_padding :: Padding
view_padding = Block -> Padding
default_padding Block
block
    , view_status :: Map (Int, Text) Text
view_status = forall k a. Map k a
Map.empty
    , view_track_scroll :: Int
view_track_scroll = Int
0
    , view_zoom :: Zoom
view_zoom = Zoom
zoom
    , view_selections :: Map Int Selection
view_selections = forall k a. Map k a
Map.empty
    }

-- | Pixel width and height of stuff in the view that is not the track area,
-- i.e. scrollbars, skeleton display, block title, etc.
--
-- Only fltk knows the width of all the various widgets, but it's cached
-- here so pure code doesn't have to call to the UI and import BlockC.
-- Only 'UiMsg.UpdateViewResize' should set this, which in turn comes from
-- MsgCollector::msg_resize, which in turn comes from Block::get_padding.
data Padding = Padding {
    Padding -> Int
left :: !Int
    , Padding -> Int
top :: !Int
    , Padding -> Int
bottom :: !Int
    -- Right padding is not necessary, because I can add up track widths.
    } deriving (Padding -> Padding -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Padding -> Padding -> Bool
$c/= :: Padding -> Padding -> Bool
== :: Padding -> Padding -> Bool
$c== :: Padding -> Padding -> Bool
Eq, Eq Padding
Padding -> Padding -> Bool
Padding -> Padding -> Ordering
Padding -> Padding -> Padding
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Padding -> Padding -> Padding
$cmin :: Padding -> Padding -> Padding
max :: Padding -> Padding -> Padding
$cmax :: Padding -> Padding -> Padding
>= :: Padding -> Padding -> Bool
$c>= :: Padding -> Padding -> Bool
> :: Padding -> Padding -> Bool
$c> :: Padding -> Padding -> Bool
<= :: Padding -> Padding -> Bool
$c<= :: Padding -> Padding -> Bool
< :: Padding -> Padding -> Bool
$c< :: Padding -> Padding -> Bool
compare :: Padding -> Padding -> Ordering
$ccompare :: Padding -> Padding -> Ordering
Ord, Int -> Padding -> ShowS
[Padding] -> ShowS
Padding -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Padding] -> ShowS
$cshowList :: [Padding] -> ShowS
show :: Padding -> String
$cshow :: Padding -> String
showsPrec :: Int -> Padding -> ShowS
$cshowsPrec :: Int -> Padding -> ShowS
Show)

instance Pretty Padding where
    pretty :: Padding -> Text
pretty (Padding Int
left Int
top Int
bottom) = forall a. Pretty a => a -> Text
pretty (Int
left, Int
top, Int
bottom)

default_padding :: Block -> Padding
default_padding :: Block -> Padding
default_padding Block
block = Padding
    { left :: Int
left = Int
Config.view_left_padding
    , top :: Int
top = Int
Config.view_top_padding
        forall a. Num a => a -> a -> a
+ if Text -> Bool
Text.null (Block -> Text
block_title Block
block) then Int
0 else Int
Config.block_title_height
    , bottom :: Int
bottom = Int
Config.view_bottom_padding
    }

-- | Figure out what color the background of the status line should be.
status_color :: BlockId -> Block -> Maybe BlockId -> Color.Color
status_color :: BlockId -> Block -> Maybe BlockId -> Color
status_color BlockId
block_id Block
block Maybe BlockId
maybe_root_id
    | forall a. a -> Maybe a
Just BlockId
block_id forall a. Eq a => a -> a -> Bool
== Maybe BlockId
maybe_root_id = Color
Config.status_root
    | Just (BlockId
_, TrackDestinations
dests) <- Block -> Maybe (BlockId, TrackDestinations)
block_integrated Block
block = case TrackDestinations
dests of
        DeriveDestinations {} -> Color
Config.status_integrate_destination
        ScoreDestinations {} -> Color
Config.status_score_integrate_destination
    | Bool
otherwise = Color
Config.status_default

show_status :: Map (Int, Text) Text -> Text
show_status :: Map (Int, Text) Text -> Text
show_status = Text -> [Text] -> Text
Text.intercalate Text
" | " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
    -- I used to display the keys, but they take up too much space, so now
    -- I just use them for sorting.

-- | Return how much track is in view.
visible_time :: View -> TrackTime
visible_time :: View -> TrackTime
visible_time View
view = Zoom -> Int -> TrackTime
Zoom.to_time (View -> Zoom
view_zoom View
view) (View -> Int
view_visible_time View
view)

visible_track :: View -> Types.Width
visible_track :: View -> Int
visible_track = View -> Int
view_visible_track

-- | Get the rect of the track area within the view.  This is used with
-- 'set_track_rect' to set the size of the visible track area, minus the
-- extra GUI bits around it.
track_rect :: View -> Rect.Rect
track_rect :: View -> Rect
track_rect (View { view_rect :: View -> Rect
view_rect = Rect
rect, view_padding :: View -> Padding
view_padding = Padding
padding }) = Rect.Rect
    { x :: Int
x = Rect -> Int
Rect.x Rect
rect forall a. Num a => a -> a -> a
+ Padding -> Int
left Padding
padding
    , y :: Int
y = Rect -> Int
Rect.y Rect
rect forall a. Num a => a -> a -> a
+ Padding -> Int
top Padding
padding
    , w :: Int
w = Rect -> Int
Rect.w Rect
rect forall a. Num a => a -> a -> a
- Padding -> Int
left Padding
padding
    , h :: Int
h = Rect -> Int
Rect.h Rect
rect forall a. Num a => a -> a -> a
- Padding -> Int
top Padding
padding forall a. Num a => a -> a -> a
- Padding -> Int
bottom Padding
padding
    }

-- | The inverse of 'track_rect'  Use this to set the track area area to
-- a certain size.
set_track_rect :: View -> Rect.Rect -> Rect.Rect
set_track_rect :: View -> Rect -> Rect
set_track_rect (View { view_padding :: View -> Padding
view_padding = Padding
padding }) Rect
rect = Rect.Rect
    { x :: Int
x = Rect -> Int
Rect.x Rect
rect forall a. Num a => a -> a -> a
- Padding -> Int
left Padding
padding
    , y :: Int
y = Rect -> Int
Rect.y Rect
rect forall a. Num a => a -> a -> a
- Padding -> Int
top Padding
padding
    , w :: Int
w = Rect -> Int
Rect.w Rect
rect forall a. Num a => a -> a -> a
+ Padding -> Int
left Padding
padding
    , h :: Int
h = Rect -> Int
Rect.h Rect
rect forall a. Num a => a -> a -> a
+ Padding -> Int
top Padding
padding forall a. Num a => a -> a -> a
+ Padding -> Int
bottom Padding
padding
    }

view_visible_track, view_visible_time :: View -> Int
view_visible_track :: View -> Int
view_visible_track View
view = Rect -> Int
Rect.w (View -> Rect
view_rect View
view) forall a. Num a => a -> a -> a
- Padding -> Int
left (View -> Padding
view_padding View
view)
view_visible_time :: View -> Int
view_visible_time View
view = Rect -> Int
Rect.h (View -> Rect
view_rect View
view) forall a. Num a => a -> a -> a
- Padding -> Int
top Padding
padding forall a. Num a => a -> a -> a
- Padding -> Int
bottom Padding
padding
    where padding :: Padding
padding = View -> Padding
view_padding View
view

-- | Y coordinate of the given TrackTime.
screen_pixels :: View -> TrackTime -> Int
screen_pixels :: View -> TrackTime -> Int
screen_pixels View
view TrackTime
t =
    Zoom -> TrackTime -> Int
Zoom.to_pixels (View -> Zoom
view_zoom View
view) (TrackTime
t forall a. Num a => a -> a -> a
- Zoom -> TrackTime
Zoom.offset (View -> Zoom
view_zoom View
view))
    forall a. Num a => a -> a -> a
+ Padding -> Int
top (View -> Padding
view_padding View
view) forall a. Num a => a -> a -> a
+ Rect -> Int
Rect.y (View -> Rect
view_rect View
view)