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

-- | Utilities for simple scales, which simply map pitch names to frequencies.
-- Ok, so they also have octave structure, used by the input mechanism and to
-- parse to 'Pitch.Pitch'es, but it can be set to the number of degrees in the
-- scale if you don't have octaves.
module Derive.Scale.Scales where
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import           Data.Vector ((!?))

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts

import qualified Derive.Call.ScaleDegree as ScaleDegree
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.PSignal as PSignal
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Theory as Theory
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch

import           Global
import           Types


-- | Make a simple scale where there is a direct mapping from input to note to
-- nn.
make_scale :: Pitch.ScaleId -> DegreeMap -> Text -> Doc.Doc -> Scale.Scale
make_scale :: ScaleId -> DegreeMap -> Text -> Doc -> Scale
make_scale ScaleId
scale_id DegreeMap
dmap Text
pattern Doc
doc = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Text
pattern
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
standard_transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = (Note -> Either PitchError Pitch)
-> Environ -> Note -> Either PitchError Pitch
forall a b. a -> b -> a
const ((Note -> Either PitchError Pitch)
 -> Environ -> Note -> Either PitchError Pitch)
-> (Note -> Either PitchError Pitch)
-> Environ
-> Note
-> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ DegreeMap -> Note -> Either PitchError Pitch
read_note DegreeMap
dmap
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = (Pitch -> Either PitchError Note)
-> Environ -> Pitch -> Either PitchError Note
forall a b. a -> b -> a
const ((Pitch -> Either PitchError Note)
 -> Environ -> Pitch -> Either PitchError Note)
-> (Pitch -> Either PitchError Note)
-> Environ
-> Pitch
-> Either PitchError Note
forall a b. (a -> b) -> a -> b
$ DegreeMap -> Pitch -> Either PitchError Note
show_pitch DegreeMap
dmap
    , scale_bottom :: Pitch
scale_bottom = PitchClass -> PitchClass -> Pitch
forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch (DegreeMap -> PitchClass
dm_start_octave DegreeMap
dmap) (DegreeMap -> PitchClass
dm_start_pc DegreeMap
dmap)
    , scale_layout :: Layout
scale_layout = PitchClass -> Layout
Scale.diatonic_layout (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap)
    , scale_transpose :: Transpose
scale_transpose = DegreeMap -> Transpose
transpose DegreeMap
dmap
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = DegreeMap -> Scale -> Note -> Maybe ValCall
mapped_note_to_call DegreeMap
dmap Scale
scale
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = DegreeMap -> Environ -> Input -> Either PitchError Note
input_to_note DegreeMap
dmap
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = DegreeMap
-> ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
mapped_input_to_nn DegreeMap
dmap
    , scale_call_doc :: DocumentedCall
scale_call_doc = Set Control -> DegreeMap -> Doc -> DocumentedCall
call_doc Set Control
standard_transposers DegreeMap
dmap Doc
doc
    }
    where scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
standard_transposers

-- | An empty scale that doesn't do anything.
empty_scale :: Pitch.ScaleId -> Text -> Derive.DocumentedCall -> Scale.Scale
empty_scale :: ScaleId -> Text -> DocumentedCall -> Scale
empty_scale ScaleId
scale_id Text
pattern DocumentedCall
doc = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Text
pattern
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
standard_transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = \Environ
_ Note
_ -> PitchError -> Either PitchError Pitch
forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = \Environ
_ Pitch
_ -> PitchError -> Either PitchError Note
forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_bottom :: Pitch
scale_bottom = PitchClass -> Integer -> Pitch
forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
1 Integer
0
    , scale_layout :: Layout
scale_layout = [PitchClass] -> Layout
Scale.layout []
    , scale_transpose :: Transpose
scale_transpose = \Transposition
_ Environ
_ PitchClass
_ Pitch
_ -> PitchError -> Either PitchError Pitch
forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = Maybe ValCall -> Note -> Maybe ValCall
forall a b. a -> b -> a
const Maybe ValCall
forall a. Maybe a
Nothing
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = \Environ
_ Input
_ -> PitchError -> Either PitchError Note
forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = \ ScoreTime
_ Input
_ -> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PitchError NoteNumber
 -> Deriver (Either PitchError NoteNumber))
-> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall a b. (a -> b) -> a -> b
$ PitchError -> Either PitchError NoteNumber
forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_call_doc :: DocumentedCall
scale_call_doc = DocumentedCall
doc
    }

-- * types

data DegreeMap = DegreeMap {
    DegreeMap -> Map Note PitchClass
dm_to_semis :: Map Pitch.Note Pitch.Semi
    , DegreeMap -> Vector Note
dm_to_note :: Vector.Vector Pitch.Note
    , DegreeMap -> Vector NoteNumber
dm_to_nn :: Vector.Vector Pitch.NoteNumber
    -- | Number of scale steps per octave.  Actually, simple scales are just
    -- a collection of frequencies and don't need to have a notion of an
    -- octave.  But since the input mechanism wants to orient around octaves,
    -- it needs to know how many keys to assign to each octave.  So if your
    -- scale has no octaves, then just set this to 7, that way it lines up with
    -- the piano keyboard.
    , DegreeMap -> PitchClass
dm_per_octave :: Pitch.Semi
    , DegreeMap -> PitchClass
dm_start_octave :: Pitch.Octave
    , DegreeMap -> PitchClass
dm_start_pc :: Pitch.PitchClass
    } deriving (PitchClass -> DegreeMap -> ShowS
[DegreeMap] -> ShowS
DegreeMap -> String
(PitchClass -> DegreeMap -> ShowS)
-> (DegreeMap -> String)
-> ([DegreeMap] -> ShowS)
-> Show DegreeMap
forall a.
(PitchClass -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DegreeMap] -> ShowS
$cshowList :: [DegreeMap] -> ShowS
show :: DegreeMap -> String
$cshow :: DegreeMap -> String
showsPrec :: PitchClass -> DegreeMap -> ShowS
$cshowsPrec :: PitchClass -> DegreeMap -> ShowS
Show)

instance Pretty DegreeMap where
    format :: DegreeMap -> Doc
format DegreeMap
dmap = Map PitchClass (Note, Maybe NoteNumber) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Map PitchClass (Note, Maybe NoteNumber) -> Doc)
-> Map PitchClass (Note, Maybe NoteNumber) -> Doc
forall a b. (a -> b) -> a -> b
$ [(PitchClass, (Note, Maybe NoteNumber))]
-> Map PitchClass (Note, Maybe NoteNumber)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PitchClass, (Note, Maybe NoteNumber))]
 -> Map PitchClass (Note, Maybe NoteNumber))
-> [(PitchClass, (Note, Maybe NoteNumber))]
-> Map PitchClass (Note, Maybe NoteNumber)
forall a b. (a -> b) -> a -> b
$ do
        (Note
note, PitchClass
semis) <- Map Note PitchClass -> [(Note, PitchClass)]
forall k a. Map k a -> [(k, a)]
Map.toList (DegreeMap -> Map Note PitchClass
dm_to_semis DegreeMap
dmap)
        (PitchClass, (Note, Maybe NoteNumber))
