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

-- | Calls to highlight events.
module Derive.C.Prelude.Highlight (
    library
    , c_highlight_strings_note
    , out_of_range, open_strings, warn_non_open
) where
import qualified Data.Maybe as Maybe

import qualified Util.Test.ApproxEq as ApproxEq
import qualified Derive.Args as Args
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Derive as Derive
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch
import qualified Ui.Color as Color

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
    [ (Symbol
"highlight", Transformer Note
c_highlight)
    , (Symbol
"highlight-strings", Transformer Note
c_highlight_strings)
    , (Symbol
"highlight-out-of-range", Transformer Note
c_highlight_out_of_range)
    ]

c_highlight :: Derive.Transformer Derive.Note
c_highlight :: Transformer Note
c_highlight = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"highlight" forall a. Monoid a => a
mempty
    Doc
"Add a highlight color."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"highlight" Doc
"Highlight code.")
    forall a b. (a -> b) -> a -> b
$ \Highlight
highlight PassedArgs Note
_ Deriver (Stream Note)
deriver -> forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Highlight -> Note -> Note
add_highlight Highlight
highlight) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

instance ShowVal.ShowVal Color.Highlight
instance Typecheck.Typecheck Color.Highlight


-- * open strings

-- | This is a generator that goes on null call, not a transformer over
-- everything.
c_highlight_strings_note :: Derive.Generator Derive.Note
c_highlight_strings_note :: Generator Note
c_highlight_strings_note = CallName
-> Doc -> Tags -> Transformer Note (Stream Note) -> Generator Note
Note.transformed_note_name CallName
"note-highlight"
    (Doc
"Highlight any notes whose initial pitch isn't in "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
EnvKey.open_strings forall a. Semigroup a => a -> a -> a
<> Doc
".")
    forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args Deriver (Stream Note)
deriver -> do
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        ScoreTime -> Deriver (Stream Note) -> Deriver (Stream Note)
out_of_range (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) forall a b. (a -> b) -> a -> b
$ RealTime
-> (Bool -> Maybe Highlight)
-> Deriver (Stream Note)
-> Deriver (Stream Note)
open_strings RealTime
pos Bool -> Maybe Highlight
warn_non_open Deriver (Stream Note)
deriver

c_highlight_strings :: Derive.Transformer Derive.Note
c_highlight_strings :: Transformer Note
c_highlight_strings = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"highlight-strings"
    forall a. Monoid a => a
mempty (Doc
"Highlight any notes whose initial pitch either is or isn't in "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
EnvKey.open_strings forall a. Semigroup a => a -> a -> a
<> Doc
".")
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt
    ( forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"open" EnvironDefault
Sig.Prefixed Bool
False
        Doc
"If true, put Info on open strings, else put Warning on non-open ones."
    ) forall a b. (a -> b) -> a -> b
$ \Bool
highlight_open PassedArgs Note
args Deriver (Stream Note)
deriver -> do
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        RealTime
-> (Bool -> Maybe Highlight)
-> Deriver (Stream Note)
-> Deriver (Stream Note)
open_strings RealTime
pos (if Bool
highlight_open then Bool -> Maybe Highlight
notice_open else Bool -> Maybe Highlight
warn_non_open)
            Deriver (Stream Note)
deriver

warn_non_open :: Bool -> Maybe Color.Highlight
warn_non_open :: Bool -> Maybe Highlight
warn_non_open Bool
open = if Bool
open then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Highlight
Color.Warning

notice_open :: Bool -> Maybe Color.Highlight
notice_open :: Bool -> Maybe Highlight
notice_open Bool
open = if Bool
open then forall a. a -> Maybe a
Just Highlight
Color.Notice else forall a. Maybe a
Nothing

open_strings :: RealTime -> (Bool -> Maybe Color.Highlight)
    -- ^ True if this note is on an open string.
    -> Derive.NoteDeriver -> Derive.NoteDeriver
open_strings :: RealTime
-> (Bool -> Maybe Highlight)
-> Deriver (Stream Note)
-> Deriver (Stream Note)
open_strings RealTime
pos Bool -> Maybe Highlight
highlight Deriver (Stream Note)
deriver = do
    Maybe [Pitch]
maybe_pitches <- forall a. Typecheck a => Key -> Deriver (Maybe a)
Derive.lookup_val Key
EnvKey.open_strings
    Maybe [Transposed]
maybe_pitches <- case Maybe [Pitch]
maybe_pitches of
        Just [Pitch]
pitches -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
pos) [Pitch]
pitches
        Maybe [Pitch]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\[Transposed]
pitches -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ ([Transposed] -> Note -> Note
apply [Transposed]
pitches))) Maybe [Transposed]
maybe_pitches
        Deriver (Stream Note)
deriver
    where
    apply :: [PSignal.Transposed] -> Score.Event -> Score.Event
    apply :: [Transposed] -> Note -> Note
apply [Transposed]
pitches Note
event = case Note -> Maybe NoteNumber
Score.initial_nn Note
event of
        Just NoteNumber
nn -> case Bool -> Maybe Highlight
highlight (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (NoteNumber -> Transposed -> Bool
same_pitch NoteNumber
nn) [Transposed]
pitches) of
            Maybe Highlight
Nothing -> Note
event
            Just Highlight
highlight -> Highlight -> Note -> Note
add_highlight Highlight
highlight Note
event
        Maybe NoteNumber
_ -> Note
event
    same_pitch :: NoteNumber -> Transposed -> Bool
same_pitch NoteNumber
nn Transposed
pitch = case Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn Transposed
pitch of
        Right NoteNumber
string_nn -> forall a. ApproxEq a => Double -> a -> a -> Bool
ApproxEq.eq Double
0.05 NoteNumber
nn NoteNumber
string_nn
        Either PitchError NoteNumber
_ -> Bool
False


-- * out of range

c_highlight_out_of_range :: Derive.Transformer Derive.Note
c_highlight_out_of_range :: Transformer Note
c_highlight_out_of_range = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude
    CallName
"highlight-out-of-range" forall a. Monoid a => a
mempty
    (Doc
"Error on notes whose initial pitch is below "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
EnvKey.instrument_bottom forall a. Semigroup a => a -> a -> a
<> Doc
" or above "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
EnvKey.instrument_top forall a. Semigroup a => a -> a -> a
<> Doc
". The range must be \
        \ in NNs.")
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args Deriver (Stream Note)
deriver -> ScoreTime -> Deriver (Stream Note) -> Deriver (Stream Note)
out_of_range (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) Deriver (Stream Note)
deriver

-- | Highlight with 'Color.Warning' if there is 'EnvKey.instrument_top' or
-- 'EnvKey.instrument_bottom' and the pitch is above or below it,
-- respectively.
out_of_range :: ScoreTime -> Derive.NoteDeriver -> Derive.NoteDeriver
out_of_range :: ScoreTime -> Deriver (Stream Note) -> Deriver (Stream Note)
out_of_range ScoreTime
pos Deriver (Stream Note)
deriver = do
    (Maybe NoteNumber
maybe_top, Maybe NoteNumber
maybe_bottom) <- ScoreTime -> Deriver (Maybe NoteNumber, Maybe NoteNumber)
get_instrument_range ScoreTime
pos
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
Maybe.isNothing [Maybe NoteNumber
maybe_top, Maybe NoteNumber
maybe_bottom] then Deriver (Stream Note)
deriver
        else forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Maybe NoteNumber -> Maybe NoteNumber -> Note -> Note
apply Maybe NoteNumber
maybe_top Maybe NoteNumber
maybe_bottom) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver
    where
    apply :: Maybe NoteNumber -> Maybe NoteNumber -> Note -> Note
apply Maybe NoteNumber
maybe_top Maybe NoteNumber
maybe_bottom Note
event
        | Bool
is_oor = Highlight -> Note -> Note
add_highlight Highlight
Color.Error Note
event
        | Bool
otherwise = Note
event
        where
        is_oor :: Bool
is_oor = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
            NoteNumber
nn <- Note -> Maybe NoteNumber
Score.initial_nn Note
event
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> a -> Bool
<NoteNumber
nn) Maybe NoteNumber
maybe_top
                Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> a -> Bool
>NoteNumber
nn) Maybe NoteNumber
maybe_bottom

get_instrument_range :: ScoreTime
    -> Derive.Deriver (Maybe Pitch.NoteNumber, Maybe Pitch.NoteNumber)
get_instrument_range :: ScoreTime -> Deriver (Maybe NoteNumber, Maybe NoteNumber)
get_instrument_range ScoreTime
pos = do
    (Note -> Maybe Pitch
_parse_p, Pitch -> Maybe Note
show_p, Transposition -> Step -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Step -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
    Maybe NoteNumber
maybe_top <- (Pitch -> Maybe Note)
-> Key -> Deriver State Error (Maybe NoteNumber)
get Pitch -> Maybe Note
show_p Key
EnvKey.instrument_top
    Maybe NoteNumber
maybe_bottom <- (Pitch -> Maybe Note)
-> Key -> Deriver State Error (Maybe NoteNumber)
get Pitch -> Maybe Note
show_p Key
EnvKey.instrument_bottom
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NoteNumber
maybe_top, Maybe NoteNumber
maybe_bottom)
    where
    get :: (Pitch -> Maybe Note)
-> Key -> Deriver State Error (Maybe NoteNumber)
get Pitch -> Maybe Note
show_p Key
key =
        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 a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Pitch -> Maybe Note) -> ScoreTime -> Pitch -> Deriver NoteNumber
resolve_pitch Pitch -> Maybe Note
show_p ScoreTime
pos) forall (m :: * -> *) a. Monad m => a -> m a
return)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Typecheck a => Key -> Deriver (Maybe a)
Derive.lookup_val Key
key

resolve_pitch :: (Pitch.Pitch -> Maybe Pitch.Note) -> ScoreTime -> Pitch.Pitch
    -> Derive.Deriver Pitch.NoteNumber
resolve_pitch :: (Pitch -> Maybe Note) -> ScoreTime -> Pitch -> Deriver NoteNumber
resolve_pitch Pitch -> Maybe Note
show_p ScoreTime
pos = Transposed -> Deriver NoteNumber
Pitches.pitch_nn forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Pitch -> Maybe Note) -> ScoreTime -> Pitch -> Deriver Transposed
Call.eval_pitch Pitch -> Maybe Note
show_p ScoreTime
pos

_initial_pitch :: Scale.Scale -> Score.Event -> Maybe Pitch.Pitch
_initial_pitch :: Scale -> Note -> Maybe Pitch
_initial_pitch Scale
scale Note
event = do
    Note
note <- Note -> Maybe Note
Score.initial_note Note
event
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale forall a. Monoid a => a
mempty Note
note


-- * util

add_highlight :: Color.Highlight -> Score.Event -> Score.Event
add_highlight :: Highlight -> Note -> Note
add_highlight Highlight
highlight Note
event = Note
event
    { event_highlight :: Highlight
Score.event_highlight = Highlight
highlight forall a. Semigroup a => a -> a -> a
<> Note -> Highlight
Score.event_highlight Note
event }