-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Scale is actually defined in "Derive.Deriver.Monad" to avoid circular
-- imports.  But you should refer to it from here.
--
-- The difference between this and "Derive.Scale.Scales" is that this is
-- intended for using scales, while Scales is intended for implementing them.
module Derive.Scale (module Derive.Deriver.Monad, module Derive.Scale) where
import qualified Data.Map as Map
import qualified Data.Vector as Vector

import qualified Derive.Deriver.Monad as Derive
-- TODO remove re-exports
import           Derive.Deriver.Monad
    (LookupScale(..), Scale(..), Transposition(..))
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.Eval as Eval
import qualified Derive.PSignal as PSignal
import qualified Derive.Sig as Sig

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

import           Global


-- | Lookup a scale or throw.
get :: Derive.CallName -> [DeriveT.Val] -> Derive.Deriver Derive.Scale
get :: CallName -> [Val] -> Deriver Scale
get CallName
name [Val]
args = forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"Scale.get: unknown scale: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty CallName
name)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CallName -> [Val] -> Deriver (Maybe Scale)
lookup_scale CallName
name [Val]
args

lookup_scale :: Derive.CallName -> [DeriveT.Val]
    -> Derive.Deriver (Maybe Derive.Scale)
lookup_scale :: CallName -> [Val] -> Deriver (Maybe Scale)
lookup_scale CallName
name [Val]
args = do
    Map CallName ScaleCall
scale_calls <- forall st a err. (st -> a) -> Deriver st err a
Derive.gets forall a b. (a -> b) -> a -> b
$
        Constant -> Map CallName ScaleCall
Derive.state_scale_calls forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
Derive.state_constant
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CallName
name Map CallName ScaleCall
scale_calls of
        Maybe ScaleCall
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just ScaleCall
scall -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScaleCall -> [Val] -> Deriver Scale
Derive.scall_call ScaleCall
scall [Val]
args

-- | Scale calls always use Sig.Unprefixed.  This makes them inconsistent with
-- other kinds of calls, but I think is the better default, since I try to make
-- them respond to some standard env vals, such as key or scale-inst.
-- Especially scale-inst relies on it.
call :: Sig.Parser a -> (a -> Derive.Deriver Derive.Scale)
    -> Derive.WithArgDoc Derive.ScaleF
call :: forall a.
Parser a
-> (a -> Deriver Scale) -> WithArgDoc ([Val] -> Deriver Scale)
call Parser a
parser a -> Deriver Scale
f = ([Val] -> Deriver Scale
go, forall a. Parser a -> Docs
Sig.parser_docs Parser a
parser)
    where
    go :: [Val] -> Deriver Scale
go [Val]
args =
        a -> Deriver Scale
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Either Error a -> Deriver a
Sig.require_right forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
Sig.parse_vals Parser a
parser forall {a}. Context a
ctx CallName
call_name [Val]
args
    -- This will make Sig.Prefixed act like Sig.Unprefixed.
    call_name :: CallName
call_name = CallName
""
    -- TODO Sig.parse insists on having a ctx, can I remove it?
    -- used for Typecheck.Derive -> Sig.quoted_to_deriver -> Eval.eval_quoted
    ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 Text
"scale-call"

-- * old Definition

data Definition =
    -- | Fancy scales can configure themselves.  Since you can't just look at
    -- the Scale directly, it has the ScaleId (pattern, doc) extracted.
    Make !Pitch.ScaleId !(Text, Derive.DocumentedCall)
        !(Env.Environ -> LookupScale -> Either DeriveT.PitchError Scale)
    | Simple !Scale

scale_id_of :: Definition -> Pitch.ScaleId
scale_id_of :: Definition -> ScaleId
scale_id_of (Make ScaleId
scale_id (Text, DocumentedCall)
_ Environ -> LookupScale -> Either PitchError Scale
_) = ScaleId
scale_id
scale_id_of (Simple Scale
scale) = Scale -> ScaleId
scale_id Scale
scale

-- * util

