-- | Tuning graph with edges determined by interval set.
module Music.Theory.Tuning.Graph.Iset where

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

import qualified Data.Graph.Inductive.Graph as Fgl {- fgl -}
import qualified Data.Graph.Inductive.PatriciaTree as Fgl {- fgl -}

import qualified Music.Theory.Graph.Type as T {- hmt-base -}
import qualified Music.Theory.List as T {- hmt-base -}
import qualified Music.Theory.Show as T {- hmt-base -}

import qualified Music.Theory.Graph.Dot as T {- hmt -}
import qualified Music.Theory.Graph.Fgl as T {- hmt -}
import qualified Music.Theory.Tuning as T {- hmt -}
import qualified Music.Theory.Tuning.Graph.Euler as Euler {- hmt -}
import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}

-- * R

-- | R = Rational
type R = Rational

-- | Flip a ratio in (1,2) and multiply by 2.
--
-- > import Data.Ratio {- base -}
-- > map r_flip [5%4,3%2,7%4] == [8%5,4%3,8%7]
-- > map r_flip [3/2,5/4,7/4] == [4/3,8/5,8/7]
r_flip :: R -> R
r_flip :: R -> R
r_flip R
n = if R
n forall a. Ord a => a -> a -> Bool
< R
1 Bool -> Bool -> Bool
|| R
n forall a. Ord a => a -> a -> Bool
> R
2 then forall a. HasCallStack => [Char] -> a
error [Char]
"r_flip" else R
1 forall a. Fractional a => a -> a -> a
/ R
n forall a. Num a => a -> a -> a
* R
2

-- | r = ratio, nrm = normalise
r_nrm :: R -> R
r_nrm :: R -> R
r_nrm = forall t i.
(Ord t, Integral i) =>
(Ratio i -> t) -> Ratio i -> Ratio i
T.ratio_interval_class_by forall a. a -> a
id

-- | The folded interval from p to q.
--
-- > r_rel (1,3/2) == 4/3
r_rel :: (R,R) -> R
r_rel :: (R, R) -> R
r_rel (R
p,R
q) = forall n. (Ord n, Fractional n) => n -> n
T.fold_ratio_to_octave_err (R
p forall a. Fractional a => a -> a -> a
/ R
q)

-- | The interval set /i/ and it's 'r_flip'.
iset_sym :: [R] -> [R]
iset_sym :: [R] -> [R]
iset_sym [R]
l = [R]
l forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map R -> R
r_flip [R]
l

-- | Require r to have a perfect octave as last element, and remove it.
rem_oct :: [R] -> [R]
rem_oct :: [R] -> [R]
rem_oct [R]
r = if forall a. [a] -> a
last [R]
r forall a. Eq a => a -> a -> Bool
/= R
2 then forall a. HasCallStack => [Char] -> a
error [Char]
"rem_oct" else forall t. [t] -> [t]
T.drop_last [R]
r

r_pcset :: [R] -> [Int]
r_pcset :: [R] -> [Int]
r_pcset = 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 (Int -> R -> Int
T.ratio_to_pc Int
0)

r_pcset_univ :: [R] -> [Int]
r_pcset_univ :: [R] -> [Int]
r_pcset_univ = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. [R] -> [Int]
r_pcset

-- | Does [R] construct indicated /pcset/.
r_is_pcset :: [Int] -> [R] -> Bool
r_is_pcset :: [Int] -> [R] -> Bool
r_is_pcset [Int]
pcset = forall a. Eq a => a -> a -> Bool
(==) [Int]
pcset forall b c a. (b -> c) -> (a -> b) -> a -> c
. [R] -> [Int]
r_pcset

-- * G

-- | Edges are (v1,v2) where v1 < v2
type G = T.Gr R

edj_r :: (R, R) -> R
edj_r :: (R, R) -> R
edj_r = R -> R
r_nrm forall b c a. (b -> c) -> (a -> b) -> a -> c
. (R, R) -> R
r_rel

-- | The graph with vertices /scl_r/ and all edges where the interval (i,j) is in /iset/.
mk_graph :: [R] -> [R] -> G
mk_graph :: [R] -> [R] -> G
mk_graph [R]
iset [R]
scl_r =
  ([R]
scl_r
  ,forall a. (a -> Bool) -> [a] -> [a]
filter
    (\(R, R)
e -> (R, R) -> R
edj_r (R, R)
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [R] -> [R]
iset_sym [R]
iset)
    [(R
p,R
q) |
     R
p <- [R]
scl_r,
     R
q <- [R]
scl_r,
     R
p forall a. Ord a => a -> a -> Bool
< R
q])

gen_graph :: Ord v => [T.Dot_Meta_Attr] -> T.Graph_Pp v e -> [T.Edge_Lbl v e] -> [String]
gen_graph :: forall v e.
Ord v =>
[Dot_Meta_Attr] -> Graph_Pp v e -> [Edge_Lbl v e] -> [[Char]]
gen_graph [Dot_Meta_Attr]
opt Graph_Pp v e
pp [Edge_Lbl v e]
es = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Meta_Attr] -> Graph_Pp v e -> gr v e -> [[Char]]
T.fgl_to_udot [Dot_Meta_Attr]
opt Graph_Pp v e
pp (forall v e. (Eq v, Ord v) => [Edge_Lbl v e] -> Gr v e
T.g_from_edges_l [Edge_Lbl v e]
es)