-> [(PitchClass, (Note, Maybe NoteNumber))]
forall (m :: * -> *) a. Monad m => a -> m a
return (PitchClass
semis, (Note
note, DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap Vector NoteNumber -> PitchClass -> Maybe NoteNumber
forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
semis))

degree_map :: Pitch.PitchClass
    -> Pitch.Octave -- ^ The first Note is this Octave and PitchClass.
    -> Pitch.PitchClass
    -> [Pitch.Note] -> [Pitch.NoteNumber] -> DegreeMap
degree_map :: PitchClass
-> PitchClass -> PitchClass -> [Note] -> [NoteNumber] -> DegreeMap
degree_map PitchClass
per_octave PitchClass
start_octave PitchClass
start_pc [Note]
notes_ [NoteNumber]
nns_ = DegreeMap
    { dm_to_semis :: Map Note PitchClass
dm_to_semis = [(Note, PitchClass)] -> Map Note PitchClass
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Note] -> [PitchClass] -> [(Note, PitchClass)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Note]
notes [PitchClass
0..])
    , dm_to_note :: Vector Note
dm_to_note = [Note] -> Vector Note
forall a. [a] -> Vector a
Vector.fromList [Note]
notes
    , dm_to_nn :: Vector NoteNumber
dm_to_nn = [NoteNumber] -> Vector NoteNumber
forall a. [a] -> Vector a
Vector.fromList [NoteNumber]
nns
    , dm_per_octave :: PitchClass
dm_per_octave = PitchClass
per_octave
    , dm_start_octave :: PitchClass
dm_start_octave = PitchClass
start_octave
    , dm_start_pc :: PitchClass
dm_start_pc = PitchClass
start_pc
    }
    where
    -- Guard against infinite notes or nns.
    ([Note]
notes, [NoteNumber]
nns) = [(Note, NoteNumber)] -> ([Note], [NoteNumber])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Note, NoteNumber)] -> ([Note], [NoteNumber]))
-> [(Note, NoteNumber)] -> ([Note], [NoteNumber])
forall a b. (a -> b) -> a -> b
$ [Note] -> [NoteNumber] -> [(Note, NoteNumber)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Note]
notes_ [NoteNumber]
nns_

type SemisToNoteNumber = PSignal.PitchConfig -> Pitch.Semi
    -> Either DeriveT.PitchError Pitch.NoteNumber

-- * scale functions

read_note :: DegreeMap -> Pitch.Note -> Either DeriveT.PitchError Pitch.Pitch
read_note :: DegreeMap -> Note -> Either PitchError Pitch
read_note DegreeMap
dmap Note
note = DegreeMap -> PitchClass -> Pitch
semis_to_pitch DegreeMap
dmap (PitchClass -> Pitch)
-> Either PitchError PitchClass -> Either PitchError Pitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    PitchError -> Maybe PitchClass -> Either PitchError PitchClass
forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) (Note -> Map Note PitchClass -> Maybe PitchClass
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Note
note (DegreeMap -> Map Note PitchClass
dm_to_semis DegreeMap
dmap))

show_pitch :: DegreeMap -> Pitch.Pitch -> Either DeriveT.PitchError Pitch.Note
show_pitch :: DegreeMap -> Pitch -> Either PitchError Note
show_pitch DegreeMap
dmap Pitch
pitch = PitchError -> Maybe Note -> Either PitchError Note
forall err a. err -> Maybe a -> Either err a
justErr
    (Text -> PitchError
DeriveT.PitchError (Text
"invalid pitch: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pitch -> Text
forall a. Pretty a => a -> Text
pretty Pitch
pitch)) (Maybe Note -> Either PitchError Note)
-> Maybe Note -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$
    DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap Vector Note -> PitchClass -> Maybe Note
forall a. Vector a -> PitchClass -> Maybe a
!? DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap Pitch
pitch

-- ** transpose

transpose :: DegreeMap -> Derive.Transpose
transpose :: DegreeMap -> Transpose
transpose DegreeMap
dmap Transposition
_transposition Environ
_environ PitchClass
steps Pitch
pitch
    | Maybe Note -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe Note -> Bool) -> Maybe Note -> Bool
forall a b. (a -> b) -> a -> b
$ DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap Vector Note -> PitchClass -> Maybe Note
forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
transposed =
        Pitch -> Either PitchError Pitch
