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

module Derive.Scale.BohlenPierce where
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import           Data.Ratio ((%))
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.Num as Num
import qualified Derive.Call.ScaleDegree as ScaleDegree
import qualified Derive.Derive as Derive
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Scale.ChromaticScales as ChromaticScales
import qualified Derive.Scale.JustScales as JustScales
import qualified Derive.Scale.Scales as Scales
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.TheoryFormat as TheoryFormat

import qualified Perform.Pitch as Pitch

import           Global


scales :: [Scale.Definition]
scales :: [Definition]
scales = forall a b. (a -> b) -> [a] -> [b]
map Scale -> Definition
Scale.Simple [Scale
absolute_scale]

scale_id :: Pitch.ScaleId
scale_id :: ScaleId
scale_id = ScaleId
"bp"

absolute_scale :: Scale.Scale
absolute_scale :: Scale
absolute_scale =
    (ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
scale_id ScaleMap
scale_map forall a b. (a -> b) -> a -> b
$
        Doc
"Bohlen-Pierce is derived from 3 instead of 2, and thus has a\
        \ \"tritave\" instead of an octave.\n"
        forall a. Semigroup a => a -> a -> a
<> Doc
ChromaticScales.twelve_doc)
    { scale_note_to_call :: Note -> Maybe ValCall
Scale.scale_note_to_call = ScaleMap -> Note -> Maybe ValCall
note_to_call ScaleMap
scale_map
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
Scale.scale_input_to_nn = InputToNote
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
Scales.computed_input_to_nn
        (ScaleMap -> InputToNote
ChromaticScales.input_to_note ScaleMap
scale_map) (ScaleMap -> Note -> Maybe ValCall
note_to_call ScaleMap
scale_map)
    }
    -- TODO that's pretty awkward, ChromaticScales should provide a way to make
    -- a scale but specify my own pitch aspect.

scale_map :: ChromaticScales.ScaleMap
scale_map :: ScaleMap
scale_map = (Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout Format
absolute_fmt Keys
all_keys Key
default_key)
    { smap_semis_to_nn :: SemisToNoteNumber
ChromaticScales.smap_semis_to_nn = SemisToNoteNumber
semis_to_nn }

pscale :: PSignal.Scale
pscale :: Scale
pscale = Scale -> Scale
Pitches.scale Scale
absolute_scale

absolute_fmt :: TheoryFormat.Format
absolute_fmt :: Format
absolute_fmt = Text -> Degrees -> Format
TheoryFormat.make_absolute_format
        (Degrees -> Text
TheoryFormat.make_pattern Degrees
degrees) Degrees
degrees
    where
    degrees :: Degrees
degrees = [Text] -> Degrees
TheoryFormat.make_degrees
        [Text
"a", Text
"b", Text
"c", Text
"d", Text
"e", Text
"f", Text
"g", Text
"h", Text
"i"]

note_to_call :: ChromaticScales.ScaleMap -> Pitch.Note -> Maybe Derive.ValCall
note_to_call :: ScaleMap -> Note -> Maybe ValCall
note_to_call ScaleMap
smap Note
note =
    case Format -> Note -> Either PitchError RelativePitch
TheoryFormat.read_relative_pitch Format
fmt Note
note of
        Left PitchError
_ -> Scale -> NamedIntervals -> Note -> Maybe ValCall
ScaleDegree.scale_degree_interval Scale
pscale NamedIntervals
named_intervals Note
note
        Right RelativePitch
pitch -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchNn -> PitchNote -> ValCall
scale_degree
            (ScaleMap -> RelativePitch -> PitchNn
ChromaticScales.pitch_nn ScaleMap
smap RelativePitch
pitch)
            (ScaleMap -> RelativePitch -> PitchNote
ChromaticScales.pitch_note ScaleMap
smap RelativePitch
pitch)
    where fmt :: Format
fmt = ScaleMap -> Format
ChromaticScales.smap_fmt ScaleMap
smap

-- TODO frac should always be 0, right?
semis_to_nn :: ChromaticScales.SemisToNoteNumber
semis_to_nn :: SemisToNoteNumber
semis_to_nn (PSignal.PitchConfig Environ
env ControlValMap
controls) Double
fsemi =
    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
$ forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Double
hz1 Double
hz2 Double
frac
    where
    hz1 :: Double
hz1 = Double -> PitchClass -> PitchClass -> Double
degree_to_hz Double
base_hz PitchClass
tonic PitchClass
degree
    hz2 :: Double
hz2 = Double -> PitchClass -> PitchClass -> Double
degree_to_hz Double
base_hz PitchClass
tonic (PitchClass
degree forall a. Num a => a -> a -> a
+ PitchClass
1)
    (PitchClass
degree, Double
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
fsemi
    base_hz :: Double
base_hz = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Double
default_base_hz Control
JustScales.just_base_control
        ControlValMap
controls
    tonic :: PitchClass
tonic = Layout -> Degree -> PitchClass
Theory.degree_to_semis Layout
layout forall a b. (a -> b) -> a -> b
$ Key -> Degree
Theory.key_tonic Key
key
    key :: Key
key = forall a. a -> Maybe a -> a
fromMaybe Key
default_key forall a b. (a -> b) -> a -> b
$ do
        Key
key <- Environ -> Maybe Key
Scales.environ_key Environ
env
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Keys
all_keys

degree_to_hz :: Pitch.Hz -> Pitch.Semi -> Pitch.Semi -> Pitch.Hz
degree_to_hz :: Double -> PitchClass -> PitchClass -> Double
degree_to_hz Double
base_hz PitchClass
tonic PitchClass
semis = Double
oct_base forall a. Num a => a -> a -> a
* Double
ratio
    where
    oct_base :: Double
oct_base = Double
base_hz forall a. Num a => a -> a -> a
* Double
3 forall a b. (Fractional a, Integral b) => a -> b -> a
^^ (PitchClass
octave forall a. Num a => a -> a -> a
- PitchClass
Pitch.middle_octave)
    ratio :: Double
ratio = forall a. Vector a -> PitchClass -> a
index_mod Vector Double
just_ratios (PitchClass
degree forall a. Num a => a -> a -> a
- PitchClass
tonic)
    (PitchClass
octave, PitchClass
degree) = PitchClass
semis forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
semis_per_octave

index_mod :: Vector.Vector a -> Int -> a
index_mod :: forall a. Vector a -> PitchClass -> a
index_mod Vector a
v PitchClass
i = forall a. Vector a -> PitchClass -> a
Vector.unsafeIndex Vector a
v (PitchClass
i forall a. Integral a => a -> a -> a
`mod` forall a. Vector a -> PitchClass
Vector.length Vector a
v)

default_base_hz :: Pitch.Hz
default_base_hz :: Double
default_base_hz = Double
Pitch.middle_c_hz

scale_degree :: Scale.PitchNn -> Scale.PitchNote -> Derive.ValCall
scale_degree :: PitchNn -> PitchNote -> ValCall
scale_degree = Scale
-> NamedIntervals -> Double -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree_just Scale
pscale NamedIntervals
named_intervals Double
1

-- **

-- | Keyboard layout where the lambda mode in A is analogous to C-major:
--
-- > A - B C D - E F - G H - I A
-- > 1   2 3 4   5 6   7 8   9 1
-- >
-- > │ █ │ │ █ │ █ │ █ │ │
-- > │ █ │ │ █ │ █ │ █ │ │
-- > │ │ │ │ │ │ │ │ │ │ │
-- > └─┴─┴─┴─┴─┴─┴─┴─┴─┴─┘
-- >  1 2 3 4 5 6 7 8 9 A
-- >  A B C D E F G H I A
layout :: Theory.Layout
layout :: Layout
layout = [PitchClass] -> Layout
Theory.layout [PitchClass]
lambda_intervals

lambda_intervals :: [Int]
lambda_intervals :: [PitchClass]
lambda_intervals = [PitchClass
2, PitchClass
1, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1]

-- 1, 7, 11, or in lambda: A, E, G -- 1 5 7
just_ratios :: Vector.Vector Double
just_ratios :: Vector Double
just_ratios = forall a. [a] -> Vector a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Real a, Fractional b) => a -> b
realToFrac [Rational]
bp_ratios)

