-- Copyright 2017 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 EmptyDataDecls #-}
{- | Sample values are doubles, which means each point in the signal is 8*2
    bytes.  The double resolution is overkill for the value, but float would
    be too small for time given the time stretching.

    TODO split this into Float and Double versions since only Warp really
    needs Double.  Or does Warp really need Double?
-}
module Perform.Signal (
    -- * types
    Signal, Sample(..)
    , X, Y, x_to_y, y_to_x, y_to_score, y_to_nn, nn_to_y
    , Tempo, Warp, Control, NoteNumber, Display

    -- * construct / destruct
    , from_sample, from_pairs, from_segments
    , to_samples, to_pairs, to_pairs_desc
    , to_segments, to_vector
    , constant, constant_val, constant_val_from
    , beginning
    , prepend
    , unfoldr
    , coerce
    , to_piecewise_constant
    , with_ptr

    -- * query
    , null
    , at, at_maybe, segment_at
    , head, last
    , minimum, maximum
    , find

    -- * transform
    , drop_after, drop_before
    , clip_after, clip_before, clip_before_segments, clip_before_pairs
    , clip_after_keep_last
    , shift

    , invert, sig_add, sig_subtract, sig_multiply, sig_scale
    , scale, scale_invert

    -- ** hacks
    , drop_discontinuity_at

    -- ** scalar transformation
    , scalar_max
    , scalar_add, scalar_subtract, scalar_multiply, scalar_divide
    , scalar_scale
    , map_x, map_y, map_y_linear, map_err

    -- * special functions
    , integrate_inverse, integrate, tempo_srate
) where
import Prelude hiding (head, last, maximum, minimum, null, drop)
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Vector.Storable as Vector
import qualified Foreign

import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Segment as Segment
import Util.Segment (X, Sample(..))
import qualified Util.Seq as Seq
import qualified Util.Serialize as Serialize
import qualified Util.TimeVector as TimeVector

import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Ui.ScoreTime as ScoreTime

import Global
import Types


-- * types

-- | A Signal is a 'Segment.Signal' of 'Y' values, which are just Doubles.  It
-- takes a phantom type parameter to make the signal's intended uses a little
-- clearer.  There are type aliases for the various flavors of signal below,
-- but it really is just documentation and anyone who wants to operate on
-- a generic signal can take a @Signal kind@.
newtype Signal kind = Signal Segment.NumSignal
    deriving (Show, Eq, DeepSeq.NFData, Serialize.Serialize)

instance Pretty (Signal kind) where
    format sig = case constant_val sig of
        Just y -> "Signal.constant" Pretty.<+> Pretty.format y
        Nothing -> Pretty.format (_signal sig)

_signal :: Signal kind -> Segment.NumSignal
_signal (Signal sig) = sig

modify :: (Segment.NumSignal -> Segment.NumSignal) -> Signal kind -> Signal kind
modify f = Signal . f . _signal

type Y = Double

instance Semigroup (Signal kind) where
    s1 <> s2
        | null s1 = s2
        | null s2 = s1
        | otherwise = mconcat [s1, s2]

instance Monoid (Signal kind) where
    mempty = Signal Segment.empty
    mappend = (<>)
    mconcat = Signal . Segment.concat (Just (==)) Segment.num_interpolate
        . map _signal . filter (not . null)

-- | This is the type of performer-interpreted controls that go into the
-- event's control map.
type Control = Signal ControlSig
data ControlSig

-- | A tempo is a normal Control signal, except that instead of going into the
-- control map, it gets turned into a Warp and goes into the warp map.
type Tempo = Signal TempoSig
data TempoSig

-- | A tempo warp maps score time to real time.  Of course the type is still
-- (ScoreTime, Y), so functions that process Warps have to convert.
type Warp = Signal WarpSig
data WarpSig

-- | This is the type of pitch signals used by the performer, after the scale
-- has been factored out.
type NoteNumber = Signal NoteNumberSig
data NoteNumberSig

-- | This is the type of signals which are sent to the UI for display.
type Display = Signal DisplaySig
data DisplaySig

x_to_y :: X -> Y
x_to_y = RealTime.to_seconds

y_to_x :: Y -> X
y_to_x = RealTime.seconds

-- | Some control signals may be interpreted as score time.
y_to_score :: Y -> ScoreTime
y_to_score = ScoreTime.from_double

y_to_nn :: Y -> Pitch.NoteNumber
y_to_nn = Pitch.NoteNumber

nn_to_y :: Pitch.NoteNumber -> Y
nn_to_y (Pitch.NoteNumber nn) = nn

-- * construct / destruct

from_sample :: X -> Y -> Signal kind
from_sample x y = from_pairs [(x, y)]

from_pairs :: [(X, Y)] -> Signal kind
from_pairs = Signal . Segment.from_pairs

from_segments :: [Segment.Segment Y] -> Signal kind
from_segments = Signal . Segment.from_segments

