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

{- | Simple Events are supposed to be easy to read, and easy to serialize to
    text and load back again.  Functions here convert them to and from text
    form, stashing converted simple blocks in the clipboard.
-}
module Cmd.Simple where
import qualified Data.Map as Map
import qualified Data.Tree as Tree

import qualified Util.Pretty as Pretty
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Selection as Selection
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Instrument.InstT as InstT
import qualified Midi.Midi as Midi
import qualified Perform.Midi.MSignal as MSignal
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Midi.Types as Midi.Types
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Skeleton as Skeleton
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- | Dump a score, or part of a score, to paste into a test.
-- (global_transform, allocations, blocks)
type State = (Text, Allocations, [Block])

-- | (id_name, title, tracks, skeleton)
type Block = (Text, Text, [Maybe Track], [Skeleton.Edge])

-- | (id_name, title, events)
type Track = (Text, Text, [Event])

-- | (start, duration, text)
type Event = (Double, Double, Text)

-- | (start, duration, text, initial_nn)
type ScoreEvent = (Double, Double, String, Maybe Pitch.NoteNumber)

-- | (inst, start, duration, initial_nn)
type PerfEvent = (String, Double, Double, Pitch.NoteNumber)

-- | (instrument, (qualified, [(device, chan)]))
--
-- [] chans means it's UiConfig.Dummy.
--
-- This doesn't include 'Patch.config_settings', so it's assumed they're the
-- same as 'Patch.patch_defaults'.
type Allocations = [(Instrument, (Qualified, Allocation))]
type Instrument = Text
type Qualified = Text
type WriteDevice = Text

data Allocation = Midi [(WriteDevice, Midi.Channel)] | Dummy | Im | Sc
    deriving (Allocation -> Allocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Allocation -> Allocation -> Bool
$c/= :: Allocation -> Allocation -> Bool
== :: Allocation -> Allocation -> Bool
$c== :: Allocation -> Allocation -> Bool
Eq, Int -> Allocation -> ShowS
[Allocation] -> ShowS
Allocation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Allocation] -> ShowS
$cshowList :: [Allocation] -> ShowS
show :: Allocation -> String
$cshow :: Allocation -> String
showsPrec :: Int -> Allocation -> ShowS
$cshowsPrec :: Int -> Allocation -> ShowS
Show)

instance Pretty Allocation where
    format :: Allocation -> Doc
format = \case
        Midi [(Text, Channel)]
allocs -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Midi" [forall a. Pretty a => a -> Doc
Pretty.format [(Text, Channel)]
allocs]
        Allocation
Dummy -> Doc
"Dummy"
        Allocation
Im -> Doc
"Im"
        Allocation
Sc -> Doc
"Sc"

from_score :: ScoreTime -> Double
from_score :: ScoreTime -> Y
from_score = ScoreTime -> Y
ScoreTime.to_double

from_real :: RealTime -> Double
from_real :: RealTime -> Y
from_real = RealTime -> Y
RealTime.to_seconds

event :: Event.Event -> Event
event :: Event -> Event
event Event
e =
    (ScoreTime -> Y
from_score (Event -> ScoreTime
Event.start Event
e), ScoreTime -> Y
from_score (Event -> ScoreTime
Event.duration Event
e), Event -> Text
Event.text Event
e)

score_event :: Score.Event -> ScoreEvent
score_event :: Event -> ScoreEvent
score_event Event
evt =
    ( RealTime -> Y
from_real (Event -> RealTime
Score.event_start Event
evt)
    , RealTime -> Y
from_real (Event -> RealTime
Score.event_duration Event
evt)
    , Text -> String
untxt forall a b. (a -> b) -> a -> b
$ Event -> Text
Score.event_text Event
evt
    , Event -> Maybe NoteNumber
Score.initial_nn Event
evt
    )

perf_event :: Midi.Types.Event -> PerfEvent
perf_event :: Event -> PerfEvent
perf_event Event
evt =
    ( Text -> String
untxt forall a b. (a -> b) -> a -> b
$ Instrument -> Text
ScoreT.instrument_name forall a b. (a -> b) -> a -> b
$ Patch -> Instrument
Midi.Types.patch_name forall a b. (a -> b) -> a -> b
$
        Event -> Patch
Midi.Types.event_patch Event
evt
    , RealTime -> Y
from_real RealTime
start
    , RealTime -> Y
from_real (Event -> RealTime
Midi.Types.event_duration Event
evt)
    , forall a. Real a => a -> NoteNumber
Pitch.nn (RealTime -> Signal -> Y
MSignal.at RealTime
start (Event -> Signal
Midi.Types.event_pitch Event
evt))
    )
    where start :: RealTime
