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

{- | This module is sister to "Derive.Deriver.Lib", except that it contains
    functions which are normally only used by the built-in track derivation
    scheme, and are not used when writing most normal calls.
-}
module Derive.Deriver.Internal where
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import qualified Util.CallStack as CallStack
import qualified Util.Log as Log
import qualified Util.Seed as Seed

import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Derive.TrackWarp as TrackWarp
import qualified Derive.Warp as Warp

import qualified Ui.Block as Block
import qualified Ui.Ruler as Ruler
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Derive.Deriver.Monad
import           Global
import           Types


-- * generic state access

get_dynamic :: (Dynamic -> a) -> Deriver a
get_dynamic :: forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> a
f = forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)

get_constant :: (Constant -> a) -> Deriver a
get_constant :: forall a. (Constant -> a) -> Deriver a
get_constant Constant -> a
f = forall st a err. (st -> a) -> Deriver st err a
gets (Constant -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)

-- | This is a little different from Reader.local because only a portion of
-- the state is used Reader-style.
--
-- Note that this doesn't restore the state on an exception.  I think this
-- is ok because exceptions are always \"caught\" at the event evaluation
-- level since it runs each one separately.  Since the state dynamic state
-- (i.e. except Collect) from the sub derivation is discarded, whatever state
-- it's in after the exception shouldn't matter.
local :: (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local :: forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local Dynamic -> Dynamic
modify_dynamic = forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Dynamic
modify_dynamic)

localm :: (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm :: forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm Dynamic -> Deriver Dynamic
modify_dynamic Deriver a
deriver = do
    State
st <- forall st err. Deriver st err st
get
    Dynamic
new <- Dynamic -> Deriver Dynamic
modify_dynamic (State -> Dynamic
state_dynamic State
st)
    forall st err. st -> Deriver st err ()
put forall a b. (a -> b) -> a -> b
$ State
st { state_dynamic :: Dynamic
state_dynamic = Dynamic
new }
    a
result <- Deriver a
deriver
    forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
new -> State
new { state_dynamic :: Dynamic
state_dynamic = State -> Dynamic
state_dynamic State
st }
    forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | A version of 'local' that catches exceptions and ignores any changes to
-- Collect.  This is appropriate for sub-calls that are below normal track
-- derivation.
detached_local :: (Dynamic -> Dynamic) -> Deriver a -> Deriver (Either Error a)
detached_local :: forall a.
(Dynamic -> Dynamic) -> Deriver a -> Deriver (Either Error a)
detached_local Dynamic -> Dynamic
modify_dynamic Deriver a
deriver = do
    State
st <- forall st err. Deriver st err st
get
    let (Either Error a
result, State
_, [Msg]
logs) = forall st err a. st -> Deriver st err a -> RunResult st err a
run
            (State
st { state_dynamic :: Dynamic
state_dynamic = Dynamic -> Dynamic
modify_dynamic (State -> Dynamic
state_dynamic State
st) }) Deriver a
deriver
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    forall (m :: * -> *) a. Monad m => a -> m a
return Either Error a
result

set_threaded :: Threaded -> Deriver ()
set_threaded :: Threaded -> Deriver State Error ()
set_threaded Threaded
threaded = forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_threaded :: Threaded
state_threaded = Threaded
threaded }

-- * Collect

-- | Collect is only ever accumulated.
--
-- Direct modification would be potentially more efficient, but according to
-- profiling it doesn't make a difference.
merge_collect :: Collect -> Deriver ()
merge_collect :: Collect -> Deriver State Error ()
merge_collect Collect
c = forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = State -> Collect
state_collect State
st forall a. Semigroup a => a -> a -> a
<> Collect
c }
    -- I append the Collect, which means that I wind up with the first instance
    -- for Maps with duplicate keys.  This seems a bit more intuitive than the
    -- last one.

-- | Run with an empty Collect, restore the original Collect, and return the
-- sub-deriver's Collect.
local_collect :: Deriver a -> Deriver (a, Collect)
local_collect :: forall a. Deriver a -> Deriver (a, Collect)
local_collect Deriver a
deriver = do
    Collect
old <- forall st a err. (st -> a) -> Deriver st err a
gets State -> Collect
state_collect
    forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = forall a. Monoid a => a
mempty }
    a
result <- Deriver a
deriver
    Collect
