-- | Euler plane diagrams as /dot/ language graphs.
--
-- <http://rohandrape.net/?t=hmt-texts&e=md/euler.md>
module Music.Theory.Tuning.Graph.Euler where

import Data.List {- base -}
import Data.Ratio {- base -}

import qualified Music.Theory.Function as T {- hmt -}
import qualified Music.Theory.List as T {- hmt -}
import qualified Music.Theory.Pitch.Note as T {- hmt -}
import qualified Music.Theory.Show as T {- hmt -}
import qualified Music.Theory.Tuning as T {- hmt -}
import qualified Music.Theory.Tuple as T {- hmt -}

-- | 'T.fold_ratio_to_octave_err' of '*'.
rat_mul :: Rational -> Rational -> Rational
rat_mul :: Rational -> Rational -> Rational
rat_mul Rational
r = forall n. (Ord n, Fractional n) => n -> n
T.fold_ratio_to_octave_err forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Rational
r)

-- | 'T.fold_ratio_to_octave_err' of '/'.
rat_div :: Rational -> Rational -> Rational
rat_div :: Rational -> Rational -> Rational
rat_div Rational
p Rational
q = forall n. (Ord n, Fractional n) => n -> n
T.fold_ratio_to_octave_err (Rational
p forall a. Fractional a => a -> a -> a
/ Rational
q)

-- | /n/ = length, /m/ = multiplier, /r/ = initial ratio.
--
-- > tun_seq 5 (3/2) 1 == [1/1,3/2,9/8,27/16,81/64]
tun_seq :: Int -> Rational -> Rational -> [Rational]
tun_seq :: Int -> Rational -> Rational -> [Rational]
tun_seq Int
n Rational
m = forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> a -> [a]
iterate (Rational -> Rational -> Rational
rat_mul Rational
m)

-- | All possible pairs of elements (/x/,/y/) where /x/ is from /p/ and /y/ from /q/.
--
-- > all_pairs "ab" "cde" == [('a','c'),('a','d'),('a','e'),('b','c'),('b','d'),('b','e')]
all_pairs :: [t] -> [u] -> [(t,u)]
all_pairs :: forall t u. [t] -> [u] -> [(t, u)]
all_pairs [t]
p [u]
q = [(t
x,u
y) | t
x <- [t]
p, u
y <- [u]
q]

-- | Give all pairs from (l2,l1) and (l3,l2) that are at interval ratios r1 and r2 respectively.
euler_align_rat :: T.T2 Rational -> T.T3 [Rational] -> T.T2 [T.T2 Rational]
euler_align_rat :: T2 Rational -> T3 [Rational] -> T2 [T2 Rational]
euler_align_rat (Rational
r1,Rational
r2) ([Rational]
l1,[Rational]
l2,[Rational]
l3) =
    let f :: Rational -> T2 Rational -> Bool
f Rational
r (Rational
p,Rational
q) = Rational -> Rational -> Rational
rat_mul Rational
p Rational
r forall a. Eq a => a -> a -> Bool
== Rational
q
    in (forall a. (a -> Bool) -> [a] -> [a]
filter (Rational -> T2 Rational -> Bool
f Rational
r1) (forall t u. [t] -> [u] -> [(t, u)]
all_pairs [Rational]
l2 [Rational]
l1)
       ,forall a. (a -> Bool) -> [a] -> [a]
filter (Rational -> T2 Rational -> Bool
f Rational
r2) (forall t u. [t] -> [u] -> [(t, u)]
all_pairs [Rational]
l3 [Rational]
l2))

-- | Pretty printer for pitch class (UNICODE).
--
-- > unwords (map pc_pp [0..11]) == "C♮ C♯ D♮ E♭ E♮ F♮ F♯ G♮ A♭ A♮ B♭ B♮"
pc_pp :: (Integral i,Show i) => i -> String
pc_pp :: forall i. (Integral i, Show i) => i -> String
pc_pp i
x =
    case forall i. Integral i => i -> Maybe (Note, Alteration)
