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

{-# LANGUAGE CPP #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Derive.Scale.JavaScales (
    ScaleMap(..)
    , Instrument(..)
    , Absolute(..)
    , make_scale
    , Layout(..)
    , make_layout
    -- * Format
    , Format(..)
    , cipher_absolute
    , cipher_octave_relative
    -- * Tuning
    , Laras(..)
#ifdef TESTING
    , add_diatonic
    , module Derive.Scale.JavaScales
#endif
) where
import qualified Data.Attoparsec.Text as A
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText

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.PSignal as PSignal
import qualified Derive.REnv as REnv
import qualified Derive.Scale as Scale
import qualified Derive.Scale.BaliScales as BaliScales
import qualified Derive.Scale.Scales as Scales
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           Util.Affine


data ScaleMap = ScaleMap {
    ScaleMap -> Layout
layout :: Layout
    , ScaleMap -> LarasMap
laras_map :: Map Text BaliScales.Laras
    , ScaleMap -> Laras
default_laras :: BaliScales.Laras
    , ScaleMap -> Format
format :: Format
    }

data Instrument = Instrument {
    Instrument -> Int
center :: Pitch.Octave
    , Instrument -> Absolute
bottom :: Absolute
    -- | Unlike most ranges, this is inclusive, so top is a valid pitch.
    -- This seems more intuitive for instruments, and besides there's no
    -- need for an empty range.
    , Instrument -> Absolute
top :: Absolute
    } deriving (Int -> Instrument -> ShowS
[Instrument] -> ShowS
Instrument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instrument] -> ShowS
$cshowList :: [Instrument] -> ShowS
show :: Instrument -> String
$cshow :: Instrument -> String
showsPrec :: Int -> Instrument -> ShowS
$cshowsPrec :: Int -> Instrument -> ShowS
Show)

check_range :: Instrument -> Absolute -> Either DeriveT.PitchError Absolute
check_range :: Instrument -> Absolute -> Either PitchError Absolute
check_range Instrument
inst Absolute
pitch
    | Instrument
inst.bottom forall a. Ord a => a -> a -> Bool
<= Absolute
pitch Bool -> Bool -> Bool
&& Absolute
pitch forall a. Ord a => a -> a -> Bool
<= Instrument
inst.top = forall a b. b -> Either a b
Right Absolute
pitch
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PitchError
DeriveT.PitchError forall a b. (a -> b) -> a -> b
$
        Text
"out of instrument range " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst.bottom forall a. Semigroup a => a -> a -> a
<> Text
" to "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst.top forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Absolute
pitch

-- | An absolute pitch as parsed from Pitch.Note, so e.g. 1-7 (for 1-7).  This
-- is the "chromatic" representation, while Pitch is the diatonic one, taking
-- pathet into account.
--
-- TheoryFormat has a similar notion of relative to absolute, but it's
-- the other way around, in that Pitch.Pitch is the absolute one, while
-- Pitch.Note is relative.
data Absolute = Absolute !Pitch.Octave !Pitch.PitchClass
    deriving (Int -> Absolute -> ShowS
[Absolute] -> ShowS
Absolute -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Absolute] -> ShowS
$cshowList :: [Absolute] -> ShowS
show :: Absolute -> String
$cshow :: Absolute -> String
showsPrec :: Int -> Absolute -> ShowS
$cshowsPrec :: Int -> Absolute -> ShowS
Show, Absolute -> Absolute -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Absolute -> Absolute -> Bool
$c/= :: Absolute -> Absolute -> Bool
== :: Absolute -> Absolute -> Bool
$c== :: Absolute -> Absolute -> Bool
Eq, Eq Absolute
Absolute -> Absolute -> Bool
Absolute -> Absolute -> Ordering
Absolute -> Absolute -> Absolute
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Absolute -> Absolute -> Absolute
$cmin :: Absolute -> Absolute -> Absolute
max :: Absolute -> Absolute -> Absolute
$cmax :: Absolute -> Absolute -> Absolute
>= :: Absolute -> Absolute -> Bool
$c>= :: Absolute -> Absolute -> Bool
> :: Absolute -> Absolute -> Bool
$c> :: Absolute -> Absolute -> Bool
<= :: Absolute -> Absolute -> Bool
$c<= :: Absolute -> Absolute -> Bool
< :: Absolute -> Absolute -> Bool
$c< :: Absolute -> Absolute -> Bool
compare :: Absolute -> Absolute -> Ordering
$ccompare :: Absolute -> Absolute -> Ordering
Ord)

instance Pretty Absolute where
    pretty :: Absolute -> Text
pretty (Absolute Int
oct Int
pc) = forall a. Show a => a -> Text
showt Int
oct forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
pc

