-- Copyright 2021 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.Meter.Mark (
    Marklist, MarklistVector
    , marklist, marklist_from_vector
    , empty
    , to_list
    , ascending, descending
    , end, start
    , insert_mark
    , Mark(..)
    , Label

    -- * for RulerC's eyes only
    , MarklistPtr(..)
    , marklist_vec, marklist_fptr
) where
import qualified Control.Concurrent.MVar as MVar
import qualified Control.DeepSeq as DeepSeq
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Foreign
import qualified System.IO.Unsafe as Unsafe

import qualified Util.TimeVector as TimeVector
import qualified Perform.RealTime as RealTime
import qualified Ui.Color as Color
import qualified Ui.Meter.Meter as Meter

import           Global
import           Types


data Marklist = Marklist
    { Marklist -> MarklistVector
marklist_vec :: !MarklistVector
    -- | This is a cache for the C-marshalled version of the marklist.
    -- It will be allocated if the Marklist is passed to C, and is managed with
    -- its own reference count.
    --
    -- I think this should be safe as long as 'marklist' is the only
    -- constructor.
    , Marklist -> MarklistPtr
marklist_fptr :: !MarklistPtr
    }

type MarklistVector = TimeVector.Boxed Mark

instance Eq Marklist where
    Marklist
m1 == :: Marklist -> Marklist -> Bool
== Marklist
m2 = Marklist -> MarklistVector
marklist_vec Marklist
m1 MarklistVector -> MarklistVector -> Bool
forall a. Eq a => a -> a -> Bool
== Marklist -> MarklistVector
marklist_vec Marklist
m2
instance Show Marklist where
    show :: Marklist -> String
show Marklist
m = String
"Ruler.marklist " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [PosMark] -> String
forall a. Show a => a -> String
show (ScoreTime -> Marklist -> [PosMark]
ascending ScoreTime
0 Marklist
m)
instance Pretty Marklist where
    pretty :: Marklist -> Text
pretty Marklist
m = Text
"((" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt (MarklistVector -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
TimeVector.length (Marklist -> MarklistVector
marklist_vec Marklist
m)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" marks))"

-- | This should be opaque, but it needs to be exported for RulerC.  Don't look
-- inside if you're not RulerC, OK?
--
-- The Left value is actually not used, but prevents the unsafePerformIO from
-- being floated out of the lambda.
--
-- I used to just copy the ruler each time, but it was actually pretty big.
-- Rulers can have lots of marks, there are many rulers per block since each
-- track has one.  But many tracks share the same ruler, and they change
-- rarely.  All of these differences from 'Events.Events' push for passing
-- by pointer rather than copying over the whole thing each time (as with the
-- signal), or passing a callback that fetches the required range (as with
-- events).
--
-- TODO I could share the memory by making MarklistVector into Vector.Storable
-- PosMark.  It's otherwise equivalant though, and the number of distinct
-- rulers is probably small, so the memory savings doesn't seem that
-- compelling.
newtype MarklistPtr = MarklistPtr
    (MVar.MVar (Either MarklistVector (Foreign.ForeignPtr Marklist)))
type PosMark = (ScoreTime, Mark)

marklist :: [PosMark] -> Marklist
marklist :: [PosMark] -> Marklist
marklist = MarklistVector -> Marklist
marklist_from_vector (MarklistVector -> Marklist)
-> ([PosMark] -> MarklistVector) -> [PosMark] -> Marklist
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(X, Mark)] -> MarklistVector
forall (v :: * -> *) y.
Vector v (Sample y) =>
[(X, y)] -> v (Sample y)
TimeVector.from_pairs
    ([(X, Mark)] -> MarklistVector)
-> ([PosMark] -> [(X, Mark)]) -> [PosMark] -> MarklistVector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PosMark -> (X, Mark)) -> [PosMark] -> [(X, Mark)]
forall a b. (a -> b) -> [a] -> [b]
map ((ScoreTime -> X) -> PosMark -> (X, Mark)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ScoreTime -> X
RealTime.from_score)