forall a b. b -> Either a b
Right (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ DegreeMap -> PitchClass -> Pitch
semis_to_pitch DegreeMap
dmap PitchClass
transposed
    | Bool
otherwise = PitchError -> Either PitchError Pitch
forall a b. a -> Either a b
Left (PitchError -> Either PitchError Pitch)
-> PitchError -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ OutOfRange -> PitchError
DeriveT.OutOfRangeError OutOfRange
DeriveT.out_of_range
    where transposed :: PitchClass
transposed = DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap Pitch
pitch PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
steps

-- | Transpose function for a non-transposing scale.
non_transposing :: Derive.Transpose
non_transposing :: Transpose
non_transposing Transposition
_ Environ
_ PitchClass
_ Pitch
_ = PitchError -> Either PitchError Pitch
forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented

-- | Indicate that this scale responds to the standard set of transpose
-- signals.  It still has to implement the support in its
-- 'Scale.scale_note_to_call'.
standard_transposers :: Set ScoreT.Control
standard_transposers :: Set Control
standard_transposers = [Control] -> Set Control
forall a. Ord a => [a] -> Set a
Set.fromList
    [ Control
Controls.octave, Control
Controls.chromatic, Control
Controls.diatonic
    , Control
Controls.nn, Control
Controls.hz
    ]

-- ** note_to_call

-- | A specialization of 'note_to_call' that operates on scales with
-- a 'DegreeMap', i.e. a static map from notes to degrees, and from degrees to
-- NNs.
mapped_note_to_call :: DegreeMap -> PSignal.Scale
    -> Pitch.Note -> Maybe Derive.ValCall
mapped_note_to_call :: DegreeMap -> Scale -> Note -> Maybe ValCall
mapped_note_to_call DegreeMap
dmap Scale
scale Note
note = do
    PitchClass
semis <- Note -> Map Note PitchClass -> Maybe PitchClass
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Note
note (DegreeMap -> Map Note PitchClass
dm_to_semis DegreeMap
dmap)
    ValCall -> Maybe ValCall
forall a. a -> Maybe a
Just (ValCall -> Maybe ValCall) -> ValCall -> Maybe ValCall
forall a b. (a -> b) -> a -> b
$ PitchClass
-> Maybe PitchClass
-> Scale
-> SemisToNoteNumber
-> (PitchClass -> Maybe Note)
-> ValCall
note_to_call (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap) (PitchClass -> Maybe PitchClass
forall a. a -> Maybe a
Just PitchClass
max_semi)
        Scale
scale (PitchClass -> SemisToNoteNumber
forall {p}.
PitchClass -> p -> PitchClass -> Either PitchError NoteNumber
semis_to_nn PitchClass
semis) (PitchClass -> PitchClass -> Maybe Note
semis_to_note PitchClass
semis)
    where
    max_semi :: PitchClass
max_semi = Vector NoteNumber -> PitchClass
forall a. Vector a -> PitchClass
Vector.length (DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap)
    semis_to_nn :: PitchClass -> p -> PitchClass -> Either PitchError NoteNumber
semis_to_nn PitchClass
semis p
_config PitchClass
transpose =
        PitchError -> Maybe NoteNumber -> Either PitchError NoteNumber
forall err a. err -> Maybe a -> Either err a
justErr PitchError
err (Maybe NoteNumber -> Either PitchError NoteNumber)
-> Maybe NoteNumber -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$ DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap Vector NoteNumber -> PitchClass -> Maybe NoteNumber
forall a. Vector a -> PitchClass -> Maybe a
!? (PitchClass
semis PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
transpose)
        where
        err :: PitchError
err = PitchClass -> (PitchClass, PitchClass) -> PitchError
forall a. Real a => a -> (PitchClass, PitchClass) -> PitchError
DeriveT.out_of_range_error (PitchClass
semis PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
transpose) (PitchClass
0, PitchClass
max_semi)
    semis_to_note :: PitchClass -> PitchClass -> Maybe Note
semis_to_note PitchClass
semis PitchClass
transpose = DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap Vector Note -> PitchClass -> Maybe Note
forall a. Vector a -> PitchClass -> Maybe a
!? (PitchClass
semis PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
transpose)

-- | Create a note call that respects chromatic and diatonic transposition.
-- However, diatonic transposition is mapped to chromatic transposition,
-- so this is for scales that don't distinguish.
note_to_call :: Pitch.Semi -> Maybe Pitch.Semi -> PSignal.Scale
    -> SemisToNoteNumber -> (Pitch.Semi -> Maybe Pitch.Note) -> Derive.ValCall
note_to_call :: PitchClass
-> Maybe PitchClass
-> Scale
-> SemisToNoteNumber
-> (PitchClass -> Maybe Note)
-> ValCall
note_to_call PitchClass
per_octave Maybe PitchClass
max_semi Scale
scale SemisToNoteNumber
semis_to_nn PitchClass -> Maybe Note
semis_to_note =
    Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree Scale
scale PitchNn
pitch_nn PitchNote
pitch_note
    where
    pitch_nn :: Scale.PitchNn
    pitch_nn :: PitchNn
pitch_nn PitchConfig
config = PitchClass -> Frac -> PitchNn
to_nn PitchClass
transpose_steps Frac
frac PitchConfig
config
        where (PitchClass
transpose_steps, Frac
frac) = Frac -> (PitchClass, Frac)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Frac -> (PitchClass, Frac)) -> Frac -> (PitchClass, Frac)
forall a b. (a -> b) -> a -> b
$ PitchConfig -> Frac
transposition PitchConfig
config
    to_nn :: PitchClass -> Frac -> PitchNn
to_nn PitchClass
semis Frac
frac PitchConfig
config
        | Frac
frac Frac -> Frac -> Bool
forall a. Eq a => a -> a -> Bool
== Frac
0 = SemisToNoteNumber
semis_to_nn PitchConfig
config PitchClass
semis
        | Bool
otherwise = NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale
            (NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber)
-> Either PitchError NoteNumber
-> Either PitchError (NoteNumber -> NoteNumber -> NoteNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SemisToNoteNumber
semis_to_nn PitchConfig
config PitchClass
semis
            Either PitchError (NoteNumber -> NoteNumber -> NoteNumber)
-> Either PitchError NoteNumber
-> Either PitchError (NoteNumber -> NoteNumber)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SemisToNoteNumber
semis_to_nn PitchConfig
config (PitchClass
semis PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
1)
            Either PitchError (NoteNumber -> NoteNumber)
-> Either PitchError NoteNumber -> Either PitchError NoteNumber
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NoteNumber -> Either PitchError NoteNumber
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Frac -> NoteNumber
Pitch.NoteNumber Frac
frac)
    pitch_note :: Scale.PitchNote
    pitch_note :: PitchNote
pitch_note PitchConfig
config = PitchError -> Maybe Note -> Either PitchError Note
forall err a. err -> Maybe a -> Either err a
justErr PitchError
err (Maybe Note -> Either PitchError Note)
-> Maybe Note -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$ PitchClass -> Maybe Note
semis_to_note PitchClass
semis
        where
        semis :: PitchClass
semis = Frac -> PitchClass
forall a b. (RealFrac a, Integral b) => a -> b
floor (Frac -> PitchClass) -> Frac -> PitchClass
forall a b. (a -> b) -> a -> b
$ PitchConfig -> Frac
transposition PitchConfig
config
        err :: PitchError
err = OutOfRange -> PitchError
DeriveT.OutOfRangeError (OutOfRange -> PitchError) -> OutOfRange -> PitchError
forall a b. (a -> b) -> a -> b
$ OutOfRange
DeriveT.out_of_range
            { oor_semi :: Maybe Frac
DeriveT.oor_semi = Frac -> Maybe Frac
forall a. a -> Maybe a
Just (PitchClass -> Frac
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
semis)
            , oor_valid :: Maybe (PitchClass, PitchClass)
DeriveT.oor_valid = (PitchClass
0,) (PitchClass -> (PitchClass, PitchClass))
-> Maybe PitchClass -> Maybe (PitchClass, PitchClass)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PitchClass
max_semi
            }
    transposition :: PitchConfig -> Frac
transposition PitchConfig
config =
        Control -> Frac
get Control
Controls.octave Frac -> Frac -> Frac
forall a. Num a => a -> a -> a
* PitchClass -> Frac
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
per_octave
            Frac -> Frac -> Frac
forall a. Num a => a -> a -> a
+ Control -> Frac
get Control
Controls.chromatic Frac -> Frac -> Frac
forall a. Num a => a -> a -> a
+ Control -> Frac
get Control
Controls.diatonic
        where get :: Control -> Frac
get Control
c = Frac -> Control -> Map Control Frac -> Frac
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Frac
0 Control
c (PitchConfig -> Map Control Frac
PSignal.pitch_controls PitchConfig
config)

add_pc :: DegreeMap -> Pitch.PitchClass -> Pitch.Pitch -> Pitch.Pitch
add_pc :: DegreeMap -> PitchClass -> Pitch -> Pitch
add_pc DegreeMap
dmap = PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap)

-- ** input

type InputToNote = Env.Environ -> Pitch.Input
    -> Either DeriveT.PitchError Pitch.Note