make_scale :: Text -> ScaleMap -> Doc.Doc -> Scale.Scale
make_scale :: Text -> ScaleMap -> Doc -> Scale
make_scale Text
name ScaleMap
smap Doc
doc = Scale.Scale
    { ScaleId
scale_id :: ScaleId
scale_id :: ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = ScaleMap
smap.format.pattern
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
Scales.standard_transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = \Environ
_env -> ScaleMap
smap.format.read
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = \Environ
_env -> ScaleMap
smap.format.show
    -- TODO technically it can change per laras, but can I forbid that?
    , scale_bottom :: Pitch
scale_bottom = Laras -> Pitch
BaliScales.laras_base ScaleMap
smap.default_laras
    , scale_layout :: Intervals
scale_layout = ScaleMap
smap.layout.intervals
    , scale_transpose :: Transpose
scale_transpose = ScaleMap -> Transpose
transpose ScaleMap
smap
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
Scales.no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = Scale -> ScaleMap -> Note -> Maybe ValCall
note_to_call Scale
scale ScaleMap
smap
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = ScaleMap -> Environ -> Input -> Either PitchError Note
input_to_note ScaleMap
smap
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = (Environ -> Input -> Either PitchError Note)
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
Scales.computed_input_to_nn
        (ScaleMap -> Environ -> Input -> Either PitchError Note
input_to_note ScaleMap
smap) (Scale -> ScaleMap -> Note -> Maybe ValCall
note_to_call Scale
scale ScaleMap
smap)
    -- TODO
    , scale_call_doc :: DocumentedCall
scale_call_doc = (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
Scales.scale_degree_doc Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree
    }
    where
    scale_id :: ScaleId
scale_id = Text -> ScaleId
Pitch.ScaleId Text
name
    scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
Scales.standard_transposers

-- TODO rename to Key or Pathet?
data Layout = Layout {
    -- | 'Absolute' (chromatic) step on which 'intervals' starts, to
    -- map from Absolute to Pitch and back.
    Layout -> Int
start :: Pitch.PitchClass
    , Layout -> Intervals
intervals :: Intervals
    , Layout -> Layout
theory :: Theory.Layout -- TODO remove, only BaliScales.semis_to_nn
    -- | Cache diatonic to chromatic mappings.
    , Layout -> Vector Chromatic
d_to_c :: Vector.Vector Chromatic
    , Layout -> Vector (Diatonic, ChromaticSteps)
c_to_d :: Vector.Vector (Diatonic, ChromaticSteps)
    -- | This is like d_to_c, except it includes chromatic steps as
    -- accidentals, so it can map from the ascii kbd.
    -- TODO merge with d_to_c.
    , Layout -> Map Degree Int
degree_to_pc :: Map Pitch.Degree Pitch.PitchClass
    } deriving (Int -> Layout -> ShowS
[Layout] -> ShowS
Layout -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layout] -> ShowS
$cshowList :: [Layout] -> ShowS
show :: Layout -> String
$cshow :: Layout -> String
showsPrec :: Int -> Layout -> ShowS
$cshowsPrec :: Int -> Layout -> ShowS
Show)

type Intervals = Vector.Vector Pitch.Semi

make_layout :: Int -> [Pitch.Semi] -> Layout
make_layout :: Int -> [Int] -> Layout
make_layout Int
start [Int]
intervals = Layout
    { $sel:start:Layout :: Int
start = Int
start
    , $sel:intervals:Layout :: Intervals
intervals = Intervals
intervals_v
    , $sel:theory:Layout :: Layout
theory = [Int] -> Layout
Theory.layout [Int]
intervals
    , $sel:d_to_c:Layout :: Vector Chromatic
d_to_c = Intervals -> Vector Chromatic
make_d_to_c Intervals
intervals_v
    , $sel:c_to_d:Layout :: Vector (Diatonic, ChromaticSteps)
c_to_d = Intervals -> Vector (Diatonic, ChromaticSteps)
make_c_to_d Intervals
intervals_v
    , $sel:degree_to_pc:Layout :: Map Degree Int
degree_to_pc = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Degree]
to_degree [Int
0..]
    }
    where
    to_degree :: [Degree]
to_degree = [Int] -> [Degree]
make_step_to_degree [Int]
intervals
    intervals_v :: Intervals
intervals_v = forall a. [a] -> Vector a
Vector.fromList [Int]
intervals

make_step_to_degree :: [Pitch.Semi] -> [Pitch.Degree]
make_step_to_degree :: [Int] -> [Degree]
make_step_to_degree = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> [Degree]
make [Int
0..]
    where make :: Int -> Int -> [Degree]
make Int
pc Int
acc = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Degree
Pitch.Degree Int
pc) [Int
0 .. Int
accforall a. Num a => a -> a -> a
-Int
1]

lima :: Layout
lima = Int -> [Int] -> Layout
make_layout Int
0 [Int
1, Int
1, Int
2, Int
1, Int
2]
barang :: Layout
barang = Int -> [Int] -> Layout
make_layout Int
1 [Int
1, Int
2, Int
1, Int
1, Int
2] -- 23567

note_to_call :: DeriveT.Scale -> ScaleMap -> Pitch.Note -> Maybe Derive.ValCall
note_to_call :: Scale -> ScaleMap -> Note -> Maybe ValCall
note_to_call Scale
scale ScaleMap
smap Note
note = case ScaleMap
smap.format.read Note
note of
    Left PitchError
_ -> forall a. Maybe a
Nothing
    Right Pitch
pitch -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree Scale
scale
        (Pitch -> PitchNn
pitch_nn Pitch
pitch) (Pitch -> PitchNote
pitch_note Pitch
pitch)
    where
    pitch_nn :: Pitch.Pitch -> Scale.PitchNn
    pitch_nn :: Pitch -> PitchNn
pitch_nn Pitch
pitch config :: PitchConfig
config@(PSignal.PitchConfig Environ
_env ControlValMap
controls) =
        ScaleMap
-> PitchConfig -> FChromatic -> Either PitchError NoteNumber
chromatic_to_nn ScaleMap
smap PitchConfig
config forall a b. (a -> b) -> a -> b
$
        Layout -> Pitch -> ControlValMap -> FChromatic
pitch_to_transposed Layout
layout Pitch
pitch ControlValMap
controls
    pitch_note :: Pitch.Pitch -> Scale.PitchNote
    pitch_note :: Pitch -> PitchNote
pitch_note Pitch
pitch (PSignal.PitchConfig Environ
_env ControlValMap
controls) =
        ScaleMap
smap.format.show forall a b. (a -> b) -> a -> b
$ Layout -> Chromatic -> Pitch
chromatic_to_pitch Layout
layout forall a b. (a -> b) -> a -> b
$
        FChromatic -> Chromatic
round_chromatic forall a b. (a -> b) -> a -> b
$ Layout -> Pitch -> ControlValMap -> FChromatic
pitch_to_transposed Layout
layout Pitch
pitch ControlValMap
controls
    layout :: Layout
layout = ScaleMap
smap.layout

