-- 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.Derive, module Derive.Scale) where
import qualified Data.Vector.Unboxed as Vector

import qualified Derive.Derive as Derive
import           Derive.Derive
       (lookup_scale, Layout, Scale(..), LookupScale(..), 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 Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch

import           Global


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

-- | 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] -> Layout
layout :: [Int] -> Layout
layout = [Int] -> Layout
forall a. Unbox a => [a] -> Vector a
Vector.fromList

no_octaves :: Layout
no_octaves :: Layout
no_octaves = Layout
forall a. Unbox a => Vector a
Vector.empty

diatonic_layout :: Pitch.PitchClass -> Layout
diatonic_layout :: Int -> Layout
diatonic_layout Int
per_oct = [Int] -> Layout
layout ([Int] -> Layout) -> [Int] -> Layout
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Int]
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 :: Layout -> Pitch.Semi
semis_per_octave :: Layout -> Int
semis_per_octave = Layout -> Int
forall a. (Unbox a, Num a) => Vector a -> a
Vector.sum

semis_at_pc :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Layout -> Int
forall a. (Unbox a, Num a) => Vector a -> a
Vector.sum Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
forall a. (Unbox a, Num a) => Vector a -> a
Vector.sum (Int -> Layout -> Layout
forall a. Unbox a => Int -> Vector a -> Vector a
Vector.take Int
i Layout
layout)
        where (Int
oct, Int
i) = Int
pc Int -> Int -> (Int, Int)
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 :: Layout -> Maybe Pitch.PitchClass
pc_per_octave :: Layout -> Maybe Int
pc_per_octave Layout
layout
    | Layout -> Bool
forall a. Unbox a => Vector a -> Bool
Vector.null Layout
layout = Maybe Int
forall a. Maybe a
Nothing
    | Bool
otherwise = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Layout -> Int
forall a. Unbox a => Vector a -> Int
Vector.length Layout
layout

diatonic_difference :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pc2)
    where oct_diff :: Int
oct_diff = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
oct1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
oct2)) (Layout -> Maybe Int
pc_per_octave Layout
layout)

chromatic_difference :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Layout -> Int -> Int
semis_at_pc Layout
layout Int
pc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Layout -> Int -> Int
semis_at_pc Layout
layout Int
pc2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
acc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
acc2)
    where oct_diff :: Int
oct_diff = Layout -> Int
semis_per_octave Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
oct1 Int -> Int -> Int
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
    (Pitch -> Either PitchError Note)
-> (Note -> Either PitchError Pitch)
-> Note
-> Either PitchError Note
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
    (Pitch -> Either PitchError Pitch)
-> (Pitch -> Pitch) -> Pitch -> Either PitchError Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pitch -> Pitch
Pitch.add_octave Int
octaves (Pitch -> Either PitchError Pitch)
-> (Note -> Either PitchError Pitch)
-> Note
-> Either PitchError Pitch
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
    (Pitch -> Either PitchError Pitch)
-> (Pitch -> Pitch) -> Pitch -> Either PitchError Pitch
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
(Int -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
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)

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

instance Pretty Range where
    pretty :: Range -> Text
pretty (Range Pitch
bottom Pitch
top) = Pitch -> Text
forall a. Pretty a => a -> Text
pretty Pitch
bottom Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pitch -> Text
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 Pitch -> [Pitch] -> [Pitch]
forall a. a -> [a] -> [a]
: (PitchError -> [Pitch])
-> (Pitch -> [Pitch]) -> Either PitchError Pitch -> [Pitch]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Pitch] -> PitchError -> [Pitch]
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 Note -> [Note] -> [Note]
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 [] = [NoteNumber] -> Deriver [NoteNumber]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (Note
note : [Note]
notes) = do
        RawPitch Transposed_
pitch <- Scale -> Note -> Deriver (RawPitch Transposed_)
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:) ([NoteNumber] -> [NoteNumber])
-> Deriver [NoteNumber] -> Deriver [NoteNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Note] -> Deriver [NoteNumber]
go [Note]
notes
            Left (DeriveT.OutOfRangeError {}) -> [NoteNumber] -> Deriver [NoteNumber]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Left PitchError
err -> Text -> Deriver [NoteNumber]
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver [NoteNumber]) -> Text -> Deriver [NoteNumber]
forall a b. (a -> b) -> a -> b
$ Text
"note_numbers: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PitchError -> Text
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 (ScaleId -> Text
forall a. Pretty a => a -> Text
pretty ScaleId
scale_id) ([(Key, NoteNumber)] -> Scale) -> [(Key, NoteNumber)] -> Scale
forall a b. (a -> b) -> a -> b
$
    ((Int, NoteNumber) -> (Key, NoteNumber))
-> [(Int, NoteNumber)] -> [(Key, NoteNumber)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Key) -> (Int, NoteNumber) -> (Key, NoteNumber)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Key
forall a. Integral a => a -> Key
Midi.to_key) ([(Int, NoteNumber)] -> [(Key, NoteNumber)])
-> [(Int, NoteNumber)] -> [(Key, NoteNumber)]
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 = Int -> Int -> [NoteNumber] -> [(Int, NoteNumber)]
forall {b}. RealFrac b => Int -> Int -> [b] -> [(Int, b)]
go Int
0 (Int
top_key Int -> Int -> Int
forall a. Num a => a -> a -> a
- [NoteNumber] -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
top_key = []
        | Bool
otherwise =
            (Int
assigned, b
nn) (Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
: Int -> Int -> [b] -> [(Int, b)]
go (Int
assignedInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
extra Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
assignedInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
key)) [b]
nns
        where assigned :: Int
assigned = Int
key Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (b -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor b
nn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
key) Int
extra)