bp_ratios :: [Ratio.Rational]
bp_ratios :: [Rational]
bp_ratios =
    [ Rational
1, Integer
27 forall a. Integral a => a -> a -> Ratio a
% Integer
25, Integer
25 forall a. Integral a => a -> a -> Ratio a
% Integer
21, Integer
9 forall a. Integral a => a -> a -> Ratio a
% Integer
7, Integer
7 forall a. Integral a => a -> a -> Ratio a
% Integer
5, Integer
75 forall a. Integral a => a -> a -> Ratio a
% Integer
49, Integer
5 forall a. Integral a => a -> a -> Ratio a
% Integer
3
    , Integer
9 forall a. Integral a => a -> a -> Ratio a
% Integer
5, Integer
49 forall a. Integral a => a -> a -> Ratio a
% Integer
25, Integer
15 forall a. Integral a => a -> a -> Ratio a
% Integer
7, Integer
7 forall a. Integral a => a -> a -> Ratio a
% Integer
3, Integer
63 forall a. Integral a => a -> a -> Ratio a
% Integer
25, Integer
25 forall a. Integral a => a -> a -> Ratio a
% Integer
9
    ]

-- | Display scale degrees and the intervals between them.
_print_intervals :: Text
_print_intervals :: Text
_print_intervals =
    [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall {a}. [a] -> [a] -> [a]
interleave (forall a b. (a -> b) -> [a] -> [b]
map ((Text
"("<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>Text
")")) [Text]
degrees) [Text]
intervals
    where
    interleave :: [a] -> [a] -> [a]
interleave (a
x:[a]
xs) (a
y:[a]
ys) = a
x forall a. a -> [a] -> [a]
: a
y forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
interleave [a]
xs [a]
ys
    interleave [a]
xs [] = [a]
xs
    interleave [] [a]
ys = [a]
ys
    degrees :: [Text]
degrees = Key -> Format -> [Text]
TheoryFormat.key_degrees Key
default_key Format
absolute_fmt
    intervals :: [Text]
intervals = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Rational -> Rational -> Text
interval [Rational]
bp_ratios (forall a. PitchClass -> [a] -> [a]
drop PitchClass
1 [Rational]
bp_ratios)
    interval :: Rational -> Rational -> Text
interval Rational
low Rational
high = forall a. a -> Maybe a -> a
fromMaybe (Text
"no interval: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Rational
highforall a. Fractional a => a -> a -> a
/Rational
low)) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Rational
high forall a. Fractional a => a -> a -> a
/ Rational
low) Map Rational Text
names
    names :: Map Rational Text
names = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Rational
v, Text
k) | (Text
k, Rational
v) <- forall k a. Map k a -> [(k, a)]
Map.toList NamedIntervals
named_intervals]

-- | Display the keys and their signatures.
_print_scales :: IO ()
_print_scales :: IO ()
_print_scales = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
untxt) forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (Format -> Key -> Text
TheoryFormat.show_key_signature Format
absolute_fmt) forall a b. (a -> b) -> a -> b
$
    forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
0 PitchClass
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Degree
Theory.key_tonic) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Keys
all_keys

pc_per_octave :: Pitch.PitchClass
pc_per_octave :: PitchClass
pc_per_octave = forall (t :: * -> *) a. Foldable t => t a -> PitchClass
length [PitchClass]
lambda_intervals

semis_per_octave :: Int
semis_per_octave :: PitchClass
semis_per_octave = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [PitchClass]
lambda_intervals

all_keys :: ChromaticScales.Keys
all_keys :: Keys
all_keys = Format -> [Key] -> Keys
ChromaticScales.make_keys Format
absolute_fmt forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> [PitchClass] -> [Key]
make_keys) [(Text, [PitchClass])]
modes

default_key :: Theory.Key
Just Key
default_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Key
Pitch.Key Text
"a-lambda") Keys
all_keys