T.pc_to_note_alteration_ks i
x of
      Just (Note
n,Alteration
a) -> [Note -> Char
T.note_pp Note
n,Alteration -> Char
T.alteration_symbol Alteration
a]
      Maybe (Note, Alteration)
Nothing -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show (String
"pc_pp",i
x))

-- | Show ratio as intergral ('round') cents value.
cents_pp :: Rational -> String
cents_pp :: Rational -> String
cents_pp = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (RealFrac a, Integral b) => a -> b
round :: Double -> Integer) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => Ratio i -> Double
T.ratio_to_cents

-- | (unit-pitch-class,print-cents)
type RAT_LABEL_OPT = (Int,Bool)

-- | Dot label for ratio, /k/ is the pitch-class of the unit ratio.
--
-- > rat_label (0,False) 1 == "C♮\\n1:1"
-- > rat_label (3,True) (7/4) == "C♯=969\\n7:4"
rat_label :: RAT_LABEL_OPT -> Rational -> String
rat_label :: RAT_LABEL_OPT -> Rational -> String
rat_label (Int
k,Bool
with_cents) Rational
r =
    if Rational
r forall a. Ord a => a -> a -> Bool
< Rational
1 Bool -> Bool -> Bool
|| Rational
r forall a. Ord a => a -> a -> Bool
>= Rational
2
    then forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show (String
"rat_label",Rational
r))
    else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall i. (Integral i, Show i) => i -> String
pc_pp (Int -> Rational -> Int
T.ratio_to_pc Int
k Rational
r)
                ,if Bool
with_cents
                 then Char
'=' forall a. a -> [a] -> [a]
: Rational -> String
cents_pp Rational
r
                 else String
""
                ,String
"\\n",Rational -> String
T.ratio_pp Rational
r]

-- | Generate value /dot/ node identifier for ratio.
--
-- > rat_id (5/4) == "R_5_4"
rat_id :: Rational-> String
rat_id :: Rational -> String
rat_id Rational
r = String
"R_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ratio a -> a
numerator Rational
r) forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ratio a -> a
denominator Rational
r)

-- | Printer for edge label between given ratio nodes.
rat_edge_label :: (Rational, Rational) -> String
rat_edge_label :: T2 Rational -> String
rat_edge_label (Rational
p,Rational
q) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"   (",Rational -> String
T.ratio_pp (Rational -> Rational -> Rational
rat_div Rational
p Rational
q),String
")"]

-- | Zip start-middle-end.
--
-- > zip_sme (0,1,2) "abcd" == [(0,'a'),(1,'b'),(1,'c'),(2,'d')]
zip_sme :: (t,t,t) -> [u] -> [(t,u)]
zip_sme :: forall t u. (t, t, t) -> [u] -> [(t, u)]
zip_sme (t
s,t
m,t
e) [u]
xs =
    case [u]
xs of
      u
x0:u
x1:[u]
xs' -> (t
s,u
x0) forall a. a -> [a] -> [a]
: (t
m,u
x1) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
T.at_last (\u
x -> (t
m,u
x)) (\u
x -> (t
e,u
x)) [u]
xs'
      [u]
_ -> forall a. HasCallStack => String -> a
error String
"zip_sme: not SME list"

-- | Euler diagram given as (/h/,/v/) duple,
-- where /h/ are the horizontal sequences and /v/ are the vertical edges.
type Euler_Plane t = ([[t]],[(t,t)])

-- | Ratios at plane, sorted.
euler_plane_r :: Ord t => Euler_Plane t -> [t]
euler_plane_r :: forall t. Ord t => Euler_Plane t -> [t]
euler_plane_r = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