-- Adapt to ChromaticScales.SemisToNoteNumber
-- TODO which should use typed FChromatic instead of untyped Pitch.FSemi
chromatic_to_nn :: ScaleMap -> PSignal.PitchConfig -> FChromatic
    -> Either DeriveT.PitchError Pitch.NoteNumber
chromatic_to_nn :: ScaleMap
-> PitchConfig -> FChromatic -> Either PitchError NoteNumber
chromatic_to_nn ScaleMap
smap PitchConfig
config FChromatic
fc =
    Layout -> LarasMap -> Laras -> SemisToNoteNumber
BaliScales.semis_to_nn ScaleMap
smap.layout.theory ScaleMap
smap.laras_map ScaleMap
smap.default_laras
        PitchConfig
config (FChromatic -> Double
to_semis FChromatic
fc)
    where
    -- Adapt to Pitch.FSemi taken by SemisToNoteNumber.  Pitch.Pitch is
    -- relative to layout.start, so I have to add it back Because FSemis are
    -- absolute, while Chromatic is scale-relative.
    to_semis :: FChromatic -> Double
to_semis (FChromatic Double
fc) = Double
fc forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral ScaleMap
smap.layout.start

-- | Pitch plus transposition to absolute chromatic.
pitch_to_transposed :: Layout -> Pitch.Pitch -> ScoreT.ControlValMap
    -> FChromatic
pitch_to_transposed :: Layout -> Pitch -> ControlValMap -> FChromatic
pitch_to_transposed Layout
layout Pitch
pitch ControlValMap
controls =
    FChromatic
fc forall p. Affine p => p -> Diff p -> p
.+^ (FChromaticSteps
octave forall a. Num a => a -> a -> a
* FChromaticSteps
per_oct forall a. Num a => a -> a -> a
+ FChromaticSteps
dsteps forall a. Num a => a -> a -> a
+ FChromaticSteps
csteps)
    where
    fc :: FChromatic
fc = Chromatic -> FChromatic
fchromatic forall a b. (a -> b) -> a -> b
$ Layout -> Pitch -> Chromatic
pitch_to_chromatic Layout
layout Pitch
pitch
    per_oct :: FChromaticSteps
per_oct = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Intervals -> Int
c_per_oct Layout
layout.intervals
    dsteps :: FChromaticSteps
dsteps = Layout -> Chromatic -> FDiatonicSteps -> FChromaticSteps
diatonic_to_chromatic_frac
        Layout
layout (Layout -> Pitch -> Chromatic
pitch_to_chromatic Layout
layout Pitch
pitch) FDiatonicSteps
diatonic
    octave :: FChromaticSteps
octave = Double -> FChromaticSteps
FChromaticSteps forall a b. (a -> b) -> a -> b
$ Control -> Double
get Control
Controls.octave
    csteps :: FChromaticSteps
csteps = Double -> FChromaticSteps
FChromaticSteps forall a b. (a -> b) -> a -> b
$ Control -> Double
get Control
Controls.chromatic
    diatonic :: FDiatonicSteps
diatonic = Double -> FDiatonicSteps
FDiatonicSteps forall a b. (a -> b) -> a -> b
$ Control -> Double
get Control
Controls.diatonic
    get :: Control -> Double
get Control
m = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Double
0 Control
m ControlValMap
controls

input_to_note :: ScaleMap -> Scales.InputToNote
input_to_note :: ScaleMap -> Environ -> Input -> Either PitchError Note
input_to_note ScaleMap
smap Environ
_env (Pitch.Input KbdType
kbd_type Pitch
pitch Double
_frac) = do
    -- Tonic is to reverse to_absolute, but JavaScales are the opposite way,
    -- displayed absolute, see 'Absolute'.
    let tonic :: Int
tonic = Int
0
    Pitch
pitch <- KbdType -> Int -> Int -> Pitch -> Either PitchError Pitch
Scales.kbd_to_scale KbdType
kbd_type Int
per_octave Int
tonic Pitch
pitch
    ScaleMap
smap.format.show Pitch
pitch
    where per_octave :: Int
per_octave = Intervals -> Int
d_per_oct ScaleMap
smap.layout.intervals


-- ** transpose

transpose :: ScaleMap -> Derive.Transpose
transpose :: ScaleMap -> Transpose
transpose ScaleMap
smap Transposition
transposition Environ
_env Int
steps Pitch
pitch = case Transposition
transposition of
    Transposition
Scale.Diatonic ->
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Layout -> Pitch -> DiatonicSteps -> Pitch
transpose_diatonic ScaleMap
smap.layout Pitch
pitch (Int -> DiatonicSteps
DiatonicSteps Int
steps)
    Transposition
Scale.Chromatic ->
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Layout -> Pitch -> ChromaticSteps -> Pitch
transpose_chromatic ScaleMap
smap.layout Pitch
pitch (Int -> ChromaticSteps
ChromaticSteps Int
steps)

transpose_diatonic :: Layout -> Pitch.Pitch -> DiatonicSteps -> Pitch.Pitch
transpose_diatonic :: Layout -> Pitch -> DiatonicSteps -> Pitch
transpose_diatonic Layout
layout Pitch
pitch DiatonicSteps
steps =
    Layout -> Chromatic -> Pitch
chromatic_to_pitch Layout
layout forall a b. (a -> b) -> a -> b
$
        Layout -> Chromatic -> DiatonicSteps -> Chromatic
add_diatonic Layout
layout (Layout -> Pitch -> Chromatic
pitch_to_chromatic Layout
layout Pitch
pitch) DiatonicSteps
steps

transpose_chromatic :: Layout -> Pitch.Pitch -> ChromaticSteps -> Pitch.Pitch
transpose_chromatic :: Layout -> Pitch -> ChromaticSteps -> Pitch
transpose_chromatic Layout
layout Pitch
pitch ChromaticSteps
steps =
    Layout -> Chromatic -> Pitch
chromatic_to_pitch Layout
layout (Layout -> Pitch -> Chromatic
pitch_to_chromatic Layout
layout Pitch
pitch forall p. Affine p => p -> Diff p -> p
.+^ ChromaticSteps
steps)

