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

-- | Operations on pitch tracks.
--
-- TODO It seems a little arbitrary to divide these cmds out like this.
-- However, they are distinct from Cmd.PitchTrack, so a separate module is
-- good.  I suppose if I need these functions elsewhere I can more them to more
-- generic places.
module Cmd.Repl.LPitch where
import qualified Util.Lists as Lists
import qualified Cmd.Cmd as Cmd
import qualified Cmd.ModifyEvents as ModifyEvents
import qualified Cmd.Perf as Perf
import qualified Cmd.PitchTrack as PitchTrack
import qualified Cmd.Selection as Selection

import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.Twelve as Twelve
import qualified Derive.ShowVal as ShowVal

import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch

import           Global


-- | Turn an nn back to a human-readable note name.
nn_to_note :: Int -> Maybe Pitch.Note
nn_to_note :: Int -> Maybe Note
nn_to_note = NoteNumber -> Maybe Note
Twelve.show_nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- * scales

patch_scale :: Cmd.M m => Pitch.ScaleId -> m Patch.Scale
patch_scale :: forall (m :: * -> *). M m => ScaleId -> m Scale
patch_scale ScaleId
scale_id = (forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. M m => Deriver a -> m (Either Text a)
Perf.derive) forall a b. (a -> b) -> a -> b
$ do
    Scale
scale <- ScaleId -> Deriver Scale
Derive.get_scale ScaleId
scale_id
    [NoteNumber]
nns <- Scale -> Environ -> Deriver [NoteNumber]
Scale.note_numbers Scale
scale forall a. Monoid a => a
mempty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ScaleId -> [NoteNumber] -> Scale
Scale.patch_scale ScaleId
scale_id [NoteNumber]
nns


-- * transpose

-- | Chromatic transposition.
transpose_c :: Cmd.M m => Pitch.Step -> ModifyEvents.Track m
transpose_c :: forall (m :: * -> *). M m => Int -> Track m
transpose_c = forall (m :: * -> *). M m => Transposition -> Int -> Int -> Track m
transpose Transposition
Scale.Chromatic Int
0

-- | Diatonic transposition.
transpose_d :: Cmd.M m => Pitch.Step -> ModifyEvents.Track m
transpose_d :: forall (m :: * -> *). M m => Int -> Track m
transpose_d = forall (m :: * -> *). M m => Transposition -> Int -> Int -> Track m
transpose Transposition
Scale.Diatonic Int
0

-- | Octave transposition.
transpose_o :: Cmd.M m => Pitch.Octave -> ModifyEvents.Track m
transpose_o :: forall (m :: * -> *). M m => Int -> Track m
transpose_o Int
octaves = forall (m :: * -> *). M m => Transposition -> Int -> Int -> Track m
transpose Transposition
Scale.Chromatic Int
octaves Int
0

transpose :: Cmd.M m => Scale.Transposition -> Pitch.Octave -> Pitch.Step
    -> ModifyEvents.Track m
transpose :: forall (m :: * -> *). M m => Transposition -> Int -> Int -> Track m
transpose Transposition
transposition Int
octs Int
steps =
    forall (m :: * -> *). M m => ModifyPitch -> Track m
PitchTrack.pitch_tracks forall a b. (a -> b) -> a -> b
$ Transposition -> Int -> Int -> ModifyPitch
PitchTrack.transpose Transposition
transposition Int
octs Int
steps

-- * modify pitches

modify_pitch :: Cmd.M m => (Pitch.Pitch -> Pitch.Pitch)
    -> ModifyEvents.Track m
modify_pitch :: forall (m :: * -> *). M m => (Pitch -> Pitch) -> Track m
modify_pitch Pitch -> Pitch
modify = forall (m :: * -> *). M m => ModifyPitch -> Track m
PitchTrack.pitch_tracks forall a b. (a -> b) -> a -> b
$ \Scale
scale Environ
env Note
note -> do
    Pitch
pitch <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
note
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Pitch -> Either PitchError Note
Scale.scale_show Scale
scale Environ
env forall a b. (a -> b) -> a -> b
$ Pitch -> Pitch
modify Pitch
pitch

-- | Change notes from one scale to another.  This only makes sense if the
-- scales have the same number of notes per octave.
--
-- TODO it would be nice to change the track title too, but ModifyEvents.Track
-- doesn't support that.  Of course, maybe I want the scale in the block or
-- global transform.
change_scale :: Cmd.M m => Pitch.ScaleId -> m (ModifyEvents.Track m)
change_scale :: forall (m :: * -> *). M m => ScaleId -> m (Track m)
change_scale ScaleId
to_scale_id = do
    (BlockId, Maybe TrackId)
track <- forall (m :: * -> *). M m => m (BlockId, Maybe TrackId)
Selection.track
    Scale