-- | BP modes, as documented on <http://www.huygens-fokker.org/bpsite/>
--
-- The only difference is that I wrap the octave at A, rather than C.
--
-- This has keys rooted at every chromatic step, but BP modes rooted on
-- accidentals tend to wind up with crazy key signatures, e.g. with triple
-- sharps, probably due to the lack of a circle-of-fifths organization.
modes :: [(Text, [Pitch.Semi])]
modes :: [(Text, [PitchClass])]
modes = forall {a} {a}. [a] -> [a] -> [(a, [a])]
make_modes [Text]
lambda_names [PitchClass]
lambda_intervals
    forall {a}. [a] -> [a] -> [a]
++ forall {a} {a}. [a] -> [a] -> [(a, [a])]
make_modes [Text]
gamma_names [PitchClass]
gamma_intervals
    where
    make_modes :: [a] -> [a] -> [(a, [a])]
make_modes [a]
names [a]
intervals =
        [ (a
name, forall a. PitchClass -> [a] -> [a]
take PitchClass
pc_per_octave (forall a. PitchClass -> [a] -> [a]
drop PitchClass
n (forall a. [a] -> [a]
cycle [a]
intervals)))
        | (PitchClass
n, a
name) <- forall a b. [a] -> [b] -> [(a, b)]
zip [PitchClass
0..] [a]
names
        ]

-- | Lambda family, never has 2 whole steps in a row.
lambda_names :: [Text]
lambda_names :: [Text]
lambda_names =
    [ Text
"lambda", Text
"walker-a", Text
"moll-2", Text
"walker-1", Text
"harmonic", Text
"walker-2"
    , Text
"dur-1", Text
"moll-1", Text
"walker-b"
    ]

-- | Gamma family.  The x modes are considered not very useful.
gamma_names :: [Text]
gamma_names :: [Text]
gamma_names = [Text
"gamma", Text
"x1", Text
"x2", Text
"x3", Text
"x4", Text
"x5", Text
"x6", Text
"dur-2", Text
"x7"]
gamma_intervals :: [Int]
gamma_intervals :: [PitchClass]
gamma_intervals = [PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
1, PitchClass
2, PitchClass
2, PitchClass
1]

make_keys :: Text -> [Pitch.Semi] -> [Theory.Key]
make_keys :: Text -> [PitchClass] -> [Key]
make_keys Text
name [PitchClass]
intervals =
    [Degree -> Text -> [PitchClass] -> Layout -> Key
Theory.key Degree
tonic Text
name [PitchClass]
intervals Layout
layout
        | Degree
tonic <- [Degree]
all_degrees, forall a. Num a => a -> a
abs (Degree -> PitchClass
Pitch.degree_accidentals Degree
tonic) forall a. Ord a => a -> a -> Bool
<= PitchClass
1]

all_degrees :: [Pitch.Degree]
all_degrees :: [Degree]
all_degrees =
    [PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc PitchClass
accs | PitchClass
pc <- [PitchClass
0 .. PitchClass
pc_per_octave forall a. Num a => a -> a -> a
- PitchClass
1], PitchClass
accs <- [-PitchClass
1..PitchClass
1]]

named_intervals :: ScaleDegree.NamedIntervals
named_intervals :: NamedIntervals
named_intervals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"d", Rational
minor)
    , (Text
"D", Rational
major)
    , (Text
"m-2", Rational
small)
    , (Text
"m2", Rational
small forall a. Num a => a -> a -> a
* Rational
minor)
    , (Text
"M2", Rational
small forall a. Num a => a -> a -> a
* Rational
major)
    , (Text
"M+2", Rational
small forall a. Num a => a -> a -> a
* Rational
minor forall a. Num a => a -> a -> a
* Rational
major)
    ]
    where
    small :: Rational
small = Integer
27 forall a. Integral a => a -> a -> Ratio a
% Integer
25
    minor :: Rational
minor = Integer
245 forall a. Integral a => a -> a -> Ratio a
% Integer
243 -- minor diesis
    major :: Rational
major = Integer
3125 forall a. Integral a => a -> a -> Ratio a
% Integer
3087 -- major diesis