-- | Euler-Fokker genus <http://www.huygens-fokker.org/microtonality/efg.html>
module Music.Theory.Tuning.Efg where

import Data.List {- base -}

import qualified Music.Theory.List as T {- hmt -}
import qualified Music.Theory.Set.List as T {- hmt -}

import Music.Theory.Tuning {- hmt -}

-- | Normal form, value with occurences count (ie. exponent in notation above).
type Efg i = [(i,Int)]

-- | Degree of Efg, ie. sum of exponents.
--
-- > efg_degree [(3,3),(7,2)] == 3 + 2
efg_degree :: Efg i -> Int
efg_degree :: forall i. Efg i -> Int
efg_degree = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd

-- | Number of tones of Efg, ie. product of increment of exponents.
--
-- > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1)
efg_tones :: Efg i -> Int
efg_tones :: forall i. Efg i -> Int
efg_tones = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
+ Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

-- | Collate a genus given as a multiset into standard form, ie. histogram.
--
-- > efg_collate [3,3,3,7,7] == [(3,3),(7,2)]
efg_collate :: Ord i => [i] -> Efg i
efg_collate :: forall i. Ord i => [i] -> Efg i
efg_collate = forall i. Ord i => [i] -> Efg i
T.histogram forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort

{- | Factors of Efg given with co-ordinate of grid location.

> efg_factors [(3,3)]

> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7])
>         ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7])
>         ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7])
>         ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])]

> efg_factors [(3,3),(7,2)] == r

-}
efg_factors :: Efg i -> [([Int],[i])]
efg_factors :: forall i. Efg i -> [([Int], [i])]
efg_factors Efg i
efg =
    let k :: [[Int]]
k = forall a b. (a -> b) -> [a] -> [b]
map (\(i
_,Int
n) -> [Int
0 .. Int
n]) Efg i
efg
        k' :: [[Int]]
k' = if forall (t :: * -> *) a. Foldable t => t a -> Int
length Efg i
efg forall a. Eq a => a -> a -> Bool
== Int
1
             then forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return) [[Int]]
k
             else forall a. [[a]] -> [[a]]
T.nfold_cartesian_product [[Int]]
k
        z :: [i]
z = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst Efg i
efg
        f :: [Int] -> ([Int], [i])
f [Int]
ix = ([Int]
ix,forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n Int
m -> forall a. Int -> a -> [a]
replicate Int
n ([i]
z forall a. [a] -> Int -> a
!! Int
m)) [Int]
ix [Int
0..]))
    in forall a b. (a -> b) -> [a] -> [b]
map [Int] -> ([Int], [i])
f [[Int]]
k'

{- | Ratios of Efg, taking /n/ as the 1:1 ratio, with indices, folded into one octave.

> import Data.List
> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)]
> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32]
> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173]

      0:         1/1          C          0.000 cents
      1:         9/8          D        203.910 cents
      2:         8/7          D+       231.174 cents
      3:         9/7          E+       435.084 cents
      4:        21/16         F-       470.781 cents
      5:       189/128        G-       674.691 cents
      6:         3/2          G        701.955 cents
      7:        27/16         A        905.865 cents
      8:        12/7          A+       933.129 cents
      9:         7/4          Bb-      968.826 cents
     10:        27/14         B+      1137.039 cents
     11:        63/32         C-      1172.736 cents
     12:         2/1          C       1200.000 cents

> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)]
> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128]
> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124]

> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)]
> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4]
> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969]

> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200]
> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200]
> let c2 = [0,155,267,386,498,653,884,969,1200]
> let f (c',y) = map (\x -> (x,y,x,y + 10)) c'
> map f (zip [c0,c1,c2] [0,20,40])

-}
efg_ratios :: Real r => Rational -> Efg r -> [([Int],Rational)]
efg_ratios :: forall r. Real r => Rational -> Efg r -> [([Int], Rational)]
efg_ratios Rational
n =
    let to_r :: [r] -> Rational
to_r = forall n. (Ord n, Fractional n) => n -> n
fold_ratio_to_octave_err forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ Rational
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product
        f :: (a, [r]) -> (a, Rational)
f (a
ix,[r]
i) = (a
ix,[r] -> Rational
to_r [r]
i)
    in forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, [r]) -> (a, Rational)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Efg i -> [([Int], [i])]
efg_factors

{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples.
     h=row height, m=distance of vertical mark from row edge, k=distance between rows

> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]]
> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]]
> let e' = map efg_collate e
> efg_diagram_set (round,25,4,75) e'

-}
efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [Efg n] -> [(n,n,n,n)]
efg_diagram_set :: forall n.
(Enum n, Real n) =>
(Cents -> n, n, n, n) -> [Efg n] -> [(n, n, n, n)]
efg_diagram_set (Cents -> n
to_f,n
h,n
m,n
k) [Efg n]
e =
    let f :: Efg n -> [n]
f = (forall a. [a] -> [a] -> [a]
++ [n
1200]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Cents -> n
to_f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => Ratio i -> Cents
ratio_to_cents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Real r => Rational -> Efg r -> [([Int], Rational)]
efg_ratios Rational
1
        g :: ([c], n) -> [(c, n, c, n)]
g ([c]
c,n
y) = let y' :: n
y' = n
y forall a. Num a => a -> a -> a
+ n
h
                      b :: [(c, n, c, n)]
b = [(c
0,n
y,c
1200,n
y),(c
0,n
y',c
1200,n
y')]
                  in [(c, n, c, n)]
b forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\c
x -> (c
x,n
y forall a. Num a => a -> a -> a
+ n
m,c
x,n
y' forall a. Num a => a -> a -> a
- n
m)) [c]
c
    in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {c}. Num c => ([c], n) -> [(c, n, c, n)]
g (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map Efg n -> [n]
f [Efg n]
e) [n
0,n
k ..])