sub_collect <- forall st a err. (st -> a) -> Deriver st err a
gets State -> Collect
state_collect
    forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = Collect
old }
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Collect
sub_collect)

-- | Modify the 'collect_warp_map' to reduce the start and end by the given
-- times.  This is useful if you're going to clip off some events.  The
-- TrackWarps, and hence playback cursor, can't know you're going to do this,
-- so you have to tell it.
trim_track_warps :: Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a
trim_track_warps :: forall a.
Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a
trim_track_warps Maybe RealTime
start Maybe RealTime
end = forall a. (Collect -> Collect) -> Deriver a -> Deriver a
with_collect forall a b. (a -> b) -> a -> b
$ \Collect
st -> Collect
st
    { collect_warp_map :: WarpMap
collect_warp_map = Track -> Track
trim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Collect -> WarpMap
collect_warp_map Collect
st }
    where
    trim :: Track -> Track
trim (TrackWarp.Track RealTime
s RealTime
e Warp
warp BlockId
block_id Maybe TrackId
track_id) =
        RealTime -> RealTime -> Warp -> BlockId -> Maybe TrackId -> Track
TrackWarp.Track (forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
s (forall a. Ord a => a -> a -> a
max RealTime
s) Maybe RealTime
start) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
e (forall a. Ord a => a -> a -> a
min RealTime
e) Maybe RealTime
end)
            Warp
warp BlockId
block_id Maybe TrackId
track_id

-- | Run the deriver and modify the Collect it returns.
with_collect :: (Collect -> Collect) -> Deriver a -> Deriver a
with_collect :: forall a. (Collect -> Collect) -> Deriver a -> Deriver a
with_collect Collect -> Collect
modify Deriver a
deriver = do
    (a
a, Collect
collect) <- forall a. Deriver a -> Deriver (a, Collect)
local_collect Deriver a
deriver
    Collect -> Deriver State Error ()
merge_collect (Collect -> Collect
modify Collect
collect)
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | TODO this is sketchy, you're supposed to use 'merge_collect'.
modify_collect :: (Collect -> Collect) -> Deriver ()
modify_collect :: (Collect -> Collect) -> Deriver State Error ()
modify_collect Collect -> Collect
f = forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = Collect -> Collect
f (State -> Collect
state_collect State
st) }

-- * environ

get_environ :: Deriver DeriveT.Environ
get_environ :: Deriver Environ
get_environ = forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Environ
state_environ

-- | Figure out the current block and track, and record the current environ
-- in the Collect.  It only needs to be recorded once per track.
record_track_dynamic :: Dynamic -> Maybe TrackDynamic
record_track_dynamic :: Dynamic -> Maybe TrackDynamic
record_track_dynamic Dynamic
dyn = case Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of (Dynamic -> Stack
state_stack Dynamic
dyn) of
    Just (BlockId
bid, TrackId
tid) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall k a. k -> a -> Map k a
Map.singleton (BlockId
bid, TrackId
tid) forall a b. (a -> b) -> a -> b
$!
        -- If I don't clear the inversion state, any inverting call that uses
        -- this dynamic will throw a double inversion error.  Also the function
        -- closure probably causes drag.
        Dynamic
dyn { state_inversion :: Inversion
state_inversion = Inversion
NotInverted }
    Maybe (BlockId, TrackId)
Nothing -> forall a. Maybe a
Nothing

-- | 'record_track_dynamic' for when I already know BlockId and TrackId.
record_track_dynamic_for :: BlockId -> TrackId -> Deriver ()
record_track_dynamic_for :: BlockId -> TrackId -> Deriver State Error ()
record_track_dynamic_for BlockId
block_id TrackId
track_id = do
    Dynamic
dynamic <- forall st a err. (st -> a) -> Deriver st err a
gets State -> Dynamic
state_dynamic
    Collect -> Deriver State Error ()
merge_collect forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
        { collect_track_dynamic :: TrackDynamic
collect_track_dynamic = forall k a. k -> a -> Map k a
Map.singleton (BlockId
block_id, TrackId
track_id) Dynamic
dynamic }

-- * misc Dynamic state

