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

-- | Examples for integrating with external scores.  This parses a file in
-- a simple format, but if there generator is in haskell it can also be
-- directly imported.
--
-- The easiest way to call the functions in here is to import it into
-- Local/Repl.hs, which should then show up in the REPL.
module Example.Integrate where
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified System.FilePath as FilePath
import qualified Text.Read as Read

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Create as Create
import qualified Cmd.Integrate.Manual as Manual
import qualified Cmd.ModifyNotes as ModifyNotes
import qualified Cmd.Ruler.RulerUtil as RulerUtil
import qualified Cmd.Selection as Selection

import qualified Derive.ShowVal as ShowVal
import qualified Perform.Pitch as Pitch
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.Meter.Meters as Meters
import qualified Ui.Ruler as Ruler
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Ui as Ui

import           Global
import           Types



-- | Read score from the file, and create a new block if it's the first time,
-- or integrate changes the next time.  Changes made to the file should be
-- merged into the block it creates.
integrate_file :: Cmd.CmdT IO (Maybe BlockId)
integrate_file :: CmdT IO (Maybe BlockId)
integrate_file = do
    Score
score <- FilePath -> CmdT IO Score
read_score FilePath
fname
    Maybe BlockId
mb_block_id <- forall (m :: * -> *). M m => Text -> Score -> m (Maybe BlockId)
integrate_score (FilePath -> Text
txt (FilePath -> FilePath
FilePath.takeFileName FilePath
fname)) Score
score
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe BlockId
mb_block_id (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m ViewId
Create.view)
    forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockId
mb_block_id
    where
    fname :: FilePath
fname = FilePath
"Example/integrate-score"

integrate_score :: Ui.M m => Text -> Score -> m (Maybe BlockId)
integrate_score :: forall (m :: * -> *). M m => Text -> Score -> m (Maybe BlockId)
integrate_score Text
name Score
score = do
    BlockId
block_id <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Ui.require Text
"invalid name" forall a b. (a -> b) -> a -> b
$ forall a. Ident a => Id -> Maybe a
Id.make forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Id
Id.id Namespace
namespace Text
name
    -- Make a m44 ruler up to the give end time.  Rulers are not quite as
    -- unreasonably complicated as they used to be.
    let end :: TrackTime
end = Double -> TrackTime
ScoreTime.from_double forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Double
s forall a. Num a => a -> a -> a
+ Double
d | (Double
s, Double
d, Text
_, Double
_) <- Score
score]
    RulerId
ruler_id <- forall (m :: * -> *). M m => BlockId -> ModifyRuler -> m RulerId
RulerUtil.replace BlockId
block_id forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        Meter -> Ruler
Ruler.meter_ruler forall a b. (a -> b) -> a -> b
$ AbstractMeter -> TrackTime -> Int -> TrackTime -> Meter
RulerUtil.meter_until AbstractMeter
Meters.m44 TrackTime
1 Int
4 TrackTime
end
    forall (m :: * -> *).
M m =>
Text -> BlockId -> RulerId -> Text -> Tracks -> m (Maybe BlockId)
Manual.block Text
source_key BlockId
block_id RulerId
ruler_id Text
block_title [(Track
note, [Track]
controls)]
    where
    (Track
note, [Track]
controls) = Text -> NoteTrack -> (Track, [Track])
Manual.convert_note_track Text
source_key (TrackTime -> Score -> NoteTrack
note_track TrackTime
0 Score
score)
    block_title :: Text
block_title = Text
""
    -- See Block.SourceKey
    source_key :: Text
source_key = Text
name
    -- IDs have a namespace, originally so you could merge different scores
    -- without name collisions.  It's also convenient to put all generated
    -- score into its own namespace.
    namespace :: Namespace
namespace = Text -> Namespace
Id.namespace Text
"ex"

-- | Insert 'score' at the selection position.  This is a plain insert, no
-- fancy integration.  It won't clear out any existing notes, so it'll get
-- haphazardly merged if stuff is already there.  This is because it's
-- part of ModifyNotes, which is a general way to do score transformations,
-- and it expects its caller 'ModifyNotes.selection' to have cleared the old
-- notes.
-- insert_at_selection :: Cmd.M m => FilePath -> m ()
insert_at_selection :: FilePath -> Cmd.CmdT IO ()
insert_at_selection :: FilePath -> CmdT IO ()
insert_at_selection FilePath
fname = do
    Score