-- | I would much rather pass a more specific value than Environ.
-- Unfortunately, ChromaticScales.SemisToNoteNumber needs a per-scale value
-- (e.g. Environ.key or Environ.tuning).  So pitch_nn needs to be parameterized
-- with a "get_key" function, but it also needs Environ.key.  I think it's
-- doable by parameterizing pitch_nn and hence note_to_call and moving
-- smap_semis_to_nn into note_to_call, but it seems complicated.
type PitchNn = PSignal.PitchConfig -> Either PSignal.PitchError Pitch.NoteNumber
type PitchNote = PSignal.PitchConfig -> Either PSignal.PitchError Pitch.Note

layout :: [Pitch.Semi] -> Derive.Layout
layout :: [Int] -> Layout
layout = forall a. [a] -> Vector a
Vector.fromList

no_octaves :: Derive.Layout
no_octaves :: Layout
no_octaves = forall a. Vector a
Vector.empty

diatonic_layout :: Pitch.PitchClass -> Derive.Layout
diatonic_layout :: Int -> Layout
diatonic_layout Int
per_oct = [Int] -> Layout
layout forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
per_oct Int
1

-- | Number of chromatic steps in an octave.  Nothing if this scale doesn't
-- have octaves.
semis_per_octave :: Derive.Layout -> Pitch.Semi
semis_per_octave :: Layout -> Int
semis_per_octave = forall a. Num a => Vector a -> a
Vector.sum

semis_at_pc :: Derive.Layout -> Pitch.PitchClass -> Pitch.Semi
semis_at_pc :: Layout -> Int -> Int
semis_at_pc Layout
layout Int
pc = case Layout -> Maybe Int
pc_per_octave Layout
layout of
    Maybe Int
Nothing -> Int
pc
    Just Int
per_oct -> Int
oct forall a. Num a => a -> a -> a
* forall a. Num a => Vector a -> a
Vector.sum Layout
layout forall a. Num a => a -> a -> a
+ forall a. Num a => Vector a -> a
Vector.sum (forall a. Int -> Vector a -> Vector a
Vector.take Int
i Layout
layout)
        where (Int
oct, Int
i) = Int
pc forall a. Integral a => a -> a -> (a, a)
`divMod` Int
per_oct

-- | Number of diatonic steps in an octave.  Nothing if this scale doesn't have
-- octaves.  This is the same as 'semis_per_octave' for scales without
-- a diatonic\/chromatic distinction.
pc_per_octave :: Derive.Layout -> Maybe Pitch.PitchClass
pc_per_octave :: Layout -> Maybe Int
pc_per_octave Layout
layout
    | forall a. Vector a -> Bool
Vector.null Layout
layout = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
Vector.length Layout
layout

diatonic_difference :: Derive.Layout -> Pitch.Pitch -> Pitch.Pitch
    -> Pitch.PitchClass
diatonic_difference :: Layout -> Pitch -> Pitch -> Int
diatonic_difference Layout
layout (Pitch.Pitch Int
oct1 (Pitch.Degree Int
pc1 Int
_))
        (Pitch.Pitch Int
oct2 (Pitch.Degree Int
pc2 Int
_)) =
    Int
oct_diff forall a. Num a => a -> a -> a
+ (Int
pc1 forall a. Num a => a -> a -> a
- Int
pc2)
    where oct_diff :: Int
oct_diff = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a. Num a => a -> a -> a
* (Int
oct1forall a. Num a => a -> a -> a
-Int
oct2)) (Layout -> Maybe Int
pc_per_octave Layout
layout)

chromatic_difference :: Derive.Layout -> Pitch.Pitch -> Pitch.Pitch
    -> Pitch.Semi
chromatic_difference :: Layout -> Pitch -> Pitch -> Int
chromatic_difference Layout
layout (Pitch.Pitch Int
oct1 (Pitch.Degree Int
pc1 Int
acc1))
        (Pitch.Pitch Int
oct2 (Pitch.Degree Int
pc2 Int
acc2)) =
    Int