with_default_merge :: Map ScoreT.Control Merger -> Deriver a -> Deriver a
with_default_merge :: forall a. Map Control Merger -> Deriver a -> Deriver a
with_default_merge Map Control Merger
defaults = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local forall a b. (a -> b) -> a -> b
$ \Dynamic
st -> Dynamic
st
    { state_control_merge_defaults :: Map Control Merger
state_control_merge_defaults =
        Map Control Merger
defaults forall a. Semigroup a => a -> a -> a
<> Dynamic -> Map Control Merger
state_control_merge_defaults Dynamic
st
    }

-- * cache

with_control_damage :: ControlDamage -> Deriver derived -> Deriver derived
with_control_damage :: forall derived. ControlDamage -> Deriver derived -> Deriver derived
with_control_damage ControlDamage
damage = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local forall a b. (a -> b) -> a -> b
$ \Dynamic
st ->
    Dynamic
st { state_control_damage :: ControlDamage
state_control_damage = ControlDamage
damage }

add_block_dep :: BlockId -> Deriver ()
add_block_dep :: BlockId -> Deriver State Error ()
add_block_dep BlockId
block_id = Collect -> Deriver State Error ()
merge_collect forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
    { collect_block_deps :: BlockDeps
collect_block_deps = Set BlockId -> BlockDeps
BlockDeps (forall a. a -> Set a
Set.singleton BlockId
block_id) }

-- * ui state

get_ui_state :: (Ui.State -> a) -> Deriver a
get_ui_state :: forall a. (State -> a) -> Deriver a
get_ui_state State -> a
f = forall st a err. (st -> a) -> Deriver st err a
gets (State -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constant -> State
state_ui forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)

get_ui_config :: (UiConfig.Config -> a) -> Deriver a
get_ui_config :: forall a. (Config -> a) -> Deriver a
get_ui_config Config -> a
f = forall a. (State -> a) -> Deriver a
get_ui_state (Config -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config)

-- | Because Deriver is not a UiStateMonad.
--
-- TODO I suppose it could be, but then I'd be tempted to make
-- a ReadOnlyUiStateMonad.  And I'd have to merge the exceptions.
-- Or just rethrow, right?
get_track :: TrackId -> Deriver Track.Track
get_track :: TrackId -> Deriver Track
get_track TrackId
track_id = forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id TrackId
track_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. (State -> a) -> Deriver a
get_ui_state State -> Map TrackId Track
Ui.state_tracks

get_block :: BlockId -> Deriver Block.Block
get_block :: BlockId -> Deriver Block
get_block BlockId
block_id = forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id BlockId
block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. (State -> a) -> Deriver a
get_ui_state State -> Map BlockId Block
Ui.state_blocks

-- | Evaluate a Ui.M computation, rethrowing any errors.
eval_ui :: CallStack.Stack => Ui.StateId a -> Deriver a
eval_ui :: forall a. Stack => StateId a -> Deriver a
eval_ui StateId a
action = do
    State
ui_state <- forall a. (State -> a) -> Deriver a
get_ui_state forall a. a -> a
id
    let rethrow :: a -> Deriver a
rethrow a
exc = forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty a
exc
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} {a}. Pretty a => a -> Deriver a
rethrow forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. State -> StateId a -> Either Error a
Ui.eval State
ui_state StateId a
action)

-- | Lookup @map!key@, throwing if it doesn't exist.
lookup_id :: (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id :: forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id k
key Map k a
map = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k a
map of
    Maybe a
Nothing -> forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"unknown " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt k
key
    Just a
val -> forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- * stack

lookup_current_block_id :: Deriver (Maybe BlockId)
lookup_current_block_id :: Deriver (Maybe BlockId)
lookup_current_block_id = do
    Stack
stack <- Deriver Stack
get_stack
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [BlockId
bid | Stack.Block BlockId
bid <- Stack -> [Frame]
Stack.innermost Stack
stack] of
        [] -> forall a. Maybe a
Nothing
        BlockId
bid : [BlockId]
_ -> forall a. a -> Maybe a
Just BlockId
bid

get_current_block_id :: Deriver BlockId
get_current_block_id :: Deriver BlockId
get_current_block_id =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Stack => Text -> Deriver a
throw Text
"get_current_block_id: no blocks in stack") forall (m :: * -> *) a. Monad m => a -> m a
return
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Maybe BlockId)
lookup_current_block_id

lookup_current_tracknum :: Deriver (Maybe (BlockId, TrackNum))
lookup_current_tracknum :: Deriver (Maybe (BlockId, Serial))
lookup_current_tracknum = do
    Stack
