module Music.Theory.Instrument.Choir where
import Data.List.Split
import Data.Maybe
import qualified Music.Theory.Clef as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Pitch.Name as T
data Voice = Bass | Tenor | Alto | Soprano
deriving (Eq,Ord,Enum,Bounded,Show)
voice_abbrev :: Voice -> Char
voice_abbrev = head . show
voice_clef :: Integral i => Voice -> T.Clef i
voice_clef v =
case v of
Bass -> T.Clef T.Bass 0
Tenor -> T.Clef T.Treble (1)
Alto -> T.Clef T.Treble 0
Soprano -> T.Clef T.Treble 0
type Voice_Rng_Tbl = [(Voice,(T.Pitch,T.Pitch))]
voice_rng_tbl_std :: Voice_Rng_Tbl
voice_rng_tbl_std =
[(Bass,(T.d2,T.c4))
,(Tenor,(T.c3,T.a4))
,(Alto,(T.f3,T.f5))
,(Soprano,(T.c4,T.a5))]
voice_rng_tbl_safe :: Voice_Rng_Tbl
voice_rng_tbl_safe =
[(Bass,(T.g2,T.c4))
,(Tenor,(T.c3,T.f4))
,(Alto,(T.g3,T.c5))
,(Soprano,(T.c4,T.f5))]
lookup_err :: Eq a => a -> [(a,b)] -> b
lookup_err e = fromMaybe (error "lookup_err") . lookup e
voice_rng :: Voice_Rng_Tbl -> Voice -> (T.Pitch,T.Pitch)
voice_rng tbl v = lookup_err v tbl
voice_rng_std :: Voice -> (T.Pitch,T.Pitch)
voice_rng_std = voice_rng voice_rng_tbl_std
voice_rng_safe :: Voice -> (T.Pitch,T.Pitch)
voice_rng_safe = voice_rng voice_rng_tbl_safe
in_range_inclusive :: Ord a => a -> (a,a) -> Bool
in_range_inclusive p (l,r) = p >= l && p <= r
in_voice_rng :: T.Pitch -> Voice -> (Bool,Bool)
in_voice_rng p v =
(in_range_inclusive p (voice_rng_std v)
,in_range_inclusive p (voice_rng_safe v))
possible_voices :: Voice_Rng_Tbl -> T.Pitch -> [Voice]
possible_voices tbl p =
let f = in_range_inclusive p . voice_rng tbl
in filter f [Bass .. Soprano]
possible_voices_std :: T.Pitch -> [Voice]
possible_voices_std = possible_voices voice_rng_tbl_std
possible_voices_safe :: T.Pitch -> [Voice]
possible_voices_safe = possible_voices voice_rng_tbl_safe
satb :: [Voice]
satb = [Soprano,Alto,Tenor,Bass]
satb_name :: [String]
satb_name = map show satb
satb_abbrev :: [String]
satb_abbrev = map (return . voice_abbrev) satb
type Part = (Voice,Int)
ch_satb_seq :: Int -> [Part]
ch_satb_seq k = [(vc,n) | vc <- satb, n <- [1..k]]
ch_parts :: Int -> [[Part]]
ch_parts k = chunksOf k (ch_satb_seq k)
part_nm :: Part -> String
part_nm (v,n) = voice_abbrev v : show n
k_ch_groups :: Int -> [[Part]]
k_ch_groups k =
let f n = map (\p -> (p,n)) satb
in map f [1 .. k]
k_ch_groups' :: Int -> [Part]
k_ch_groups' = concat . k_ch_groups
dbl_ch_parts :: Int -> [[Part]]
dbl_ch_parts k =
let v = satb
f p = map (\n -> (p,n))
g = zipWith f v . replicate 4
in concatMap g (chunksOf (k `div` 2) [1 .. k])
mk_clef_seq :: [Part] -> [T.Clef Int]
mk_clef_seq = map (voice_clef . fst)