module Music.Theory.Gamelan where
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Ratio
import Text.Printf
import qualified Music.Theory.Clef as T
import qualified Music.Theory.Enum as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Tuning as T
import qualified Music.Theory.Tuning.ET as T
fromJust_err :: String -> Maybe a -> a
fromJust_err err = fromMaybe (error err)
near_rat :: Double -> Rational
near_rat = flip approxRational 0.01
data Instrument_Family
= Bonang
| Gender
| Gong
| Saron
deriving (Enum,Bounded,Eq,Ord,Show,Read)
instrument_family_set :: [Instrument_Family]
instrument_family_set = T.enum_univ
data Instrument_Name
= Bonang_Barung
| Bonang_Panerus
| Gender_Barung
| Gender_Panerus
| Gender_Panembung
| Gong_Ageng
| Gong_Suwukan
| Kempul
| Kempyang
| Kenong
| Ketuk
| Saron_Barung
| Saron_Demung
| Saron_Panerus
deriving (Enum,Bounded,Eq,Ord,Show,Read)
instrument_family :: Instrument_Name -> Maybe Instrument_Family
instrument_family nm =
case nm of
Bonang_Barung -> Just Bonang
Bonang_Panerus -> Just Bonang
Gender_Barung -> Just Gender
Gender_Panerus -> Just Gender
Gender_Panembung -> Just Gender
Gong_Ageng -> Just Gong
Gong_Suwukan -> Just Gong
Kempul -> Just Gong
Kempyang -> Nothing
Kenong -> Nothing
Ketuk -> Nothing
Saron_Barung -> Just Saron
Saron_Demung -> Just Saron
Saron_Panerus -> Just Saron
instrument_name_pp :: Instrument_Name -> String
instrument_name_pp =
let f c = if c == '_' then ' ' else c
in map f . show
instrument_name_clef :: Integral i => Instrument_Name -> T.Clef i
instrument_name_clef nm =
case nm of
Bonang_Barung -> T.Clef T.Treble 0
Bonang_Panerus -> T.Clef T.Treble 1
Gender_Barung -> T.Clef T.Treble 0
Gender_Panerus -> T.Clef T.Treble 1
Gender_Panembung -> T.Clef T.Bass 0
Gong_Ageng -> T.Clef T.Bass 0
Gong_Suwukan -> T.Clef T.Bass 0
Kempul -> T.Clef T.Bass 0
Kempyang -> T.Clef T.Treble 1
Kenong -> T.Clef T.Treble 0
Ketuk -> T.Clef T.Alto 0
Saron_Barung -> T.Clef T.Treble 0
Saron_Demung -> T.Clef T.Treble 0
Saron_Panerus -> T.Clef T.Treble 1
instrument_name_clef_plain :: Integral i => Instrument_Name -> T.Clef i
instrument_name_clef_plain = T.clef_zero . instrument_name_clef
data Scale = Pelog | Slendro deriving (Enum,Eq,Ord,Show,Read)
type Octave = Integer
type Degree = Integer
type Frequency = Double
type Annotation = String
data Pitch = Pitch {pitch_octave :: Octave
,pitch_degree :: Degree}
deriving (Eq,Ord,Show)
pitch_pp_ascii :: Pitch -> String
pitch_pp_ascii (Pitch o d) =
let d' = intToDigit (fromIntegral d)
o' = if o < 0
then genericReplicate (abs o) '-'
else genericReplicate o '+'
in o' ++ [d']
pitch_pp_duple :: Pitch -> String
pitch_pp_duple (Pitch o d) = printf "(%d,%d)" o d
data Note = Note {note_scale :: Scale
,note_pitch :: Pitch}
deriving (Eq,Ord,Show)
note_degree :: Note -> Degree
note_degree = pitch_degree . note_pitch
data Tone = Tone {tone_instrument_name :: Instrument_Name
,tone_note :: Maybe Note
,tone_frequency :: Maybe Frequency
,tone_annotation :: Maybe Annotation}
deriving (Eq,Show)
tone_frequency_err :: Tone -> Frequency
tone_frequency_err = fromJust_err "tone_frequency" . tone_frequency
instance Ord Tone where compare = tone_compare_frequency
plain_tone :: Instrument_Name -> Scale -> Octave -> Degree -> Tone
plain_tone nm sc o d = Tone nm (Just (Note sc (Pitch o d))) Nothing Nothing
tone_equivalent :: Tone -> Tone -> Bool
tone_equivalent p q =
let Tone nm nt _ _ = p
Tone nm' nt' _ _ = q
in nm == nm' && nt == nt'
tone_24et_pitch :: Tone -> Maybe T.Pitch
tone_24et_pitch =
let f i = let (_,pt,_,_,_) = T.nearest_24et_tone i in pt
in fmap f . tone_frequency
tone_24et_pitch' :: Tone -> T.Pitch
tone_24et_pitch' = fromJust_err "tone_24et_pitch" . tone_24et_pitch
tone_24et_pitch_detune :: Tone -> Maybe T.Pitch_Detune
tone_24et_pitch_detune = fmap T.nearest_pitch_detune_24et . tone_frequency
tone_24et_pitch_detune' :: Tone -> T.Pitch_Detune
tone_24et_pitch_detune' = fromJust_err "tone_24et_pitch_detune" . tone_24et_pitch_detune
tone_fmidi :: Tone -> Double
tone_fmidi = T.cps_to_fmidi . tone_frequency_err
tone_24et_fmidi :: Tone -> Rational
tone_24et_fmidi = near_rat . T.pitch_to_fmidi . tone_24et_pitch'
tone_12et_pitch :: Tone -> Maybe T.Pitch
tone_12et_pitch =
let f i = let (_,pt,_,_,_) = T.nearest_12et_tone i in pt
in fmap f . tone_frequency
tone_12et_pitch' :: Tone -> T.Pitch
tone_12et_pitch' = fromJust_err "tone_12et_pitch" . tone_12et_pitch
tone_12et_pitch_detune :: Tone -> Maybe T.Pitch_Detune
tone_12et_pitch_detune = fmap T.nearest_pitch_detune_12et . tone_frequency
tone_12et_pitch_detune' :: Tone -> T.Pitch_Detune
tone_12et_pitch_detune' = fromJust_err "tone_12et_pitch_detune" . tone_12et_pitch_detune
tone_12et_fmidi :: Tone -> Rational
tone_12et_fmidi = near_rat . T.pitch_to_fmidi . tone_12et_pitch'
tone_family :: Tone -> Maybe Instrument_Family
tone_family = instrument_family . tone_instrument_name
tone_family_err :: Tone -> Instrument_Family
tone_family_err = fromJust_err "tone_family" . tone_family
tone_in_family :: Instrument_Family -> Tone -> Bool
tone_in_family c t = tone_family t == Just c
select_tones :: Instrument_Family -> [Tone] -> [Maybe Tone]
select_tones c =
let f t = if tone_family t == Just c then Just t else Nothing
in map f
type Tone_Subset = ([Instrument_Family],[Scale])
tone_subset :: Tone_Subset -> Tone_Set -> Tone_Set
tone_subset (fm,sc) =
let f t = fromJust_err "tone_subset" (tone_family t) `elem` fm &&
fromJust_err "tone_subset" (tone_scale t) `elem` sc
in filter f
data Instrument = Instrument {instrument_name :: Instrument_Name
,instrument_scale :: Maybe Scale
,instrument_pitches :: Maybe [Pitch]
,instrument_frequencies :: Maybe [Frequency]}
deriving (Eq,Show)
type Tone_Set = [Tone]
type Tone_Group = [Tone_Set]
type Gamelan = [Instrument]
tone_scale :: Tone -> Maybe Scale
tone_scale = fmap note_scale . tone_note
tone_pitch :: Tone -> Maybe Pitch
tone_pitch = fmap note_pitch . tone_note
tone_degree :: Tone -> Maybe Degree
tone_degree = fmap pitch_degree . tone_pitch
tone_degree' :: Tone -> Degree
tone_degree' = fromJust_err "tone_degree" . tone_degree
tone_octave :: Tone -> Maybe Octave
tone_octave = fmap pitch_octave . tone_pitch
tone_class :: Tone -> (Instrument_Name,Maybe Scale)
tone_class t = (tone_instrument_name t,tone_scale t)
instrument_class :: Instrument -> (Instrument_Name,Maybe Scale)
instrument_class i = (instrument_name i,instrument_scale i)
tone_class_p :: (Instrument_Name, Scale) -> Tone -> Bool
tone_class_p (nm,sc) t =
tone_instrument_name t == nm &&
tone_scale t == Just sc
tone_family_class_p :: (Instrument_Family,Scale) -> Tone -> Bool
tone_family_class_p (fm,sc) t =
instrument_family (tone_instrument_name t) == Just fm &&
tone_scale t == Just sc
tone_set_near_frequency :: Tone_Set -> T.Cents -> Frequency -> Tone_Set
tone_set_near_frequency t k n =
let near i = abs (T.cps_difference_cents i n) <= k
near_t i = maybe False near (tone_frequency i)
in filter near_t t
tone_compare_frequency :: Tone -> Tone -> Ordering
tone_compare_frequency = compare `on` (maybe 0 id . tone_frequency)
map_maybe_uniform :: (a -> Maybe b) -> [a] -> Maybe [b]
map_maybe_uniform f x =
let x' = map f x
in if any isNothing x' then Nothing else Just (catMaybes x')
instrument :: Tone_Set -> Instrument
instrument c =
let sf = fmap note_scale . tone_note
pf = fmap note_pitch . tone_note
pm = map_maybe_uniform pf c
fm = map_maybe_uniform tone_frequency c
(p,f) = case (pm,fm) of
(Just i,Just j) -> let (i',j') = unzip (sort (zip i j))
in (Just i',Just j')
_ -> (pm,fm)
in case c of
t:_ -> Instrument (tone_instrument_name t) (sf t) p f
[] -> undefined
instruments :: Tone_Set -> [Instrument]
instruments c =
let c' = sortBy (compare `on` tone_instrument_name) c
c'' = groupBy ((==) `on` tone_class) c'
in map instrument c''
instrument_gamut :: Instrument -> Maybe (Pitch,Pitch)
instrument_gamut =
let f p = (head p,last p)
in fmap f . instrument_pitches
scale_degrees :: Scale -> [Degree]
scale_degrees s =
case s of
Pelog -> [1..7]
Slendro -> [1,2,3,5,6]
degree_index :: Scale -> Degree -> Maybe Int
degree_index s d = findIndex (== d) (scale_degrees s)
tone_set_gamut :: Tone_Set -> Maybe (Pitch,Pitch)
tone_set_gamut g =
case mapMaybe (fmap note_pitch . tone_note) g of
[] -> Nothing
p -> Just (minimum p,maximum p)
tone_set_instrument :: Tone_Set -> (Instrument_Name,Maybe Scale) -> Tone_Set
tone_set_instrument db (i,s) =
let f t = tone_class t == (i,s)
in filter f db