pitch_to_chromatic :: Layout -> Pitch.Pitch -> Chromatic
pitch_to_chromatic :: Layout -> Pitch -> Chromatic
pitch_to_chromatic Layout
layout (Pitch.Pitch Int
oct (Pitch.Degree Int
pc Int
acc)) =
    Layout
layout.d_to_c forall a. Vector a -> Int -> a
Vector.! Int
d
        forall p. Affine p => p -> Diff p -> p
.+^ Int -> ChromaticSteps
ChromaticSteps (Int
acc forall a. Num a => a -> a -> a
+ (Int
octforall a. Num a => a -> a -> a
+Int
oct2) forall a. Num a => a -> a -> a
* Intervals -> Int
c_per_oct Layout
layout.intervals)
    where (Int
oct2, Int
d) = Int
pc forall a. Integral a => a -> a -> (a, a)
`divMod` Intervals -> Int
d_per_oct Layout
layout.intervals

chromatic_to_pitch :: Layout -> Chromatic -> Pitch.Pitch
chromatic_to_pitch :: Layout -> Chromatic -> Pitch
chromatic_to_pitch Layout
layout Chromatic
c = Int -> Degree -> Pitch
Pitch.Pitch Int
oct (Int -> Int -> Degree
Pitch.Degree Int
pc Int
acc)
    where
    (Diatonic Int
d, ChromaticSteps Int
acc) = Layout -> Chromatic -> (Diatonic, ChromaticSteps)
to_diatonic Layout
layout Chromatic
c
    (Int
oct, Int
pc) = Int
d forall a. Integral a => a -> a -> (a, a)
`divMod` Intervals -> Int
d_per_oct Layout
layout.intervals

-- | Convert a fractional number of diatonic steps to chromatic steps, starting
-- from the given chromatic pitch.
--
-- Chromatic is not absolute in that it doesn't include octave, but it is 1-7.
-- I could make absolute easily, or just add octaves back on later.
diatonic_to_chromatic_frac :: Layout -> Chromatic -> FDiatonicSteps
    -> FChromaticSteps
diatonic_to_chromatic_frac :: Layout -> Chromatic -> FDiatonicSteps -> FChromaticSteps
diatonic_to_chromatic_frac Layout
layout Chromatic
start FDiatonicSteps
steps
    | FDiatonicSteps
steps forall a. Eq a => a -> a -> Bool
== FDiatonicSteps
0 = FChromaticSteps
0
    | FDiatonicSteps
steps forall a. Ord a => a -> a -> Bool
> FDiatonicSteps
0 = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale (DiatonicSteps -> FChromaticSteps
transpose DiatonicSteps
isteps) (DiatonicSteps -> FChromaticSteps
transpose (DiatonicSteps
istepsforall a. Num a => a -> a -> a
+DiatonicSteps
1))
        (Double -> FChromaticSteps
FChromaticSteps Double
frac)
    | Bool
otherwise = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale (DiatonicSteps -> FChromaticSteps
transpose (DiatonicSteps
istepsforall a. Num a => a -> a -> a
-DiatonicSteps
1)) (DiatonicSteps -> FChromaticSteps
transpose DiatonicSteps
isteps)
        (Double -> FChromaticSteps
FChromaticSteps (Double
1 forall a. Num a => a -> a -> a
- forall a. Num a => a -> a
abs Double
frac))
    where
    (DiatonicSteps
isteps, Double
frac) = FDiatonicSteps -> (DiatonicSteps, Double)
split_diatonic FDiatonicSteps
steps
    transpose :: DiatonicSteps -> FChromaticSteps
transpose DiatonicSteps
steps = ChromaticSteps -> FChromaticSteps
fcsteps forall a b. (a -> b) -> a -> b
$ Layout -> Chromatic -> DiatonicSteps -> Chromatic
add_diatonic Layout
layout Chromatic
start DiatonicSteps
steps forall p. Affine p => p -> p -> Diff p
.-. Chromatic
start

-- | Convert diatonic steps to chromatic steps, starting from the given
-- chromatic pitch.
--
-- Not every Chromatic corresponds to a Diatonic.  So it's unclear how to
-- diatonically transpose a note that's not diatonic in the first place.  I've
-- defined that the first diatonic step will take the note to the next
-- Diatonic.
add_diatonic :: Layout -> Chromatic -> DiatonicSteps -> Chromatic
add_diatonic :: Layout -> Chromatic -> DiatonicSteps -> Chromatic
add_diatonic Layout
layout Chromatic
start DiatonicSteps
steps
    | DiatonicSteps
steps forall a. Eq a => a -> a -> Bool
== DiatonicSteps
0 = Chromatic
start
    | Bool
otherwise = Layout -> Diatonic -> Chromatic
to_chromatic Layout
layout (Diatonic
d forall p. Affine p => p -> Diff p -> p
.+^ DiatonicSteps
steps2)
    where
    (Diatonic
d, ChromaticSteps
cs) = Layout -> Chromatic -> (Diatonic, ChromaticSteps)
to_diatonic Layout
layout Chromatic
start
    -- cs is the remainder for a non-diatonic start.  If >0, d has been rounded
    -- down.  So when going down, the first diatonic step is already accounted
    -- for in the round down.
    steps2 :: DiatonicSteps
steps2 = if DiatonicSteps
steps forall a. Ord a => a -> a -> Bool
< DiatonicSteps
0 Bool -> Bool -> Bool
&& ChromaticSteps
cs forall a. Ord a => a -> a -> Bool
> ChromaticSteps
0 then DiatonicSteps
steps forall a. Num a => a -> a -> a
+ DiatonicSteps
1 else DiatonicSteps
steps