-- | Input to note for simple scales without keys.
input_to_note :: DegreeMap -> InputToNote
input_to_note :: DegreeMap -> Environ -> Input -> Either PitchError Note
input_to_note DegreeMap
dmap Environ
_environ (Pitch.Input KbdType
kbd Pitch
pitch Frac
frac) = do
    PitchClass
steps <- DegreeMap -> KbdType -> Pitch -> Either PitchError PitchClass
simple_kbd_to_scale DegreeMap
dmap KbdType
kbd Pitch
pitch
    Note
note <- PitchError -> Maybe Note -> Either PitchError Note
forall err a. err -> Maybe a -> Either err a
justErr PitchError
DeriveT.InvalidInput (Maybe Note -> Either PitchError Note)
-> Maybe Note -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$ DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap Vector Note -> PitchClass -> Maybe Note
forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
steps
    Note -> Either PitchError Note
forall (m :: * -> *) a. Monad m => a -> m a
return (Note -> Either PitchError Note) -> Note -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$ Frac -> Note -> Note
ScaleDegree.pitch_expr Frac
frac Note
note

type InputToNn = ScoreTime -> Pitch.Input
    -> Derive.Deriver (Either DeriveT.PitchError Pitch.NoteNumber)

-- | Input to NoteNumber for scales that have a direct relationship between
-- Degree and NoteNumber.
mapped_input_to_nn :: DegreeMap -> InputToNn
mapped_input_to_nn :: DegreeMap
-> ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
mapped_input_to_nn DegreeMap
dmap = \ScoreTime
_pos (Pitch.Input KbdType
kbd Pitch
pitch Frac
frac) -> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PitchError NoteNumber
 -> Deriver (Either PitchError NoteNumber))
-> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall a b. (a -> b) -> a -> b
$ do
    PitchClass
semis <- DegreeMap -> KbdType -> Pitch -> Either PitchError PitchClass
simple_kbd_to_scale DegreeMap
dmap KbdType
kbd Pitch
pitch
    PitchError -> Maybe NoteNumber -> Either PitchError NoteNumber
forall err a. err -> Maybe a -> Either err a
justErr (OutOfRange -> PitchError
DeriveT.OutOfRangeError OutOfRange
DeriveT.out_of_range) (Maybe NoteNumber -> Either PitchError NoteNumber)
-> Maybe NoteNumber -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$
        PitchClass -> Frac -> Maybe NoteNumber
to_nn PitchClass
semis Frac
frac
    where
    to_nn :: PitchClass -> Frac -> Maybe NoteNumber
to_nn PitchClass
semis Frac
frac
        | Frac
frac Frac -> Frac -> Bool
forall a. Eq a => a -> a -> Bool
== Frac
0 = PitchClass -> Maybe NoteNumber
lookup PitchClass
semis
        | Frac
frac Frac -> Frac -> Bool
forall a. Ord a => a -> a -> Bool
> Frac
0 = do
            NoteNumber
nn <- PitchClass -> Maybe NoteNumber
lookup PitchClass
semis
            NoteNumber
next <- PitchClass -> Maybe NoteNumber
lookup (PitchClass
semis PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
1)
            NoteNumber -> Maybe NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Maybe NoteNumber) -> NoteNumber -> Maybe NoteNumber
forall a b. (a -> b) -> a -> b
$ NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
nn NoteNumber
next (Frac -> NoteNumber
Pitch.NoteNumber Frac
frac)
        | Bool
otherwise = do
            NoteNumber
nn <- PitchClass -> Maybe NoteNumber
lookup PitchClass
semis
            NoteNumber
prev <- PitchClass -> Maybe NoteNumber
lookup (PitchClass
semis PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
- PitchClass
1)
            NoteNumber -> Maybe NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Maybe NoteNumber) -> NoteNumber -> Maybe NoteNumber
forall a b. (a -> b) -> a -> b
$ NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
prev NoteNumber
nn (Frac -> NoteNumber
Pitch.NoteNumber (Frac
frac Frac -> Frac -> Frac
forall a. Num a => a -> a -> a
+ Frac
1))
    lookup :: PitchClass -> Maybe NoteNumber
lookup PitchClass
semis = DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap Vector NoteNumber -> PitchClass -> Maybe NoteNumber
forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
semis

set_direct_input_to_nn :: Scale.Scale -> Scale.Scale
set_direct_input_to_nn :: Scale -> Scale
set_direct_input_to_nn Scale
scale = Scale
scale
    { scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
Scale.scale_input_to_nn = ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
direct_input_to_nn }

-- | An Input maps directly to a NoteNumber.  This is an efficient
-- implementation for scales tuned to 12TET.
--
-- This obeys 'Controls.octave' but none of the other transposer controls.
-- This is inconsistent with 'computed_input_to_nn', but trying to implement
-- diatonic transposition would make this not so direct any more.  And in
-- any case, "Cmd.MidiThru" shouldn't let through any transposers other than
-- octave.
direct_input_to_nn :: InputToNn
direct_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
direct_input_to_nn ScoreTime
pos (Pitch.Input KbdType
_ Pitch
pitch Frac
frac) = do
    Map Control Frac
controls <- RealTime -> Deriver (Map Control Frac)
Derive.controls_at (RealTime -> Deriver (Map Control Frac))
-> Deriver State Error RealTime -> Deriver (Map Control Frac)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Deriver State Error RealTime
forall a. Time a => a -> Deriver State Error RealTime
Derive.real ScoreTime
pos
    let octaves :: Frac
octaves = Frac -> Control -> Map Control Frac -> Frac
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Frac
0 Control
Controls.octave Map Control Frac
controls
    Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PitchError NoteNumber
 -> Deriver (Either PitchError NoteNumber))
-> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall a b. (a -> b) -> a -> b
$ NoteNumber -> Either PitchError NoteNumber
forall a b. b -> Either a b
Right (NoteNumber -> Either PitchError NoteNumber)
-> NoteNumber -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$ NoteNumber
nn NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
+ Frac -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Frac
frac Frac -> Frac -> Frac
forall a. Num a => a -> a -> a
+ Frac
octaves Frac -> Frac -> Frac
forall a. Num a => a -> a -> a
* Frac
12)
    where
    nn :: NoteNumber
nn = PitchClass -> NoteNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PitchClass -> NoteNumber) -> PitchClass -> NoteNumber
forall a b. (a -> b) -> a -> b
$ PitchClass -> PitchClass
Theory.semis_to_nn (PitchClass -> PitchClass) -> PitchClass -> PitchClass
forall a b. (a -> b) -> a -> b
$
        Layout -> Pitch -> PitchClass
Theory.pitch_to_semis Layout
Theory.piano_layout Pitch
pitch

-- | Convert input to nn by going through note_to_call.  This works for
-- complicated scales that retune based on the environment but is more work.
computed_input_to_nn :: InputToNote -> (Pitch.Note -> Maybe Derive.ValCall)
    -> InputToNn
