-- 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 which are somewhat specific to European music.
module Derive.C.Europe.Chord (library) where
import qualified Data.Map as Map

import qualified Util.Lists as Lists
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
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           Global


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
    [ (Symbol
"chord", Direction -> Generator Note
c_chord Direction
Unison)
    , (Symbol
"chord^", Direction -> Generator Note
c_chord Direction
Up)
    , (Symbol
"chord_", Direction -> Generator Note
c_chord Direction
Down)
    , (Symbol
"stack", Direction -> Generator Note
c_stack Direction
Unison)
    , (Symbol
"stack^", Direction -> Generator Note
c_stack Direction
Up)
    , (Symbol
"stack_", Direction -> Generator Note
c_stack Direction
Down)
    ]

data Direction = Unison | Up | Down deriving (Step -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Step -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Step -> Direction -> ShowS
$cshowsPrec :: Step -> Direction -> ShowS
Show)

time_env :: Sig.Parser DeriveT.Duration
time_env :: Parser Duration
time_env = DefaultReal -> Duration
Typecheck._real forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"time" EnvironDefault
Sig.Prefixed (RealTime -> DefaultReal
Typecheck.real RealTime
0.08)
    Doc
"Time between notes, if they aren't unison."

-- * chord

c_chord :: Direction -> Derive.Generator Derive.Note
c_chord :: Direction -> Generator Note
c_chord Direction
dir = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.europe CallName
"chord" forall a. Monoid a => a
mempty
    Doc
"Make a chord based on a specialized chord notation. It's different from\
    \ the usual kind of chord notation because the base pitch is given\
    \ separately, and it has to be non-ambiguous, but the idea is the same."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"name" (Text
"" :: Text) Doc
"Chord name."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
time_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
name, Duration
time) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        RawPitch Untransposed_
base <- RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        [RawPitch Untransposed_]
intervals <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ RawPitch Untransposed_
-> Text -> Either Text [RawPitch Untransposed_]
parse_chord RawPitch Untransposed_
base Text
name
        forall a.
Direction
-> RawPitch Untransposed_
-> [RawPitch Untransposed_]
-> Duration
-> PassedArgs a
-> NoteDeriver
from_intervals Direction
dir RawPitch Untransposed_
base [RawPitch Untransposed_]
intervals Duration
time PassedArgs Note
args

-- Default to major, 'm' is minor, 'd' diminished, 'a' augmented, sus2 and sus4.
-- Sevenths: dim, dom, aug
-- Ninths:
-- Arguments for modification: inversion, transpose 3 5 7 9 up an octave,
-- drop 3 5 7 9.
parse_chord :: PSignal.Pitch -> Text -> Either Text [PSignal.Pitch]
parse_chord :: RawPitch Untransposed_
-> Text -> Either Text [RawPitch Untransposed_]
parse_chord RawPitch Untransposed_
_base Text
_name = forall a b. a -> Either a b
Left Text
"not implemented" -- TODO


-- * stack

-- TODO terrible name, can't I come up with something better?
c_stack :: Direction -> Derive.Generator Derive.Note
c_stack :: Direction -> Generator Note
c_stack Direction
dir = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.europe CallName
"stack" forall a. Monoid a => a
mempty
    Doc
"Make a chord by stacking intervals on a base pitch. There are variants\
    \ that arpeggiate upwards or downwards, in addition to playing in unison."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"interval" Doc
"Relative intervals, starting from the base pitch.\
        \ Can be absolute pitch, diatonic intervals, or a chromatic interval.\
        \ Chromatic intervals are notated `m3`, `M3`, `p4` for minor third,\
        \ major third, and perfect fourth respectively."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
time_env
    ) forall a b. (a -> b) -> a -> b
$ \([Interval]
intervals, Duration
time) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        RawPitch Untransposed_
base <- RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        [RawPitch Untransposed_]
intervals <- RawPitch Untransposed_
-> [Interval] -> Deriver [RawPitch Untransposed_]
resolve_intervals RawPitch Untransposed_
base [Interval]
intervals
        forall a.
Direction
-> RawPitch Untransposed_
-> [RawPitch Untransposed_]
-> Duration
-> PassedArgs a
-> NoteDeriver
from_intervals Direction
dir RawPitch Untransposed_
base [RawPitch Untransposed_]
intervals Duration
time PassedArgs Note
args

from_intervals :: Direction -> PSignal.Pitch -> [PSignal.Pitch]
    -> DeriveT.Duration -> Derive.PassedArgs a -> Derive.NoteDeriver