oct_diff forall a. Num a => a -> a -> a
+ (Layout -> Int -> Int
semis_at_pc Layout
layout Int
pc1 forall a. Num a => a -> a -> a
- Layout -> Int -> Int
semis_at_pc Layout
layout Int
pc2) forall a. Num a => a -> a -> a
+ (Int
acc1 forall a. Num a => a -> a -> a
- Int
acc2)
    where oct_diff :: Int
oct_diff = Layout -> Int
semis_per_octave Layout
layout forall a. Num a => a -> a -> a
* (Int
oct1 forall a. Num a => a -> a -> a
- Int
oct2)

transpose :: Transposition -> Scale -> Env.Environ -> Pitch.Octave
    -> Pitch.Step -> Pitch.Note -> Either DeriveT.PitchError Pitch.Note
transpose :: Transposition
-> Scale -> Environ -> Int -> Int -> Note -> Either PitchError Note
transpose Transposition
transposition Scale
scale Environ
environ Int
octaves Int
steps =
    Scale -> Environ -> Pitch -> Either PitchError Note
scale_show Scale
scale Environ
environ
    forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Scale -> Transpose
scale_transpose Scale
scale Transposition
transposition Environ
environ Int
steps
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pitch -> Pitch
Pitch.add_octave Int
octaves forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Scale -> Environ -> Note -> Either PitchError Pitch
scale_read Scale
scale Environ
environ

transpose_pitch :: Transposition -> Scale -> Env.Environ -> Pitch.Octave
    -> Pitch.Step -> Pitch.Pitch -> Either DeriveT.PitchError Pitch.Pitch
transpose_pitch :: Transposition
-> Scale
-> Environ
-> Int
-> Int
-> Pitch
-> Either PitchError Pitch
transpose_pitch Transposition
transposition Scale
scale Environ
environ Int
octaves Int
steps =
    Scale -> Transpose
scale_transpose Scale
scale Transposition
transposition Environ
environ Int
steps
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pitch -> Pitch
Pitch.add_octave Int
octaves

-- * Range

-- | This is an inclusive pitch range, intended for instrument ranges.
data Range = Range {
    Range -> Pitch
range_bottom :: !Pitch.Pitch
    , Range -> Pitch
range_top :: !Pitch.Pitch
    } deriving (Int -> Range -> ShowS
[Range] -> ShowS
Range -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Range] -> ShowS
$cshowList :: [Range] -> ShowS
show :: Range -> String
$cshow :: Range -> String
showsPrec :: Int -> Range -> ShowS
$cshowsPrec :: Int -> Range -> ShowS
Show, Range -> Range -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c== :: Range -> Range -> Bool
Eq)

in_range :: Range -> Pitch.Pitch -> Bool
in_range :: Range -> Pitch -> Bool
in_range (Range Pitch
bottom Pitch
top) Pitch
pitch = Pitch
bottom forall a. Ord a => a -> a -> Bool
<= Pitch
pitch Bool -> Bool -> Bool
&& Pitch
pitch forall a. Ord a => a -> a -> Bool
<= Pitch
top

instance Pretty Range where
    pretty :: Range -> Text
pretty (Range Pitch
bottom Pitch
top) = forall a. Pretty a => a -> Text
pretty Pitch
bottom forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
top

-- * pitches

-- | Return the pitches in the scale.  If the scale has an unbounded range,
-- this may go on forever, so zip with 'note_numbers' if you want the usable
-- range.  Also, not all scales actually have defined degrees.
pitches :: Scale -> Env.Environ -> [Pitch.Pitch]
pitches :: Scale -> Environ -> [Pitch]
pitches Scale
scale Environ
environ = Pitch -> [Pitch]
go (Scale -> Pitch
scale_bottom Scale
scale)
    where
    go :: Pitch -> [Pitch]
go Pitch
pitch = Pitch
pitch forall a. a -> [a] -> [a]
: forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) Pitch -> [Pitch]
go (Pitch -> Either PitchError Pitch
step Pitch
pitch)
    step :: Pitch -> Either PitchError Pitch
step = Scale -> Transpose
scale_transpose Scale
scale Transposition
Chromatic Environ
environ Int
1