computed_input_to_nn :: (Environ -> Input -> Either PitchError Note)
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
computed_input_to_nn Environ -> Input -> Either PitchError Note
input_to_note Note -> Maybe ValCall
note_to_call ScoreTime
pos Input
input = do
    Environ
env <- Deriver Environ
Derive.get_environ
    case Environ -> Either PitchError (Note, ValCall)
get_call Environ
env of
        Left PitchError
err -> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PitchError NoteNumber
 -> Deriver (Either PitchError NoteNumber))
-> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall a b. (a -> b) -> a -> b
$ PitchError -> Either PitchError NoteNumber
forall a b. a -> Either a b
Left PitchError
err
        Right (Note
note, ValCall
call) -> do
            RawPitch Any
pitch <- ScoreTime -> ValCall -> Deriver (RawPitch Any)
forall a. ScoreTime -> ValCall -> Deriver (RawPitch a)
Eval.apply_pitch ScoreTime
pos ValCall
call
            Map Control Frac
controls <- RealTime -> Deriver (Map Control Frac)
Derive.controls_at (RealTime -> Deriver (Map Control Frac))
-> Deriver State Error RealTime -> Deriver (Map Control Frac)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Deriver State Error RealTime
forall a. Time a => a -> Deriver State Error RealTime
Derive.real ScoreTime
pos
            NoteNumber
nn <- (PitchError -> Text)
-> Either PitchError NoteNumber -> Deriver NoteNumber
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right
                    (((Text
"evaluating note " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
forall a. Pretty a => a -> Text
pretty Note
note Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Text -> Text) -> (PitchError -> Text) -> PitchError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchError -> Text
forall a. Pretty a => a -> Text
pretty) (Either PitchError NoteNumber -> Deriver NoteNumber)
-> Either PitchError NoteNumber -> Deriver NoteNumber
forall a b. (a -> b) -> a -> b
$
                Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn (Transposed -> Either PitchError NoteNumber)
-> Transposed -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$
                PitchConfig -> RawPitch Any -> Transposed
forall a b. PitchConfig -> RawPitch a -> RawPitch b
PSignal.apply_config (Environ -> Map Control Frac -> PitchConfig
PSignal.PitchConfig Environ
env Map Control Frac
controls) RawPitch Any
pitch
            Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PitchError NoteNumber
 -> Deriver (Either PitchError NoteNumber))
-> Either PitchError NoteNumber
-> Deriver (Either PitchError NoteNumber)
forall a b. (a -> b) -> a -> b
$ NoteNumber -> Either PitchError NoteNumber
forall a b. b -> Either a b
Right NoteNumber
nn
    where
    get_call :: Environ -> Either PitchError (Note, ValCall)
get_call Environ
env = do
        Note
note <- Environ -> Input -> Either PitchError Note
input_to_note Environ
env Input
input
        (Note
note,) (ValCall -> (Note, ValCall))
-> Either PitchError ValCall -> Either PitchError (Note, ValCall)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PitchError -> Maybe ValCall -> Either PitchError ValCall
forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) (Note -> Maybe ValCall
note_to_call Note
note)

make_nn :: Maybe Pitch.NoteNumber -> Pitch.NoteNumber -> Maybe Pitch.NoteNumber
    -> Pitch.Frac -> Maybe Pitch.NoteNumber
make_nn :: Maybe NoteNumber
-> NoteNumber -> Maybe NoteNumber -> Frac -> Maybe NoteNumber
make_nn Maybe NoteNumber
mprev NoteNumber
nn Maybe NoteNumber
mnext Frac
frac
    | Frac
frac Frac -> Frac -> Bool
forall a. Eq a => a -> a -> Bool
== Frac
0 = NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just NoteNumber
nn
    | Frac
frac Frac -> Frac -> Bool
forall a. Ord a => a -> a -> Bool
> Frac
0 = (NoteNumber -> NoteNumber) -> Maybe NoteNumber -> Maybe NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NoteNumber
next -> NoteNumber -> NoteNumber -> NoteNumber
interpolate NoteNumber
nn NoteNumber
next) Maybe NoteNumber
mnext
    | Bool
otherwise = (NoteNumber -> NoteNumber) -> Maybe NoteNumber -> Maybe NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NoteNumber
prev -> NoteNumber -> NoteNumber -> NoteNumber
interpolate NoteNumber
prev NoteNumber
nn) Maybe NoteNumber
mprev
    where
    interpolate :: NoteNumber -> NoteNumber -> NoteNumber
interpolate NoteNumber
low NoteNumber
high = NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
low NoteNumber
high (Frac -> NoteNumber
Pitch.NoteNumber Frac
frac)

-- *** diatonic

simple_kbd_to_scale :: DegreeMap -> Pitch.KbdType -> Pitch.Pitch
    -> Either DeriveT.PitchError Pitch.Semi
simple_kbd_to_scale :: DegreeMap -> KbdType -> Pitch -> Either PitchError PitchClass
simple_kbd_to_scale DegreeMap
dmap KbdType
kbd Pitch
pitch =
    DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap (Pitch -> PitchClass)
-> Either PitchError Pitch -> Either PitchError PitchClass
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KbdType
-> PitchClass -> PitchClass -> Pitch -> Either PitchError Pitch
kbd_to_scale KbdType
kbd (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap) PitchClass
0 Pitch
pitch

pitch_to_semis :: DegreeMap -> Pitch.Pitch -> Pitch.Semi
pitch_to_semis :: DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs)) =
    (PitchClass
oct PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
- DegreeMap -> PitchClass
dm_start_octave DegreeMap
dmap) PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
* DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap
        PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
pc PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
- DegreeMap -> PitchClass
dm_start_pc DegreeMap
dmap PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
accs

semis_to_pitch :: DegreeMap -> Pitch.Semi -> Pitch.Pitch
semis_to_pitch :: DegreeMap -> PitchClass -> Pitch
semis_to_pitch DegreeMap
dmap PitchClass
semis =
    PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc PitchClass
per_oct (DegreeMap -> PitchClass
dm_start_pc DegreeMap
dmap) (Pitch -> Pitch) -> Pitch -> Pitch
forall a b. (a -> b) -> a -> b
$
        PitchClass -> Degree -> Pitch
Pitch.Pitch (PitchClass
oct PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ DegreeMap -> PitchClass
dm_start_octave DegreeMap
dmap) (PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc PitchClass
0)
    where
    (PitchClass
oct, PitchClass
pc) = PitchClass
semis PitchClass -> PitchClass -> (PitchClass, PitchClass)
forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
per_oct
    per_oct :: PitchClass
per_oct = DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap

kbd_to_scale :: Pitch.KbdType -> Pitch.PitchClass -> Pitch.PitchClass
    -> Pitch.Pitch -> Either DeriveT.PitchError Pitch.Pitch