stack <- Deriver Stack
get_stack
    case Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of Stack
stack of
        Maybe (BlockId, TrackId)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (BlockId
block_id, TrackId
track_id) -> do
            Serial
tracknum <- forall a. Stack => StateId a -> Deriver a
eval_ui forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => BlockId -> TrackId -> m Serial
Ui.get_tracknum_of BlockId
block_id TrackId
track_id
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (BlockId
block_id, Serial
tracknum)

get_current_tracknum :: Deriver (BlockId, TrackNum)
get_current_tracknum :: Deriver (BlockId, Serial)
get_current_tracknum =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Stack => Text -> Deriver a
throw Text
"get_current_tracknum") forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Maybe (BlockId, Serial))
lookup_current_tracknum

-- | Make a quick trick block stack.
{-# SCC with_stack_block #-}
with_stack_block :: BlockId -> Deriver a -> Deriver a
with_stack_block :: forall a. BlockId -> Deriver a -> Deriver a
with_stack_block = forall a. Frame -> Deriver a -> Deriver a
with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Frame
Stack.Block

-- | Make a quick trick track stack.
{-# SCC with_stack_track #-}
with_stack_track :: TrackId -> Deriver a -> Deriver a
with_stack_track :: forall a. TrackId -> Deriver a -> Deriver a
with_stack_track = forall a. Frame -> Deriver a -> Deriver a
with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> Frame
Stack.Track

{-# SCC with_stack_region #-}
with_stack_region :: ScoreTime -> ScoreTime -> Deriver a -> Deriver a
with_stack_region :: forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
with_stack_region ScoreTime
s ScoreTime
e = forall a. Frame -> Deriver a -> Deriver a
with_stack (ScoreTime -> ScoreTime -> Frame
Stack.Region ScoreTime
s ScoreTime
e)

{-# SCC with_stack_call #-}
with_stack_call :: CallName -> Deriver a -> Deriver a
with_stack_call :: forall a. CallName -> Deriver a -> Deriver a
with_stack_call (CallName Text
name) = forall a. Frame -> Deriver a -> Deriver a
with_stack (Text -> Frame
Stack.Call Text
name)

{-# SCC with_stack_serial #-}
with_stack_serial :: Int -> Deriver a -> Deriver a
with_stack_serial :: forall a. Serial -> Deriver a -> Deriver a
with_stack_serial = forall a. Frame -> Deriver a -> Deriver a
with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Serial -> Frame
Stack.Serial

with_stack :: Stack.Frame -> Deriver a -> Deriver a
with_stack :: forall a. Frame -> Deriver a -> Deriver a
with_stack Frame
frame = forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm forall a b. (a -> b) -> a -> b
$ \Dynamic
st -> do
    Stack
stack <- Deriver Stack
get_stack
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Stack -> Serial
Stack.length Stack
stack forall a. Ord a => a -> a -> Bool
>= Serial
max_depth) forall a b. (a -> b) -> a -> b
$
        forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"call stack too deep: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Frame
frame
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Frame -> Dynamic -> Dynamic
add_stack_frame Frame
frame Dynamic
st
    where
    -- A recursive loop will result in an unfriendly hang.  So limit the total
    -- nesting depth to catch those.  I could disallow all recursion, but this
    -- is more general.
    max_depth :: Serial
max_depth = Serial
100

{- | Add a new stack frame and hash it with the random seed.

    I skip Stack.Call for seed changes.  This is so I can use calls like
    log-seed to record the seed to hardcode it later, which is the whole point
    of doing this thing where I hash on every stack frame.  Otherwise, the
    presence of the log-seed call itself would be enough to change the seed.

    In addition, calculating the seed eagerly this way is actually pretty
    expensive, since the stack is constantly being updated, so updating it
    less frequently is good for performance.  It's possible I could update
    the seed lazily to reduce this cost, but not doing something at all
    is still cheaper than lazy, and can't be accidentally forced.

    The risk is that this makes the seed too stable, and things which should
    be randomized become identical.
-}
add_stack_frame :: Stack.Frame -> Dynamic -> Dynamic
add_stack_frame :: Frame -> Dynamic -> Dynamic
add_stack_frame Frame
frame Dynamic
st = Dynamic
st
    { state_stack :: Stack
state_stack = Frame -> Stack -> Stack
Stack.add Frame
frame (Dynamic -> Stack
state_stack Dynamic
st)
    , state_environ :: Environ
state_environ = (if Frame -> Bool
should_update_seed Frame
frame then Environ -> Environ
update_seed else forall a. a -> a
id)
        (Dynamic -> Environ
state_environ Dynamic
st)
    }
    where
    should_update_seed :: Frame -> Bool
should_update_seed (Stack.Call {}) = Bool
False
    should_update_seed Frame
_ = Bool
True
    update_seed :: Environ -> Environ
update_seed Environ
env =
        Text -> Val -> Environ -> Environ
DeriveT.insert Text
EnvKey.seed (Double -> Val
DeriveT.num (Double -> Double
update Double
old)) Environ
env
        where
        old :: Double
old = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 forall a. Typed a -> a
ScoreT.val_of forall a b. (a -> b) -> a -> b
$
            Val -> Maybe (Typed Double)
DeriveT.constant_val forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Environ -> Maybe Val
DeriveT.lookup Text
EnvKey.seed Environ
env
    update :: Double -> Double
    update :: Double -> Double
update Double
n = Serial -> Double
i2d (forall a. Seed a => Serial -> a -> Serial
Seed.to_seed (forall a b. (RealFrac a, Integral b) => a -> b
floor Double
n) Frame
frame)
    -- A Double should be able to hold up to 2^52, but that's still an
    -- annoyingly large number to write in a score, so restrict it further.
    i2d :: Int -> Double
    i2d :: Serial -> Double
i2d Serial
i = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Serial
i forall a. Integral a => a -> a -> a
`mod` Serial
999)

get_stack :: Deriver Stack.Stack
get_stack :: Deriver Stack
get_stack = forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Stack
state_stack

-- ** time and duration

-- | Times are types that can be converted to RealTime and ScoreTime.
class Time a where
    real :: a -> Deriver RealTime
    score :: a -> Deriver ScoreTime
    to_duration :: a -> DeriveT.Duration

instance Time ScoreTime where
    real :: ScoreTime -> Deriver RealTime
real = ScoreTime -> Deriver RealTime
score_to_real
    score :: ScoreTime -> Deriver ScoreTime
score = forall (m :: * -> *) a. Monad m => a -> m a
return
    to_duration :: ScoreTime -> Duration
to_duration = ScoreTime -> Duration
DeriveT.ScoreDuration

instance Time RealTime where
    real :: RealTime -> Deriver RealTime
real = forall (m :: * -> *) a. Monad m => a -> m a
return
    score :: RealTime -> Deriver ScoreTime
score = RealTime -> Deriver ScoreTime
real_to_score
    to_duration :: RealTime -> Duration
to_duration = RealTime -> Duration
DeriveT.RealDuration

instance Time DeriveT.Duration where
    real :: Duration -> Deriver RealTime
real (DeriveT.RealDuration RealTime
t) = forall a. Time a => a -> Deriver RealTime
real RealTime
t
    real (DeriveT.ScoreDuration ScoreTime
t) = forall a. Time a => a -> Deriver RealTime
real ScoreTime
t
    score :: Duration -> Deriver ScoreTime
score (DeriveT.RealDuration RealTime
t) = forall a. Time a => a -> Deriver ScoreTime
score RealTime
t
    score (DeriveT.ScoreDuration ScoreTime
t) = forall a. Time a => a -> Deriver ScoreTime
score ScoreTime
t
    to_duration :: Duration -> Duration
to_duration = forall a. a -> a
id

-- * warp

in_real_time :: Deriver a -> Deriver a
in_real_time :: forall a. Deriver a -> Deriver a
in_real_time = forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp (forall a b. a -> b -> a
const Warp
Warp.identity)

with_warp :: (Warp.Warp -> Warp.Warp) -> Deriver a -> Deriver a
with_warp :: forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp Warp -> Warp
f = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local forall a b. (a -> b) -> a -> b
$ \Dynamic
st -> Dynamic
st { state_warp :: Warp
state_warp = Warp -> Warp
f (Dynamic -> Warp
state_warp Dynamic
st) }

get_warp :: Deriver Warp.Warp
get_warp :: Deriver Warp
get_warp = forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Warp
state_warp

at :: ScoreTime -> Deriver a -> Deriver a
at :: forall a. ScoreTime -> Deriver a -> Deriver a
at ScoreTime
shift = forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp forall a b. (a -> b) -> a -> b
$ ScoreTime -> Warp -> Warp
Warp.shift ScoreTime
shift

stretch :: ScoreTime -> Deriver a -> Deriver a
stretch :: forall a. ScoreTime -> Deriver a -> Deriver a
stretch ScoreTime
factor = forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp forall a b. (a -> b) -> a -> b
$ ScoreTime -> Warp -> Warp
Warp.stretch ScoreTime
factor

-- | 'at' and 'stretch' in one.  It's a little more efficient than using them
-- separately.  The order is stretch, then shift.
place :: ScoreTime -> ScoreTime -> Deriver a -> Deriver a
place :: forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
place ScoreTime
shift ScoreTime
stretch = forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp forall a b. (a -> b) -> a -> b
$ ScoreTime -> Warp -> Warp
Warp.stretch ScoreTime
stretch forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Warp -> Warp
Warp.shift ScoreTime
shift
    -- Warp.stretch and Warp.shift look like they're in the wrong order here,
    -- but they're not.  "Derive.Warp" for details.

-- | Compose warps.
warp :: Warp.Warp -> Deriver a -> Deriver a
warp :: forall a. Warp -> Deriver a -> Deriver a
warp Warp
w
    | Warp -> Bool
Warp.is_identity Warp
w = forall a. a -> a
id
    | Bool
otherwise = forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp (Warp -> Warp -> Warp
`Warp.compose` Warp
w)

-- ** track warp

-- | Start a new track warp for the current block_id.
--
-- This must be called for each block, and it must be called after the tempo is
-- warped for that block so it can install the new warp.
add_new_track_warp :: Maybe TrackId -> Deriver ()
add_new_track_warp :: Maybe TrackId -> Deriver State Error ()
add_new_track_warp Maybe TrackId
maybe_track_id = do
    Stack
stack <- Deriver Stack
get_stack
    BlockId
block_id <- Deriver BlockId
get_current_block_id
    RealTime
start <- ScoreTime -> Deriver RealTime
score_to_real ScoreTime
0
    -- Use block_event_end instead of block_logical_range.  Otherwise, the play
    -- monitor can't go past the end of the ruler, while the player is
    -- perfectly happy to do so.
    RealTime
end <- forall a. Time a => a -> Deriver RealTime
real forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> Deriver ScoreTime
block_event_end BlockId
block_id
    Warp
warp <- Deriver Warp
get_warp
    let track :: Track
track = RealTime -> RealTime -> Warp -> BlockId -> Maybe TrackId -> Track
TrackWarp.Track RealTime
start RealTime
end Warp
warp BlockId
block_id Maybe TrackId
maybe_track_id
    Collect -> Deriver State Error ()
merge_collect forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { collect_warp_map :: WarpMap
collect_warp_map = forall k a. k -> a -> Map k a
Map.singleton Stack
stack Track
track }

-- | Sub-derived blocks are stretched according to their length, and this
-- function defines the length of a block.  This is therefore the logical
-- duration of the block, which may be shorter or lorger than the end of the
-- last event, or the ruler.
block_logical_range :: BlockId -> Deriver (TrackTime, TrackTime)
block_logical_range :: BlockId -> Deriver (ScoreTime, ScoreTime)
block_logical_range = forall a. Stack => StateId a -> Deriver a
eval_ui forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m (ScoreTime, ScoreTime)
Ui.block_logical_range

-- | Get the duration of the block according to the last event.
block_event_end :: BlockId -> Deriver ScoreTime
block_event_end :: BlockId -> Deriver ScoreTime
block_event_end = forall a. Stack => StateId a -> Deriver a
eval_ui forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m ScoreTime
Ui.block_event_end


-- * track

-- | The deriver strips out tracks that can't be derived because they have no
-- notes.  But that means the track warps and track dynamics aren't recorded,
-- which means they don't have tempo or a playback monitor, which makes them
-- annoying.
record_empty_tracks :: [TrackId] -> Deriver ()
record_empty_tracks :: [TrackId] -> Deriver State Error ()
record_empty_tracks [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
record_empty_tracks [TrackId]
track_ids = do
    BlockId
block_id <- Deriver BlockId
get_current_block_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BlockId -> TrackId -> Deriver State Error ()
record_empty_track BlockId
block_id) [TrackId]
track_ids

record_empty_track :: BlockId -> TrackId -> Deriver ()
record_empty_track :: BlockId -> TrackId -> Deriver State Error ()
record_empty_track BlockId
block_id TrackId
track_id =
    BlockId -> TrackId -> Deriver State Error ()
record_track_dynamic_for BlockId
block_id TrackId
track_id

-- * ControlFunction

-- {-# SCC get_control_function_dynamic #-}
get_control_function_dynamic :: Deriver DeriveT.Dynamic
get_control_function_dynamic :: Deriver Dynamic
get_control_function_dynamic = do
    Marklists
ruler <- Deriver Marklists
get_ruler
    -- let ruler = mempty
    State
state <- forall st err. Deriver st err st
get
    -- Debug.traceM "get_control_function_dynamic" ()
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Marklists -> Dynamic -> Serial -> Dynamic
convert_dynamic Marklists
ruler (State -> Dynamic
state_dynamic State
state)
        (Threaded -> Serial
state_event_serial (State -> Threaded
state_threaded State
state))

convert_dynamic :: Ruler.Marklists -> Dynamic -> Stack.Serial
    -> DeriveT.Dynamic
convert_dynamic :: Marklists -> Dynamic -> Serial -> Dynamic
convert_dynamic Marklists
ruler Dynamic
dyn Serial
serial = DeriveT.Dynamic
    { dyn_pitch :: PSignal
dyn_pitch = Dynamic -> PSignal
state_pitch Dynamic
dyn
    , dyn_environ :: Environ
dyn_environ = Dynamic -> Environ
state_environ Dynamic
dyn
    , dyn_event_serial :: Serial
dyn_event_serial = Serial
serial
    , dyn_warp :: Warp
dyn_warp = Dynamic -> Warp
state_warp Dynamic
dyn
    , dyn_ruler :: Marklists
dyn_ruler = Marklists
ruler
    }

-- | Get the 'Ruler.meter' marklists, if there is a ruler track here.  This
-- is called in all contexts, due to 'control_at', so it has to be careful
-- to not require a ruler.
get_ruler :: Deriver Ruler.Marklists
get_ruler :: Deriver Marklists
get_ruler = Deriver (Maybe (BlockId, Serial))
lookup_current_tracknum forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (BlockId, Serial)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    Just (BlockId
block_id, Serial
tracknum) -> do
        State
state <- forall a. (State -> a) -> Deriver a
get_ui_state forall a. a -> a
id
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. State -> StateId a -> Either Error a
Ui.eval State
state forall a b. (a -> b) -> a -> b
$ do
            RulerId
ruler_id <- forall a. a -> Maybe a -> a
fromMaybe RulerId
Ui.no_ruler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *). M m => BlockId -> Serial -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id Serial
tracknum
            Ruler -> Marklists
Ruler.ruler_marklists forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => RulerId -> m Ruler
Ui.get_ruler RulerId
ruler_id


-- * Threaded

modify_threaded :: (Threaded -> Threaded) -> Deriver ()
modify_threaded :: (Threaded -> Threaded) -> Deriver State Error ()
modify_threaded Threaded -> Threaded
f = forall st err. (st -> st) -> Deriver st err ()
modify forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
    { state_threaded :: Threaded
state_threaded = Threaded -> Threaded
f (State -> Threaded
state_threaded State
state) }

-- | Increment 'state_event_serial'.
increment_event_serial :: Deriver ()
increment_event_serial :: Deriver State Error ()
increment_event_serial = (Threaded -> Threaded) -> Deriver State Error ()
modify_threaded forall a b. (a -> b) -> a -> b
$ \Threaded
threaded -> Threaded
threaded
    { state_event_serial :: Serial
state_event_serial = Threaded -> Serial
state_event_serial Threaded
threaded forall a. Num a => a -> a -> a
+ Serial
1 }


-- * misc

-- | Am I deriving the toplevel block?
is_root_block :: Deriver Bool
is_root_block :: Deriver Bool
is_root_block = Stack -> Bool
is_root_block_stack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Stack
get_stack
    where
    is_root_block_stack :: Stack -> Bool
is_root_block_stack Stack
stack =
        case [BlockId
bid | Stack.Block BlockId
bid <- Stack -> [Frame]
Stack.outermost Stack
stack] of
            [] -> Bool
True
            [BlockId
_] -> Bool
True
            [BlockId]
_ -> Bool
False