{-# NOINLINE marklist_from_vector #-} -- due to evil unsafePerformIO
marklist_from_vector :: MarklistVector -> Marklist
marklist_from_vector :: MarklistVector -> Marklist
marklist_from_vector MarklistVector
vec = Marklist
    { marklist_vec :: MarklistVector
marklist_vec = MarklistVector
vec
    , marklist_fptr :: MarklistPtr
marklist_fptr = MVar (Either MarklistVector (ForeignPtr Marklist)) -> MarklistPtr
MarklistPtr (MVar (Either MarklistVector (ForeignPtr Marklist)) -> MarklistPtr)
-> MVar (Either MarklistVector (ForeignPtr Marklist))
-> MarklistPtr
forall a b. (a -> b) -> a -> b
$ IO (MVar (Either MarklistVector (ForeignPtr Marklist)))
-> MVar (Either MarklistVector (ForeignPtr Marklist))
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (MVar (Either MarklistVector (ForeignPtr Marklist)))
 -> MVar (Either MarklistVector (ForeignPtr Marklist)))
-> IO (MVar (Either MarklistVector (ForeignPtr Marklist)))
-> MVar (Either MarklistVector (ForeignPtr Marklist))
forall a b. (a -> b) -> a -> b
$
        Either MarklistVector (ForeignPtr Marklist)
-> IO (MVar (Either MarklistVector (ForeignPtr Marklist)))
forall a. a -> IO (MVar a)
MVar.newMVar (MarklistVector -> Either MarklistVector (ForeignPtr Marklist)
forall a b. a -> Either a b
Left MarklistVector
vec)
    }

empty :: Marklist
empty :: Marklist
empty = [PosMark] -> Marklist
marklist [PosMark]
forall a. Monoid a => a
mempty