-- | Apply /f/ at all nodes of the plane.
euler_plane_map :: (t -> u) -> Euler_Plane t -> Euler_Plane u
euler_plane_map :: forall t u. (t -> u) -> Euler_Plane t -> Euler_Plane u
euler_plane_map t -> u
f ([[t]]
p,[(t, t)]
q) = (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map t -> u
f) [[t]]
p,forall a b. (a -> b) -> [a] -> [b]
map (forall t u. (t -> u) -> (t, t) -> (u, u)
T.bimap1 t -> u
f) [(t, t)]
q)

-- | Generate /dot/ graph given printer functions and an /Euler_Plane/.
euler_plane_to_dot :: (t -> String,t -> String,(t,t) -> String) -> Euler_Plane t -> [String]
euler_plane_to_dot :: forall t.
(t -> String, t -> String, (t, t) -> String)
-> Euler_Plane t -> [String]
euler_plane_to_dot (t -> String
n_id,t -> String
n_pp,(t, t) -> String
e_pp) ([[t]]
h,[(t, t)]
v) =
    let mk_lab_term :: String -> String
mk_lab_term String
x = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
" [label=\"",String
x,String
"\"];"]
        node_to_dot :: t -> String
node_to_dot t
x = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [t -> String
n_id t
x,String -> String
mk_lab_term (t -> String
n_pp t
x)]
        subgraph_edges :: [t] -> String
subgraph_edges [t]
x = forall a. [a] -> [[a]] -> [a]
intercalate String
" -- " (forall a b. (a -> b) -> [a] -> [b]
map t -> String
n_id [t]
x) forall a. [a] -> [a] -> [a]
++ String
";"
        edge_to_dot :: (t, t) -> String
edge_to_dot (t
lhs,t
rhs) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [t -> String
n_id t
lhs,String
" -- ",t -> String
n_id t
rhs,String -> String
mk_lab_term ((t, t) -> String
e_pp (t
lhs,t
rhs))]
        subgraphs_to_dot :: (String, [t]) -> String
subgraphs_to_dot (String
ty,[t]
x) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"{rank=",String
ty,String
"; ",[String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map t -> String
n_id [t]
x),String
"}"]
    in [String
"graph g {"
       ,String
"graph [layout=\"dot\",rankdir=\"TB\",nodesep=0.5];"
       ,String
"edge [fontsize=\"8\",fontname=\"century schoolbook\"];"
       ,String
"node [shape=\"plaintext\",fontsize=\"10\",fontname=\"century schoolbook\"];"] forall a. [a] -> [a] -> [a]
++
       forall a b. (a -> b) -> [a] -> [b]
map t -> String
node_to_dot (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[t]]
h) forall a. [a] -> [a] -> [a]
++
       forall a b. (a -> b) -> [a] -> [b]
map [t] -> String
subgraph_edges [[t]]
h forall a. [a] -> [a] -> [a]
++
       forall a b. (a -> b) -> [a] -> [b]
map (t, t) -> String
edge_to_dot [(t, t)]
v forall a. [a] -> [a] -> [a]
++
       forall a b. (a -> b) -> [a] -> [b]
map (String, [t]) -> String
subgraphs_to_dot (forall t u. (t, t, t) -> [u] -> [(t, u)]
zip_sme (String
"min",String
"same",String
"max") [[t]]
h) forall a. [a] -> [a] -> [a]
++
       [String
"}"]

-- | Variant with default printers and fixed node type.
euler_plane_to_dot_rat :: RAT_LABEL_OPT -> Euler_Plane Rational -> [String]
euler_plane_to_dot_rat :: RAT_LABEL_OPT -> Euler_Plane Rational -> [String]
euler_plane_to_dot_rat RAT_LABEL_OPT
opt = forall t.
(t -> String, t -> String, (t, t) -> String)
-> Euler_Plane t -> [String]
euler_plane_to_dot (Rational -> String
rat_id,RAT_LABEL_OPT -> Rational -> String
rat_label RAT_LABEL_OPT
opt,T2 Rational -> String
rat_edge_label)