-- | Cannot convert Chromatic to Diatonic because not every chromatic step is
-- in a scale.  So I need a leftover.
to_diatonic :: Layout -> Chromatic -> (Diatonic, ChromaticSteps)
to_diatonic :: Layout -> Chromatic -> (Diatonic, ChromaticSteps)
to_diatonic Layout
layout (Chromatic Int
c) =
    (Diatonic
d forall p. Affine p => p -> Diff p -> p
.+^ Int -> DiatonicSteps
DiatonicSteps (Int
oct forall a. Num a => a -> a -> a
* Intervals -> Int
d_per_oct Layout
layout.intervals), ChromaticSteps
cs)
    where
    (Diatonic
d, ChromaticSteps
cs) = Layout
layout.c_to_d forall a. Vector a -> Int -> a
Vector.! Int
c2
    (Int
oct, Int
c2) = Int
c forall a. Integral a => a -> a -> (a, a)
`divMod` Intervals -> Int
c_per_oct Layout
layout.intervals

to_chromatic :: Layout -> Diatonic -> Chromatic
to_chromatic :: Layout -> Diatonic -> Chromatic
to_chromatic Layout
layout (Diatonic Int
d) =
    Layout
layout.d_to_c forall a. Vector a -> Int -> a
Vector.! Int
d2 forall p. Affine p => p -> Diff p -> p
.+^ Int -> ChromaticSteps
ChromaticSteps (Int
oct forall a. Num a => a -> a -> a
* Intervals -> Int
c_per_oct Intervals
intervals)
    where
    (Int
oct, Int
d2) = Int
d forall a. Integral a => a -> a -> (a, a)
`divMod` Intervals -> Int
d_per_oct Intervals
intervals
    intervals :: Intervals
intervals = Layout
layout.intervals

-- | This should return DiatonicSteps, but only one caller wants that.
d_per_oct :: Intervals -> Int
d_per_oct :: Intervals -> Int
d_per_oct = forall a. Vector a -> Int
Vector.length

-- | This should return ChromaticSteps, but only one caller wants that.
c_per_oct :: Intervals -> Int
c_per_oct :: Intervals -> Int
c_per_oct = forall a. Num a => Vector a -> a
Vector.sum

make_d_to_c :: Intervals -> Vector.Vector Chromatic
make_d_to_c :: Intervals -> Vector Chromatic
make_d_to_c = forall a b. (a -> b) -> Vector a -> Vector b
Vector.map Int -> Chromatic
Chromatic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b -> a) -> a -> Vector b -> Vector a
Vector.scanl forall a. Num a => a -> a -> a
(+) Int
0

make_c_to_d :: Intervals -> Vector.Vector (Diatonic, ChromaticSteps)
make_c_to_d :: Intervals -> Vector (Diatonic, ChromaticSteps)
make_c_to_d Intervals
intervals = forall a. [a] -> Vector a
Vector.fromList
    [ (Int -> Diatonic
Diatonic Int
pc, Int -> ChromaticSteps
ChromaticSteps Int
acc)
    | (Int
pc, Int
steps) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall a. Vector a -> [a]
Vector.toList Intervals
intervals)
    , Int
acc <- forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range' Int
0 Int
steps Int
1
    ]

-- * conversions

round_chromatic :: FChromatic -> Chromatic
round_chromatic :: FChromatic -> Chromatic
round_chromatic (FChromatic Double
fc) = Int -> Chromatic
Chromatic (forall a b. (RealFrac a, Integral b) => a -> b
round Double
fc)

fchromatic :: Chromatic -> FChromatic
fchromatic :: Chromatic -> FChromatic
fchromatic (Chromatic Int
a) = Double -> FChromatic
FChromatic (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a)

fcsteps :: ChromaticSteps -> FChromaticSteps
fcsteps :: ChromaticSteps -> FChromaticSteps
fcsteps (ChromaticSteps Int
a) = Double -> FChromaticSteps
FChromaticSteps (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a)

fdiatonic :: DiatonicSteps -> FDiatonicSteps
fdiatonic :: DiatonicSteps -> FDiatonicSteps
fdiatonic (DiatonicSteps Int
a) = Double -> FDiatonicSteps
FDiatonicSteps (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a)

split_diatonic :: FDiatonicSteps -> (DiatonicSteps, Double)
split_diatonic :: FDiatonicSteps -> (DiatonicSteps, Double)
split_diatonic (FDiatonicSteps Double
d) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> DiatonicSteps
DiatonicSteps (forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
d)


-- * Format

data Format = Format {
    Format -> Pitch -> Either PitchError Note
show :: Pitch.Pitch -> Either DeriveT.PitchError Pitch.Note
    , Format -> Note -> Either PitchError Pitch
read :: Pitch.Note -> Either DeriveT.PitchError Pitch.Pitch
    , Format -> Text
pattern :: Text
    }

cipher_absolute :: Layout -> Format
cipher_absolute :: Layout -> Format
cipher_absolute Layout
layout = Format
    { $sel:show:Format :: Pitch -> Either PitchError Note
show = Layout -> Pitch -> Either PitchError Note
show_absolute Layout
layout
    , $sel:read:Format :: Note -> Either PitchError Pitch
read = Layout -> Note -> Either PitchError Pitch
read_absolute Layout
layout
    , $sel:pattern:Format :: Text
pattern = Text
"[0-9][1-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Intervals -> Int
c_per_oct Layout
layout.intervals) forall a. Semigroup a => a -> a -> a
<> Text
"]"
    }

cipher_octave_relative :: Layout -> Instrument -> Format
cipher_octave_relative :: Layout -> Instrument -> Format
cipher_octave_relative Layout
layout Instrument
inst = Format
    { $sel:show:Format :: Pitch -> Either PitchError Note
show = Layout -> Instrument -> Pitch -> Either PitchError Note
show_dotted_cipher Layout
layout Instrument
inst
    , $sel:read:Format :: Note -> Either PitchError Pitch
read = Layout -> Int -> Note -> Either PitchError Pitch
read_dotted_cipher Layout
layout Instrument
inst.center
    , $sel:pattern:Format :: Text
pattern = Text
degree forall a. Semigroup a => a -> a -> a
<> Text
"|`" forall a. Semigroup a => a -> a -> a
<> Text
degree forall a. Semigroup a => a -> a -> a
<> Text
"[.^]+`"
    }
    where
    degree :: Text