score <- FilePath -> CmdT IO Score
read_score FilePath
fname
    (BlockId
block_id, Int
_, TrackId
track_id, TrackTime
at) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    forall (m :: * -> *).
M m =>
Score -> BlockId -> TrackId -> TrackTime -> m ()
insert Score
score BlockId
block_id TrackId
track_id TrackTime
at

insert :: Ui.M m => Score -> BlockId -> TrackId -> TrackTime -> m ()
insert :: forall (m :: * -> *).
M m =>
Score -> BlockId -> TrackId -> TrackTime -> m ()
insert Score
score BlockId
block_id TrackId
track_id TrackTime
at =
    forall (m :: * -> *).
M m =>
BlockId -> [TrackId] -> [NoteTrack] -> m ()
ModifyNotes.write_tracks BlockId
block_id [TrackId
track_id] [TrackTime -> Score -> NoteTrack
note_track TrackTime
at Score
score]

-- | Convert the simple score to ModifyNotes.NoteTrack, which is a generic
-- high level representation of the track structure.  Since karya represents
-- pitch and control tracks separately from the notes, they have to be
-- extracted.
note_track :: TrackTime -> Score -> ModifyNotes.NoteTrack
note_track :: TrackTime -> Score -> NoteTrack
note_track TrackTime
offset Score
score = Events -> Controls -> NoteTrack
ModifyNotes.NoteTrack ([(Double, Double, Text)] -> Events
mk_events [(Double, Double, Text)]
notes) Controls
control_tracks
    where
    control_tracks :: Controls
control_tracks = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (ScaleId -> Control
ModifyNotes.Pitch ScaleId
Pitch.empty_scale, [(Double, Double, Text)] -> Events
mk_events [(Double, Double, Text)]
pitches)
        , (Control -> Control
ModifyNotes.Control Control
"dyn", [(Double, Double, Text)] -> Events
mk_events [(Double, Double, Text)]
dyns)
        ]
    notes :: [(Double, Double, Text)]
notes = [(Double
start, Double
dur, Text
"") | (Double
start, Double
dur, Text
_, Double
_) <- Score
score]
    pitches :: [(Double, Double, Text)]
pitches = [(Double
start, Double
0, Text
pitch) | (Double
start, Double
_, Text
pitch, Double
_) <- Score
score]
    dyns :: [(Double, Double, Text)]
dyns = [(Double
start, Double
0, forall a. ShowVal a => a -> Text
ShowVal.show_val Double
dyn) | (Double
start, Double
_, Text
_, Double
dyn) <- Score
score]
    mk_events :: [(Double, Double, Text)] -> Events
mk_events = [Event] -> Events
Events.from_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Real a, Real a) => (a, a, Text) -> Event
mk_event
    mk_event :: (a, a, Text) -> Event
mk_event (a
start, a
dur, Text
text) =
        TrackTime -> TrackTime -> Text -> Event
Event.event (TrackTime
offset forall a. Num a => a -> a -> a
+ forall a b. (Real a, Fractional b) => a -> b
realToFrac a
start) (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
dur) Text
text


-- | Simple score with (start, dur, pitch, dyn).
type Score = [(Double, Double, Text, Double)]

score :: Score
score :: Score
score =
    [ (Double
0, Double
1, Text
"4c", Double
1)
    , (Double
1, Double
1, Text
"4d", Double
0.75)
    ]

read_score :: FilePath -> Cmd.CmdT IO Score
read_score :: FilePath -> CmdT IO Score
read_score FilePath
fname = do
    Text
score <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
Text.IO.readFile FilePath
fname
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Text -> Either Text Score
parse_score Text
score

parse_score :: Text -> Either Text Score
parse_score :: Text -> Either Text Score
parse_score = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {a} {a} {a}.
(Read a, Read a, Read a, Read a) =>
Text -> Either Text (a, a, a, a)
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
    where
    parse :: Text -> Either Text (a, a, a, a)
parse Text
line = case Text -> [Text]
Text.words Text
line of
        [Text
start, Text
dur, Text
pitch, Text
dyn] -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {b}. Either Text b
fail forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
            (,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => Text -> Maybe a
p Text
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Read a => Text -> Maybe a
p Text
dur forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Read a => Text -> Maybe a
p Text
pitch forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Read a => Text -> Maybe a
p Text
dyn
        [Text]
_ -> forall {b}. Either Text b
fail
        where
        fail :: Either Text b
fail = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"can't parse: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
line
    p :: Read a => Text -> Maybe a
    p :: forall a. Read a => Text -> Maybe a
p = forall a. Read a => FilePath -> Maybe a
Read.readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
untxt