to_list :: Marklist -> [PosMark]
to_list :: Marklist -> [PosMark]
to_list = (Sample Mark -> PosMark) -> [Sample Mark] -> [PosMark]
forall a b. (a -> b) -> [a] -> [b]
map Sample Mark -> PosMark
unsample ([Sample Mark] -> [PosMark])
-> (Marklist -> [Sample Mark]) -> Marklist -> [PosMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarklistVector -> [Sample Mark]
forall (v :: * -> *) a. Vector v a => v a -> [a]
TimeVector.toList (MarklistVector -> [Sample Mark])
-> (Marklist -> MarklistVector) -> Marklist -> [Sample Mark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Marklist -> MarklistVector
marklist_vec

-- | Marks starting at the first mark >= the given pos, to the end.
ascending :: ScoreTime -> Marklist -> [PosMark]
ascending :: ScoreTime -> Marklist -> [PosMark]
ascending ScoreTime
pos Marklist
mlist = (Sample Mark -> PosMark) -> [Sample Mark] -> [PosMark]
forall a b. (a -> b) -> [a] -> [b]
map Sample Mark -> PosMark
unsample ([Sample Mark] -> [PosMark]) -> [Sample Mark] -> [PosMark]
forall a b. (a -> b) -> a -> b
$
    X -> MarklistVector -> [Sample Mark]
forall (v :: * -> *) y.
Vector v (Sample y) =>
X -> v (Sample y) -> [Sample y]
TimeVector.ascending (ScoreTime -> X
RealTime.from_score ScoreTime
pos) (Marklist -> MarklistVector
marklist_vec Marklist
mlist)

-- | Marks starting at the first mark below the given pos, to the beginning.
descending :: ScoreTime -> Marklist -> [PosMark]
descending :: ScoreTime -> Marklist -> [PosMark]
descending ScoreTime
pos Marklist
mlist = (Sample Mark -> PosMark) -> [Sample Mark] -> [PosMark]
forall a b. (a -> b) -> [a] -> [b]
map Sample Mark -> PosMark
unsample ([Sample Mark] -> [PosMark]) -> [Sample Mark] -> [PosMark]
forall a b. (a -> b) -> a -> b
$
    X -> MarklistVector -> [Sample Mark]
forall (v :: * -> *) y.
Vector v (Sample y) =>
X -> v (Sample y) -> [Sample y]
TimeVector.descending (ScoreTime -> X
RealTime.from_score ScoreTime
pos) (Marklist -> MarklistVector
marklist_vec Marklist
mlist)

unsample :: TimeVector.Sample Mark -> PosMark
unsample :: Sample Mark -> PosMark
unsample Sample Mark
s = (X -> ScoreTime
RealTime.to_score (Sample Mark -> X
forall y. Sample y -> X
TimeVector.sx Sample Mark
s), Sample Mark -> Mark
forall y. Sample y -> y
TimeVector.sy Sample Mark
s)

-- | Get the position of the last mark.
end :: Marklist -> ScoreTime
end :: Marklist -> ScoreTime
end = ScoreTime
-> (Sample Mark -> ScoreTime) -> Maybe (Sample Mark) -> ScoreTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
0 (X -> ScoreTime
RealTime.to_score (X -> ScoreTime) -> (Sample Mark -> X) -> Sample Mark -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample Mark -> X
forall y. Sample y -> X
TimeVector.sx)
    (Maybe (Sample Mark) -> ScoreTime)
-> (Marklist -> Maybe (Sample Mark)) -> Marklist -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarklistVector -> Maybe (Sample Mark)
forall (v :: * -> *) a. Vector v a => v a -> Maybe a
TimeVector.last (MarklistVector -> Maybe (Sample Mark))
-> (Marklist -> MarklistVector) -> Marklist -> Maybe (Sample Mark)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Marklist -> MarklistVector
marklist_vec

start :: Marklist -> ScoreTime
start :: Marklist -> ScoreTime
start = ScoreTime
-> (Sample Mark -> ScoreTime) -> Maybe (Sample Mark) -> ScoreTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
0 (X -> ScoreTime
RealTime.to_score (X -> ScoreTime) -> (Sample Mark -> X) -> Sample Mark -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample Mark -> X
forall y. Sample y -> X
TimeVector.sx)
    (Maybe (Sample Mark) -> ScoreTime)
-> (Marklist -> Maybe (Sample Mark)) -> Marklist -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarklistVector -> Maybe (Sample Mark)
forall (v :: * -> *) a. Vector v a => v a -> Maybe a
TimeVector.head (MarklistVector -> Maybe (Sample Mark))
-> (Marklist -> MarklistVector) -> Marklist -> Maybe (Sample Mark)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Marklist -> MarklistVector
marklist_vec

insert_mark :: ScoreTime -> Mark -> Marklist -> Marklist
insert_mark :: ScoreTime -> Mark -> Marklist -> Marklist
insert_mark ScoreTime
pos Mark
mark = [PosMark] -> Marklist
marklist ([PosMark] -> Marklist)
-> (Marklist -> [PosMark]) -> Marklist -> Marklist
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PosMark -> PosMark -> Ordering)
-> PosMark -> [PosMark] -> [PosMark]
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
List.insertBy PosMark -> PosMark -> Ordering
forall {a} {b} {b}. Ord a => (a, b) -> (a, b) -> Ordering
cmp (ScoreTime
pos, Mark
mark) ([PosMark] -> [PosMark])
-> (Marklist -> [PosMark]) -> Marklist -> [PosMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Marklist -> [PosMark]
ascending ScoreTime
0
    where cmp :: (a, b) -> (a, b) -> Ordering
cmp (a, b)
a (a, b)
b = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
a) ((a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
b)

-- * mark

data Mark = Mark {
    -- | An arbitrary low integer.  This is the only part of the mark that
    -- matters to the code, the rest is purely visual.  By convention, the
    -- most prominent divisions start at rank 0 and go up from there.
    Mark -> Rank
mark_rank :: !Meter.Rank
    -- | Width in pixels.
    , Mark -> Int
mark_width :: !Int
    , Mark -> Color
mark_color :: !Color.Color
    -- | A bit of text displayed with the mark.  This can use backtick symbols.
    , Mark -> Text
mark_name :: !Label
    -- | The text is only displayed when the zoom factor exceeds this value.
    , Mark -> Double
mark_name_zoom_level :: !Double
    -- | The mark itself is only displayed when the zoom factor exeeds this
    -- value.
    , Mark -> Double
mark_zoom_level :: !Double
    } deriving (Mark -> Mark -> Bool
(Mark -> Mark -> Bool) -> (Mark -> Mark -> Bool) -> Eq Mark
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mark -> Mark -> Bool
$c/= :: Mark -> Mark -> Bool
== :: Mark -> Mark -> Bool
$c== :: Mark -> Mark -> Bool
Eq, Int -> Mark -> ShowS
[Mark] -> ShowS
Mark -> String
(Int -> Mark -> ShowS)
-> (Mark -> String) -> ([Mark] -> ShowS) -> Show Mark
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mark] -> ShowS
$cshowList :: [Mark] -> ShowS
show :: Mark -> String
$cshow :: Mark -> String
showsPrec :: Int -> Mark -> ShowS
$cshowsPrec :: Int -> Mark -> ShowS
Show)

type Label = Text

instance DeepSeq.NFData Mark where
    rnf :: Mark -> ()
rnf (Mark Rank
rank Int
width Color
color Text
name Double
name_zoom Double
zoom) = Rank
rank Rank -> () -> ()
`seq` Int
width
        Int -> () -> ()
`seq` Color
color Color -> () -> ()
`seq` Text
name Text -> () -> ()
`seq` Double
name_zoom Double -> () -> ()
`seq` Double
zoom Double -> () -> ()
`seq` ()

instance Pretty Mark where
    pretty :: Mark -> Text
pretty Mark
m = Text
"(mark " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rank -> Text
forall a. Show a => a -> Text
showt (Mark -> Rank
mark_rank Mark
m) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        where name :: Text
name = if Text -> Bool
Text.null (Mark -> Text
mark_name Mark
m) then Text
"" else Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Mark -> Text
mark_name Mark
m