degree = Text
"[1-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
pc_per_octave forall a. Semigroup a => a -> a -> a
<> Text
"]"
    pc_per_octave :: Int
pc_per_octave = Intervals -> Int
c_per_oct Layout
layout.intervals

show_dotted_cipher :: Layout -> Instrument -> Pitch.Pitch
    -> Either DeriveT.PitchError Pitch.Note
show_dotted_cipher :: Layout -> Instrument -> Pitch -> Either PitchError Note
show_dotted_cipher Layout
layout Instrument
inst Pitch
pitch = do
    Absolute Int
oct Int
pc <- Instrument -> Absolute -> Either PitchError Absolute
check_range Instrument
inst
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left PitchError
DeriveT.InvalidInput) forall a b. b -> Either a b
Right (Layout -> Pitch -> Maybe Absolute
to_absolute Layout
layout Pitch
pitch)
    let delta :: Int
delta = Int
oct forall a. Num a => a -> a -> a
- Instrument
inst.center
    let degree :: Text
degree = forall a. Show a => a -> Text
showt Int
pc
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Note
Pitch.Note forall a b. (a -> b) -> a -> b
$ if Int
delta forall a. Eq a => a -> a -> Bool
== Int
0 then Text
degree else forall a. Monoid a => [a] -> a
mconcat
        [ Text
"`", Text
degree
        , Int -> Text -> Text
Text.replicate (forall a. Num a => a -> a
abs Int
delta) (if Int
delta forall a. Ord a => a -> a -> Bool
> Int
0 then Text
"^" else Text
".")
        , Text
"`"
        ]

read_dotted_cipher :: Layout -> Pitch.Octave -> Pitch.Note
    -> Either DeriveT.PitchError Pitch.Pitch
read_dotted_cipher :: Layout -> Int -> Note -> Either PitchError Pitch
read_dotted_cipher Layout
layout Int
center =
    forall a. Parser a -> Note -> Either PitchError a
parse forall a b. (a -> b) -> a -> b
$ (forall {m :: * -> *}. Monad m => Int -> Int -> m Pitch
mkpitch Int
0 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Int
parse_pc) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Pitch
p_with_octave
    where
    p_with_octave :: Parser Text Pitch
p_with_octave = do
        Char -> Parser Char
A.char Char
'`'
        Int
pc <- Parser Int
parse_pc
        String
octs <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
A.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'^'
        Char -> Parser Char
A.char Char
'`'
        let oct :: Int
oct = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Lists.count (forall a. Eq a => a -> a -> Bool
==Char
'^') String
octs forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Lists.count (forall a. Eq a => a -> a -> Bool
==Char
'.') String
octs
        forall {m :: * -> *}. Monad m => Int -> Int -> m Pitch
mkpitch Int
oct Int
pc
    mkpitch :: Int -> Int -> m Pitch
mkpitch Int
oct Int
pc = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Layout -> Absolute -> Pitch
from_absolute Layout
layout (Int -> Int -> Absolute
Absolute (Int
octforall a. Num a => a -> a -> a
+Int
center) Int
pc)
    parse_pc :: Parser Int
parse_pc = Int -> Parser Int
p_pc (Intervals -> Int
c_per_oct Layout
layout.intervals)

show_absolute :: Layout -> Pitch.Pitch -> Either DeriveT.PitchError Pitch.Note
show_absolute :: Layout -> Pitch -> Either PitchError Note
show_absolute Layout
layout Pitch
pitch = do
    -- show_pitch is used by input_to_note, InvalidInput is correct for that at
    -- least.
    Absolute Int
oct Int
pc <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left PitchError
DeriveT.InvalidInput) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        Layout -> Pitch -> Maybe Absolute
to_absolute Layout
layout Pitch
pitch
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Note
Pitch.Note forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt Int
oct forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
pc

read_absolute :: Layout -> Pitch.Note -> Either DeriveT.PitchError Pitch.Pitch
read_absolute :: Layout -> Note -> Either PitchError Pitch
read_absolute Layout
layout Note
note = do
    Absolute
absolute <- forall a. Parser a -> Note -> Either PitchError a
parse
        (Int -> Int -> Absolute
Absolute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
p_octave forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
p_pc (Intervals -> Int
c_per_oct Layout
layout.intervals)) Note
note
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Layout -> Absolute -> Pitch
from_absolute Layout
layout Absolute
absolute

from_absolute :: Layout -> Absolute -> Pitch.Pitch
from_absolute :: Layout -> Absolute -> Pitch
from_absolute Layout
layout (Absolute Int
oct Int
pc) =
    Int -> Degree -> Pitch
Pitch.Pitch (Int
octforall a. Num a => a -> a -> a
+Int
oct2) (Int -> Int -> Degree
Pitch.Degree Int
d Int
cs)
    where
    (Int
oct2, Int
pc2) = (Int
pc forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Layout
layout.start) forall a. Integral a => a -> a -> (a, a)
`divMod` Intervals -> Int
c_per_oct Layout
layout.intervals
    (Diatonic Int
d, ChromaticSteps Int
cs) = Layout
layout.c_to_d forall a. Vector a -> Int -> a
Vector.! Int
pc2

to_absolute :: Layout -> Pitch.Pitch -> Maybe Absolute
to_absolute :: Layout -> Pitch -> Maybe Absolute
to_absolute Layout
layout (Pitch.Pitch Int
oct Degree
degree) =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Degree
degree Layout
layout.degree_to_pc of
        Maybe Int
Nothing -> forall a. Maybe a
Nothing
        Just Int
pc -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Absolute
Absolute (Int
octforall a. Num a => a -> a -> a
+Int
oct2) (Int
pc2forall a. Num a => a -> a -> a
+Int
1)
            where
            (Int
oct2, Int
pc2) = (Int
pc forall a. Num a => a -> a -> a
+ Layout
layout.start)
                forall a. Integral a => a -> a -> (a, a)
