-- 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.Hex where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import Data.Ratio ((%))
import qualified Data.Vector as Vector

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Derive.Scale as Scale
import qualified Derive.Scale.ChromaticScales as ChromaticScales
import qualified Derive.Scale.JustScales as JustScales
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
    [ ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
JustScales.make_scale ScaleId
"hex"
        (Format -> ScaleMap
scale_map (Int -> Format
TheoryFormat.letters Int
pc_per_octave))
        Doc
doc [(Doc, Doc)]
doc_fields
    , ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
JustScales.make_scale ScaleId
"hex-r"
        (Format -> ScaleMap
scale_map (forall key. Int -> RelativeFormat key -> Format
TheoryFormat.cipher Int
pc_per_octave RelativeFormat Int
relative_fmt))
        Doc
doc [(Doc, Doc)]
doc_fields
    ]

doc :: Doc.Doc
doc :: Doc
doc = Doc
"This is a family of 6 note just scales, based on Erv Wilson's hexanies.\
    \ The keys look like `a-159b-1`.  The `a` means that in absolute naming,\
    \ unity is on `a` (in relative naming, unity is always `1`).  `159b` means\
    \ the hexany is built on 1, 5, 9, 11.  The trailing `1` means unity is\
    \ assigned to the first ratio produced. For example, if you modulate to the\
    \ 5th scale degree, you would change the key to `a-159b-6` and set\
    \ `%just-base` accordingly.\n"

doc_fields :: [(Doc.Doc, Doc.Doc)]
doc_fields :: [(Doc, Doc)]
doc_fields =
    [ (Text -> Doc
Doc.literal Text
name,
        Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Map Text Ratios -> Text
JustScales.show_ratios (Key -> Map Text Ratios
JustScales.key_ratios Key
key))
    | (Text
name, Key
key) <- forall a. [(Key, a)] -> [(Text, a)]
ChromaticScales.group_tonic_mode (forall k a. Map k a -> [(k, a)]
Map.toList Keys
keys)
    ]

pc_per_octave :: Int
pc_per_octave :: Int
pc_per_octave = Int
6

scale_map :: TheoryFormat.Format -> JustScales.ScaleMap
scale_map :: Format -> ScaleMap
scale_map = Keys -> Key -> Maybe Text -> Format -> ScaleMap
JustScales.scale_map Keys
keys Key
default_key forall a. Maybe a
Nothing

relative_fmt :: TheoryFormat.RelativeFormat TheoryFormat.Tonic
relative_fmt :: RelativeFormat Int
relative_fmt = Keys -> Key -> RelativeFormat Int
JustScales.make_relative_fmt Keys
keys Key
default_key

default_key :: JustScales.Key
Just Key
default_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Key
Pitch.Key Text
"a-1357-1") Keys
keys

keys :: JustScales.Keys
keys :: Keys
keys = [Text] -> [(Text, [(Text, Ratios)])] -> Keys
JustScales.make_keys (forall a. Int -> [a] -> [a]
take Int
pc_per_octave [Text]
TheoryFormat.letter_degrees)
    [(Text
key, [(Text
"", Ratios
ratios)]) | (Text
key, Ratios
ratios) <- [(Text, Ratios)]
key_ratios]

key_ratios :: [(Text, JustScales.Ratios)]
key_ratios :: [(Text, Ratios)]
key_ratios = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Int] -> [(Text, Ratios)]
make_hexany
    [ [Int
a, Int
b, Int
c, Int
d] | Int
a <- [Int]
primes, Int
b <- [Int]
primes, Int
b forall a. Ord a => a -> a -> Bool
> Int
a
    , Int
c <- [Int]
primes, Int
c forall a. Ord a => a -> a -> Bool
> Int
b, Int
d <- [Int]
primes, Int
d forall a. Ord a => a -> a -> Bool
> Int
c
    ]
    where primes :: [Int]
primes = [Int
1, Int
3, Int
5, Int
7, Int
9, Int
11, Int
13]

hexany_ratios :: [[Int]] -> [[Ratio]]
hexany_ratios :: [[Int]] -> [[Ratio]]
hexany_ratios = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [(Int, [Ratio])]
make_ratios)

make_hexany :: [Int] -> [(Text, JustScales.Ratios)]
make_hexany :: [Int] -> [(Text, Ratios)]
make_hexany [Int]
xs =
    [ ([Int] -> Text
show_roots [Int]
xs forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Int
nforall a. Num a => a -> a -> a
+Int
1), forall a. [a] -> Vector a
Vector.fromList [Ratio]
ratios)
    | (Int
n, [Ratio]
ratios) <- [Int] -> [(Int, [Ratio])]
make_ratios [Int]
xs
    ]

show_roots :: [Int] -> Text
show_roots :: [Int] -> Text
show_roots = String -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe Char
Num.showHigit

make_ratios :: [Int] -> [(Int, [Ratio])]
make_ratios :: [Int] -> [(Int, [Ratio])]
make_ratios =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Ord a => [a] -> [a]
List.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Ratio -> Ratio
reduce_octave)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. (Enum a, Fractional b, Num a) => [b] -> [(a, [b])]
choose_unity
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Num a => a -> a -> a
(*)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, a)]
permute forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Integral a => a -> a -> Ratio a
%Int
1)
    where
    choose_unity :: [b] -> [(a, [b])]
choose_unity [b]
xs = [(a
n, forall a b. (a -> b) -> [a] -> [b]
map (forall a. Fractional a => a -> a -> a
/b
x) [b]
xs) | (a
n, b
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] [b]
xs]

permute :: [a] -> [(a, a)]
permute :: forall a. [a] -> [(a, a)]
permute (a
x:[a]
xs) = [(a
x, a
y) | a
y <- [a]
xs] forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [(a, a)]
permute [a]
xs
permute [] = []

type Ratio = Ratio.Ratio Int

reduce_octave :: Ratio -> Ratio
reduce_octave :: Ratio -> Ratio
reduce_octave Ratio
ratio
    | Ratio
ratio forall a. Ord a => a -> a -> Bool
>= Ratio
2 = Ratio -> Ratio
reduce_octave (Ratio
ratio forall a. Fractional a => a -> a -> a
/ Ratio
2)
    | Ratio
ratio forall a. Ord a => a -> a -> Bool
< Ratio
1 = Ratio -> Ratio
reduce_octave (Ratio
ratio forall a. Num a => a -> a -> a
* Ratio
2)
    | Bool
otherwise = Ratio
ratio