to_scale <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"scale not found"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
(BlockId, Maybe TrackId) -> ScaleId -> m (Maybe Scale)
Perf.lookup_scale (BlockId, Maybe TrackId)
track ScaleId
to_scale_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => ModifyPitch -> Track m
PitchTrack.pitch_tracks forall a b. (a -> b) -> a -> b
$ \Scale
from_scale Environ
env Note
note -> do
        Pitch
pitch <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
from_scale Environ
env Note
note
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Pitch -> Either PitchError Note
Scale.scale_show Scale
to_scale Environ
env Pitch
pitch

-- | Convert the selected absolute pitch track into a relative one by
-- subtracting all the notes from the given base note.
--
-- TODO as above, would be nice to set thet track title.
to_relative :: Cmd.M m => Bool -> Pitch.Note -> ModifyEvents.Track m
to_relative :: forall (m :: * -> *). M m => Bool -> Note -> Track m
to_relative Bool
diatonic Note
base = forall (m :: * -> *). M m => ModifyPitch -> Track m
PitchTrack.pitch_tracks forall a b. (a -> b) -> a -> b
$ \Scale
scale Environ
env Note
note -> do
    Pitch
base <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
base
    Pitch
pitch <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
note
    let layout :: Layout
layout = Scale -> Layout
Scale.scale_layout Scale
scale
    let d :: Int
d = if Bool
diatonic then Layout -> Pitch -> Pitch -> Int
Scale.diatonic_difference Layout
layout Pitch
pitch Pitch
base
            else Layout -> Pitch -> Pitch -> Int
Scale.chromatic_difference Layout
layout Pitch
pitch Pitch
base
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Note
Pitch.Note forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Text
ShowVal.show_val Int
d


-- * enharmonics

-- | Respell enharmonics according to the key.
respell :: Cmd.M m => ModifyEvents.Track m
respell :: forall (m :: * -> *). M m => Track m
respell = forall (m :: * -> *). M m => ModifyPitch -> Track m
PitchTrack.pitch_tracks forall a b. (a -> b) -> a -> b
$ \Scale
scale Environ
env Note
note -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ do
    Pitch
pitch <- Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
note
    Scale -> Environ -> Input -> Either PitchError Note
Scale.scale_input_to_note Scale
scale Environ
env (Pitch -> Input
to_piano_input Pitch
pitch)

to_piano_input :: Pitch.Pitch -> Pitch.Input
to_piano_input :: Pitch -> Input
to_piano_input Pitch
pitch = KbdType -> Pitch -> Frac -> Input
Pitch.Input KbdType
Pitch.PianoKbd (Pitch -> Pitch
to_sharps Pitch
pitch) Frac
0
    where
    to_sharps :: Pitch -> Pitch
to_sharps = Layout -> Int -> Pitch
Theory.semis_to_pitch_sharps Layout
Theory.piano_layout
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Pitch -> Int
Theory.pitch_to_semis Layout
Theory.piano_layout

-- | Convert all sharps to their enharmonic flats.
sharps_to_flats :: Cmd.M m => ModifyEvents.Track m
sharps_to_flats :: forall (m :: * -> *). M m => Track m
sharps_to_flats = forall (m :: * -> *). M m => ModifyPitch -> Track m
PitchTrack.pitch_tracks forall a b. (a -> b) -> a -> b
$ \Scale
scale Environ
env Note
note -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ do
    Pitch
pitch <- Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
note
    if Pitch -> Int
Pitch.pitch_accidentals Pitch
pitch forall a. Ord a => a -> a -> Bool
<= Int
0 then forall (m :: * -> *) a. Monad m => a -> m a
return Note
note else do
        [Note]
notes <- Scale -> Enharmonics
Scale.scale_enharmonics Scale
scale Environ
env Note
note
        [Pitch]
pitches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env) [Note]
notes
        forall err a. err -> Maybe a -> Either err a
justErr (Text -> PitchError
DeriveT.PitchError forall a b. (a -> b) -> a -> b
$ Text
"no flats for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note
note) forall a b. (a -> b) -> a -> b
$
            forall a. [(Pitch, a)] -> Maybe a
e_sharps_to_flats (forall a b. [a] -> [b] -> [(a, b)]
zip [Pitch]
pitches [Note]
notes)

e_sharps_to_flats :: [(Pitch.Pitch, a)] -> Maybe a
e_sharps_to_flats :: forall a. [(Pitch, a)] -> Maybe a
e_sharps_to_flats = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.maximumOn forall {b}. (Pitch, b) -> Int
accs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (Pitch, b) -> Int
accs)
    where accs :: (Pitch, b) -> Int
accs = Pitch -> Int
Pitch.pitch_accidentals forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst