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

{-# LANGUAGE CPP #-}
-- | Post-process 'T.Token's.  Check barlines, resolve ties, etc.
module Derive.TScore.Check (
    Config(..), default_config
    , Scope(..)
    , From(..)
    , AssertCoincident(..)
    , parse_directive, parse_directives
    , apply_block_from
    , check
    , call_block_id
    , Meter(..)
#ifdef TESTING
    , module Derive.TScore.Check
#endif
) where
import qualified Control.Monad.State.Strict as State
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Tuple as Tuple
import qualified Data.Vector as Vector
import qualified Data.Void as Void

import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

import qualified Util.EList as EList
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
import qualified Util.Then as Then

import qualified Cmd.Ruler.Gong as Gong
import qualified Cmd.Ruler.Tala as Tala
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Parse.Instruments as Instruments
import qualified Derive.Scale.Theory as Theory
import qualified Derive.TScore.Parse as Parse
import qualified Derive.TScore.T as T

import qualified Perform.Pitch as Pitch
import qualified Ui.Id as Id
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Meter.Meters as Meters

import           Global
import           Types


data Config = Config {
    Config -> Meter
config_meter :: !Meter
    , Config -> Scale
config_scale :: !Scale
    , Config -> DurationMode
config_duration :: !DurationMode
    , Config -> Maybe From
config_from :: !(Maybe From)
    -- | Use negative durations.  Notes arrive at beats instead of departing
    -- from them.
    , Config -> Bool
config_negative :: !Bool
    , Config -> [Allocation]
config_instruments :: ![Instruments.Allocation]
    , Config -> Text
config_ky :: !Text
    } deriving (PitchClass -> Config -> ShowS
[Config] -> ShowS
Config -> [Char]
forall a.
(PitchClass -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> [Char]
$cshow :: Config -> [Char]
showsPrec :: PitchClass -> Config -> ShowS
$cshowsPrec :: PitchClass -> Config -> ShowS
Show)

-- | The target of a 'T.CopyFrom'.
data From = From {
    From -> Maybe BlockId
from_block :: !(Maybe Id.BlockId)
    , From -> PitchClass
from_tracknum :: !TrackNum
    , From -> Pos
from_pos :: !T.Pos
    } deriving (PitchClass -> From -> ShowS
[From] -> ShowS
From -> [Char]
forall a.
(PitchClass -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [From] -> ShowS
$cshowList :: [From] -> ShowS
show :: From -> [Char]
$cshow :: From -> [Char]
showsPrec :: PitchClass -> From -> ShowS
$cshowsPrec :: PitchClass -> From -> ShowS
Show)

instance Pretty From where
    pretty :: From -> Text
pretty (From Maybe BlockId
block PitchClass
tracknum Pos
_) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((forall a. Semigroup a => a -> a -> a
<>Text
":") forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Text
Parse.show_block) Maybe BlockId
block forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt PitchClass
tracknum

default_config :: Config
default_config :: Config
default_config = Config
    { config_meter :: Meter
config_meter = Meter
meter_44
    , config_scale :: Scale
config_scale = Scale
scale_sargam
    , config_duration :: DurationMode
config_duration = DurationMode
Multiplicative
    , config_from :: Maybe From
config_from = forall a. Maybe a
Nothing
    , config_negative :: Bool
config_negative = Bool
False
    , config_instruments :: [Allocation]
config_instruments = []
    , config_ky :: Text
config_ky = Text
""
    }

parse_directives :: Scope -> Config -> [T.Directive] -> Either T.Error Config
parse_directives :: Scope -> Config -> [Directive] -> Either Error Config
parse_directives Scope
scope = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Scope -> Directive -> Config -> Either Error Config
parse_directive Scope
scope))

-- | Directives can appear in various places, which affects their scope.
data Scope = Global | Block | Track
    deriving (Scope -> Scope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c== :: Scope -> Scope -> Bool
Eq, PitchClass -> Scope -> ShowS
[Scope] -> ShowS
Scope -> [Char]
forall a.
(PitchClass -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Scope] -> ShowS
$cshowList :: [Scope] -> ShowS
show :: Scope -> [Char]
$cshow :: Scope -> [Char]
showsPrec :: PitchClass -> Scope -> ShowS
$cshowsPrec :: PitchClass -> Scope -> ShowS
Show)

parse_directive :: Scope -> T.Directive -> Config -> Either T.Error Config
parse_directive :: Scope -> Directive -> Config -> Either Error Config
parse_directive Scope
scope (T.Directive Pos
pos Text
name Maybe Text
maybe_val) Config
config =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Pos -> Text -> Error
T.Error Pos
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
nameforall a. Semigroup a => a -> a -> a
<>Text
": ")<>)) forall a b. (a -> b) -> a -> b
$ case Text
name of
        Text
"dur" -> forall {f :: * -> *} {a} {b}.
MonadError Text f =>
(Config -> a -> b) -> (Text -> Maybe a) -> Text -> f b
set_config (\Config
c DurationMode
a -> Config
c { config_duration :: DurationMode
config_duration = DurationMode
a })
            (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Text DurationMode
duration_map) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Text
with_arg
        -- f for from.  This is abbreviated because it shows up per-track.
        Text
"f" -> do
            From
from <- Scope -> Pos -> Text -> Either Text From
parse_from Scope
scope Pos
pos forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Text
with_arg
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config
config { config_from :: Maybe From
config_from = forall a. a -> Maybe a
Just From
from }
        Text
"meter" -> forall {f :: * -> *} {a} {b}.
MonadError Text f =>
(Config -> a -> b) -> (Text -> Maybe a) -> Text -> f b
set_config (\Config
c Meter
a -> Config
c { config_meter :: Meter
config_meter = Meter
a }) Text -> Maybe Meter
parse_meter
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Text
with_arg
        Text
"negative" -> Either Text ()
without_arg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Config
config { config_negative :: Bool
config_negative = Bool
True })
        Text
"scale" -> forall {f :: * -> *} {a} {b}.
MonadError Text f =>
(Config -> a -> b) -> (Text -> Maybe a) -> Text -> f b
set_config (\Config
c Scale
a -> Config
c { config_scale :: Scale
config_scale = Scale
a })
            (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Text Scale
scale_map) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Text
with_arg
        Text
"instruments" -> do
            Either Text ()
require_toplevel
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> [Allocation]
config_instruments Config
config)) forall a b. (a -> b) -> a -> b
$
                forall a b. a -> Either a b
Left Text
"should only be one %instruments"
            Text
val <- Either Text Text
with_arg
            [Allocation]
allocs <- Text -> Either Text [Allocation]
parse_instruments Text
val
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config
config { config_instruments :: [Allocation]
config_instruments = [Allocation]
allocs }
        Text
"ky" -> do
            Either Text ()
require_toplevel
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Text
config_ky Config
config forall a. Eq a => a -> a -> Bool
== Text
"") forall a b. (a -> b) -> a -> b
$
                forall a b. a -> Either a b
Left Text
"should only be one %ky"
            forall {f :: * -> *} {a} {b}.
MonadError Text f =>
(Config -> a -> b) -> (Text -> Maybe a) -> Text -> f b
set_config (\Config
c Text
a -> Config
c { config_ky :: Text
config_ky = Text
a }) forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Text
with_arg
        -- default_call affects parsing, so I don't handle it here, but
        -- I can make sure it doesn't have an argument.
        Text
_ | Text
name forall a. Eq a => a -> a -> Bool
== Text
Parse.default_call -> Either Text ()
without_arg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Config
config
        Text
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"unknown directive: " forall a. Semigroup a => a -> a -> a
<> Text
name
    where
    require_toplevel :: Either Text ()
require_toplevel = case Scope
scope of
        Scope
Global -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Scope
_ -> forall a b. a -> Either a b
Left Text
"must be at global scope"
    with_arg :: Either Text Text
with_arg = forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Text
"expected arg" Maybe Text
maybe_val
    without_arg :: Either Text ()
without_arg = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right ()) (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"unexpected arg: "<>)) Maybe Text
maybe_val
    set_config :: (Config -> a -> b) -> (Text -> Maybe a) -> Text -> f b
set_config Config -> a -> b
setter Text -> Maybe a
parse Text
val = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Config -> a -> b
setter Config
config) (forall {m :: * -> *} {a}.
MonadError Text m =>
(Text -> Maybe a) -> Text -> m a
lookup Text -> Maybe a
parse Text
val)
    lookup :: (Text -> Maybe a) -> Text -> m a
lookup Text -> Maybe a
parse Text
val = forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"unknown " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
val) (Text -> Maybe a
parse Text
val)

parse_instruments :: Text -> Either Text [Instruments.Allocation]
parse_instruments :: Text -> Either Text [Allocation]
parse_instruments Text
val = do
    -- Instrument parsing is line-oriented, which is awkward with the
    -- usuall comment/whitespace handling, so I have to account for
    -- comment-only lines.
    let empty :: Text -> Bool
empty = Text -> Bool
Text.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Parse.strip_comment
    [Allocation]
allocs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Show a => (a, Text) -> Either Text Allocation
parse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Text
Text.strip) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
val
    let dups :: [Instrument]
dups = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>PitchClass
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> PitchClass
length) forall a b. (a -> b) -> a -> b
$ forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Lists.groupSort forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map Allocation -> Instrument
Instruments.alloc_name [Allocation]
allocs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Instrument]
dups) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"duplicate instrument definitions: "
            forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Instrument]
dups)
    forall (m :: * -> *) a. Monad m => a -> m a
return [Allocation]
allocs
    where
    parse :: (a, Text) -> Either Text Allocation
parse (a
n, Text
s) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((Text
"alloc " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
n forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt) forall a b. (a -> b) -> a -> b
$
        Text -> Either [Char] Allocation
Parse.parse_allocation Text
s

parse_from :: Scope -> T.Pos -> Text -> Either Text From
parse_from :: Scope -> Pos -> Text -> Either Text From
parse_from Scope
scope Pos
pos Text
arg = case Scope
scope of
    Scope
Global -> forall a b. a -> Either a b
Left Text
"can't use at global scope"
    Scope
Block -> do
        BlockId
block_id <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"not a valid block_id: " forall a. Semigroup a => a -> a -> a
<> Text
arg) 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.read_short Namespace
Parse.default_namespace Text
arg
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ From
            { from_block :: Maybe BlockId
from_block = forall a. a -> Maybe a
Just BlockId
block_id
            , from_tracknum :: PitchClass
from_tracknum = PitchClass
0
            , from_pos :: Pos
from_pos = Pos
pos
            }
    Scope
Track -> do
        PitchClass
tracknum <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"not a tracknum: " forall a. Semigroup a => a -> a -> a
<> Text
arg) forall a b. (a -> b) -> a -> b
$ Text -> Maybe PitchClass
ParseText.int Text
arg
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PitchClass
tracknum forall a. Ord a => a -> a -> Bool
<= PitchClass
0) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"tracknums start at 1"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ From
            { from_block :: Maybe BlockId
from_block = forall a. Maybe a
Nothing
            , from_tracknum :: PitchClass
from_tracknum = PitchClass
tracknum
            , from_pos :: Pos
from_pos = Pos
pos
            }

-- | Convert a block-level From into a track-level From for each tracknum.
-- Due to 'parse_from', the block From should have a 'from_block'.  It's ok
-- to have both block and track From, in this case the track From gives the
-- tracknum from a different block.
apply_block_from :: Config -> TrackNum -> Config -> Config
apply_block_from :: Config -> PitchClass -> Config -> Config
apply_block_from Config
block_config PitchClass
tracknum Config
track_config =
    Maybe From -> Config
set forall a b. (a -> b) -> a -> b
$ case (Config -> Maybe From
config_from Config
block_config, Config -> Maybe From
config_from Config
track_config) of
        (Maybe From
Nothing, Maybe From
mb_track) -> Maybe From
mb_track
        (Just From
block, Maybe From
Nothing) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ From
block { from_tracknum :: PitchClass
from_tracknum = PitchClass
tracknum }
        -- If the block had a From, the track will have inherited it.
        (Just From
block, Just From
track) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ From
track
            { from_block :: Maybe BlockId
from_block = From -> Maybe BlockId
from_block From
block
            , from_tracknum :: PitchClass
from_tracknum = if From -> PitchClass
from_tracknum From
track forall a. Eq a => a -> a -> Bool
/= PitchClass
0
                then From -> PitchClass
from_tracknum From
track else PitchClass
tracknum
            }
    where set :: Maybe From -> Config
set Maybe From
from = Config
track_config { config_from :: Maybe From
config_from = Maybe From
from }

-- * check

type Stream a = [EList.Elt Meta a]
type Token call pitch dur = T.Token call pitch dur dur
type Meta = Either T.Error AssertCoincident

type NPitch = T.NPitch T.Pitch

type GetCallDuration = Text -> (Either Text T.Time, [Log.Msg])

mkerror :: T.Pos -> Text -> EList.Elt Meta a
mkerror :: forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos Text
msg = forall e a. e -> Elt e a
EList.Meta forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error Pos
pos Text
msg

data AssertCoincident = AssertCoincident !T.Time !T.Pos
    deriving (AssertCoincident -> AssertCoincident -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AssertCoincident -> AssertCoincident -> Bool
$c/= :: AssertCoincident -> AssertCoincident -> Bool
== :: AssertCoincident -> AssertCoincident -> Bool
$c== :: AssertCoincident -> AssertCoincident -> Bool
Eq, PitchClass -> AssertCoincident -> ShowS
[AssertCoincident] -> ShowS
AssertCoincident -> [Char]
forall a.
(PitchClass -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AssertCoincident] -> ShowS
$cshowList :: [AssertCoincident] -> ShowS
show :: AssertCoincident -> [Char]
$cshow :: AssertCoincident -> [Char]
showsPrec :: PitchClass -> AssertCoincident -> ShowS
$cshowsPrec :: PitchClass -> AssertCoincident -> ShowS
Show)

check :: GetCallDuration -> Config
    -> [T.Token T.CallText NPitch T.NDuration T.Duration]
    -> ( [Either Meta
            (T.Time, T.Note T.CallText (T.NPitch (Maybe T.PitchText)) T.Time)]
       , T.Time
       )
check :: GetCallDuration
-> Config
-> [Token Text NPitch NDuration Duration]
-> ([Either Meta (Time, Note Text (NPitch (Maybe Text)) Time)],
    Time)
check GetCallDuration
get_dur (Config Meter
meter Scale
scale DurationMode
dur_mode Maybe From
_ Bool
negative [Allocation]
_instruments Text
_ky) =
    forall a b. (a, b) -> (b, a)
Tuple.swap
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall e a. Elt e a -> Either e a
EList.toEither)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall time call dur.
Scale
-> Stream (time, Note call NPitch dur)
-> Stream (time, Note call (NPitch (Maybe Text)) dur)
resolve_pitch Scale
scale)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
negative then forall call pitch.
(Time, Stream (Time, Note call pitch Time))
-> (Time, Stream (Time, Note call pitch Time))
time_to_negative else forall a. a -> a
id)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pitch call.
(Eq pitch, Pretty pitch) =>
Stream (Token call pitch (Time, Bool))
-> (Time, Stream (Time, Note call pitch Time))
resolve_time
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call pitch tie.
Meter
-> Stream (Token call pitch (Time, tie))
-> Stream (Token call pitch (Time, tie))
check_barlines Meter
meter
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call pitch.
DurationMode
-> Stream (Token call pitch (Either Time Duration) Duration)
-> Stream (Token call pitch (Time, Bool) (Time, Bool))
resolve_duration DurationMode
dur_mode
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pitch rdur.
GetCallDuration
-> Stream (Token Text pitch NDuration rdur)
-> Stream (Token Text pitch (Either Time Duration) rdur)
resolve_call_duration GetCallDuration
get_dur
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pitch.
Stream (Token Text pitch NDuration Duration)
-> Stream (Token Text pitch NDuration Duration)
carry_call_duration
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream (Token Text NPitch NDuration Duration)
-> Stream (Token Text NPitch NDuration Duration)
resolve_repeats
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall e a. a -> Elt e a
EList.Elt

-- * time

-- | Carry CallDuration if the next note has no duration, but does have a call.
carry_call_duration
    :: Stream (T.Token T.CallText pitch T.NDuration T.Duration)
    -> Stream (T.Token T.CallText pitch T.NDuration T.Duration)
carry_call_duration :: forall pitch.
Stream (Token Text pitch NDuration Duration)
-> Stream (Token Text pitch NDuration Duration)
carry_call_duration = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
State.evalState Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b e.
Applicative m =>
(a -> m b) -> [Elt e a] -> m [Elt e b]
EList.mapM (forall (m :: * -> *) call1 pitch1 ndur call2 pitch2 rdur.
Applicative m =>
(Note call1 pitch1 ndur -> m (Note call2 pitch2 ndur))
-> Token call1 pitch1 ndur rdur -> m (Token call2 pitch2 ndur rdur)
T.map_note forall {m :: * -> *} {call} {pitch}.
(MonadState Bool m, Eq call, IsString call) =>
Note call pitch NDuration -> m (Note call pitch NDuration)
carry)
    where
    carry :: Note call pitch NDuration -> m (Note call pitch NDuration)
carry Note call pitch NDuration
note = do
        NDuration
dur <- case forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch NDuration
note of
            NDuration
T.CallDuration -> do
                forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Bool
True
                forall (m :: * -> *) a. Monad m => a -> m a
return NDuration
T.CallDuration
            T.NDuration Duration
dur
                | forall {a} {pitch} {dur}.
(Eq a, IsString a) =>
Note a pitch dur -> Duration -> Bool
can_carry Note call pitch NDuration
note Duration
dur -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM forall s (m :: * -> *). MonadState s m => m s
State.get
                    (forall (m :: * -> *) a. Monad m => a -> m a
return NDuration
T.CallDuration)
                    (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Duration -> NDuration
T.NDuration Duration
dur)
                | Bool
otherwise -> forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> NDuration
T.NDuration Duration
dur)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Note call pitch NDuration
note { note_duration :: NDuration
T.note_duration = NDuration
dur }
    can_carry :: Note a pitch dur -> Duration -> Bool
can_carry Note a pitch dur
note Duration
dur = forall call pitch dur. Note call pitch dur -> call
T.note_call Note a pitch dur
note forall a. Eq a => a -> a -> Bool
/= a
""
        Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
Maybe.isNothing [Duration -> Maybe PitchClass
T.dur_int1 Duration
dur, Duration -> Maybe PitchClass
T.dur_int2 Duration
dur]

resolve_call_duration :: GetCallDuration
    -> Stream (T.Token T.CallText pitch T.NDuration rdur)
    -> Stream (T.Token T.CallText pitch (Either T.Time T.Duration) rdur)
resolve_call_duration :: forall pitch rdur.
GetCallDuration
-> Stream (Token Text pitch NDuration rdur)
-> Stream (Token Text pitch (Either Time Duration) rdur)
resolve_call_duration GetCallDuration
get_dur = forall a e b. (a -> [Elt e b]) -> [Elt e a] -> [Elt e b]
EList.concatMapE forall a b. (a -> b) -> a -> b
$ \case
    T.TBarline Pos
pos Barline
a -> [forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall call pitch ndur rdur.
Pos -> Barline -> Token call pitch ndur rdur
T.TBarline Pos
pos Barline
a]
    T.TRest Pos
pos Rest rdur
a -> [forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall call pitch ndur rdur.
Pos -> Rest rdur -> Token call pitch ndur rdur
T.TRest Pos
pos Rest rdur
a]
    T.TNote Pos
pos Note Text pitch NDuration
note ->
        forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {ndur} {rdur}. ndur -> Token Text pitch ndur rdur
set) (Pos -> Text -> NDuration -> [Elt Meta (Either Time Duration)]
resolve Pos
pos (forall call pitch dur. Note call pitch dur -> call
T.note_call Note Text pitch NDuration
note) (forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note Text pitch NDuration
note))
        where set :: ndur -> Token Text pitch ndur rdur
set ndur
dur = forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos forall a b. (a -> b) -> a -> b
$ Note Text pitch NDuration
note { note_duration :: ndur
T.note_duration = ndur
dur }
    where
    resolve :: Pos -> Text -> NDuration -> [Elt Meta (Either Time Duration)]
resolve Pos
_ Text
_ (T.NDuration Duration
dur) = [forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Duration
dur]
    resolve Pos
pos Text
call NDuration
T.CallDuration
        | Text -> Bool
Text.null Text
call =
            [forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos Text
"can't get call duration of empty call"]
        | Bool
otherwise = case GetCallDuration
get_dur Text
call of
            (Left Text
err, [Msg]
logs) -> forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos Text
err forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Msg -> Elt Meta a
to_error [Msg]
logs
            (Right Time
time, [Msg]
logs) -> forall e a. a -> Elt e a
EList.Elt (forall a b. a -> Either a b
Left Time
time) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Msg -> Elt Meta a
to_error [Msg]
logs
        where to_error :: Msg -> Elt Meta a
to_error = forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Text
Log.format_msg

call_block_id :: Id.BlockId -> Text -> Maybe Id.BlockId
call_block_id :: BlockId -> Text -> Maybe BlockId
call_block_id BlockId
parent =
    Namespace -> Maybe BlockId -> Symbol -> Maybe BlockId
Eval.call_to_block_id Namespace
Parse.default_namespace (forall a. a -> Maybe a
Just BlockId
parent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Symbol
Expr.Symbol

resolve_repeats
    :: Stream (T.Token T.CallText NPitch T.NDuration T.Duration)
    -> Stream (T.Token T.CallText NPitch T.NDuration T.Duration)
resolve_repeats :: Stream (Token Text NPitch NDuration Duration)
-> Stream (Token Text NPitch NDuration Duration)
resolve_repeats =
    forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state a e b.
(state -> a -> (state, Elt e b))
-> state -> [Elt e a] -> (state, [Elt e b])
EList.mapAccumLE forall {rdur}.
Maybe (Note Text NPitch NDuration)
-> Token Text NPitch NDuration rdur
-> (Maybe (Note Text NPitch NDuration),
    Elt Meta (Token Text NPitch NDuration rdur))
resolve_dot forall a. Maybe a
Nothing
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {rdur}.
(Token Text NPitch NDuration rdur,
 Maybe (Note Text NPitch NDuration))
-> Token Text NPitch NDuration rdur
resolve_tie) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call pitch ndur rdur.
Stream (Token call pitch ndur rdur)
-> Stream
     (Token call pitch ndur rdur, Maybe (Note call pitch ndur))
zip_next_note
    where
    resolve_tie :: (Token Text NPitch NDuration rdur,
 Maybe (Note Text NPitch NDuration))
-> Token Text NPitch NDuration rdur
resolve_tie (T.TNote Pos
pos Note Text NPitch NDuration
note, Just Note Text NPitch NDuration
next)
        | forall {call} {pitch} {dur}.
Note call pitch dur -> Note call pitch dur
strip Note Text NPitch NDuration
next forall a. Eq a => a -> a -> Bool
== Note Text NPitch NDuration
Parse.tie_note = forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos forall a b. (a -> b) -> a -> b
$ forall {call} {pitch}.
Bool -> Note call pitch NDuration -> Note call pitch NDuration
set_tie Bool
True Note Text NPitch NDuration
note
    resolve_tie (T.TNote Pos
pos Note Text NPitch NDuration
note, Maybe (Note Text NPitch NDuration)
_)
        -- Normalize Parse.tie_note to a Parse.dot_note, since the tie part has
        -- been handled in the previous equation.  It's important to do this
        -- here, so I only normalize "original" 'Parse.tie_note's, not tied
        -- notes created by the previous equation, which is what happens with
        -- two 'Parse.tie_note's in a row.
        | forall {call} {pitch} {dur}.
Note call pitch dur -> Note call pitch dur
strip Note Text NPitch NDuration
note forall a. Eq a => a -> a -> Bool
== Note Text NPitch NDuration
Parse.tie_note = forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos Note Text NPitch NDuration
Parse.dot_note
    resolve_tie (Token Text NPitch NDuration rdur
token, Maybe (Note Text NPitch NDuration)
_) = Token Text NPitch NDuration rdur
token
    -- x ~ .    (tie, no, no)
    -- x . ~    (no, tie, no)
    -- x ~ ~    (tie, tie, no)
    -- x~ . .   (tie, no, no)
    -- So don't inherit the tie from the prev note, get it from the current
    -- note.
    resolve_dot :: Maybe (Note Text NPitch NDuration)
-> Token Text NPitch NDuration rdur
-> (Maybe (Note Text NPitch NDuration),
    Elt Meta (Token Text NPitch NDuration rdur))
resolve_dot Maybe (Note Text NPitch NDuration)
mb_prev token :: Token Text NPitch NDuration rdur
token@(T.TNote Pos
pos Note Text NPitch NDuration
note)
        | forall {call} {pitch} {dur}.
Note call pitch dur -> Note call pitch dur
strip Note Text NPitch NDuration
note forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Note Text NPitch NDuration]
repeat_notes = case Maybe (Note Text NPitch NDuration)
mb_prev of
            Just Note Text NPitch NDuration
prev ->
                ( Maybe (Note Text NPitch NDuration)
mb_prev
                , forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos (forall {call} {pitch}.
Bool -> Note call pitch NDuration -> Note call pitch NDuration
set_tie Bool
tied (forall {call} {pitch}.
PitchClass
-> Note call pitch NDuration -> Note call pitch NDuration
set_dots PitchClass
0 Note Text NPitch NDuration
prev))
                )
                where tied :: Bool
tied = forall {call} {pitch} {dur}.
Note call pitch dur -> Note call pitch dur
strip Note Text NPitch NDuration
note forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Note Text NPitch NDuration
tie_dot_note, Note Text NPitch NDuration
Parse.tie_note]
            Maybe (Note Text NPitch NDuration)
Nothing ->
                ( Maybe (Note Text NPitch NDuration)
mb_prev
                , forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos Text
"repeat with no previous note"
                )

        | Bool
otherwise = (forall a. a -> Maybe a
Just Note Text NPitch NDuration
note, forall e a. a -> Elt e a
EList.Elt Token Text NPitch NDuration rdur
token)
    resolve_dot Maybe (Note Text NPitch NDuration)
mb_prev Token Text NPitch NDuration rdur
token = (Maybe (Note Text NPitch NDuration)
mb_prev, forall e a. a -> Elt e a
EList.Elt Token Text NPitch NDuration rdur
token)

    strip :: Note call pitch dur -> Note call pitch dur
strip Note call pitch dur
note = Note call pitch dur
note { note_pos :: Pos
T.note_pos = PitchClass -> Pos
T.Pos PitchClass
0 }
    repeat_notes :: [Note Text NPitch NDuration]
repeat_notes = [Note Text NPitch NDuration
Parse.dot_note, Note Text NPitch NDuration
Parse.tie_note, Note Text NPitch NDuration
tie_dot_note]
    tie_dot_note :: Note Text NPitch NDuration
tie_dot_note = forall {call} {pitch}.
Bool -> Note call pitch NDuration -> Note call pitch NDuration
set_tie Bool
True Note Text NPitch NDuration
Parse.dot_note
    set_tie :: Bool -> Note call pitch NDuration -> Note call pitch NDuration
set_tie Bool
tie = forall call pitch.
(Duration -> Duration)
-> Note call pitch NDuration -> Note call pitch NDuration
modify_duration forall a b. (a -> b) -> a -> b
$ \Duration
dur -> Duration
dur { dur_tie :: Bool
T.dur_tie = Bool
tie }
    set_dots :: PitchClass
-> Note call pitch NDuration -> Note call pitch NDuration
set_dots PitchClass
n = forall call pitch.
(Duration -> Duration)
-> Note call pitch NDuration -> Note call pitch NDuration
modify_duration forall a b. (a -> b) -> a -> b
$ \Duration
dur -> Duration
dur { dur_dots :: PitchClass
T.dur_dots = PitchClass
n }

zip_next_note :: Stream (T.Token call pitch ndur rdur)
    -> Stream (T.Token call pitch ndur rdur, Maybe (T.Note call pitch ndur))
zip_next_note :: forall call pitch ndur rdur.
Stream (Token call pitch ndur rdur)
-> Stream
     (Token call pitch ndur rdur, Maybe (Note call pitch ndur))
zip_next_note = forall a b e. (a -> b) -> [Elt e a] -> [Elt e b]
EList.map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {call} {pitch} {ndur} {rdur}.
Token call pitch ndur rdur -> Maybe (Note call pitch ndur)
note_of)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. [Elt e a] -> [Elt e (a, [a])]
EList.zipNexts
    where
    note_of :: Token call pitch ndur rdur -> Maybe (Note call pitch ndur)
note_of (T.TNote Pos
_ Note call pitch ndur
n) = forall a. a -> Maybe a
Just Note call pitch ndur
n
    note_of Token call pitch ndur rdur
_ = forall a. Maybe a
Nothing

modify_duration :: (T.Duration -> T.Duration) -> T.Note call pitch T.NDuration
    -> T.Note call pitch T.NDuration
modify_duration :: forall call pitch.
(Duration -> Duration)
-> Note call pitch NDuration -> Note call pitch NDuration
modify_duration Duration -> Duration
modify Note call pitch NDuration
note =
    Note call pitch NDuration
note { note_duration :: NDuration
T.note_duration = NDuration -> NDuration
set (forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch NDuration
note) }
    where
    set :: NDuration -> NDuration
set (T.NDuration Duration
dur) = Duration -> NDuration
T.NDuration (Duration -> Duration
modify Duration
dur)
    set NDuration
T.CallDuration = NDuration
T.CallDuration

-- ** meter

data Meter = Meter {
    -- | Rank pattern.
    --
    -- Adi: [2, 0, 0, 0, 1, 0, 0, 1, 0, 0]
    -- > || ssss rrrr gggg mmmm | pppp dddd | nnnn sssss ||
    -- 4/4: [1, 0, 0, 0]
    -- > | ssss rrrr gggg mmmm |
    Meter -> [PitchClass]
meter_pattern :: [T.Rank]
    -- | This is the duration one one element of 'meter_pattern'.
    , Meter -> Time
meter_step :: !T.Time
    -- | If true, beats fall at the end of measures.
    -- TODO has no effect yet, not even sure what it would be for
    , Meter -> Bool
meter_negative :: !Bool
    -- | Meter as used by the UI.
    -- TODO redundant with meter_pattern, merge them?
    , Meter -> (Config, MSection)
meter_ui :: !(Meter.Config, Meter.MSection)
    } deriving (Meter -> Meter -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Meter -> Meter -> Bool
$c/= :: Meter -> Meter -> Bool
== :: Meter -> Meter -> Bool
$c== :: Meter -> Meter -> Bool
Eq, PitchClass -> Meter -> ShowS
[Meter] -> ShowS
Meter -> [Char]
forall a.
(PitchClass -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Meter] -> ShowS
$cshowList :: [Meter] -> ShowS
show :: Meter -> [Char]
$cshow :: Meter -> [Char]
showsPrec :: PitchClass -> Meter -> ShowS
$cshowsPrec :: PitchClass -> Meter -> ShowS
Show)

meter_duration :: Meter -> T.Time
meter_duration :: Meter -> Time
meter_duration Meter
m = Meter -> Time
meter_step Meter
m forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> PitchClass
length (Meter -> [PitchClass]
meter_pattern Meter
m))

parse_meter :: Text -> Maybe Meter
parse_meter :: Text -> Maybe Meter
parse_meter Text
name = case Text -> [Char]
untxt Text
name of
    [Char
n1, Char
n2] | Just PitchClass
n1 <- Char -> Maybe PitchClass
Num.readDigit Char
n1, Just PitchClass
n2 <- Char -> Maybe PitchClass
Num.readDigit Char
n2 ->
        PitchClass -> PitchClass -> Maybe Meter
simple_meter PitchClass
n1 PitchClass
n2
    Char
'a':Char
'd':Char
'i' : [Char]
n
        | Just PitchClass
n <- Text -> Maybe PitchClass
ParseText.nat ([Char] -> Text
txt [Char]
n) -> PitchClass -> Maybe Meter
meter_adi PitchClass
n
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
n -> PitchClass -> Maybe Meter
meter_adi PitchClass
4
    [Char]
"gong" -> forall a. a -> Maybe a
Just Meter
meter_gong
    [Char]
_ -> forall a. Maybe a
Nothing

-- If I do akshara as 1, then kanda is 1/5th notes.  I'd want to reduce the
-- pulse to 1/5, or write .1--.5?
meter_adi :: Int -> Maybe Meter
meter_adi :: PitchClass -> Maybe Meter
meter_adi PitchClass
nadai
    | PitchClass
2 forall a. Ord a => a -> a -> Bool
<= PitchClass
nadai Bool -> Bool -> Bool
&& PitchClass
nadai forall a. Ord a => a -> a -> Bool
<= PitchClass
9 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Meter
        { meter_pattern :: [PitchClass]
meter_pattern = [PitchClass
2, PitchClass
0, PitchClass
0, PitchClass
0, PitchClass
1, PitchClass
0, PitchClass
1, PitchClass
0]
        , meter_step :: Time
meter_step = Time
1
        , meter_negative :: Bool
meter_negative = Bool
False
        , meter_ui :: (Config, MSection)
meter_ui =
            ( Tala -> Config
Tala.config Tala
Tala.adi_tala
            , PitchClass -> Duration -> AbstractMeter -> MSection
Meter.MSection PitchClass
4 Duration
1 (Tala -> PitchClass -> AbstractMeter
Tala.tala_to_meter Tala
Tala.adi_tala PitchClass
nadai)
            )
        }
    | Bool
otherwise = forall a. Maybe a
Nothing

meter_gong :: Meter
meter_gong :: Meter
meter_gong = Meter
    { meter_pattern :: [PitchClass]
meter_pattern = [PitchClass
1, PitchClass
0, PitchClass
0, PitchClass
0, PitchClass
0, PitchClass
0, PitchClass
0, PitchClass
0]
    , meter_step :: Time
meter_step = Time
1
    , meter_negative :: Bool
meter_negative = Bool
True
    , meter_ui :: (Config, MSection)
meter_ui =
        ( Config
Gong.config
        , PitchClass -> Duration -> AbstractMeter -> MSection
Meter.MSection PitchClass
4 Duration
Gong.measure_dur
            ([PitchClass] -> AbstractMeter
Meter.regular_subdivision [PitchClass
2, PitchClass
2, PitchClass
2, PitchClass
2, PitchClass
2, PitchClass
2])
        )
    }

meter_44 :: Meter
Just Meter
meter_44 = PitchClass -> PitchClass -> Maybe Meter
simple_meter PitchClass
4 PitchClass
4

simple_meter :: Int -> Int -> Maybe Meter
simple_meter :: PitchClass -> PitchClass -> Maybe Meter
simple_meter PitchClass
n1 PitchClass
n2 = do
    AbstractMeter
abs_meter <- PitchClass -> PitchClass -> Maybe AbstractMeter
Meters.simple PitchClass
n1 PitchClass
n2
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Meter
        { meter_pattern :: [PitchClass]
meter_pattern = PitchClass
1 forall a. a -> [a] -> [a]
: forall a. PitchClass -> a -> [a]
replicate (PitchClass
n1forall a. Num a => a -> a -> a
-PitchClass
1) PitchClass
0
        , meter_step :: Time
meter_step = Time
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
n2
        , meter_negative :: Bool
meter_negative = Bool
False
        , meter_ui :: (Config, MSection)
meter_ui =
            ( Config
Meter.default_config
            , Meter.MSection
                { section_measures :: PitchClass
section_measures = PitchClass
4
                , section_measure_duration :: Duration
section_measure_duration = Duration
1
                , section_measure :: AbstractMeter
section_measure = AbstractMeter
abs_meter
                }
            )
        }

-- ** resolve_time

time_to_negative ::
    (T.Time, Stream (T.Time, T.Note call pitch T.Time))
    -> (T.Time, Stream (T.Time, T.Note call pitch T.Time))
time_to_negative :: forall call pitch.
(Time, Stream (Time, Note call pitch Time))
-> (Time, Stream (Time, Note call pitch Time))
time_to_negative (Time
end, Stream (Time, Note call pitch Time)
stream) = (Time
end, forall a b e. (a -> b) -> [Elt e a] -> [Elt e b]
EList.map forall {dur} {call} {pitch}.
Num dur =>
(dur, Note call pitch dur) -> (dur, Note call pitch dur)
invert Stream (Time, Note call pitch Time)
stream)
    where
    invert :: (dur, Note call pitch dur) -> (dur, Note call pitch dur)
invert (dur
start, Note call pitch dur
note) = (dur
start forall a. Num a => a -> a -> a
+ dur
dur, Note call pitch dur
note { note_duration :: dur
T.note_duration = -dur
dur })
        where dur :: dur
dur = forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch dur
note

-- | Remove TBarline and TRest, add start times, and resolve ties.
resolve_time :: (Eq pitch, Pretty pitch)
    => Stream (Token call pitch (T.Time, Bool))
    -> (T.Time, Stream (T.Time, T.Note call pitch T.Time))
resolve_time :: forall pitch call.
(Eq pitch, Pretty pitch) =>
Stream (Token call pitch (Time, Bool))
-> (Time, Stream (Time, Note call pitch Time))
resolve_time Stream (Token call pitch (Time, Bool))
tokens = forall {pitch} {call}.
(Eq pitch, Pretty pitch) =>
[Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go (forall a e b. [a] -> [Elt e b] -> [Elt e (a, Maybe b)]
EList.zipPaddedSnd [Time]
starts Stream (Token call pitch (Time, Bool))
tokens)
    where
    starts :: [Time]
starts = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\Time
n -> (Time
n+)) Time
0 (forall a b. (a -> b) -> [a] -> [b]
map forall call pitch tie. Token call pitch (Time, tie) -> Time
duration_of (forall e a. [Elt e a] -> [a]
EList.elts Stream (Token call pitch (Time, Bool))
tokens))
    go :: [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go (EList.Elt (Time
start, Maybe (Token call pitch (Time, Bool) (Time, Bool))
Nothing) : [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts = (Time
start, [])
        | Bool
otherwise = [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
    go (EList.Elt (Time
start, Just Token call pitch (Time, Bool) (Time, Bool)
t) : [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts) = case Token call pitch (Time, Bool) (Time, Bool)
t of
        T.TNote Pos
_ Note call pitch (Time, Bool)
note
            | forall call pitch a1 a2.
Token call pitch (a1, Bool) (a2, Bool) -> Bool
is_tied Token call pitch (Time, Bool) (Time, Bool)
t ->
                case forall pitch call dur.
(Eq pitch, Pretty pitch) =>
Note call pitch dur
-> [(Time, Token call pitch (Time, Bool))] -> Either Error Time
tied_notes Note call pitch (Time, Bool)
note (forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Lists.mapMaybeSnd forall a. a -> a
id (forall e a. [Elt e a] -> [a]
EList.elts [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
pre)) of
                    Left Error
err -> (forall e a. e -> Elt e a
EList.Meta (forall a b. a -> Either a b
Left Error
err) :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
post
                    Right Time
end ->
                        (forall e a. a -> Elt e a
EList.Elt (Time
start, forall {dur} {call} {pitch} {dur}.
dur -> Note call pitch dur -> Note call pitch dur
set_dur (Time
endforall a. Num a => a -> a -> a
-Time
start) Note call pitch (Time, Bool)
note) :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
post
            | Bool
otherwise ->
                (forall e a. a -> Elt e a
EList.Elt (Time
start, forall {dur} {call} {pitch} {dur}.
dur -> Note call pitch dur -> Note call pitch dur
set_dur (forall a b. (a, b) -> a
fst (forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch (Time, Bool)
note)) Note call pitch (Time, Bool)
note) :)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
        T.TBarline Pos
_ (T.Barline {}) -> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
        T.TBarline Pos
pos Barline
T.AssertCoincident ->
            (forall e a. e -> Elt e a
EList.Meta (forall a b. b -> Either a b
Right (Time -> Pos -> AssertCoincident
AssertCoincident Time
start Pos
pos)) :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
        T.TRest {}
            | forall call pitch a1 a2.
Token call pitch (a1, Bool) (a2, Bool) -> Bool
is_tied Token call pitch (Time, Bool) (Time, Bool)
t -> case forall call pitch. [Token call pitch (Time, Bool)] -> Maybe Error
tied_rests (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd (forall e a. [Elt e a] -> [a]
EList.elts [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
pre)) of
                Just Error
err -> (forall e a. e -> Elt e a
EList.Meta (forall a b. a -> Either a b
Left Error
err) :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
post
                Maybe Error
Nothing -> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
post
            | Bool
otherwise -> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
        where
        ([Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
pre, [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
post) = forall a rest.
(a -> Bool) -> ([a] -> ([a], rest)) -> [a] -> ([a], rest)
Then.span forall {e} {a} {call} {pitch} {a1} {a2}.
Elt e (a, Maybe (Token call pitch (a1, Bool) (a2, Bool))) -> Bool
any_tied (forall a. PitchClass -> [a] -> ([a], [a])
splitAt PitchClass
1) [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
        any_tied :: Elt e (a, Maybe (Token call pitch (a1, Bool) (a2, Bool))) -> Bool
any_tied (EList.Meta e
_) = Bool
True
        any_tied (EList.Elt (a
_, Just Token call pitch (a1, Bool) (a2, Bool)
n)) = forall {call} {pitch} {ndur} {rdur}.
Token call pitch ndur rdur -> Bool
is_barline Token call pitch (a1, Bool) (a2, Bool)
n Bool -> Bool -> Bool
|| forall call pitch a1 a2.
Token call pitch (a1, Bool) (a2, Bool) -> Bool
is_tied Token call pitch (a1, Bool) (a2, Bool)
n
        any_tied (EList.Elt (a
_, Maybe (Token call pitch (a1, Bool) (a2, Bool))
Nothing)) = Bool
False
    go (EList.Meta Meta
e : [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts) = (forall e a. e -> Elt e a
EList.Meta Meta
e :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
-> (Time, [Elt Meta (Time, Note call pitch Time)])
go [Elt
   Meta (Time, Maybe (Token call pitch (Time, Bool) (Time, Bool)))]
ts
    go [] = (Time
0, [])
    set_dur :: dur -> Note call pitch dur -> Note call pitch dur
set_dur dur
dur Note call pitch dur
note = Note call pitch dur
note { note_duration :: dur
T.note_duration = dur
dur }
    is_barline :: Token call pitch ndur rdur -> Bool
is_barline (T.TBarline {}) = Bool
True
    is_barline Token call pitch ndur rdur
_ = Bool
False

tied_notes :: (Eq pitch, Pretty pitch)
    => T.Note call pitch dur -> [(T.Time, Token call pitch (T.Time, Bool))]
    -> Either T.Error T.Time
tied_notes :: forall pitch call dur.
(Eq pitch, Pretty pitch) =>
Note call pitch dur
-> [(Time, Token call pitch (Time, Bool))] -> Either Error Time
tied_notes Note call pitch dur
note [(Time, Token call pitch (Time, Bool))]
tied = case [(Time, Token call pitch (Time, Bool))]
others of
    [] -> case forall a. [a] -> Maybe a
Lists.last [(Time, Note call pitch (Time, Bool))]
matches of
        Maybe (Time, Note call pitch (Time, Bool))
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error (forall call pitch dur. Note call pitch dur -> Pos
T.note_pos Note call pitch dur
note) Text
"final note has a tie"
        Just (Time
s, Note call pitch (Time, Bool)
n)
            | forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch (Time, Bool)
n ->
                forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error (forall call pitch dur. Note call pitch dur -> Pos
T.note_pos Note call pitch (Time, Bool)
n) Text
"final note has a tie"
            | Bool
otherwise -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Time
s forall a. Num a => a -> a -> a
+ forall {call} {pitch} {c} {b}. Note call pitch (c, b) -> c
dur_of Note call pitch (Time, Bool)
n
    (Time
_, Token call pitch (Time, Bool)
bad) : [(Time, Token call pitch (Time, Bool))]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error (forall call pitch ndur rdur. Token call pitch ndur rdur -> Pos
T.token_pos Token call pitch (Time, Bool)
bad) forall a b. (a -> b) -> a -> b
$ case Token call pitch (Time, Bool)
bad of
        T.TNote Pos
_ Note call pitch (Time, Bool)
n -> Text
"note tied to different pitch: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note call pitch dur
note) forall a. Semigroup a => a -> a -> a
<> Text
" ~ "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note call pitch (Time, Bool)
n)
        Token call pitch (Time, Bool)
_ -> Text
"note tied to " forall a. Semigroup a => a -> a -> a
<> forall call pitch ndur rdur. Token call pitch ndur rdur -> Text
T.token_name Token call pitch (Time, Bool)
bad
    where
    ([(Time, Note call pitch (Time, Bool))]
matches, [(Time, Token call pitch (Time, Bool))]
others) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.partitionOn forall {a} {call} {dur} {rdur}.
(a, Token call pitch dur rdur) -> Maybe [(a, Note call pitch dur)]
match [(Time, Token call pitch (Time, Bool))]
tied
    dur_of :: Note call pitch (c, b) -> c
dur_of = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call pitch dur. Note call pitch dur -> dur
T.note_duration
    match :: (a, Token call pitch dur rdur) -> Maybe [(a, Note call pitch dur)]
match (a
s, T.TNote Pos
_ Note call pitch dur
n) | forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note call pitch dur
note forall a. Eq a => a -> a -> Bool
== forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note call pitch dur
n = forall a. a -> Maybe a
Just [(a
s, Note call pitch dur
n)]
    match (a
_, T.TBarline {}) = forall a. a -> Maybe a
Just []
    match (a, Token call pitch dur rdur)
_ = forall a. Maybe a
Nothing

tied_rests :: [Token call pitch (T.Time, Bool)] -> Maybe T.Error
tied_rests :: forall call pitch. [Token call pitch (Time, Bool)] -> Maybe Error
tied_rests = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {call} {pitch} {ndur} {rdur}.
Token call pitch ndur rdur -> Error
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {call} {pitch} {ndur} {rdur}.
Token call pitch ndur rdur -> Bool
matches)
    where
    format :: Token call pitch ndur rdur -> Error
format Token call pitch ndur rdur
token =
        Pos -> Text -> Error
T.Error (forall call pitch ndur rdur. Token call pitch ndur rdur -> Pos
T.token_pos Token call pitch ndur rdur
token) forall a b. (a -> b) -> a -> b
$ Text
"rest tied to " forall a. Semigroup a => a -> a -> a
<> forall call pitch ndur rdur. Token call pitch ndur rdur -> Text
T.token_name Token call pitch ndur rdur
token
    matches :: Token call pitch ndur rdur -> Bool
matches (T.TRest {}) = Bool
True
    matches (T.TBarline {}) = Bool
True
    matches Token call pitch ndur rdur
_ = Bool
False

is_tied :: T.Token call pitch (a1, Bool) (a2, Bool) -> Bool
is_tied :: forall call pitch a1 a2.
Token call pitch (a1, Bool) (a2, Bool) -> Bool
is_tied (T.TNote Pos
_ Note call pitch (a1, Bool)
note) = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch (a1, Bool)
note
is_tied (T.TRest Pos
_ (T.Rest (a2
_, Bool
tied))) = Bool
tied
is_tied Token call pitch (a1, Bool) (a2, Bool)
_ = Bool
False

-- ** check_barlines

check_barlines :: Meter
    -> Stream (Token call pitch (T.Time, tie))
    -> Stream (Token call pitch (T.Time, tie))
check_barlines :: forall call pitch tie.
Meter
-> Stream (Token call pitch (Time, tie))
-> Stream (Token call pitch (Time, tie))
check_barlines Meter
meter =
    forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
State.runState Time
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a e b.
Applicative m =>
(a -> m [Elt e b]) -> [Elt e a] -> m [Elt e b]
EList.concatMapEM forall {m :: * -> *} {a} {call} {pitch} {tie}.
(MonadState Time m, Show a) =>
(a, Token call pitch (Time, tie) (Time, tie))
-> m [Elt Meta (Token call pitch (Time, tie) (Time, tie))]
check_token
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e b. [a] -> [Elt e b] -> [Elt e (a, b)]
EList.zip [Integer
0..]
    where
    check_token :: (a, Token call pitch (Time, tie) (Time, tie))
-> m [Elt Meta (Token call pitch (Time, tie) (Time, tie))]
check_token (a
i, Token call pitch (Time, tie) (Time, tie)
token) = do
        Time
now <- forall s (m :: * -> *). MonadState s m => m s
State.get
        forall s (m :: * -> *). MonadState s m => s -> m ()
State.put forall a b. (a -> b) -> a -> b
$! Time
now forall a. Num a => a -> a -> a
+ Time
dur
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. a -> Elt e a
EList.Elt Token call pitch (Time, tie) (Time, tie)
token forall a. a -> [a] -> [a]
: forall {a}. Time -> [Elt Meta a]
warning Time
now
        where
        dur :: Time
dur = forall call pitch tie. Token call pitch (Time, tie) -> Time
duration_of Token call pitch (Time, tie) (Time, tie)
token
        warning :: Time -> [Elt Meta a]
warning Time
now = case Token call pitch (Time, tie) (Time, tie)
token of
            T.TBarline Pos
pos Barline
bar -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) (forall {a} {a}.
Show a =>
Pos -> Time -> a -> Barline -> Maybe (Elt Meta a)
check Pos
pos Time
now a
i Barline
bar)
            Token call pitch (Time, tie) (Time, tie)
_ -> []
    check :: Pos -> Time -> a -> Barline -> Maybe (Elt Meta a)
check Pos
pos Time
now a
i (T.Barline PitchClass
rank) = case Map Time PitchClass -> Time -> PitchClass -> Maybe Text
check_beat Map Time PitchClass
beat_rank Time
beat PitchClass
rank of
        Maybe Text
Nothing -> forall a. Maybe a
Nothing
        Just Text
err -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> Text -> Text
warn a
i forall a b. (a -> b) -> a -> b
$
            Text
"beat " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
beat forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        where beat :: Time
beat = Time
now forall a. Real a => a -> a -> a
`Num.fmod` Time
cycle_dur
    -- resolve_time will turn this into 'AssertCoincident'.
    check Pos
_ Time
_ a
_ Barline
T.AssertCoincident = forall a. Maybe a
Nothing
    cycle_dur :: Time
cycle_dur = Meter -> Time
meter_duration Meter
meter
    beat_rank :: Map Time PitchClass
beat_rank = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>PitchClass
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ Time
0 (Meter -> Time
meter_step Meter
meter))
            -- Two bars, to ensure 'check_beat' can always find the next beat.
            (Meter -> [PitchClass]
meter_pattern Meter
meter forall a. [a] -> [a] -> [a]
++ Meter -> [PitchClass]
meter_pattern Meter
meter)
    warn :: a -> Text -> Text
warn a
i Text
msg = Text
"barline check: token " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
i forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
msg

-- | Nothing if the expected rank falls on the given beat, or an error msg.
check_beat :: Map T.Time T.Rank -> T.Time -> T.Rank -> Maybe Text
check_beat :: Map Time PitchClass -> Time -> PitchClass -> Maybe Text
check_beat Map Time PitchClass
beat_rank Time
beat PitchClass
rank = (Text
prefix<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe PitchClass
at of
    Maybe PitchClass
Nothing -> forall a. a -> Maybe a
Just Text
next_beat
    Just PitchClass
r
        | PitchClass
r forall a. Eq a => a -> a -> Bool
== PitchClass
rank -> forall a. Maybe a
Nothing
        | Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"expected " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (PitchClass -> Barline
T.Barline PitchClass
r)
            forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> Text
next_beat
    where
    prefix :: Text
prefix = Text
"saw " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (PitchClass -> Barline
T.Barline PitchClass
rank) forall a. Semigroup a => a -> a -> a
<> Text
", "
    next_beat :: Text
next_beat = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
==PitchClass
rank) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
Map.toList Map Time PitchClass
post) of
        Maybe (Time, PitchClass)
Nothing -> Text
"no following beat with that rank"
        Just (Time
t, PitchClass
_) -> Text
"next beat of that rank is " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
t
            forall a. Semigroup a => a -> a -> a
<> Text
" (short " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Time
tforall a. Num a => a -> a -> a
-Time
beat) forall a. Semigroup a => a -> a -> a
<> Text
")"
    (Map Time PitchClass
_, Maybe PitchClass
at, Map Time PitchClass
post) = forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup Time
beat Map Time PitchClass
beat_rank

duration_of :: Token call pitch (T.Time, tie) -> T.Time
duration_of :: forall call pitch tie. Token call pitch (Time, tie) -> Time
duration_of = \case
    T.TBarline {} -> Time
0
    T.TNote Pos
_ Note call pitch (Time, tie)
note -> forall a b. (a, b) -> a
fst (forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch (Time, tie)
note)
    T.TRest Pos
_ (T.Rest (Time
dur, tie
_)) -> Time
dur

-- ** resolve duration

duration_map :: Map Text DurationMode
duration_map :: Map Text DurationMode
duration_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"mul", DurationMode
Multiplicative)
    , (Text
"add", DurationMode
Additive)
    ]

data DurationMode = Multiplicative | Additive
    deriving (DurationMode -> DurationMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DurationMode -> DurationMode -> Bool
$c/= :: DurationMode -> DurationMode -> Bool
== :: DurationMode -> DurationMode -> Bool
$c== :: DurationMode -> DurationMode -> Bool
Eq, PitchClass -> DurationMode -> ShowS
[DurationMode] -> ShowS
DurationMode -> [Char]
forall a.
(PitchClass -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DurationMode] -> ShowS
$cshowList :: [DurationMode] -> ShowS
show :: DurationMode -> [Char]
$cshow :: DurationMode -> [Char]
showsPrec :: PitchClass -> DurationMode -> ShowS
$cshowsPrec :: PitchClass -> DurationMode -> ShowS
Show)

resolve_duration :: DurationMode
    -> Stream (T.Token call pitch (Either T.Time T.Duration) T.Duration)
    -> Stream (T.Token call pitch (T.Time, Bool) (T.Time, Bool))
resolve_duration :: forall call pitch.
DurationMode
-> Stream (Token call pitch (Either Time Duration) Duration)
-> Stream (Token call pitch (Time, Bool) (Time, Bool))
resolve_duration = \case
    DurationMode
Multiplicative -> forall call pitch.
Stream (Token call pitch (Either Time Duration) Duration)
-> Stream (Token call pitch (Time, Bool))
multiplicative
    DurationMode
Additive -> forall call pitch.
Stream (Token call pitch (Either Time Duration) Duration)
-> Stream (Token call pitch (Time, Bool))
additive

-- | Each number is the inverse of the number of beats, so 2 is 1/2, 8 is 1/8
-- etc.  If there are two numbers, you can set both numerator and denominator.
-- This carrier both values or none.
multiplicative
    :: Stream (T.Token call pitch (Either T.Time T.Duration) T.Duration)
    -> Stream (Token call pitch (T.Time, Bool))
multiplicative :: forall call pitch.
Stream (Token call pitch (Either Time Duration) Duration)
-> Stream (Token call pitch (Time, Bool))
multiplicative =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
State.evalState (PitchClass
1, forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a e b.
Applicative m =>
(a -> m (Elt e b)) -> [Elt e a] -> m [Elt e b]
EList.mapEM (forall int1 int2 (m :: * -> *) time call pitch.
MonadState (int1, int2) m =>
(Maybe PitchClass -> Maybe PitchClass -> m (int1, int2))
-> (int1 -> int2 -> PitchClass -> time)
-> Token call pitch (Either time Duration) Duration
-> m (Elt Meta (Token call pitch (time, Bool) (time, Bool)))
map_duration forall {a} {m :: * -> *}.
MonadState (a, Maybe a) m =>
Maybe a -> Maybe a -> m (a, Maybe a)
carry forall {p} {a}.
(Integral p, Integral a) =>
p -> Maybe a -> PitchClass -> Time
time_of)
    where
    time_of :: p -> Maybe a -> PitchClass -> Time
time_of p
int1 Maybe a
mb_int2 PitchClass
dots = Time
dur forall a. Num a => a -> a -> a
+ Time
dot_dur
        where
        dur :: Time
dur = Rational -> Time
T.Time forall a b. (a -> b) -> a -> b
$ case Maybe a
mb_int2 of
            Maybe a
Nothing -> Rational
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral p
int1
            Just a
int2 -> forall a b. (Integral a, Num b) => a -> b
fromIntegral p
int1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
int2
        dot_dur :: Time
dot_dur = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a. PitchClass -> [a] -> [a]
take PitchClass
dots forall a b. (a -> b) -> a -> b
$ forall a. PitchClass -> [a] -> [a]
drop PitchClass
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate (forall a. Fractional a => a -> a -> a
/Time
2) Time
dur
    carry :: Maybe a -> Maybe a -> m (a, Maybe a)
carry Maybe a
Nothing Maybe a
Nothing = forall s (m :: * -> *). MonadState s m => m s
State.get
    carry Maybe a
Nothing (Just a
int2) = forall (m :: * -> *) a. Monad m => a -> m a
return (a
int2, forall a. Maybe a
Nothing)
    carry (Just a
int1) Maybe a
mb_int2 = forall (m :: * -> *) a. Monad m => a -> m a
return (a
int1, Maybe a
mb_int2)

-- | Each number is just the number of Time beats.  If there are two numbers,
-- int1 corresponds to a higher level of division, which is meter specific.
-- E.g. akshara:matra.
additive :: Stream (T.Token call pitch (Either T.Time T.Duration) T.Duration)
    -> Stream (Token call pitch (T.Time, Bool))
additive :: forall call pitch.
Stream (Token call pitch (Either Time Duration) Duration)
-> Stream (Token call pitch (Time, Bool))
additive =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
State.evalState (PitchClass
1, PitchClass
4) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a e b.
Applicative m =>
(a -> m (Elt e b)) -> [Elt e a] -> m [Elt e b]
EList.mapEM (forall int1 int2 (m :: * -> *) time call pitch.
MonadState (int1, int2) m =>
(Maybe PitchClass -> Maybe PitchClass -> m (int1, int2))
-> (int1 -> int2 -> PitchClass -> time)
-> Token call pitch (Either time Duration) Duration
-> m (Elt Meta (Token call pitch (time, Bool) (time, Bool)))
map_duration forall {m :: * -> *} {a} {b}.
MonadState (a, b) m =>
Maybe a -> Maybe b -> m (a, b)
carry forall {a} {p} {p}.
(Integral p, Integral p, Fractional a) =>
p -> p -> PitchClass -> a
time_of)
    where
    time_of :: p -> p -> PitchClass -> a
time_of p
int1 p
int2 PitchClass
dots = a
dur forall a. Num a => a -> a -> a
+ a
dot_dur
        where
        dur :: a
dur = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
int1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral p
int2
        dot_dur :: a
dot_dur = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a. PitchClass -> [a] -> [a]
take PitchClass
dots forall a b. (a -> b) -> a -> b
$ forall a. PitchClass -> [a] -> [a]
drop PitchClass
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate (forall a. Fractional a => a -> a -> a
/a
2) a
dur
    carry :: Maybe a -> Maybe b -> m (a, b)
carry Maybe a
int1 Maybe b
int2 = do
        (a
p_int1, b
p_int2) <- forall s (m :: * -> *). MonadState s m => m s
State.get
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a -> a
fromMaybe a
p_int1 Maybe a
int1, forall a. a -> Maybe a -> a
fromMaybe b
p_int2 Maybe b
int2)

map_duration :: State.MonadState (int1, int2) m
    => (Maybe Int -> Maybe Int -> m (int1, int2))
    -> (int1 -> int2 -> Int -> time)
    -> T.Token call pitch (Either time T.Duration) T.Duration
    -> m (EList.Elt Meta (T.Token call pitch (time, Bool) (time, Bool)))
map_duration :: forall int1 int2 (m :: * -> *) time call pitch.
MonadState (int1, int2) m =>
(Maybe PitchClass -> Maybe PitchClass -> m (int1, int2))
-> (int1 -> int2 -> PitchClass -> time)
-> Token call pitch (Either time Duration) Duration
-> m (Elt Meta (Token call pitch (time, Bool) (time, Bool)))
map_duration Maybe PitchClass -> Maybe PitchClass -> m (int1, int2)
carry int1 -> int2 -> PitchClass -> time
time_of = \case
    T.TBarline Pos
pos Barline
a -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall call pitch ndur rdur.
Pos -> Barline -> Token call pitch ndur rdur
T.TBarline Pos
pos Barline
a
    T.TNote Pos
pos Note call pitch (Either time Duration)
note -> do
        Either Text (time, Bool)
result <- case forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note call pitch (Either time Duration)
note of
            Left time
time -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (time
time, Bool
False)
            Right (T.Duration Maybe PitchClass
mb_int1 Maybe PitchClass
mb_int2 PitchClass
dots Bool
tie) -> do
                (int1
int1, int2
int2) <- Maybe PitchClass -> Maybe PitchClass -> m (int1, int2)
carry Maybe PitchClass
mb_int1 Maybe PitchClass
mb_int2
                forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (int1
int1, int2
int2)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (int1 -> int2 -> PitchClass -> time
time_of int1
int1 int2
int2 PitchClass
dots, Bool
tie)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Text (time, Bool)
result of
            Left Text
err -> forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos Text
err
            Right (time
time, Bool
tie) -> forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos forall a b. (a -> b) -> a -> b
$
                Note call pitch (Either time Duration)
note { note_duration :: (time, Bool)
T.note_duration = (time
time, Bool
tie) }
    T.TRest Pos
pos (T.Rest (T.Duration Maybe PitchClass
mb_int1 Maybe PitchClass
mb_int2 PitchClass
dots Bool
tie)) -> do
        (int1
int1, int2
int2) <- Maybe PitchClass -> Maybe PitchClass -> m (int1, int2)
carry Maybe PitchClass
mb_int1 Maybe PitchClass
mb_int2
        forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (int1
int1, int2
int2)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. a -> Elt e a
EList.Elt forall a b. (a -> b) -> a -> b
$ forall call pitch ndur rdur.
Pos -> Rest rdur -> Token call pitch ndur rdur
T.TRest Pos
pos forall a b. (a -> b) -> a -> b
$ forall dur. dur -> Rest dur
T.Rest (int1 -> int2 -> PitchClass -> time
time_of int1
int1 int2
int2 PitchClass
dots, Bool
tie)

-- * pitch

data Scale = Scale {
    Scale -> Text
scale_name :: !Text
    , Scale -> Text -> Maybe Degree
scale_parse :: Text -> Maybe Pitch.Degree
    , Scale -> Degree -> Maybe Text
scale_unparse :: Pitch.Degree -> Maybe Text
    , Scale -> Layout
scale_layout :: !Theory.Layout
    , Scale -> PitchClass
scale_initial_octave :: !Pitch.Octave
    }

instance Show Scale where
    show :: Scale -> [Char]
show Scale
scale = [Char]
"((" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
untxt (Scale -> Text
scale_name Scale
scale) forall a. Semigroup a => a -> a -> a
<> [Char]
"))"

resolve_pitch :: Scale
    -> Stream (time, T.Note call NPitch dur)
    -> Stream (time, T.Note call (T.NPitch (Maybe Text)) dur)
resolve_pitch :: forall time call dur.
Scale
-> Stream (time, Note call NPitch dur)
-> Stream (time, Note call (NPitch (Maybe Text)) dur)
resolve_pitch Scale
scale =
    forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
State.runState (Scale -> PitchClass
scale_initial_octave Scale
scale, forall a. Maybe a
Nothing)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a e b.
Applicative m =>
(a -> m (Elt e b)) -> [Elt e a] -> m [Elt e b]
EList.mapEM forall {f :: * -> *} {a} {call} {dur}.
MonadState (PitchClass, Maybe Degree) f =>
(a, Note call NPitch dur)
-> f (Elt Meta (a, Note call (NPitch (Maybe Text)) dur))
token
    where
    token :: (a, Note call NPitch dur)
-> f (Elt Meta (a, Note call (NPitch (Maybe Text)) dur))
token (a
start, Note call NPitch dur
note) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {pitch}. pitch -> (a, Note call pitch dur)
set forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note call NPitch dur
note of
        NPitch
T.CopyFrom -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. a -> Elt e a
EList.Elt forall pitch. NPitch pitch
T.CopyFrom
        T.NPitch Pitch
pitch -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall pitch. pitch -> NPitch pitch
T.NPitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *}.
MonadState (PitchClass, Maybe Degree) m =>
Pos -> Pitch -> m (Elt Meta (Maybe Text))
resolve (forall call pitch dur. Note call pitch dur -> Pos
T.note_pos Note call NPitch dur
note) Pitch
pitch
        where set :: pitch -> (a, Note call pitch dur)
set pitch
pitch = (a
start, Note call NPitch dur
note { note_pitch :: pitch
T.note_pitch = pitch
pitch })
    resolve :: Pos -> Pitch -> m (Elt Meta (Maybe Text))
resolve Pos
pos Pitch
pitch = case forall pitch.
Pos
-> (Text -> Maybe pitch)
-> Pitch
-> Elt Meta (Maybe (Octave, pitch))
parse_pitch Pos
pos (Scale -> Text -> Maybe Degree
scale_parse Scale
scale) Pitch
pitch of
        EList.Meta Meta
m -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. e -> Elt e a
EList.Meta Meta
m
        EList.Elt Maybe (Octave, Degree)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. a -> Elt e a
EList.Elt forall a. Maybe a
Nothing
        EList.Elt (Just (Octave, Degree)
pitch) -> do
            (PitchClass, Maybe Degree)
prev <- forall s (m :: * -> *). MonadState s m => m s
State.get
            pitch :: Pitch
pitch@(Pitch.Pitch PitchClass
oct Degree
degree) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                PitchClass
-> (PitchClass, Maybe Degree) -> (Octave, Degree) -> Pitch
infer_octave PitchClass
per_octave (PitchClass, Maybe Degree)
prev (Octave, Degree)
pitch
            forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (PitchClass
oct, forall a. a -> Maybe a
Just Degree
degree)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pos -> Scale -> Pitch -> Elt Meta Text
pitch_to_symbolic Pos
pos Scale
scale Pitch
pitch
    per_octave :: PitchClass
per_octave = Layout -> PitchClass
Theory.layout_pc_per_octave (Scale -> Layout
scale_layout Scale
scale)

parse_pitch :: T.Pos -> (T.PitchText -> Maybe pitch) -> T.Pitch
    -> EList.Elt Meta (Maybe (T.Octave, pitch))
parse_pitch :: forall pitch.
Pos
-> (Text -> Maybe pitch)
-> Pitch
-> Elt Meta (Maybe (Octave, pitch))
parse_pitch Pos
pos Text -> Maybe pitch
parse (T.Pitch Octave
oct Text
call)
    -- If there's a previous pitch, the pitch track will carry it.
    | Text -> Bool
Text.null Text
call = forall e a. a -> Elt e a
EList.Elt forall a. Maybe a
Nothing
    | Bool
otherwise = case Text -> Maybe pitch
parse Text
call of
        Maybe pitch
Nothing -> forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos forall a b. (a -> b) -> a -> b
$ Text
"can't parse pitch: " forall a. Semigroup a => a -> a -> a
<> Text
call
        Just pitch
p -> forall e a. a -> Elt e a
EList.Elt (forall a. a -> Maybe a
Just (Octave
oct, pitch
p))

infer_octave :: Pitch.PitchClass -> (Pitch.Octave, Maybe Pitch.Degree)
    -> (T.Octave, Pitch.Degree) -> Pitch.Pitch
infer_octave :: PitchClass
-> (PitchClass, Maybe Degree) -> (Octave, Degree) -> Pitch
infer_octave PitchClass
per_octave (PitchClass
prev_oct, Maybe Degree
prev_degree) (Octave
oct, Degree
degree) =
    PitchClass -> Degree -> Pitch
Pitch.Pitch PitchClass
inferred_oct Degree
degree
    where
    inferred_oct :: PitchClass
inferred_oct = case Octave
oct of
        T.Relative PitchClass
n -> case Maybe Degree
prev_degree of
            Maybe Degree
Nothing -> PitchClass
prev_oct forall a. Num a => a -> a -> a
+ PitchClass
n
            Just Degree
prev_degree
                -- Pick closest pitch in any direction.
                | PitchClass
n forall a. Eq a => a -> a -> Bool
== PitchClass
0 -> (PitchClass -> Bool) -> PitchClass
pick (forall a b. a -> b -> a
const Bool
True)
                -- Always go up, but that may not imply up an octave!  So pick
                -- the closest pitch above.  Additional up octaves just get
                -- added.
                | PitchClass
n forall a. Ord a => a -> a -> Bool
> PitchClass
0 -> (PitchClass -> Bool) -> PitchClass
pick (forall a. Ord a => a -> a -> Bool
>PitchClass
0) forall a. Num a => a -> a -> a
+ (PitchClass
nforall a. Num a => a -> a -> a
-PitchClass
1)
                | Bool
otherwise -> (PitchClass -> Bool) -> PitchClass
pick (forall a. Ord a => a -> a -> Bool
<PitchClass
0) forall a. Num a => a -> a -> a
+ (PitchClass
nforall a. Num a => a -> a -> a
+PitchClass
1)
                where
                -- by_distance should never be [] due to the filters given.
                -- I could probably get rid of this with Lists.minOn but it's
                -- hard to think about.
                pick :: (PitchClass -> Bool) -> PitchClass
pick PitchClass -> Bool
predicate = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable") forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
                    forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
                    forall a. (a -> Bool) -> [a] -> [a]
filter (PitchClass -> Bool
predicate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(PitchClass, PitchClass)]
by_distance
                by_distance :: [(PitchClass, PitchClass)]
by_distance =
                    forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn (PitchClass -> Degree -> Degree -> PitchClass -> PitchClass
distance PitchClass
prev_oct Degree
prev_degree Degree
degree)
                        [PitchClass
prev_octforall a. Num a => a -> a -> a
-PitchClass
1, PitchClass
prev_oct, PitchClass
prev_octforall a. Num a => a -> a -> a
+PitchClass
1]
        T.Absolute PitchClass
oct -> PitchClass
oct
    distance :: PitchClass -> Degree -> Degree -> PitchClass -> PitchClass
distance PitchClass
prev_oct Degree
prev_degree Degree
degree PitchClass
oct =
        PitchClass -> Pitch -> Pitch -> PitchClass
Pitch.diff_pc PitchClass
per_octave (PitchClass -> Degree -> Pitch
Pitch.Pitch PitchClass
oct Degree
degree)
            (PitchClass -> Degree -> Pitch
Pitch.Pitch PitchClass
prev_oct Degree
prev_degree)

-- | Convert 'Pitch'es back to symbolic form.
pitch_to_symbolic :: T.Pos -> Scale -> Pitch.Pitch -> EList.Elt Meta T.PitchText
pitch_to_symbolic :: Pos -> Scale -> Pitch -> Elt Meta Text
pitch_to_symbolic Pos
pos Scale
scale Pitch
pitch = case Pitch -> Maybe Text
unparse Pitch
pitch of
    Maybe Text
Nothing -> forall a. Pos -> Text -> Elt Meta a
mkerror Pos
pos forall a b. (a -> b) -> a -> b
$ Text
"bad pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
pitch
    Just Text
sym -> forall e a. a -> Elt e a
EList.Elt Text
sym
    where
    unparse :: Pitch -> Maybe Text
unparse (Pitch.Pitch PitchClass
oct Degree
degree) =
        (forall a. Show a => a -> Text
showt PitchClass
oct <>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scale -> Degree -> Maybe Text
scale_unparse Scale
scale Degree
degree

-- ** scale

scale_map :: Map Text Scale
scale_map :: Map Text Scale
scale_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn Scale -> Text
scale_name
    [ Scale
scale_sargam
    , Scale
scale_bali
    , Scale
scale_twelve
    ]

diatonic_scale :: Text -> [Text] -> Scale
diatonic_scale :: Text -> [Text] -> Scale
diatonic_scale Text
name [Text]
degrees_ = Scale
    { scale_name :: Text
scale_name = Text
name
    , scale_parse :: Text -> Maybe Degree
scale_parse = \Text
s -> PitchClass -> PitchClass -> Degree
Pitch.Degree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => a -> Vector a -> Maybe PitchClass
Vector.elemIndex Text
s Vector Text
degrees forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure PitchClass
0
    , scale_unparse :: Degree -> Maybe Text
scale_unparse = Degree -> Maybe Text
unparse
    , scale_layout :: Layout
scale_layout = PitchClass -> Layout
Theory.diatonic_layout (forall a. Vector a -> PitchClass
Vector.length Vector Text
degrees)
    , scale_initial_octave :: PitchClass
scale_initial_octave = PitchClass
4
    }
    where
    unparse :: Degree -> Maybe Text
unparse (Pitch.Degree PitchClass
pc PitchClass
accs)
        | PitchClass
accs forall a. Eq a => a -> a -> Bool
== PitchClass
0 = Vector Text
degrees forall a. Vector a -> PitchClass -> Maybe a
Vector.!? PitchClass
pc
        | Bool
otherwise = forall a. Maybe a
Nothing
    degrees :: Vector Text
degrees = forall a. [a] -> Vector a
Vector.fromList [Text]
degrees_

scale_sargam :: Scale
scale_sargam :: Scale
scale_sargam = Text -> [Text] -> Scale
diatonic_scale Text
"sargam" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton [Char]
"srgmpdn"

scale_bali :: Scale
scale_bali :: Scale
scale_bali = Text -> [Text] -> Scale
diatonic_scale Text
"bali" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton [Char]
"ioeua"

scale_twelve :: Scale
scale_twelve :: Scale
scale_twelve = Scale
    { scale_name :: Text
scale_name = Text
"twelve"
    , scale_parse :: Text -> Maybe Degree
scale_parse = forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
P.parseMaybe Parser Degree
p_degree
    , scale_unparse :: Degree -> Maybe Text
scale_unparse = Degree -> Maybe Text
unparse
    , scale_layout :: Layout
scale_layout = Layout
Theory.piano_layout
    , scale_initial_octave :: PitchClass
scale_initial_octave = PitchClass
4
    }
    where
    p_degree :: Parser Pitch.Degree
    p_degree :: Parser Degree
p_degree = do
        PitchClass
pc <- forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice [forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Text
c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure PitchClass
i | (PitchClass
i, Text
c) <- forall a b. [a] -> [b] -> [(a, b)]
zip [PitchClass
0..] [Text]
degrees]
        PitchClass
accs <- forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PitchClass
n, Text
c) -> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Text
c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure PitchClass
n) [(PitchClass, Text)]
accidentals
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc PitchClass
accs
    unparse :: Degree -> Maybe Text
unparse (Pitch.Degree PitchClass
pc PitchClass
accs) = forall a. Semigroup a => a -> a -> a
(<>)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> PitchClass -> Maybe a
Lists.at [Text]
degrees PitchClass
pc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PitchClass
accs [(PitchClass, Text)]
accidentals
    accidentals :: [(PitchClass, Text)]
accidentals =
        [ (PitchClass
0, Text
""), (PitchClass
0, Text
"n")
        , (PitchClass
1, Text
"#"), (PitchClass
2, Text
"x")
        , (-PitchClass
1, Text
"b"), (-PitchClass
2, Text
"bb")
        ]
    degrees :: [Text]
degrees = forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton [Char]
"cdefgab"

type Parser a = P.Parsec Void.Void Text a