`divMod` Intervals -> Int
c_per_oct Layout
layout.intervals

parse :: A.Parser a -> Pitch.Note -> Either DeriveT.PitchError a
parse :: forall a. Parser a -> Note -> Either PitchError a
parse Parser a
p Note
note = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Note -> PitchError
DeriveT.UnparseableNote Note
note) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
    forall a. Parser a -> Text -> Maybe a
ParseText.maybe_parse Parser a
p (Note -> Text
Pitch.note_text Note
note)

p_pc :: Pitch.PitchClass -> A.Parser Pitch.PitchClass
p_pc :: Int -> Parser Int
p_pc Int
pc_per_oct = Int -> Int -> Parser Int
p_digit Int
1 (Int
pc_per_octforall a. Num a => a -> a -> a
+Int
1)

p_octave :: A.Parser Pitch.Octave
p_octave :: Parser Int
p_octave = Int -> Int -> Parser Int
p_digit Int
0 Int
10

p_digit :: Int -> Int -> A.Parser Int
p_digit :: Int -> Int -> Parser Int
p_digit Int
low Int
high = do
    Int
n <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe Int
Num.readDigit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Char
A.satisfy Char -> Bool
ParseText.is_digit
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a -> Bool
Num.inRange Int
low Int
high Int
n
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

-- * Tuning

-- | Describe the frequencies in a saih.  This doesn't say what the range is,
-- since that's in the 'ScaleMap', and all saihs in one scale should have the
-- same range.
data Laras = Laras {
    Laras -> Text
name :: Text
    , Laras -> Doc
doc :: Doc.Doc
    -- | The pitch where 'umbang' and 'isep' start.  It should be such that
    -- octave 4 is close to middle C.
    , Laras -> Pitch
base :: Pitch.Pitch
    , Laras -> Vector NoteNumber
umbang :: Vector.Vector Pitch.NoteNumber
    , Laras -> Vector NoteNumber
isep :: Vector.Vector Pitch.NoteNumber
    } deriving (Laras -> Laras -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Laras -> Laras -> Bool
$c/= :: Laras -> Laras -> Bool
== :: Laras -> Laras -> Bool
$c== :: Laras -> Laras -> Bool
Eq, Int -> Laras -> ShowS
[Laras] -> ShowS
Laras -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Laras] -> ShowS
$cshowList :: [Laras] -> ShowS
show :: Laras -> String
$cshow :: Laras -> String
showsPrec :: Int -> Laras -> ShowS
$cshowsPrec :: Int -> Laras -> ShowS
Show)

data Tuning = Umbang | Isep deriving (Tuning -> Tuning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tuning -> Tuning -> Bool
$c/= :: Tuning -> Tuning -> Bool
== :: Tuning -> Tuning -> Bool
$c== :: Tuning -> Tuning -> Bool
Eq, Eq Tuning
Tuning -> Tuning -> Bool
Tuning -> Tuning -> Ordering
Tuning -> Tuning -> Tuning
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tuning -> Tuning -> Tuning
$cmin :: Tuning -> Tuning -> Tuning
max :: Tuning -> Tuning -> Tuning
$cmax :: Tuning -> Tuning -> Tuning
>= :: Tuning -> Tuning -> Bool
$c>= :: Tuning -> Tuning -> Bool
> :: Tuning -> Tuning -> Bool
$c> :: Tuning -> Tuning -> Bool
<= :: Tuning -> Tuning -> Bool
$c<= :: Tuning -> Tuning -> Bool
< :: Tuning -> Tuning -> Bool
$c< :: Tuning -> Tuning -> Bool
compare :: Tuning -> Tuning -> Ordering
$ccompare :: Tuning -> Tuning -> Ordering
Ord, Int -> Tuning
Tuning -> Int
Tuning -> [Tuning]
Tuning -> Tuning
Tuning -> Tuning -> [Tuning]
Tuning -> Tuning -> Tuning -> [Tuning]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Tuning -> Tuning -> Tuning -> [Tuning]
$cenumFromThenTo :: Tuning -> Tuning -> Tuning -> [Tuning]
enumFromTo :: Tuning -> Tuning -> [Tuning]
$cenumFromTo :: Tuning -> Tuning -> [Tuning]
enumFromThen :: Tuning -> Tuning -> [Tuning]
$cenumFromThen :: Tuning -> Tuning -> [Tuning]
enumFrom :: Tuning -> [Tuning]
$cenumFrom :: Tuning -> [Tuning]
fromEnum :: Tuning -> Int
$cfromEnum :: Tuning -> Int
toEnum :: Int -> Tuning
$ctoEnum :: Int -> Tuning
pred :: Tuning -> Tuning
$cpred :: Tuning -> Tuning
succ :: Tuning -> Tuning
$csucc :: Tuning -> Tuning
Enum, Tuning
forall a. a -> a -> Bounded a
maxBound :: Tuning
$cmaxBound :: Tuning
minBound :: Tuning
$cminBound :: Tuning
Bounded, Int -> Tuning -> ShowS
[Tuning] -> ShowS
Tuning -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tuning] -> ShowS
$cshowList :: [Tuning] -> ShowS
show :: Tuning -> String
$cshow :: Tuning -> String
showsPrec :: Int -> Tuning -> ShowS
$cshowsPrec :: Int -> Tuning -> ShowS
Show)

instance Pretty Tuning where pretty :: Tuning -> Text
pretty = forall a. Show a => a -> Text
showt
instance Typecheck.Typecheck Tuning
instance REnv.ToVal Tuning
instance ShowVal.ShowVal Tuning

-- | If ombak is unset, use the hardcoded tunings.  Otherwise, create new
-- umbang and isep tunings based on the given number.
c_ombak :: ScoreT.Control
c_ombak :: Control
c_ombak = Control
"ombak"