to_samples :: Signal kind -> [Sample Y]
to_samples = Segment.to_samples . _signal

to_pairs :: Signal kind -> [(X, Y)]
to_pairs = Seq.drop_dups id . Segment.to_pairs . _signal
    -- Since Segment functions don't have Eq y, they can emit duplicate
    -- samples.  They should be harmless but they clutter tests.

to_pairs_desc :: Signal kind -> [(X, Y)]
to_pairs_desc = Seq.drop_dups id . Segment.to_pairs_desc . _signal

to_segments :: Signal kind -> [Segment.Segment Y]
to_segments = Segment.to_segments . _signal

to_vector :: Signal kind -> Vector.Vector (Sample Y)
to_vector = Segment.to_vector . _signal

constant :: Y -> Signal kind
constant = Signal . Segment.constant

-- | Just if the signal is constant.
constant_val :: Signal kind -> Maybe Y
constant_val = Segment.constant_val_num (-RealTime.large) . _signal

constant_val_from :: X -> Signal kind -> Maybe Y
constant_val_from x = Segment.constant_val_num x . _signal

beginning :: RealTime
beginning = Segment.beginning

prepend :: Signal kind -> Signal kind -> Signal kind
prepend sig1 sig2 = Signal $
    Segment.prepend (Just (==)) Segment.num_interpolate
        (_signal sig1) (_signal sig2)

unfoldr :: (state -> Maybe ((X, Y), state)) -> state -> Signal kind
unfoldr gen state = Signal $ Segment.unfoldr gen state

-- | Sometimes signal types need to be converted.
coerce :: Signal kind1 -> Signal kind2
coerce (Signal vec) = Signal vec

to_piecewise_constant :: X -> Signal kind -> TimeVector.Unboxed
to_piecewise_constant srate = Segment.to_piecewise_constant srate . _signal

-- | 'Segment.with_ptr'.
with_ptr :: Display -> (X -> Foreign.Ptr (Sample Y) -> Int -> IO a) -> IO a
with_ptr sig = Segment.with_ptr (_signal sig)

-- * query

null :: Signal kind -> Bool
null = Segment.null . _signal

at :: X -> Signal kind -> Y
at x = fromMaybe 0 . at_maybe x

at_maybe :: X -> Signal kind -> Maybe Y
at_maybe x = Segment.at Segment.num_interpolate x . _signal

segment_at :: X -> Signal kind -> Maybe (Segment.Segment Y)
segment_at x = Segment.segment_at x . _signal

head, last :: Signal kind -> Maybe (X, Y)
head = Segment.head . _signal
last = Segment.last . _signal

-- * transform

drop_after, drop_before :: X -> Signal kind -> Signal kind
drop_after x = modify $ Segment.drop_after x
drop_before x = modify $ Segment.drop_before x

clip_after, clip_before :: X -> Signal kind -> Signal kind
clip_after x = modify $ Segment.num_clip_after False x
clip_before x = modify $ Segment.clip_before Segment.num_interpolate x

-- TODO if Segment.clip_before_samples is the same as Segment.clip_before,
-- then this is the same as 'clip_before'.
clip_before_segments :: X -> Signal kind -> [Segment.Segment Y]
clip_before_segments x = Segment.samples_to_segments
    . Segment.clip_before_samples Segment.num_interpolate x
    . _signal

clip_before_pairs :: X -> Signal kind -> [(X, Y)]
clip_before_pairs x =
    map TimeVector.to_pair
    . Segment.clip_before_samples Segment.num_interpolate x
    . _signal

-- | Like 'clip_after', but always put a sample at the end time, even if it's
-- flat.  This is not necessary if you keep this as a Signal since (<>) will
-- extend the final sample, but might be if you go to breakpoints via
-- 'to_pairs'.
clip_after_keep_last :: X -> Signal kind -> Signal kind
clip_after_keep_last x = modify $ Segment.num_clip_after True x

shift :: X -> Signal kind -> Signal kind
shift x = modify (Segment.shift x)

invert :: Signal kind -> Signal kind
invert = modify Segment.invert

sig_add, sig_multiply :: Control -> Control -> Control
sig_add = linear_operator (Just 0) (+)
sig_multiply = linear_operator (Just 1) (*)

sig_subtract :: Control -> Control -> Control
sig_subtract sig1 sig2
    | Just v <- constant_val sig2, v == 0 = sig1
    | otherwise = linear_operator Nothing (-) sig1 sig2

-- TODO I think this is linear?  Because Num.scale is just add and multiply?
sig_scale :: Control -> Control -> Control
sig_scale = linear_operator (Just 1) scale

scale :: Y -> Y -> Y
scale x v
    | v >= 0 = Num.scale x 1 v
    | otherwise = Num.scale 0 x (v + 1)

scale_invert :: Y -> Y -> Y
scale_invert old new
    | new >= old = Num.normalize old 1 new
    | otherwise = Num.normalize 0 old new - 1