-- | Return the notes in the scale.  As with 'pitches', it may be unbounded.
notes :: Scale -> Env.Environ -> [Pitch.Note]
notes :: Scale -> Environ -> [Note]
notes Scale
scale Environ
environ = [Pitch] -> [Note]
go (Scale -> Environ -> [Pitch]
pitches Scale
scale Environ
environ)
    where
    go :: [Pitch] -> [Note]
go (Pitch
p:[Pitch]
ps) = case Scale -> Environ -> Pitch -> Either PitchError Note
scale_show Scale
scale Environ
environ Pitch
p of
        Right Note
n -> Note
n forall a. a -> [a] -> [a]
: [Pitch] -> [Note]
go [Pitch]
ps
        Left PitchError
_ -> []
    go [] = []

-- | Return pitches of the scale's degrees.
note_numbers :: Scale -> Env.Environ -> Derive.Deriver [Pitch.NoteNumber]
note_numbers :: Scale -> Environ -> Deriver [NoteNumber]
note_numbers Scale
scale Environ
environ = [Note] -> Deriver [NoteNumber]
go (Scale -> Environ -> [Note]
notes Scale
scale Environ
environ)
    where
    go :: [Note] -> Deriver [NoteNumber]
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (Note
note : [Note]
notes) = do
        RawPitch Transposed_
pitch <- forall a. Scale -> Note -> Deriver (RawPitch a)
Eval.eval_note Scale
scale Note
note
        case RawPitch Transposed_ -> Either PitchError NoteNumber
PSignal.pitch_nn RawPitch Transposed_
pitch of
            Right NoteNumber
nn -> (NoteNumber
nn:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Note] -> Deriver [NoteNumber]
go [Note]
notes
            Left (DeriveT.OutOfRangeError {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            Left PitchError
err -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"note_numbers: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty PitchError
err

-- | Make a patch scale from the NoteNumbers.
patch_scale :: Pitch.ScaleId -> [Pitch.NoteNumber] -> Patch.Scale
patch_scale :: ScaleId -> [NoteNumber] -> Scale
patch_scale ScaleId
scale_id [NoteNumber]
nns = Text -> [(Key, NoteNumber)] -> Scale
Patch.make_scale (forall a. Pretty a => a -> Text
pretty ScaleId
scale_id) forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Integral a => a -> Key
Midi.to_key) forall a b. (a -> b) -> a -> b
$ Int -> [NoteNumber] -> [(Int, NoteNumber)]
assign_keys Int
128 [NoteNumber]
nns

-- | Try to assign MIDI keys that correspond to the NoteNumbers, but
-- they won't line up if there are too many NoteNumbers.
assign_keys :: Int -> [Pitch.NoteNumber] -> [(Int, Pitch.NoteNumber)]
assign_keys :: Int -> [NoteNumber] -> [(Int, NoteNumber)]
assign_keys Int
top_key [NoteNumber]
nns = forall {b}. RealFrac b => Int -> Int -> [b] -> [(Int, b)]
go Int
0 (Int
top_key forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [NoteNumber]
nns) [NoteNumber]
nns
    where
    go :: Int -> Int -> [b] -> [(Int, b)]
go Int
_ Int
_ [] = []
    go Int
key Int
extra (b
nn:[b]
nns)
        | Int
key forall a. Ord a => a -> a -> Bool
>= Int
top_key = []
        | Bool
otherwise =
            (Int
assigned, b
nn) forall a. a -> [a] -> [a]
: Int -> Int -> [b] -> [(Int, b)]
go (Int
assignedforall a. Num a => a -> a -> a
+Int
1) (Int
extra forall a. Num a => a -> a -> a
- (Int
assignedforall a. Num a => a -> a -> a
-Int
key)) [b]
nns
        where assigned :: Int
assigned = Int
key forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
max Int
0 (forall a. Ord a => a -> a -> a
min (forall a b. (RealFrac a, Integral b) => a -> b
floor b
nn forall a. Num a => a -> a -> a
- Int
key) Int
extra)