semis_to_nn :: Layout -> Laras -> Tuning -> PSignal.PitchConfig -> FChromatic
    -> Either DeriveT.PitchError Pitch.NoteNumber
semis_to_nn :: Layout
-> Laras
-> Tuning
-> PitchConfig
-> FChromatic
-> Either PitchError NoteNumber
semis_to_nn Layout
layout Laras
laras Tuning
tuning =
    \(PSignal.PitchConfig Environ
_env ControlValMap
controls) FChromatic
steps_ -> do
        -- Chromatic is relative to layout.start, so I have to add it back on
        -- to get an absolute index.
        let steps :: FChromatic
steps = FChromatic
steps_
                forall p. Affine p => p -> Diff p -> p
.+^ (Layout -> Laras -> FChromaticSteps
laras_offset Layout
layout Laras
laras forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Layout
layout.start)
        forall err a. err -> Maybe a -> Either err a
justErr (Laras -> FChromatic -> PitchError
range_error Laras
laras FChromatic
steps) forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c_ombak ControlValMap
controls of
            Maybe Double
Nothing -> case Tuning
tuning of
                Tuning
Umbang -> Vector NoteNumber -> FChromatic -> Maybe NoteNumber
get_nn Laras
laras.umbang FChromatic
steps
                Tuning
Isep -> Vector NoteNumber -> FChromatic -> Maybe NoteNumber
get_nn Laras
laras.isep FChromatic
steps
            Just Double
ombak -> do
                NoteNumber
umbang <- Vector NoteNumber -> FChromatic -> Maybe NoteNumber
get_nn Laras
laras.umbang FChromatic
steps
                NoteNumber
isep <- Vector NoteNumber -> FChromatic -> Maybe NoteNumber
get_nn Laras
laras.isep FChromatic
steps
                let avg :: Double
avg = (NoteNumber -> Double
Pitch.nn_to_hz NoteNumber
umbang forall a. Num a => a -> a -> a
+ NoteNumber -> Double
Pitch.nn_to_hz NoteNumber
isep) forall a. Fractional a => a -> a -> a
/ Double
2
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> NoteNumber
Pitch.hz_to_nn forall a b. (a -> b) -> a -> b
$ case Tuning
tuning of
                    Tuning
Umbang -> Double
avg forall a. Num a => a -> a -> a
- Double
ombak forall a. Fractional a => a -> a -> a
/ Double
2
                    Tuning
Isep -> Double
avg forall a. Num a => a -> a -> a
+ Double
ombak forall a. Fractional a => a -> a -> a
/ Double
2

range_error :: Laras -> FChromatic -> DeriveT.PitchError
range_error :: Laras -> FChromatic -> PitchError
range_error Laras
laras (FChromatic Double
fsemis) =
    forall a. Real a => a -> (Int, Int) -> PitchError
DeriveT.out_of_range_error Double
fsemis (Int
0, forall a. Vector a -> Int
Vector.length Laras
laras.umbang)

get_nn :: Vector.Vector Pitch.NoteNumber -> FChromatic
    -> Maybe Pitch.NoteNumber
get_nn :: Vector NoteNumber -> FChromatic -> Maybe NoteNumber
get_nn Vector NoteNumber
nns (FChromatic Double
fsemis)
    | Double
frac forall a. Eq a => a -> a -> Bool
== Double
0 = Vector NoteNumber
nns forall a. Vector a -> Int -> Maybe a
Vector.!? Int
semis
    | Bool
otherwise = do
        NoteNumber
low <- Vector NoteNumber
nns forall a. Vector a -> Int -> Maybe a
Vector.!? Int
semis
        NoteNumber
high <- Vector NoteNumber
nns forall a. Vector a -> Int -> Maybe a
Vector.!? (Int
semis forall a. Num a => a -> a -> a
+ Int
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
low NoteNumber
high (forall a. Real a => a -> NoteNumber
Pitch.nn Double
frac)
    where (Int
semis, Double
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
fsemis

laras_offset :: Layout -> Laras -> FChromaticSteps
laras_offset :: Layout -> Laras -> FChromaticSteps
laras_offset Layout
layout Laras
laras = Double -> FChromaticSteps
FChromaticSteps forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
    Intervals -> Int
c_per_oct Layout
layout.intervals forall a. Num a => a -> a -> a
* Pitch -> Int
Pitch.pitch_octave Laras
laras.base
        forall a. Num a => a -> a -> a
+ Pitch -> Int
Pitch.pitch_pc Laras
laras.base

{-
-- | Convert 'Pitch.FSemi' to 'Pitch.NoteNumber'.
semis_to_nn :: Theory.Layout -> LarasMap -> Laras
    -> ChromaticScales.SemisToNoteNumber
semis_to_nn layout laras_map default_laras =
    \(PSignal.PitchConfig env controls) fsemis_ -> do
        laras <- Scales.read_environ (\v -> Map.lookup v laras_map)
            (Just default_laras) laras_key env
        let fsemis = fsemis_ - fromIntegral offset
            offset = laras_offset layout laras
        tuning <- Scales.read_environ Just (Just Umbang) EnvKey.tuning env
        let err = DeriveT.out_of_range_error fsemis
                (0, Vector.length (laras_umbang laras))
        justErr err $ case Map.lookup c_ombak controls of
            Nothing -> case tuning of
                Umbang -> get_nn (laras_umbang laras) fsemis
                Isep -> get_nn (laras_isep laras) fsemis
            Just ombak -> do
                umbang <- get_nn (laras_umbang laras) fsemis
                isep <- get_nn (laras_isep laras) fsemis
                let avg = (Pitch.nn_to_hz umbang + Pitch.nn_to_hz isep) / 2
                return $ Pitch.hz_to_nn $ case tuning of
                    Umbang -> avg - ombak / 2
                    Isep -> avg + ombak / 2

-- | VStr: Select saih tuning.
laras_key :: EnvKey.Key
laras_key = "laras"
-}