start = Event -> RealTime
Midi.Types.event_start Event
evt

-- * state

dump_state :: Ui.M m => m State
dump_state :: forall (m :: * -> *). M m => m State
dump_state = do
    State
state <- forall (m :: * -> *). M m => m State
Ui.get
    [Block]
blocks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => BlockId -> m Block
dump_block (forall k a. Map k a -> [k]
Map.keys (State -> Map BlockId Block
Ui.state_blocks State
state))
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Text
UiConfig.ky forall f a. Lens f a -> f -> a
#$ State
state
        , Allocations -> Allocations
dump_allocations forall a b. (a -> b) -> a -> b
$ Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> f -> a
#$ State
state
        , [Block]
blocks
        )

load_state :: Ui.M m => State -> m Ui.State
load_state :: forall (m :: * -> *). M m => State -> m State
load_state (Text
ky, Allocations
allocs, [Block]
blocks) =
    forall (m :: * -> *) a.
M m =>
Text -> State -> StateId a -> m State
Ui.exec_rethrow Text
"convert state" State
Ui.empty forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Block -> m BlockId
make_block [Block]
blocks
        forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ (Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Text
UiConfig.ky forall f a. Lens f a -> a -> f -> f
#= Text
ky)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= Allocations -> Allocations
allocations Allocations
allocs)

-- * block

dump_block :: Ui.M m => BlockId -> m Block
dump_block :: forall (m :: * -> *). M m => BlockId -> m Block
dump_block BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    [Maybe Track]
tracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => TracklikeId -> m (Maybe Track)
dump_tracklike (Block -> [TracklikeId]
Block.block_tracklike_ids Block
block)
    TrackTree
tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ident a => a -> Text
Id.ident_text BlockId
block_id, Block -> Text
Block.block_title Block
block, [Maybe Track]
tracks,
        TrackTree -> [Edge]
to_skel TrackTree
tree)
    where
    to_skel :: TrackTree -> [Edge]
to_skel = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree TrackInfo -> [Edge]
go
        where
        go :: Tree TrackInfo -> [Edge]
go (Tree.Node TrackInfo
track TrackTree
subs) =
            [(TrackInfo -> Int
num TrackInfo
track, TrackInfo -> Int
num (forall a. Tree a -> a
Tree.rootLabel Tree TrackInfo
sub)) | Tree TrackInfo
sub <- TrackTree
subs]
            forall a. [a] -> [a] -> [a]
++ TrackTree -> [Edge]
to_skel TrackTree
subs
    num :: TrackInfo -> Int
num = TrackInfo -> Int
Ui.track_tracknum

load_block :: Cmd.M m => Block -> m Ui.State
load_block :: forall (m :: * -> *). M m => Block -> m State
load_block Block
block = forall (m :: * -> *) a.
M m =>
Text -> State -> StateId a -> m State
Ui.exec_rethrow Text
"convert block" State
Ui.empty forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). M m => Block -> m BlockId
make_block Block
block

read_block :: FilePath -> Cmd.CmdT IO Ui.State
read_block :: String -> CmdT IO State
read_block String
fn = do
    Block
simple_block <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Read a => String -> IO a
readIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
fn :: IO Block)
    forall (m :: * -> *). M m => Block -> m State
load_block Block
simple_block

make_block :: Ui.M m => Block -> m BlockId
make_block :: forall (m :: * -> *). M m => Block -> m BlockId
make_block (Text
id_name, Text
title, [Maybe Track]
tracks, [Edge]
skel) = do
    [Track]
tracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => Maybe Track -> m Track
load_tracklike [Maybe Track]
tracks
    BlockId
block_id <- forall (m :: * -> *). M m => Id -> Text -> [Track] -> m BlockId
Ui.create_block (Text -> Id
Id.read_id Text
id_name) Text
title [Track]
tracks
    forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
Ui.set_skeleton BlockId
block_id ([Edge] -> Skeleton
Skeleton.make [Edge]
skel)
    forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
block_id

dump_tracklike :: Ui.M m => Block.TracklikeId -> m (Maybe Track)
dump_tracklike :: forall (m :: * -> *). M m => TracklikeId -> m (Maybe Track)
dump_tracklike =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Track
dump_track) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracklikeId -> Maybe TrackId
Block.track_id_of

