module Music.Theory.Wyschnegradsky where
import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import Music.Theory.List
import Music.Theory.Pitch
import Music.Theory.Pitch.Spelling.Table
normalise_step :: (Eq n,Num n) => n -> n -> n
normalise_step m n
| n == 1 = 1
| n == 1 = 1
| n == m 1 = 1
| n == 1 m = 1
| otherwise = error "normalise_step"
parse_num_sign :: (Num n, Read n) => String -> n
parse_num_sign s =
case separate_last s of
(n,'+') -> read n
(n,'-') -> negate (read n)
_ -> error "parse_num_sign"
vec_expand :: Num n => Int -> [n]
vec_expand n = if n > 0 then replicate n 1 else replicate (abs n) (1)
parse_vec :: Num n => Maybe Int -> n -> String -> [n]
parse_vec n m =
let f = case n of
Just i -> dx_d m . take i . cycle
Nothing -> dx_d m
in dropRight 1 . f . concatMap (vec_expand . parse_num_sign) . splitOn ","
add_m :: Integral a => a -> a -> a -> a
add_m n p q = (p + q) `mod` n
parse_hex_clr :: (Read n,Num n) => String -> (n,n,n)
parse_hex_clr clr =
let f p q = read ("0x" ++ [p,q])
in case clr of
['#',p,q,r,s,t,u] -> (f p q,f r s,f t u)
_ -> error "parse_hex"
parse_hex_clr_int :: String -> (Int,Int,Int)
parse_hex_clr_int = parse_hex_clr
clr_normalise :: (Real r,Fractional f) => f -> (r,r,r) -> (f,f,f)
clr_normalise m (r,g,b) = let f x = realToFrac x / m in (f r,f g,f b)
data Seq a = Radial [a] | Circumferential [a]
seq_group :: Int -> Int -> Seq a -> [[a]]
seq_group c_div r_div s =
case s of
Circumferential c -> chunksOf c_div c
Radial r -> transpose (chunksOf r_div r)
iw_pc_pp :: Integral n => String -> [[n]] -> IO ()
iw_pc_pp sep =
let f = pitch_pp_opt (False,False) . octpc_to_pitch pc_spell_ks . (,) 4
in putStrLn . intercalate sep . map (unwords . map f)
u3_ix_ch :: Integral i => i -> Char
u3_ix_ch = genericIndex "ROYGBV" . (`mod` 6)
u3_ch_ix :: Char -> Int
u3_ch_ix = fromMaybe (error "u3_ch_ix") . flip elemIndex "ROYGBV"
u3_vec_text_iw :: [(String, String)]
u3_vec_text_iw =
[("4+,4-,4+,4-,2+"
,"4-,4+,4-,4+,4-,4+,4-,4+,4-")
,("9+,2+,2-,2+,2-,2+"
,"2+,2-,2+,2-,2+,2-,2+,2-,2+,18+")
,("12-,12+,12-"
,"18+,18-")
,("3+,3-,3+,3-,3+,3-"
,"18+,18-")
,("9+,9-"
,"3+,3-,3+,3-,3+,3-,3+,3-,3+,3-,3+,3-")
,("2+,2-,2+,2-,2+,2-"
,"6-,6+,6-,6+,6-,6+")
,("2+,2-,2+,2-,2+,2-"
,"6+,6-,6+,6-,6+,6-")
,("6+,6-"
,"2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-")]
u3_vec_text_rw :: [(String, String)]
u3_vec_text_rw =
[("4+,3-,5+,3-,3+"
,"4-,3+,5-,3+,5-,3+,5-,3+,5-")
,("9+,2+,1-,3+,1-,2+"
,"2+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,2-")
,("12-,12+,12-"
,"18+,18-")
,("3+,2-,4+,2-,4+,3-"
,"18+,18-")
,("9+,9-"
,"3+,2-,4+,1-,1+,1-,3+,1-,1+,1-,3+,2-,4+,1-,1+,1-,3+,1-,1+,1-")
,("2+,1-,3+,1-,3+,2-"
,"6-,6+,6-,6+,6-,6+")
,("2+,1-,3+,1-,3+,2-"
,"6+,6-,6+,6-,6+,6-")
,("6+,6-"
,"2+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,2-")]
u3_vec_ix :: Num n => ([[n]],[[n]])
u3_vec_ix =
let f (p,q) = [parse_vec Nothing 0 p,parse_vec Nothing 0 q]
[c,r] = transpose (map f u3_vec_text_rw)
in (c,r)
u3_ix_radial :: Integral n => [[n]]
u3_ix_radial =
let (c,r) = u3_vec_ix
r' = zipWith replicate (map length c) r
in zipWith (\p q -> map (add_m 6 p) q) (concat c) (concat r')
u3_clr_nm :: [String]
u3_clr_nm = words "red orange yellow green blue violet"
u3_clr_hex :: [String]
u3_clr_hex = words "#e14630 #e06e30 #e2c48e #498b43 #2a5a64 #cb7b74"
u3_clr_rgb :: Fractional n => [(n,n,n)]
u3_clr_rgb = map (clr_normalise 256 . parse_hex_clr_int) u3_clr_hex
u3_radial_ch :: [(Int,[Char])]
u3_radial_ch =
[(1,"RVBGY GBV BGYOR OYG YORVB VRO RVBGY GBVBGYO")
,(5,"ROYG YO YGBV BV BVRO RO ROYG YO YGBV BV BVR OR O")]
u3_circ_ch :: [(Int,[Char])]
u3_circ_ch =
[(6,"ROYOYGBGBVRV")
,(7,"ROYOYGBGBVRV")
,(8,"ROYGBVRVBGYO")]
u3_ch_seq_to_vec :: [Char] -> [Int]
u3_ch_seq_to_vec =
map length .
group .
map (normalise_step 6) .
d_dx .
map u3_ch_ix .
filter (not . isSpace)
dc9_circ :: Num n => [[n]]
dc9_circ =
[[6,5,4,3,2]
,[3,2,1,0,11,10]
,[11,10,9,8,7,6,5]
,[6,5]
,[6,5,4]
,[5,4,3,2]
,[3,2,1,0]
,[1,0,11]
,[0,11]
,[0,1,2,3,4,5,6]
,[5,6,7,8,9,10,9]
,[10,11,0,1]
,[0,1,2,3]
,[2,3,4]
,[3,4]
,[3,4]
,[3,4,5]
,[4,5,6,7]]
dc9_rad :: Num n => [n]
dc9_rad = [0,10,8,6,4,2,0,10,8,6,4,2,0,10,8,6,4,2]
dc9_ix :: Integral n => [[n]]
dc9_ix = map (\n -> map (add_m 12 n) dc9_rad) (concat dc9_circ)
dc9_clr_hex :: [String]
dc9_clr_hex =
let c = ["#e96d61","#e6572b"
,"#e07122","#e39e36"
,"#e8b623","#e5c928"
,"#c2ba3d","#a2a367"
,"#537a77","#203342"
,"#84525e","#bc6460"]
n = interleave [6,4,2,0,10,8] [5,3,1,11,9,7] :: [Int]
in map snd (sort (zip n c))
dc9_clr_rgb :: Fractional n => [(n,n,n)]
dc9_clr_rgb = map (clr_normalise 255 . parse_hex_clr_int) dc9_clr_hex
u11_circ :: Num n => [[n]]
u11_circ =
[[7,8,9,10,11,0,1,2,3]
,[10,11,0,1,2,3,4,5,6]
,[0,1,2,3,4,5]
,[0,1,2]
,[10,11]
,[6,7]
,[2]
,[9]
,[4]
,[11]
,[6,7]
,[2]
,[9]
,[2]
,[11]
,[6,7]
,[2,3]
,[10,11,0]
,[7,8,9,10,11,0]
,[7,8,9,10,11,0,1,2,3]
,[10,11,0,1,2,3,4,5,6]]
u11_gen_seq :: Integral i => i -> Int -> [i] -> [i]
u11_gen_seq z n = map (`mod` 12) . take n . dx_d z . cycle
u11_seq_rule :: Integral i => Maybe Int -> [i]
u11_seq_rule n = u11_gen_seq 0 18 (maybe [1] (\x -> replicate x (1) ++ [5]) n)
ull_rad_text :: [Char]
ull_rad_text =
let x = "012588----"
y = "-"
in x ++ y ++ reverse x
u11_rad :: Integral n => [[n]]
u11_rad =
let f c = if c == '-' then Nothing else Just (read [c])
in map (u11_seq_rule . f) ull_rad_text
u11_clr_hex :: [String]
u11_clr_hex =
let c = ["#dbb56a","#ffb05c","#ea7c3f","#f93829","#ee6054","#d18d9c"
,"#a94c79","#215272","#628b7d","#9dbc90","#ecdfaa","#fbeaa5"]
n = reverse ([4..11] ++ [0..3]) :: [Int]
in map snd (sort (zip n c))
u11_clr_rgb :: Fractional n => [(n,n,n)]
u11_clr_rgb = map (clr_normalise 256 . parse_hex_clr_int) u11_clr_hex