-- 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)