g_to_dot :: Int -> [(String,String)] -> (R -> [(String,String)]) -> G -> [String]
g_to_dot :: Int -> [Dot_Meta_Attr] -> (R -> [Dot_Meta_Attr]) -> G -> [[Char]]
g_to_dot Int
k [Dot_Meta_Attr]
attr R -> [Dot_Meta_Attr]
v_attr ([R]
_,[(R, R)]
e_set) =
  let opt :: [Dot_Meta_Attr]
opt =
        [([Char]
"graph:layout",[Char]
"neato")
        ,([Char]
"node:shape",[Char]
"plaintext")
        ,([Char]
"node:fontsize",[Char]
"10")
        ,([Char]
"node:fontname",[Char]
"century schoolbook")
        ,([Char]
"edge:fontsize",[Char]
"9")]
  in forall v e.
Ord v =>
[Dot_Meta_Attr] -> Graph_Pp v e -> [Edge_Lbl v e] -> [[Char]]
gen_graph
     ([Dot_Meta_Attr]
opt forall a. [a] -> [a] -> [a]
++ [Dot_Meta_Attr]
attr)
     (\(Int
_,R
v) -> ([Char]
"label",RAT_LABEL_OPT -> R -> [Char]
Euler.rat_label (Int
k,Bool
True) R
v) forall a. a -> [a] -> [a]
: R -> [Dot_Meta_Attr]
v_attr R
v
     ,\((Int, Int)
_,R
e) -> [([Char]
"label",forall a. (Show a, Integral a) => Ratio a -> [Char]
T.rational_pp R
e)])
     (forall a b. (a -> b) -> [a] -> [b]
map (\(R, R)
e -> ((R, R)
e,(R, R) -> R
edj_r (R, R)
e)) [(R, R)]
e_set)

-- * SCALA

mk_graph_scl :: [R] -> Scala.Scale -> G
mk_graph_scl :: [R] -> Scale -> G
mk_graph_scl [R]
iset = [R] -> [R] -> G
mk_graph [R]
iset forall b c a. (b -> c) -> (a -> b) -> a -> c
. [R] -> [R]
rem_oct forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [R]
Scala.scale_ratios_req

scl_to_dot :: ([R], Int, [(String, String)], R -> [(String, String)]) -> String -> IO [String]
scl_to_dot :: ([R], Int, [Dot_Meta_Attr], R -> [Dot_Meta_Attr])
-> [Char] -> IO [[Char]]
scl_to_dot ([R]
iset,Int
k,[Dot_Meta_Attr]
attr,R -> [Dot_Meta_Attr]
v_attr) [Char]
nm = do
  Scale
sc <- [Char] -> IO Scale
Scala.scl_load [Char]
nm
  let gr :: G
gr = [R] -> Scale -> G
mk_graph_scl [R]
iset Scale
sc
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Dot_Meta_Attr] -> (R -> [Dot_Meta_Attr]) -> G -> [[Char]]
g_to_dot Int
k [Dot_Meta_Attr]
attr R -> [Dot_Meta_Attr]
v_attr G
gr)

-- * Fgl

graph_to_fgl :: G -> Fgl.Gr R R
graph_to_fgl :: G -> Gr R R
graph_to_fgl ([R]
v,[(R, R)]
e) =
  let fgl_v :: [(Int, R)]
fgl_v = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [R]
v
      r_to_v :: R -> Int
      r_to_v :: R -> Int
r_to_v R
x = forall a. HasCallStack => Maybe a -> a
fromJust (forall v k. Eq v => v -> [(k, v)] -> Maybe k
T.reverse_lookup R
x [(Int, R)]
fgl_v)
      fgl_e :: [(Int, Int, R)]
fgl_e = forall a b. (a -> b) -> [a] -> [b]
map (\(R
p,R
q) -> (R -> Int
r_to_v R
p,R -> Int
r_to_v R
q,(R, R) -> R
edj_r (R
p,R
q))) [(R, R)]
e
  in forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
Fgl.mkGraph [(Int, R)]
fgl_v [(Int, Int, R)]
fgl_e

mk_graph_fgl :: [R] -> [R] -> Fgl.Gr R R
mk_graph_fgl :: [R] -> [R] -> Gr R R
mk_graph_fgl [R]
iset = G -> Gr R R
graph_to_fgl forall b c a. (b -> c) -> (a -> b) -> a -> c
. [R] -> [R] -> G
mk_graph [R]
iset

{-
-- | List of nodes at /g/ connected to node /r/.
g_edge_list :: G -> R -> [R]
g_edge_list (_,e) r =
  let f (p,q) = if r == p then Just q else if r == q then Just p else Nothing
  in mapMaybe f e
-}