module Music.Theory.Z.Boros_1990 where
import Data.Char
import Data.List
import Data.Maybe
import Numeric
import qualified Data.Graph.Inductive.Graph as G
import qualified Data.Graph.Inductive.Basic as G
import qualified Data.Graph.Inductive.PatriciaTree as G
import qualified Data.Graph.Inductive.Query.BFS as G
import qualified Music.Theory.Array.MD as T
import qualified Music.Theory.Combinations as T
import qualified Music.Theory.Graph.Dot as T
import qualified Music.Theory.Graph.FGL as T
import qualified Music.Theory.List as T
import qualified Music.Theory.Set.List as T
import qualified Music.Theory.Tuple as T
import qualified Music.Theory.Z as T
import qualified Music.Theory.Z.Forte_1973 as T
import qualified Music.Theory.Z.TTO as T
singular :: String -> [t] -> t
singular err l =
case l of
[x] -> x
_ -> error ("not singular: " ++ err)
set_eq :: Ord t => [t] -> [t] -> Bool
set_eq p q = T.set p == T.set q
elem_by :: (t -> t -> Bool) -> t -> [t] -> Bool
elem_by f e = any (f e)
tto_tni_univ :: Integral i => [T.TTO i]
tto_tni_univ = filter (not . T.tto_M) (T.z_tto_univ T.mod12)
all_tn :: Integral i => [i] -> [[i]]
all_tn p = map (\n -> map (T.z_add T.mod12 n) p) [0..11]
all_tni :: Integral i => [i] -> [[i]]
all_tni p = map (\f -> T.z_tto_apply 5 T.mod12 f p) tto_tni_univ
uniq_tni :: Integral i => [i] -> [[i]]
uniq_tni = nub . all_tni
type PC = Int
type PCSET = [PC]
type SC = PCSET
pcset_trs :: Int -> PCSET -> PCSET
pcset_trs n p = sort (map (T.mod12 . (+ n)) p)
trichords :: [PCSET]
trichords = filter ((== 3) . length) (T.sc_univ T.mod12)
self_inv :: PCSET -> Bool
self_inv p = elem_by set_eq (map (T.z_negate T.mod12) p) (all_tn p)
pcset_pp :: PCSET -> String
pcset_pp = intercalate "," . map show
pcset_pp_hex :: PCSET -> String
pcset_pp_hex = map toUpper . concat . map (flip showHex "")
ath :: PCSET
ath = [0,1,2,4,7,8]
is_ath :: PCSET -> Bool
is_ath p = T.forte_prime T.mod12 p == ath
ath_univ :: [PCSET]
ath_univ = uniq_tni ath
ath_tni :: PCSET -> T.TTO PC
ath_tni = singular "ath_tni" . filter (not . T.tto_M) . T.z_tto_rel 5 T.mod12 ath
ath_pp :: PCSET -> String
ath_pp p =
let r = ath_tni p
h = if T.tto_I r then 'h' else 'H'
in h : show (T.tto_T r)
ath_trichords :: [PCSET]
ath_trichords = T.combinations (3::Int) ath
ath_complement :: PCSET -> PCSET
ath_complement p = ath \\ p
ath_completions :: PCSET -> SC -> [PCSET]
ath_completions p q =
let f z = is_ath (p ++ z)
in filter f (uniq_tni q)
realise_ath_seq :: [PCSET] -> [[PCSET]]
realise_ath_seq sq =
case sq of
p:q:sq' -> concatMap (\z -> map (p :) (realise_ath_seq (z : sq'))) (ath_completions p q)
_ -> [sq]
ath_gr_extend :: T.GRAPH PCSET -> PCSET -> [T.EDGE PCSET]
ath_gr_extend gr c =
let f x y = if is_ath (x ++ y) then Just (x,y) else Nothing
g (p,q) = mapMaybe (f c) [p,q]
in nub (map T.t2_sort (concatMap g gr))
gr_trs :: Int -> T.GRAPH PCSET -> T.GRAPH PCSET
gr_trs n = let f (p,q) = (pcset_trs n p,pcset_trs n q) in map f
table_3 :: [((PCSET,SC,T.SC_Name),(PCSET,SC,T.SC_Name))]
table_3 =
let f p = let q = ath_complement p
i x = (x,T.forte_prime T.mod12 x,T.sc_name T.mod12 x)
in (i p,i q)
in map f ath_trichords
table_3_md :: [String]
table_3_md =
let pp = pcset_pp_hex
f ((p,q,r),(s,t,u)) = [pp p,pp q,r,pp s,pp t,u]
hdr = ["P","P/SC","P/F","Q=H0-P","Q/SC","Q/F"]
in T.md_table' (Just hdr,map f table_3)
table_4 :: [((PCSET,PCSET,T.SC_Name),(PCSET,PCSET,T.SC_Name))]
table_4 = nub (map T.t2_sort table_3)
table_4_md :: [String]
table_4_md =
let pp = pcset_pp_hex
f ((p,q,r),(s,t,u)) = [pp p ++ "/" ++ pp s,pp q ++ "/" ++ pp t,r ++ "/" ++ u]
hdr = ["Trichords","Prime Forms","Forte Numbers"]
in T.md_table' (Just hdr,map f table_4)
table_5 :: [(PCSET,Int)]
table_5 = T.histogram (map (T.forte_prime T.mod12) ath_trichords)
table_5_md :: [String]
table_5_md =
let f (p,q) = [pcset_pp_hex p,show q]
in T.md_table' (Just ["SC","#ATH"],map f table_5)
table_6 :: [(PCSET,Int,Int)]
table_6 =
let f (p,n) = (p,n,length (filter (\q -> p `T.is_subset` q) ath_univ))
in map f table_5
table_6_md :: [String]
table_6_md =
let f (p,q,r) = [pcset_pp_hex p,show q,show r]
in T.md_table' (Just ["SC","#H0","#Hn"],map f table_6)
fig_1 :: T.GRAPH PCSET
fig_1 = map (T.t2_map T.p3_snd) table_4
fig_1_gr :: G.Gr PCSET ()
fig_1_gr = T.g_from_edges fig_1
fig_2 :: [[PCSET]]
fig_2 =
let g = G.undir fig_1_gr
n = G.labNodes g
n' = filter ((== 2) . G.deg g . fst) n
c = T.combinations (2::Int) n'
p = map (\[lhs,rhs] -> G.esp (fst lhs) (fst rhs) g) c
p' = (filter (not . null) p)
in map (mapMaybe (\x -> lookup x n)) p'
fig_3 :: [T.GRAPH PCSET]
fig_3 = map (concatMap (T.adj2 1) . realise_ath_seq) fig_2
fig_3_gr :: [G.Gr PCSET ()]
fig_3_gr = map T.g_from_edges fig_3
fig_4 :: [T.GRAPH PCSET]
fig_4 =
let p = concatMap realise_ath_seq fig_2
q = filter ([0,1,2] `elem`) p
in map (T.adj2 1) q
fig_5 :: [T.GRAPH PCSET]
fig_5 =
let c = [0,4,8]
f gr = case ath_gr_extend gr c of
[] -> Nothing
r -> Just (gr ++ r)
g0 = concat fig_4
in mapMaybe (\n -> f (gr_trs n g0)) [0 .. 11]
uedge_set :: Ord v => [T.EDGE v] -> [T.EDGE v]
uedge_set = nub . map T.t2_sort
set_shape :: PCSET -> String
set_shape v = if self_inv v then "doublecircle" else "circle"
type GR = G.Gr PCSET ()
gr_pp' :: (PCSET -> String) -> T.GR_PP PCSET ()
gr_pp' f = (Just . set_shape,Just . f,const Nothing)
gr_pp :: T.GR_PP PCSET ()
gr_pp = gr_pp' pcset_pp
d_fig_1 :: [String]
d_fig_1 = T.g_to_udot [] gr_pp fig_1_gr
d_fig_3_g :: GR
d_fig_3_g = T.g_from_edges (uedge_set (concat fig_3))
d_fig_3 :: [String]
d_fig_3 = T.g_to_udot [] gr_pp d_fig_3_g
d_fig_3' :: [[String]]
d_fig_3' = map (T.g_to_udot [("node:shape","circle")] gr_pp) fig_3_gr
d_fig_4_g :: GR
d_fig_4_g = T.g_from_edges (uedge_set (concat fig_4))
d_fig_4 :: [String]
d_fig_4 = T.g_to_udot [] gr_pp d_fig_4_g
d_fig_5_g :: GR
d_fig_5_g = T.g_from_edges (uedge_set (concat fig_5))
d_fig_5 :: [String]
d_fig_5 = T.g_to_udot [("edge:len","1.5")] (gr_pp' pcset_pp_hex) d_fig_5_g
d_fig_5_e :: [T.EDGE_L PCSET PCSET]
d_fig_5_e = map (\(p,q) -> ((p,q),p++q)) (uedge_set (concat fig_5))
d_fig_5_g' :: G.Gr PCSET PCSET
d_fig_5_g' = T.g_from_edges_l d_fig_5_e
d_fig_5' :: [String]
d_fig_5' =
let pp = (const (Just ""),const Nothing,Just . ath_pp)
in T.g_to_udot [("node:shape","point"),("edge:len","1.25")] pp d_fig_5_g'