kbd_to_scale :: KbdType
-> PitchClass -> PitchClass -> Pitch -> Either PitchError Pitch
kbd_to_scale KbdType
kbd PitchClass
pc_per_octave PitchClass
tonic =
    PitchError -> Maybe Pitch -> Either PitchError Pitch
forall err a. err -> Maybe a -> Either err a
justErr PitchError
DeriveT.InvalidInput (Maybe Pitch -> Either PitchError Pitch)
-> (Pitch -> Maybe Pitch) -> Pitch -> Either PitchError Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KbdType -> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
lookup_kbd_to_scale KbdType
kbd PitchClass
pc_per_octave PitchClass
tonic

-- | Convert an absolute Pitch in the input keyboard's layout to a relative
-- Pitch within a scale with the given number of diatonic steps per octave, or
-- Nothing if that key should have no pitch.
lookup_kbd_to_scale :: Pitch.KbdType -> Pitch.PitchClass -> Pitch.PitchClass
    -> Pitch.Pitch -> Maybe Pitch.Pitch
lookup_kbd_to_scale :: KbdType -> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
lookup_kbd_to_scale KbdType
kbd PitchClass
pc_per_octave PitchClass
tonic Pitch
pitch = case KbdType
kbd of
    KbdType
Pitch.PianoKbd -> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
piano_kbd_pitch PitchClass
tonic PitchClass
pc_per_octave Pitch
pitch
    KbdType
Pitch.AsciiKbd -> Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just (Pitch -> Maybe Pitch) -> Pitch -> Maybe Pitch
forall a b. (a -> b) -> a -> b
$ PitchClass -> Pitch -> Pitch
ascii_kbd_pitch PitchClass
pc_per_octave Pitch
pitch

{- Scale octave doesn't match the kbd octave, but is absolute:

       C D E F G A B|C D E F G A B
    C  1 2 3 4 5 - - 1 2 3 4 5 - -
    D  - 1 2 3 4 5 - - 1 2 3 4 5 -
    E  - - 1 2 3 4 5 - - 1 2 3 4 5

    Piano:
       0 1 2 3 4 5 6 0 1 2 3 4 5 6 0
       C D E F G A B|C D E F G A B|C
       0 1 2 3 4 - - 0
       0 1 2 3 4 5 6 7 8 - - - - - 0
-}

-- | The MIDI kbd is absolute.  This means that relative scales start on
-- different keys rather than all starting on C.  For example, in C major
-- C produces the first scale degree, while in D major D produces the first
-- scale degree.
--
-- In addition, if the scale octave is not an even multiple of the kbd octave
-- (7), the extra notes produce Nothing.  This check has to be done to
-- the relative PitchClass.  That way, a D on a 6 note scale starting on D is
-- 1, and a C is Nothing.  Thus, the returned Pitch is relative to the given
-- tonic, so it should be formatted as-is, without the key.
piano_kbd_pitch :: Pitch.PitchClass -> Pitch.PitchClass -> Pitch.Pitch
    -> Maybe Pitch.Pitch
piano_kbd_pitch :: PitchClass -> PitchClass -> Pitch -> Maybe Pitch
piano_kbd_pitch PitchClass
tonic PitchClass
pc_per_octave (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs))
    | PitchClass
relative_pc PitchClass -> PitchClass -> Bool
forall a. Ord a => a -> a -> Bool
>= PitchClass
pc_per_octave = Maybe Pitch
forall a. Maybe a
Nothing
    | Bool
otherwise =
        Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just (Pitch -> Maybe Pitch) -> Pitch -> Maybe Pitch
forall a b. (a -> b) -> a -> b
$ PitchClass -> Degree -> Pitch
Pitch.Pitch (PitchClass
oct1 PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
oct_diff) (PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
relative_pc PitchClass
accs)
    where
    (PitchClass
oct1, PitchClass
pc1) = PitchClass
-> PitchClass
-> PitchClass
-> PitchClass
-> (PitchClass, PitchClass)
adjust_octave PitchClass
pc_per_octave PitchClass
7 PitchClass
oct PitchClass
pc
    (PitchClass
oct_diff, PitchClass
relative_pc) = (PitchClass
pc1 PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
- PitchClass
tonic) PitchClass -> PitchClass -> (PitchClass, PitchClass)
forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
max_pc
    max_pc :: PitchClass
max_pc = Frac -> PitchClass
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (PitchClass -> Frac
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
pc_per_octave Frac -> Frac -> Frac
forall a. Fractional a => a -> a -> a
/ Frac
7) PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
* PitchClass
7

-- | The ASCII kbd is relative.  This means that relative scales always start
-- on \"C\".  So the tonic note of a key in a relative scale is irrelevant,
-- C major and D major both start in the same place.  Of course, they produce
-- different frequencies, but that's the responsibility of
-- 'Scale.scale_note_to_call'.
--
-- Unlike 'absolute_to_pitch', if the scale octave is not an even multiple of
-- the kbd octave (10), the extra notes wrap to the next highest octave.
ascii_kbd_pitch :: Pitch.PitchClass -> Pitch.Pitch -> Pitch.Pitch
ascii_kbd_pitch :: PitchClass -> Pitch -> Pitch
ascii_kbd_pitch PitchClass
pc_per_octave (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs)) =
    PitchClass -> Degree -> Pitch
Pitch.Pitch (PitchClass
add_oct PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
oct1) (PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc2 PitchClass
accs)
    where
    (PitchClass
oct1, PitchClass
pc1) = PitchClass
-> PitchClass
-> PitchClass
-> PitchClass
-> (PitchClass, PitchClass)
adjust_octave PitchClass
pc_per_octave PitchClass
10 PitchClass
oct PitchClass
pc
    -- If the scale is shorter than the kbd, go up to the next octave on
    -- the same row.
    (PitchClass
add_oct, PitchClass
pc2) = PitchClass
pc1 PitchClass -> PitchClass -> (PitchClass, PitchClass)
forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
pc_per_octave

-- | Try to fit a note from a keyboard into a scale.  Round the note up to the
-- nearest multiple of the keyboard octave and adjust the octave accordingly.
adjust_octave :: Pitch.PitchClass -> Pitch.PitchClass -> Pitch.Octave
    -> Pitch.PitchClass -> (Pitch.Octave, Pitch.PitchClass)
adjust_octave :: PitchClass
-> PitchClass
-> PitchClass
-> PitchClass
-> (PitchClass, PitchClass)
adjust_octave PitchClass
pc_per_octave PitchClass
kbd_per_octave PitchClass
oct PitchClass
pc =
    (PitchClass
oct2, PitchClass
offset PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
* PitchClass
kbd_per_octave PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
pc)
    where
    rows :: PitchClass