load_tracklike :: Ui.M m => Maybe Track -> m Block.Track
load_tracklike :: forall (m :: * -> *). M m => Maybe Track -> m Track
load_tracklike Maybe Track
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TracklikeId -> Int -> Track
Block.track (RulerId -> TracklikeId
Block.RId RulerId
Ui.no_ruler) Int
0
load_tracklike (Just Track
track) = forall (m :: * -> *). M m => Track -> m Track
load_track Track
track

-- * track

dump_track :: Ui.M m => TrackId -> m Track
dump_track :: forall (m :: * -> *). M m => TrackId -> m Track
dump_track TrackId
track_id = do
    Track
track <- forall (m :: * -> *). M m => TrackId -> m Track
Ui.get_track TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (TrackId -> Track -> Track
simplify_track TrackId
track_id Track
track)

simplify_track :: TrackId -> Track.Track -> Track
simplify_track :: TrackId -> Track -> Track
simplify_track TrackId
track_id Track
track =
    (forall a. Ident a => a -> Text
Id.ident_text TrackId
track_id, Track -> Text
Track.track_title Track
track, forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
event [Event]
events)
    where events :: [Event]
events = Events -> [Event]
Events.ascending (Track -> Events
Track.track_events Track
track)

load_track :: Ui.M m => Track -> m Block.Track
load_track :: forall (m :: * -> *). M m => Track -> m Track
load_track (Text
id_name, Text
title, [Event]
events) = do
    TrackId
track_id <- forall (m :: * -> *). M m => Id -> Track -> m TrackId
Ui.create_track (Text -> Id
Id.read_id Text
id_name) forall a b. (a -> b) -> a -> b
$
        Text -> Events -> Track
Track.track Text
title ([Event] -> Events
Events.from_list (forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
load_event [Event]
events))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TracklikeId -> Int -> Track
Block.track (TrackId -> RulerId -> TracklikeId
Block.TId TrackId
track_id RulerId
Ui.no_ruler) Int
Config.track_width

load_event :: Event -> Event.Event
load_event :: Event -> Event
load_event (Y
start, Y
dur, Text
text) =
    ScoreTime -> ScoreTime -> Text -> Event
Event.event (Y -> ScoreTime
ScoreTime.from_double Y
start) (Y -> ScoreTime
ScoreTime.from_double Y
dur) Text
text

dump_selection :: Cmd.CmdL [(TrackId, [Event])]
dump_selection :: CmdL [(TrackId, [Event])]
dump_selection = 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 b. (a -> b) -> [a] -> [b]
map Event -> Event
event)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m SelectedEvents
Selection.events

-- * allocations

dump_allocations :: UiConfig.Allocations -> Allocations
dump_allocations :: Allocations -> Allocations
dump_allocations (UiConfig.Allocations Map Instrument Allocation
allocs) = do
    (Instrument
inst, Allocation
alloc) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Instrument Allocation
allocs
    let simple_alloc :: Allocation
simple_alloc = case Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc of
            UiConfig.Midi Config
config -> [(Text, Channel)] -> Allocation
Midi forall a b. (a -> b) -> a -> b
$ Config -> [(Text, Channel)]
addrs_of Config
config
            Backend
UiConfig.Im -> Allocation
Im
            UiConfig.Dummy {} -> Allocation
Dummy
            Backend
UiConfig.Sc -> Allocation
Sc
    let qualified :: Text
qualified = Qualified -> Text
InstT.show_qualified forall a b. (a -> b) -> a -> b
$ Allocation -> Qualified
UiConfig.alloc_qualified Allocation
alloc
    forall (m :: * -> *) a. Monad m => a -> m a
return (Instrument -> Text
ScoreT.instrument_name Instrument
inst, (Text
qualified, Allocation
simple_alloc))
    where
    addrs_of :: Config -> [(Text, Channel)]
addrs_of Config
config =
        [ (WriteDevice -> Text
Midi.write_device_text WriteDevice
dev, Channel
chan)
        | (WriteDevice
dev, Channel
chan) <- Config -> [(WriteDevice, Channel)]
Patch.config_addrs Config
config
        ]

allocations :: Allocations -> UiConfig.Allocations
allocations :: Allocations -> Allocations
allocations = Map Instrument Allocation -> Allocations
UiConfig.Allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text, (Text, Allocation)) -> (Instrument, Allocation)
allocation