from_intervals :: forall a.
Direction
-> RawPitch Untransposed_
-> [RawPitch Untransposed_]
-> Duration
-> PassedArgs a
-> NoteDeriver
from_intervals Direction
dir RawPitch Untransposed_
base [RawPitch Untransposed_]
intervals Duration
time PassedArgs a
args = do
    let start :: TrackTime
start = forall a. PassedArgs a -> TrackTime
Args.start PassedArgs a
args
    TrackTime
dur <- forall a. Ord a => a -> a -> a
min (forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs a
args forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Step
length [RawPitch Untransposed_]
intervals forall a. Num a => a -> a -> a
+ Step
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error TrackTime
Call.score_duration TrackTime
start Duration
time
    let ts :: [TrackTime]
ts = case Direction
dir of
            Direction
Unison -> forall a. a -> [a]
repeat TrackTime
start
            Direction
Up -> forall a. Num a => a -> a -> [a]
Lists.range_ TrackTime
start TrackTime
dur
            Direction
Down -> forall a. Num a => a -> a -> [a]
Lists.range_
                (TrackTime
start forall a. Num a => a -> a -> a
+ TrackTime
dur forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Step
length [RawPitch Untransposed_]
intervals)) (-TrackTime
dur)
    forall a. Monoid a => [a] -> a
mconcat [forall a. TrackTime -> TrackTime -> Deriver a -> Deriver a
Derive.place TrackTime
t (forall a. PassedArgs a -> TrackTime
Args.end PassedArgs a
args forall a. Num a => a -> a -> a
- TrackTime
t) (RawPitch Untransposed_ -> NoteDeriver
Call.pitched_note RawPitch Untransposed_
pitch)
        | (TrackTime
t, RawPitch Untransposed_
pitch) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackTime]
ts (RawPitch Untransposed_
base forall a. a -> [a] -> [a]
: [RawPitch Untransposed_]
intervals)]

type Interval = Either PSignal.Pitch (Either Pitch.Step Text)

resolve_intervals :: PSignal.Pitch -> [Interval]
    -> Derive.Deriver [PSignal.Pitch]
resolve_intervals :: RawPitch Untransposed_
-> [Interval] -> Deriver [RawPitch Untransposed_]
resolve_intervals RawPitch Untransposed_
b = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) state x y.
Monad m =>
(state -> x -> m (state, y)) -> state -> [x] -> m (state, [y])
Lists.mapAccumLM forall {a}.
RawPitch a
-> Either (RawPitch a) (Either Step Text)
-> Deriver State Error (RawPitch a, RawPitch a)
resolve RawPitch Untransposed_
b
    where
    resolve :: RawPitch a
-> Either (RawPitch a) (Either Step Text)
-> Deriver State Error (RawPitch a, RawPitch a)
resolve RawPitch a
_ (Left RawPitch a
pitch) = forall (m :: * -> *) a. Monad m => a -> m a
return (RawPitch a
pitch, RawPitch a
pitch)
    resolve RawPitch a
base (Right (Left Step
steps)) = forall (m :: * -> *) a. Monad m => a -> m a
return (RawPitch a
p, RawPitch a
p)
        where p :: RawPitch a
p = forall a. Step -> RawPitch a -> RawPitch a
Pitches.transpose_d (Step
steps forall a. Num a => a -> a -> a
- Step
1) RawPitch a
base
    resolve RawPitch a
base (Right (Right Text
sym)) = do
        RawPitch a
p <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"can't parse: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Text
sym)
            (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Step -> RawPitch a -> RawPitch a
Pitches.transpose_c RawPitch a
base) (Text -> Maybe Step
parse_interval Text
sym)
        forall (m :: * -> *) a. Monad m => a -> m a
return (RawPitch a
p, RawPitch a
p)

parse_interval :: Text -> Maybe Pitch.Step
parse_interval :: Text -> Maybe Step
parse_interval = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Text Step
intervals
    where
    intervals :: Map Text Step
intervals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Step
1..]
        [ Text
"m2", Text
"M2", Text
"m3", Text
"M3", Text
"p4", Text
"a4", Text
"p5", Text
"m6", Text
"M6", Text
"m7", Text
"M7"
        , Text
"p8", Text
"M9", Text
"m10", Text
"M10", Text
"p11", Text
"a11", Text
"p12", Text
"m13", Text
"M13", Text
"m14"
        , Text
"M14"
        ]