rows = Frac -> PitchClass
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Frac -> PitchClass) -> Frac -> PitchClass
forall a b. (a -> b) -> a -> b
$ PitchClass -> Frac
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
pc_per_octave Frac -> Frac -> Frac
forall a. Fractional a => a -> a -> a
/ PitchClass -> Frac
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
kbd_per_octave
    (PitchClass
oct2, PitchClass
offset) = PitchClass
oct PitchClass -> PitchClass -> (PitchClass, PitchClass)
forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
rows


-- ** call_doc

call_doc :: Set ScoreT.Control -> DegreeMap -> Doc.Doc -> Derive.DocumentedCall
call_doc :: Set Control -> DegreeMap -> Doc -> DocumentedCall
call_doc Set Control
transposers DegreeMap
dmap Doc
doc =
    Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
annotate_call_doc Set Control
transposers Doc
doc [(Doc, Doc)]
fields DocumentedCall
default_scale_degree_doc
    where
    fields :: [(Doc, Doc)]
fields
        | Vector Note -> Bool
forall a. Vector a -> Bool
Vector.null Vector Note
notes = []
        | Bool
otherwise = [(Doc
"range", Note -> Doc
forall a. Pretty a => a -> Doc
Doc.pretty Note
bottom Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" to " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Note -> Doc
forall a. Pretty a => a -> Doc
Doc.pretty Note
top)]
        where
        bottom :: Note
bottom = Vector Note
notes Vector Note -> PitchClass -> Note
forall a. Vector a -> PitchClass -> a
Vector.! PitchClass
0
        top :: Note
top = Vector Note
notes Vector Note -> PitchClass -> Note
forall a. Vector a -> PitchClass -> a
Vector.! (Vector Note -> PitchClass
forall a. Vector a -> PitchClass
Vector.length Vector Note
notes PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
- PitchClass
1)
        notes :: Vector Note
notes = DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap

-- | Documentation of the standard 'Call.Pitch.scale_degree'.
default_scale_degree_doc :: Derive.DocumentedCall
default_scale_degree_doc :: DocumentedCall
default_scale_degree_doc = (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
scale_degree_doc Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree

scale_degree_doc ::
    (PSignal.Scale -> Scale.PitchNn -> Scale.PitchNote -> Derive.ValCall)
    -> Derive.DocumentedCall
scale_degree_doc :: (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
scale_degree_doc Scale -> PitchNn -> PitchNote -> ValCall
scale_degree =
    ValCall -> DocumentedCall
Derive.extract_val_doc (ValCall -> DocumentedCall) -> ValCall -> DocumentedCall
forall a b. (a -> b) -> a -> b
$ Scale -> PitchNn -> PitchNote -> ValCall
scale_degree Scale
PSignal.no_scale PitchNn
forall {p} {b}. p -> Either PitchError b
err PitchNote
forall {p} {b}. p -> Either PitchError b
err
    where err :: p -> Either PitchError b
err p
_ = PitchError -> Either PitchError b
forall a b. a -> Either a b
Left (PitchError -> Either PitchError b)
-> PitchError -> Either PitchError b
forall a b. (a -> b) -> a -> b
$ Text -> PitchError
PSignal.PitchError Text
"it was just an example!"

annotate_call_doc :: Set ScoreT.Control -> Doc.Doc -> [(Doc.Doc, Doc.Doc)]
    -> Derive.DocumentedCall -> Derive.DocumentedCall
annotate_call_doc :: Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
annotate_call_doc Set Control
transposers Doc
doc [(Doc, Doc)]
fields = Doc -> DocumentedCall -> DocumentedCall
prepend_doc Doc
extra_doc
    where
    extra_doc :: Doc
extra_doc = Doc
doc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [(Doc, Doc)] -> Doc
join ([(Doc, Doc)]
transposers_field [(Doc, Doc)] -> [(Doc, Doc)] -> [(Doc, Doc)]
forall a. [a] -> [a] -> [a]
++ [(Doc, Doc)]
fields)
    transposers_field :: [(Doc, Doc)]
transposers_field =
        [(Doc
"transposers", Text -> Doc
Doc.Doc (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Set Control -> Text
forall a. Pretty a => a -> Text
pretty Set Control
transposers) |
            Bool -> Bool
not (Set Control -> Bool
forall a. Set a -> Bool
Set.null Set Control
transposers)]
    join :: [(Doc, Doc)] -> Doc
join = [Doc] -> Doc
forall a. (Textlike a, Monoid a, IsString a) => [a] -> a
Texts.enumeration
        ([Doc] -> Doc) -> ([(Doc, Doc)] -> [Doc]) -> [(Doc, Doc)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Doc, Doc) -> Doc) -> [(Doc, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Doc
k, Doc
v) -> Doc
k Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
": " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
v) ([(Doc, Doc)] -> [Doc])
-> ([(Doc, Doc)] -> [(Doc, Doc)]) -> [(Doc, Doc)] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Doc, Doc) -> Bool) -> [(Doc, Doc)] -> [(Doc, Doc)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Doc -> Doc -> Bool
forall a. Eq a => a -> a -> Bool
/=Doc
"") (Doc -> Bool) -> ((Doc, Doc) -> Doc) -> (Doc, Doc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc, Doc) -> Doc
forall a b. (a, b) -> b
snd)

add_doc :: Doc.Doc -> Scale.Scale -> Scale.Scale
add_doc :: Doc -> Scale -> Scale
add_doc Doc
doc Scale
scale = Scale
scale
    { scale_call_doc :: DocumentedCall
Scale.scale_call_doc = Doc -> DocumentedCall -> DocumentedCall
prepend_doc Doc
doc (Scale -> DocumentedCall
Scale.scale_call_doc Scale
scale) }

-- *** DocumentedCall