linear_operator :: Maybe Y -- ^ If an identity value is given, I can avoid
    -- copying the whole signal if the other one is a constant identity.
    -> (Y -> Y -> Y) -> Signal kind -> Signal kind -> Signal kind
linear_operator (Just identity) _ sig1 sig2
    | Just v <- constant_val sig1, v == identity = sig2
    | Just v <- constant_val sig2, v == identity = sig1
linear_operator _ op sig1 sig2 =
    Signal $ Segment.linear_operator op (_signal sig1) (_signal sig2)

-- ** hacks

drop_discontinuity_at :: X -> Control -> Control
drop_discontinuity_at x = modify $ Segment.drop_discontinuity_at x

-- ** scalar transformation

scalar_add, scalar_subtract, scalar_multiply, scalar_divide ::
    Y -> Signal kind -> Signal kind
scalar_add n = map_y_linear (+n)
scalar_subtract n = map_y_linear (subtract n)
scalar_multiply n = map_y_linear (*n)
scalar_divide n = map_y_linear (/n)

scalar_scale :: Y -> Signal kind -> Signal kind
scalar_scale n = map_y_linear (scale n)

-- | Clip signal to never go below the given value.
--
-- This is way more complicated than the piecewise constant version.
scalar_max :: Y -> Signal kind -> Signal kind
scalar_max val sig
    | minimum sig >= val = sig
    | otherwise = modify (Segment.transform_samples go) sig
    where
    go [] = []
    go [Sample x y] = [Sample x (max val y)]
    go (s1@(Sample x1 y1) : s2s@(Sample x2 y2 : sn))
        | y1 < val && y2 < val = Sample x1 val : below (s1 : s2s)
        | y1 >= val && y2 >= val = s1 : go s2s
        | otherwise = case TimeVector.x_at x1 y1 x2 y2 val of
            Nothing
                | y1 < val -> Sample x1 val : go (Sample x2 val : sn)
                | otherwise -> s1 : go s2s
            Just x_val
                | y1 < val -> Sample x1 val : go (Sample x_val val : s2s)
                | otherwise -> s1 : Sample x_val val : below s2s
    -- The first sample is below val, discard until it comes back up again.
    below (Sample x1 y1 : s2s@(Sample x2 y2 : _))
        | y2 < val = below s2s
        | y2 == val = go s2s
        | otherwise = case TimeVector.x_at x1 y1 x2 y2 val of
            -- y1 and y2 are both below, should have been caught above.
            Nothing -> below s2s
            Just x_val -> go (Sample x_val val : s2s)
    below [_] = []
    below [] = []

minimum, maximum :: Signal kind -> Y
minimum = fromMaybe 0 . Segment.minimum . _signal
maximum = fromMaybe 0 . Segment.maximum . _signal

find :: (X -> Y -> Bool) -> Signal kind -> Maybe (X, Y)
find f = Segment.find f . _signal

-- | Map Xs.  The slopes will definitely change unless the function is adding
-- a constant, but presumably that's what you want.
{-# SCC map_x #-}
map_x :: (X -> X) -> Signal kind -> Signal kind
map_x = modify . Segment.map_x

-- | Map Ys.  This resamples the signal, so it's valid for a nonlinear
-- function.
{-# SCC map_y #-}
map_y :: X -> (Y -> Y) -> Signal kind -> Signal kind
map_y srate = modify . Segment.map_y srate

-- | If the function is linear, there's no need to resample.
{-# SCC map_y_linear #-}
map_y_linear :: (Y -> Y) -> Signal kind -> Signal kind
map_y_linear = modify . Segment.map_y_linear

map_err :: (Sample Y -> Either err (Sample Y)) -> Signal kind
    -> (Signal kind, [err])
map_err f = first Signal . Segment.map_err f . _signal

-- * special functions

integrate_inverse :: Tempo -> Warp
integrate_inverse = integrate . map_y tempo_srate (1/)

-- | Integrate the signal.
--
-- Since the output will have more samples than the input, this needs
-- a sampling rate.  The sampling rate determines the resolution of the tempo
-- track.  So it can probably be fairly low resolution before having
-- a noticeable impact.
--
-- TODO this is only called after map_y at srate, so it's already been
-- resampled.  Maybe it would be more efficient to remove srate from
-- Segment.integrate.
integrate :: Tempo -> Warp
integrate = Signal . Segment.integrate tempo_srate . _signal

tempo_srate :: X
tempo_srate = RealTime.seconds 10

-- | Total duration of horizontal segments in the warp signal.  These are
-- the places where 'Warp.compose_hybrid' will emit a 1\/1 line.
_flat_duration :: Warp -> ScoreTime
_flat_duration =
    RealTime.to_score . fst . Vector.foldl' go (0, Segment.Sample 0 0)
        . Segment.to_vector . _signal
    where
    go (!acc, Segment.Sample x0 y0) sample@(Segment.Sample x y)
        | y == y0 = (acc + (x - x0), sample)
        | otherwise = (acc, sample)