allocation :: (Instrument, (Qualified, Allocation))
    -> (ScoreT.Instrument, UiConfig.Allocation)
allocation :: (Text, (Text, Allocation)) -> (Instrument, Allocation)
allocation (Text
inst, (Text
qual, Allocation
simple_alloc)) =
    (Text -> Instrument
ScoreT.Instrument Text
inst, Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
qualified Backend
backend)
    where
    qualified :: Qualified
qualified = Text -> Qualified
InstT.parse_qualified Text
qual
    backend :: Backend
backend = case Allocation
simple_alloc of
        Allocation
Dummy -> Text -> Backend
UiConfig.Dummy Text
""
        Allocation
Im -> Backend
UiConfig.Im
        Allocation
Sc -> Backend
UiConfig.Sc
        Midi [(Text, Channel)]
addrs -> Config -> Backend
UiConfig.Midi forall a b. (a -> b) -> a -> b
$ [((WriteDevice, Channel), Maybe Int)] -> Config
Patch.config
            [ ((Text -> WriteDevice
Midi.write_device Text
dev, Channel
chan), forall a. Maybe a
Nothing)
            | (Text
dev,Channel
chan) <- [(Text, Channel)]
addrs
            ]


-- * ExactPerfEvent

-- | Like 'PerfEvent', but is meant to recreate a 'Midi.Types.Event' exactly.
type ExactPerfEvent =
    ( Text, RealTime, RealTime, [(Text, [(RealTime, Signal.Y)])]
    , [(RealTime, Signal.Y)], (Signal.Y, Signal.Y), Stack.Stack
    )

dump_exact_perf_event :: Midi.Types.Event -> ExactPerfEvent
dump_exact_perf_event :: Event -> ExactPerfEvent
dump_exact_perf_event (Midi.Types.Event RealTime
start RealTime
dur Patch
patch Map Control Signal
controls Signal
pitch Y
svel Y
evel
        Stack
stack) =
    ( Instrument -> Text
ScoreT.instrument_name (Patch -> Instrument
Midi.Types.patch_name Patch
patch)
    , RealTime
start, RealTime
dur
    , forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Control -> Text
ScoreT.control_name Signal -> [(RealTime, Y)]
MSignal.to_pairs) (forall k a. Map k a -> [(k, a)]
Map.toList Map Control Signal
controls)
    , Signal -> [(RealTime, Y)]
MSignal.to_pairs Signal
pitch
    , (Y
svel, Y
evel)
    , Stack
stack
    )

load_exact_perf_event :: (InstT.Qualified -> Maybe Midi.Types.Patch)
    -> ExactPerfEvent -> Maybe Midi.Types.Event
load_exact_perf_event :: (Qualified -> Maybe Patch) -> ExactPerfEvent -> Maybe Event
load_exact_perf_event Qualified -> Maybe Patch
lookup_patch (Text
inst, RealTime
start, RealTime
dur, [(Text, [(RealTime, Y)])]
controls, [(RealTime, Y)]
pitch,
        (Y
svel, Y
evel), Stack
stack) = do
    Patch
patch <- Qualified -> Maybe Patch
lookup_patch (Text -> Qualified
InstT.parse_qualified Text
inst)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Midi.Types.Event
        { event_patch :: Patch
event_patch = Patch
patch
        , event_start :: RealTime
event_start = RealTime
start
        , event_duration :: RealTime
event_duration = RealTime
dur
        , event_controls :: Map Control Signal
event_controls = [(Text, [(RealTime, Y)])] -> Map Control Signal
control_map [(Text, [(RealTime, Y)])]
controls
        , event_pitch :: Signal
event_pitch = [(RealTime, Y)] -> Signal
MSignal.from_pairs [(RealTime, Y)]
pitch
        , event_start_velocity :: Y
event_start_velocity = Y
svel
        , event_end_velocity :: Y
event_end_velocity = Y
evel
        , event_stack :: Stack
event_stack = Stack
stack
        }

control_map :: [(Text, [(RealTime, Signal.Y)])]
    -> Map ScoreT.Control MSignal.Signal
control_map :: [(Text, [(RealTime, Y)])] -> Map Control Signal
control_map [(Text, [(RealTime, Y)])]
kvs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [(Text -> Control
ScoreT.Control Text
k, [(RealTime, Y)] -> Signal
MSignal.from_pairs [(RealTime, Y)]
vs) | (Text
k, [(RealTime, Y)]
vs) <- [(Text, [(RealTime, Y)])]
kvs]