-- | Prepend a bit of text to the documentation.
prepend_doc :: Doc.Doc -> Derive.DocumentedCall -> Derive.DocumentedCall
prepend_doc :: Doc -> DocumentedCall -> DocumentedCall
prepend_doc Doc
text = (Doc -> Doc) -> DocumentedCall -> DocumentedCall
modify_doc ((Doc
text Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n") <>)

modify_doc :: (Doc.Doc -> Doc.Doc) -> Derive.DocumentedCall
    -> Derive.DocumentedCall
modify_doc :: (Doc -> Doc) -> DocumentedCall -> DocumentedCall
modify_doc Doc -> Doc
modify (Derive.DocumentedCall CallName
name CallDoc
doc) =
    CallName -> CallDoc -> DocumentedCall
Derive.DocumentedCall CallName
name (CallDoc -> CallDoc
annotate CallDoc
doc)
    where
    annotate :: CallDoc -> CallDoc
annotate (Derive.CallDoc Module
module_ Tags
tags Doc
cdoc [ArgDoc]
args) =
        Module -> Tags -> Doc -> [ArgDoc] -> CallDoc
Derive.CallDoc Module
module_ Tags
tags (Doc -> Doc
modify Doc
cdoc) [ArgDoc]
args

-- * util

no_enharmonics :: Derive.Enharmonics
no_enharmonics :: Enharmonics
no_enharmonics Environ
_ Note
_ = [Note] -> Either PitchError [Note]
forall a b. b -> Either a b
Right []

-- | Like 'read_environ_', but with a simpler parser.
read_environ :: (Typecheck.Typecheck a, ShowVal.ShowVal a)
    => (a -> Maybe val)
    -> Maybe val -- ^ if Just, a missing value gets this, otherwise error
    -> Env.Key -> Env.Environ -> Either DeriveT.PitchError val
read_environ :: forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Text -> Environ -> Either PitchError val
read_environ a -> Maybe val
parse Maybe val
maybe_deflt =
    (a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
read_environ_ (Either (Maybe Text) val
-> (val -> Either (Maybe Text) val)
-> Maybe val
-> Either (Maybe Text) val
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> Either (Maybe Text) val
forall a b. a -> Either a b
Left Maybe Text
forall a. Maybe a
Nothing) val -> Either (Maybe Text) val
forall a b. b -> Either a b
Right (Maybe val -> Either (Maybe Text) val)
-> (a -> Maybe val) -> a -> Either (Maybe Text) val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe val
parse) (val -> Either PitchError val
forall a b. b -> Either a b
Right (val -> Either PitchError val)
-> Maybe val -> Maybe (Either PitchError val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe val
maybe_deflt)

-- | Like 'read_environ', except the default is given to the parse function.
read_environ_default :: (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    (a -> Maybe val) -> Maybe a
    -> Env.Key -> Env.Environ -> Either DeriveT.PitchError val
read_environ_default :: forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe a -> Text -> Environ -> Either PitchError val
read_environ_default a -> Maybe val
parse Maybe a
maybe_deflt Text
name =
    (a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
read_environ_ (Either (Maybe Text) val
-> (val -> Either (Maybe Text) val)
-> Maybe val
-> Either (Maybe Text) val
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> Either (Maybe Text) val
forall a b. a -> Either a b
Left Maybe Text
forall a. Maybe a
Nothing) val -> Either (Maybe Text) val
forall a b. b -> Either a b
Right (Maybe val -> Either (Maybe Text) val)
-> (a -> Maybe val) -> a -> Either (Maybe Text) val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe val
parse)
        (a -> Either PitchError val
parse_default (a -> Either PitchError val)
-> Maybe a -> Maybe (Either PitchError val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
maybe_deflt) Text
name
    where
    parse_default :: a -> Either PitchError val
parse_default a
val = case a -> Maybe val
parse a
val of
        Just val
a -> val -> Either PitchError val
forall a b. b -> Either a b
Right val
a
        Maybe val
Nothing -> Text -> Either PitchError val
forall {b}. Text -> Either PitchError b
environ_error (Text -> Either PitchError val) -> Text -> Either PitchError val
forall a b. (a -> b) -> a -> b
$
            Text
"can't parse default: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val a
val
    environ_error :: Text -> Either PitchError b
environ_error = PitchError -> Either PitchError b
forall a b. a -> Either a b
Left (PitchError -> Either PitchError b)
-> (Text -> PitchError) -> Text -> Either PitchError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
name (Maybe Text -> PitchError)
-> (Text -> Maybe Text) -> Text -> PitchError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just

-- | Read and parse an environ value, or throw a ScaleError.
-- This takes a parse function in addition to the usual Typecheck, because
-- scales and keys don't use use Typecheck, beyond ensuring it's a string.
read_environ_ :: (Typecheck.Typecheck a, ShowVal.ShowVal a)
    => (a -> Either (Maybe Text) val) -> Maybe (Either PSignal.PitchError val)
    -> Env.Key -> Env.Environ -> Either DeriveT.PitchError val
read_environ_ :: forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
read_environ_ a -> Either (Maybe Text) val
parse Maybe (Either PitchError val)
maybe_deflt Text
name Environ
env = case Text -> Environ -> Either LookupError a
forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
name Environ
env of
    Left (Env.WrongType Type
expected) ->
        Text -> Either PitchError val
forall {b}. Text -> Either PitchError b
environ_error (Text
"expected type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
expected)
    Left LookupError
Env.NotFound -> case Maybe (Either PitchError val)
maybe_deflt of
        Maybe (Either PitchError val)
Nothing -> PitchError -> Either PitchError val
forall a b. a -> Either a b
Left (PitchError -> Either PitchError val)
-> PitchError -> Either PitchError val
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
name Maybe Text
forall a. Maybe a
Nothing
        Just Either PitchError val
deflt -> Either PitchError val
deflt
    Right a
val -> a -> Either PitchError val
parse_val a
val
    where
    parse_val :: a -> Either PitchError val
parse_val a
val = case a -> Either (Maybe Text) val
parse a
val of
        Right val
a -> val -> Either PitchError val
forall a b. b -> Either a b
Right val
a
        Left Maybe Text
msg -> Text -> Either PitchError val
forall {b}. Text -> Either PitchError b
environ_error (Text -> Either PitchError val) -> Text -> Either PitchError val
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"can't parse" Maybe Text
msg
    environ_error :: Text -> Either PitchError b
environ_error = PitchError -> Either PitchError b
forall a b. a -> Either a b
Left (PitchError -> Either PitchError b)
-> (Text -> PitchError) -> Text -> Either PitchError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
name (Maybe Text -> PitchError)
-> (Text -> Maybe Text) -> Text -> PitchError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just


-- ** keys

environ_key :: Env.Environ -> Maybe Pitch.Key
environ_key :: Environ -> Maybe Key
environ_key = (Text -> Key) -> Maybe Text -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Key
Pitch.Key (Maybe Text -> Maybe Key)
-> (Environ -> Maybe Text) -> Environ -> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Text
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.key

-- | Find a key in a map, or throw a ScaleError.
get_key :: key -> Map Pitch.Key key -> Maybe Pitch.Key
    -> Either DeriveT.PitchError key
get_key :: forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
get_key key
deflt Map Key key
_ Maybe Key
Nothing = key -> Either PitchError key
forall a b. b -> Either a b
Right key
deflt
get_key key
_ Map Key key
keys (Just Key
key) = PitchError -> Maybe key -> Either PitchError key
forall err a. err -> Maybe a -> Either err a
justErr (Key -> PitchError
key_error Key
key) (Key -> Map Key key -> Maybe key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key key
keys)

lookup_key :: key -> Map Pitch.Key key -> Maybe Pitch.Key -> Maybe key
lookup_key :: forall key. key -> Map Key key -> Maybe Key -> Maybe key
lookup_key key
deflt Map Key key
_ Maybe Key
Nothing = key -> Maybe key
forall a. a -> Maybe a
Just key
deflt
lookup_key key
_ Map Key key
keys (Just Key
key) = Key -> Map Key key -> Maybe key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key key
keys

key_error :: Pitch.Key -> DeriveT.PitchError
key_error :: Key -> PitchError
key_error (Pitch.Key Text
key) =
    Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
EnvKey.key (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"unknown key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key)