diff --git a/Aoide.cabal b/Aoide.cabal new file mode 100644 --- /dev/null +++ b/Aoide.cabal @@ -0,0 +1,30 @@ +author: Liisi Kerik +build-type: Simple +cabal-version: >= 1.10 +category: Composition, Music +description: + This library provides data structures for describing music and generates Lilypond and MIDI files. In addition, it contains a + module with some music-theoretical functions that may be useful in computer-assisted composition. The library is focused on + the very basics of standard Western musical notation and does not support dynamic indications, articulation marks, double + accidentals, tempo changes, polyrhythms, time signature changes and microtonality. Tuplets are supported in MIDI scores but + not in Lilypond scores. Some features, like key changes and polytonality, can be used but not properly notated. +homepage: https://github.com/liisikerik/aoide +license: BSD3 +license-file: LICENSE +maintainer: liisikerik@hotmail.com +name: Aoide +synopsis: A simple music library with the capability of generating .ly and .mid files. +version: 0.1.0.0 +library + build-depends: + base >= 4.14.0 && < 4.15, + bytestring >= 0.10.10 && < 0.11, + mtl >= 2.2.2 && < 2.3, + process >= 1.6.8 && < 1.7, + template-haskell >= 2.16.0 && < 2.17 + default-language: Haskell2010 + exposed-modules: Composition.Lilypond, Composition.Midi, Composition.Notes, Composition.Theory + other-extensions: DeriveLift, NegativeLiterals, StandaloneDeriving, TemplateHaskell +source-repository head + location: https://github.com/liisikerik/aoide + type: git diff --git a/Composition/Lilypond.hs b/Composition/Lilypond.hs new file mode 100644 --- /dev/null +++ b/Composition/Lilypond.hs @@ -0,0 +1,461 @@ +-------------------------------------------------------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE StandaloneDeriving #-} +{-| +Description: A module for generating Lilypond files. + +This module contains the data structures and the function for generating Lilypond files from note sequences. +-} +module Composition.Lilypond ( + Basic_clef (..), + Bracket (..), + Clef (..), + Field (..), + Instrument_stave (..), + Part (..), + Part_header_field_name (..), + Score (..), + Score_header_field_name (..), + Stave (..), + lilypond) where + import Composition.Notes ( + Accidental (..), + Natural_note_name (..), + Note (..), + Note_name (..), + Note_name' (..), + Rat, + Simultaneous (..), + Time (..), + Time_and_position (..), + deconstruct_note_name, + measure_length, + sequential_length, + simultaneous_length, + subdivision) + import Control.Monad (join) + import Data.Char (isPrint) + import Data.Fixed (mod') + import Data.List (intercalate) + import Data.Maybe (catMaybes) + import Data.Ratio ((%), denominator, numerator) + import System.Process (callCommand) + -- | Basic clefs without octave transposition. + data Basic_clef = Sub_bass | Bass | Baritone_F | Baritone_C | Tenor | Alto | Soprano | Mezzosoprano | Treble | French + -- | Staves can be separate from other staves or grouped with some of the other staves in a bracket. The curly bracket groups + -- staves of the same instrument, for example, the left- and right-hand part for the keyboard. The square bracket groups + -- several instruments in the same family, for example, the strings. + data Bracket = Curly_bracket (Maybe String) [Stave] | Single Instrument_stave | Square_bracket [Instrument_stave] + -- | Clefs with octave transposition. The second argument indicates the number of octaves by which the clef is transposed. + data Clef = Clef Basic_clef Int + type Err = Either String + -- | The type that generalises score and part header fields. + data Field field_name = Field field_name String + -- | A stave with optional instrument specification. + data Instrument_stave = Instrument_stave (Maybe String) Stave + -- | Each part can have a different time signature, tempo and instrumentation. The first argument is the list of header fields + -- that may include, for example, the title of the part. The second argument is the list of accidentals. For example, the key + -- signature of C minor would be @[E_flat, A_flat, B_flat]@. + data Part = Part [Field Part_header_field_name] [Note_name] Time_and_position [Bracket] + -- | Lilypond header fields that apply to only one part of the whole document. + data Part_header_field_name = Opus | Piece + -- | The first argument is the list of score header fields that may include, for example, the composer, the dedication, the + -- instrument, the subtitle and the title. + data Score = Score [Field Score_header_field_name] [Part] + -- | Lilypond header fields that apply to the whole document. + data Score_header_field_name = + Arranger | Composer | Copyright | Dedication | Instrument | Meter | Poet | Subsubtitle | Subtitle | Tagline | Title + -- | A stave consists of one homorhythmic note sequence. Heterorhythmic voices have to be notated on separate staves. + data Stave = Stave Clef [Simultaneous] + deriving instance Eq Part_header_field_name + deriving instance Eq Score_header_field_name + deriving instance Show Basic_clef + deriving instance Show Bracket + deriving instance Show Clef + deriving instance Show field_name => Show (Field field_name) + deriving instance Show Instrument_stave + deriving instance Show Part + deriving instance Show Part_header_field_name + deriving instance Show Score + deriving instance Show Score_header_field_name + deriving instance Show Stave + all_different :: Eq a => [a] -> Bool + all_different x = + case x of + [] -> True + y : z -> all ((/=) y) z && all_different z + bracket_length :: Bracket -> Err (Maybe Rat) + bracket_length bracket = + case bracket of + Curly_bracket _ staves -> check_lengths (stave_length <$> staves) + Single instrument_stave -> Right (Just (instrument_stave_length instrument_stave)) + Square_bracket instrument_staves -> check_lengths (instrument_stave_length <$> instrument_staves) + check :: String -> Bool -> Err () + check err condition = + case condition of + False -> Left err + True -> Right () + check_bracket_lengths :: [Bracket] -> Err () + check_bracket_lengths brackets = + do + lengths <- traverse bracket_length brackets + _ <- check_lengths (catMaybes lengths) + Right () + check_lengths :: [Rat] -> Err (Maybe Rat) + check_lengths lengths = + case lengths of + [] -> Right Nothing + len : lengths' -> + do + check "Stave length mismatch." (all ((==) len) lengths') + Right (Just len) + check_range :: Ord t => String -> t -> t -> t -> Err () + check_range typ min_t max_t x = check (typ ++ " out of range.") (min_t <= x && max_t >= x) + from_right :: Either t u -> u + from_right x = + case x of + Left _ -> undefined + Right y -> y + instrument_stave_length :: Instrument_stave -> Rat + instrument_stave_length (Instrument_stave _ stave) = stave_length stave + is_power_of_two :: Int -> Bool + is_power_of_two i = + case i of + 1 -> True + _ -> even i && is_power_of_two (div i 2) + -- | Encodes the score in Lilypond format, writes it to the specified file and generates the pdf by calling lilypond. + lilypond :: String -> Score -> IO () + lilypond file_name score = + do + let file_name_ly = file_name ++ ".ly" + case write_score score of + Left err -> putStrLn ("Lilypond error. " ++ err) + Right score' -> + do + writeFile file_name_ly score' + callCommand ("lilypond" ++ " " ++ file_name_ly) + lg :: Int -> Int + lg i = + case i of + 1 -> 0 + _ -> 1 + lg (div i 2) + max_denominator :: Int + max_denominator = 2 ^ (negate min_lg) + min_length :: Rat + min_length = 1 % max_denominator + min_lg :: Integer + min_lg = -7 + split :: Time -> Rat -> Rat -> [(Rat, Rat)] + split time position len = + let + len' = measure_length time - position + position' = mod' position (measure_length (subdivision time)) + in + case len > len' of + False -> [(position', len)] + True -> (position', len') : split time 0 (len - len') + stave_length :: Stave -> Rat + stave_length (Stave _ sequential) = sequential_length sequential + write_accidentals :: [Note_name] -> Err String + write_accidentals accidentals = + do + accidentals' <- traverse (write_key_accidental (deconstruct_note_name <$> accidentals)) [C_natural .. B_natural] + Right ("\\key" ++ " " ++ write_note_name C ++ " " ++ "#" ++ "`" ++ write_round (intercalate " " accidentals')) + write_angular :: String -> String + write_angular = write_brackets "<" ">" + write_angular_2 :: String -> String + write_angular_2 = write_brackets "<<" ">>" + write_bar_line :: String + write_bar_line = "\\bar" ++ " " ++ "\"|.\"" + write_basic_clef :: Basic_clef -> String + write_basic_clef basic_clef = + case basic_clef of + Sub_bass -> "subbass" + Bass -> "bass" + Baritone_F -> "baritonevarF" + Baritone_C -> "baritone" + Tenor -> "tenor" + Alto -> "alto" + Soprano -> "soprano" + Mezzosoprano -> "mezzosoprano" + Treble -> "violin" + French -> "french" + write_bracket :: Time_and_position -> Bracket -> Err String + write_bracket time_and_initial_position bracket = + case bracket of + Curly_bracket instrument staves -> + do + instrument' <- write_instrument instrument + staves' <- traverse (write_stave time_and_initial_position Nothing) staves + Right ("\\new" ++ " " ++ "PianoStaff" ++ " " ++ instrument' ++ " " ++ write_angular_2 (intercalate " " staves')) + Single instrument_stave -> write_instrument_stave time_and_initial_position instrument_stave + Square_bracket instrument_staves -> + do + instrument_staves' <- traverse (write_instrument_stave time_and_initial_position) instrument_staves + Right ("\\new" ++ " " ++ "StaffGroup" ++ " " ++ write_angular_2 (intercalate " " instrument_staves')) + write_brackets :: String -> String -> String -> String + write_brackets left_bracket right_bracket x = left_bracket ++ x ++ right_bracket + write_char :: Char -> Err String + write_char c = + do + check "Invalid character." (isPrint c && not (elem c ['\t', '\v', '\f', '\r'])) + Right + (case c of + '\n' -> "\\n" + '"' -> "\"" + '\\' -> "\\\\" + _ -> [c]) + write_clef :: Clef -> String + write_clef clef = "\\clef" ++ " " ++ from_right (write_quotes (write_clef' clef)) + write_clef' :: Clef -> String + write_clef' (Clef basic_clef octave) = write_basic_clef basic_clef ++ write_clef_octave octave + write_clef_octave :: Int -> String + write_clef_octave octave = + case compare octave 0 of + LT -> "_" ++ write_clef_octave' (negate octave) + EQ -> "" + GT -> "^" ++ write_clef_octave' octave + write_clef_octave' :: Int -> String + write_clef_octave' octave = show (8 * octave - 1) + write_complex_length :: Time -> Rat -> Rat -> [String] + write_complex_length time position len = split time position len >>= write_simple_or_complex_length (subdivision time) + write_curly :: String -> String + write_curly = write_brackets "{" "}" + write_denominator :: Int -> Err String + write_denominator den = + do + check_range "Time signature denominator" 1 max_denominator den + check "Time signature denominator not a power of two." (is_power_of_two den) + Right (show den) + write_eq :: String -> String -> String + write_eq x y = x ++ " " ++ "=" ++ " " ++ y + write_field :: (field_name -> String) -> Field field_name -> Err String + write_field write_field_name (Field field_name value) = write_eq (write_field_name field_name) <$> write_quotes value + write_header :: Eq field_name => (field_name -> String) -> [Field field_name] -> Err String + write_header write_field_name fields = + write_maybe + (write_header' write_field_name) + (case fields of + [] -> Nothing + _ -> Just fields) + write_header' :: Eq field_name => (field_name -> String) -> [Field field_name] -> Err String + write_header' write_field_name fields = + do + check "Conflicting header fields." (all_different ((\(Field field_name _) -> field_name) <$> fields)) + fields' <- traverse (write_field write_field_name) fields + Right ("\\header" ++ " " ++ write_curly (intercalate " " fields')) + write_initial_position :: Time -> Rat -> Err [String] + write_initial_position time initial_position = + do + check_range "Initial position" 0 (measure_length time - min_length) initial_position + Right + (case initial_position of + 0 -> [] + _ -> + [ + "\\partial" ++ + " " ++ + show max_denominator ++ + "*" ++ + show (numerator ((measure_length time - initial_position) / min_length))]) + write_instrument :: Maybe String -> Err String + write_instrument = write_maybe write_instrument' + write_instrument' :: String -> Err String + write_instrument' instrument = + do + instrument' <- write_quotes instrument + Right ("\\with" ++ " " ++ write_curly (write_eq "instrumentName" instrument')) + write_instrument_stave :: Time_and_position -> Instrument_stave -> Err String + write_instrument_stave time_and_initial_position (Instrument_stave instrument stave) = + write_stave time_and_initial_position instrument stave + write_key_accidental :: [Note_name'] -> Natural_note_name -> Err String + write_key_accidental accidentals natural_note_name = + do + let accidentals' = filter (\(Note_name' natural_note_name' _) -> natural_note_name == natural_note_name') accidentals + check "Conflicting accidentals in key signature." (2 > length accidentals') + Right + (write_round + ( + show (fromEnum natural_note_name) ++ + " " ++ + "." ++ + " " ++ + "," ++ + write_key_accidental' + (case accidentals of + [Note_name' _ accidental] -> accidental + _ -> Natural))) + write_key_accidental' :: Accidental -> String + write_key_accidental' accidental = + case accidental of + Flat -> "FLAT" + Natural -> "NATURAL" + Sharp -> "SHARP" + write_key_and_time :: [Note_name] -> Time_and_position -> Err String + write_key_and_time accidentals (Time_and_position time initial_position) = + do + accidentals' <- write_accidentals accidentals + time' <- write_time time + initial_position' <- write_initial_position time initial_position + Right + (write_eq + "Key_and_time" + (write_curly (intercalate " " ([accidentals', "\\numericTimeSignature"] ++ initial_position' ++ [time'])))) + write_language :: String + write_language = "\\include" ++ " " ++ from_right (write_quotes "english.ly") + write_maybe :: (t -> Err String) -> Maybe t -> Err String + write_maybe write_t maybe_x = + case maybe_x of + Nothing -> Right "" + Just x -> write_t x + write_natural_note_name :: Natural_note_name -> String + write_natural_note_name natural_note_name = + case natural_note_name of + C_natural -> "c" + D_natural -> "d" + E_natural -> "e" + F_natural -> "f" + G_natural -> "g" + A_natural -> "a" + B_natural -> "b" + write_note :: Note -> String + write_note (Note octave note_name) = write_note_name note_name ++ write_note_octave octave + write_note_name :: Note_name -> String + write_note_name note_name = + let + Note_name' natural_note_name accidental = deconstruct_note_name note_name + in + write_natural_note_name natural_note_name ++ write_note_name_accidental accidental + write_note_name_accidental :: Accidental -> String + write_note_name_accidental accidental = + case accidental of + Flat -> "f" + Natural -> "" + Sharp -> "s" + write_note_octave :: Int -> String + write_note_octave octave = + case compare octave 3 of + LT -> replicate (3 - octave) ',' + EQ -> "" + GT -> replicate (octave - 3) '\'' + write_notes :: [Note] -> String + write_notes notes = + case notes of + [note] -> write_note note + _ -> write_angular (intercalate " " (write_note <$> notes)) + write_numerator :: [Int] -> Err String + write_numerator num = + do + check "Invalid time signature numerator." (all ((<) 1) num) + Right (show (product num)) + write_option :: String -> String -> String + write_option option value = "#" ++ write_round ("ly:set-option" ++ " " ++ "'" ++ option ++ " " ++ value) + write_options :: String + write_options = intercalate " " [write_option "delete-intermediate-files" "#t", write_option "no-point-and-click" "#t"] + write_part :: Part -> Err String + write_part (Part header accidentals time_and_initial_position brackets) = + do + header' <- write_header write_part_header_field_name header + key_and_time <- write_key_and_time accidentals time_and_initial_position + check_bracket_lengths brackets + brackets' <- traverse (write_bracket time_and_initial_position) brackets + Right + (key_and_time ++ " " ++ "\\score" ++ " " ++ write_curly (header' ++ " " ++ write_angular_2 (intercalate " " brackets'))) + write_part_header_field_name :: Part_header_field_name -> String + write_part_header_field_name field_name = + case field_name of + Opus -> "opus" + Piece -> "piece" + write_quotes :: String -> Err String + write_quotes text = + do + text' <- traverse write_char text + Right (write_brackets "\"" "\"" (join text')) + write_round :: String -> String + write_round = write_brackets "(" ")" + write_score :: Score -> Err String + write_score (Score header parts) = + do + header' <- + write_header + write_score_header_field_name + (case any (\(Field field_name _) -> field_name == Tagline) header of + False -> Field Tagline "" : header + True -> header) + parts' <- traverse write_part parts + Right (write_options ++ " " ++ write_language ++ " " ++ header' ++ " " ++ intercalate " " parts') + write_score_header_field_name :: Score_header_field_name -> String + write_score_header_field_name field_name = + case field_name of + Arranger -> "arranger" + Composer -> "composer" + Copyright -> "copyright" + Dedication -> "dedication" + Instrument -> "instrument" + Meter -> "meter" + Poet -> "poet" + Subsubtitle -> "subsubtitle" + Subtitle -> "subtitle" + Tagline -> "tagline" + Title -> "title" + write_sequential :: Time -> Rat -> [Simultaneous] -> Err [String] + write_sequential time position sequential = + case sequential of + [] -> Right [] + simultaneous : sequential' -> + ( + (:) <$> + write_simultaneous time position simultaneous <*> + write_sequential time (mod' (position + simultaneous_length simultaneous) (measure_length time)) sequential') + write_simple_length :: Rat -> Maybe String + write_simple_length len = + case is_power_of_two (1 + numerator len) && numerator len < 2 * denominator len of + False -> Nothing + True -> + let + dots = lg (1 + numerator len) - 1 + in + Just (show ((2 :: Integer) ^ (lg (denominator len) - dots)) ++ replicate dots '.') + write_simple_or_complex_length :: Time -> (Rat, Rat) -> [String] + write_simple_or_complex_length time (position, len) = + case write_simple_length len of + Nothing -> write_complex_length time position len + Just len' -> [len'] + write_simultaneous :: Time -> Rat -> Simultaneous -> Err String + write_simultaneous time position (Simultaneous notes len) = + do + check "Non-positive note length." (0 < len) + check "Tuplets are not supported." (is_power_of_two (denominator len)) + check ("Notes shorter than 1/" ++ show max_denominator ++ " are not supported.") (max_denominator >= denominator len) + let lengths = write_complex_length time position len + Right + (case notes of + [] -> intercalate " " ((++) "r" <$> lengths) + _ -> write_notes notes ++ intercalate "~" lengths) + write_stave :: Time_and_position -> Maybe String -> Stave -> Err String + write_stave (Time_and_position time initial_position) instrument (Stave clef sequential) = + do + instrument' <- write_instrument instrument + sequential' <- write_sequential time initial_position sequential + Right + ( + "\\new" ++ + " " ++ + "Staff" ++ + " " ++ + instrument' ++ + " " ++ + write_curly + ("\\Key_and_time" ++ " " ++ write_clef clef ++ " " ++ intercalate " " sequential' ++ " " ++ write_bar_line)) + write_time :: Time -> Err String + write_time time = + do + time' <- write_time' time + Right ("\\time" ++ " " ++ time') + write_time' :: Time -> Err String + write_time' (Time num den) = + do + num' <- write_numerator num + den' <- write_denominator den + Right (num' ++ "/" ++ den') +-------------------------------------------------------------------------------------------------------------------------------- diff --git a/Composition/Midi.hs b/Composition/Midi.hs new file mode 100644 --- /dev/null +++ b/Composition/Midi.hs @@ -0,0 +1,248 @@ +-------------------------------------------------------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NegativeLiterals, StandaloneDeriving #-} +{-| +Description: A module for generating MIDI files. + +This module contains the data structures and the function for generating MIDI files from note sequences. +-} +module Composition.Midi (Instrument (..), Track (..), Part (..), midi) where + import Composition.Notes ( + Note (..), + Note_name (..), + Rat, + Simultaneous (..), + Time (..), + Time_and_position (..), + sequential_length) + import Composition.Theory (semitones_from_c) + import Control.Monad (join, zipWithM) + import Data.ByteString (pack, writeFile) + import Data.Foldable (traverse_) + import Data.List (delete, transpose) + import Data.Ratio ((%), numerator, denominator) + import Data.Word (Word8) + type Err = Either String + -- | MIDI instruments. + data Instrument = + Accordion | + Bassoon | + Bells | + Cello | + Clarinet | + Double_bass | + Dulcimer | + English_horn | + Flute | + French_horn | + Glockenspiel | + Guitar | + Harp | + Harpsichord | + Oboe | + Organ | + Piano | + Piccolo | + Pizzicato_strings | + Recorder | + Timpani | + Trombone | + Trumpet | + Viola | + Violin | + Voice + -- | Each part can have a different time signature, tempo and instrumentation. The second argument is the tempo specified in + -- beats per minute. + data Part = Part Time_and_position Int [Track] + -- | A track consists of one homorhythmic note sequence. Heterorhythmic voices require separate tracks. + data Track = Track Instrument [Simultaneous] + deriving instance Show Instrument + deriving instance Show Part + deriving instance Show Track + channels :: [Word8] + channels = delete 9 [0 .. 15] + check :: String -> Bool -> Err () + check err condition = + case condition of + False -> Left err + True -> Right () + check_range :: Ord t => String -> t -> t -> t -> Err () + check_range typ min_t max_t x = check (typ ++ " out of range.") (min_t <= x && max_t >= x) + encode_chunk :: [Word8] -> [Word8] -> [Word8] + encode_chunk typ dat = typ ++ encode_int_fixed 4 (length dat) ++ dat + encode_end_track :: [Word8] + encode_end_track = encode_meta_event_0 47 [] + encode_event :: Int -> Rat -> [Word8] -> [Word8] + encode_event lcd time dat = encode_time lcd time ++ dat + encode_format :: [Word8] + encode_format = [0, 1] + encode_header :: Int -> Int -> Err [Word8] + encode_header number_of_tracks lcd = + do + let quarter = length_in_ticks lcd (1 % 4) + check_range "The number of ticks in quarter note" 1 max_ticks_in_quarter_note quarter + Right + (encode_chunk + [77, 84, 104, 100] + (encode_format ++ encode_int_fixed 2 (1 + number_of_tracks) ++ encode_int_fixed 2 quarter)) + encode_instrument :: Word8 -> Instrument -> [Word8] + encode_instrument channel instrument = encode_midi_event channel 12 [encode_instrument' instrument] + encode_instrument' :: Instrument -> Word8 + encode_instrument' instrument = + case instrument of + Accordion -> 21 + Bassoon -> 70 + Bells -> 14 + Cello -> 42 + Clarinet -> 71 + Double_bass -> 43 + Dulcimer -> 15 + English_horn -> 69 + Flute -> 73 + French_horn -> 60 + Glockenspiel -> 9 + Guitar -> 24 + Harp -> 46 + Harpsichord -> 6 + Oboe -> 68 + Organ -> 19 + Piano -> 0 + Piccolo -> 72 + Pizzicato_strings -> 45 + Recorder -> 74 + Timpani -> 47 + Trombone -> 57 + Trumpet -> 56 + Viola -> 41 + Violin -> 40 + Voice -> 52 + encode_int_fixed :: Integer -> Int -> [Word8] + encode_int_fixed n i = + case n of + 0 -> [] + _ -> encode_int_fixed (n - 1) (div i 256) ++ [fromIntegral i] + encode_int_flexible :: Int -> [Word8] + encode_int_flexible i = encode_int_flexible' (div i 128) ++ [fromIntegral (mod i 128)] + encode_int_flexible' :: Int -> [Word8] + encode_int_flexible' i = + case i of + 0 -> [] + _ -> encode_int_flexible' (div i 128) ++ [128 + fromIntegral (mod i 128)] + max_number_of_tracks :: Int + max_number_of_tracks = length channels + max_ticks_in_quarter_note :: Int + max_ticks_in_quarter_note = 2 ^ (16 :: Integer) - 1 + max_track_length :: Int + max_track_length = 2 ^ (32 :: Integer) - 1 + -- | Encodes the score in MIDI format and writes it to the specified file. + midi :: String -> [Part] -> IO () + midi file_name score = + case encode_score score of + Left err -> putStrLn ("Midi error. " ++ err) + Right encoding -> Data.ByteString.writeFile (file_name ++ ".mid") (pack encoding) + encode_meta_event :: Int -> Rat -> Word8 -> [Word8] -> [Word8] + encode_meta_event lcd time typ dat = encode_event lcd time ([255, typ, fromIntegral (length dat)] ++ dat) + encode_meta_event_0 :: Word8 -> [Word8] -> [Word8] + encode_meta_event_0 = encode_meta_event 1 0 + encode_midi_event :: Word8 -> Word8 -> [Word8] -> [Word8] + encode_midi_event channel typ dat = encode_event 1 0 ([channel + 16 * typ] ++ dat) + encode_note :: Note -> Word8 + encode_note (Note octave note_name) = fromIntegral (12 * (1 + octave) + semitones_from_c note_name) + encode_note_off :: Word8 -> Note -> [Word8] + encode_note_off channel note = encode_midi_event channel 8 [encode_note note, velocity] + encode_note_on :: Word8 -> Note -> [Word8] + encode_note_on channel note = encode_midi_event channel 9 [encode_note note, velocity] + encode_part :: Int -> Int -> Part -> Err [[Word8]] + encode_part number_of_tracks lcd (Part (Time_and_position time _) tempo tracks) = + do + tempo' <- encode_tempo time tempo + let tracks' = (\(Track instrument sequential) -> Track instrument (sequential ++ [Simultaneous [] 1])) <$> tracks + len <- + case track_length <$> tracks' of + [] -> Right 1 + len' : lengths -> + do + check "Track length mismatch." (all ((==) len') lengths) + Right len' + check_range "Part length" 0 max_note_length (length_in_ticks lcd len) + let rest = encode_rest lcd len + tracks'' <- zipWithM (encode_track lcd) channels tracks' + Right ([tempo' ++ rest] ++ tracks'' ++ replicate (number_of_tracks - length tracks') rest) + encode_rest :: Int -> Rat -> [Word8] + encode_rest lcd len = encode_text lcd len [] + encode_score :: [Part] -> Err [Word8] + encode_score parts = + do + let parts' = parts ++ [Part (Time_and_position (Time [2, 2] 4) 0) 100 []] + let number_of_tracks = maximum (number_of_tracks_in_part <$> parts') + check_range "Number of tracks" 0 max_number_of_tracks number_of_tracks + let lcd = lcm_all (lcd_of_part <$> parts') + header <- encode_header number_of_tracks lcd + parts'' <- traverse (encode_part number_of_tracks lcd) parts' + tracks <- traverse encode_tracks (transpose parts'') + Right (header ++ join tracks) + encode_sequential :: Int -> Word8 -> [Simultaneous] -> Err [Word8] + encode_sequential lcd channel sequential = join <$> traverse (encode_simultaneous lcd channel) sequential + encode_simultaneous :: Int -> Word8 -> Simultaneous -> Err [Word8] + encode_simultaneous lcd channel (Simultaneous notes len) = + do + traverse_ (check_range "Note" min_note max_note) notes + check "Non-positive note length." (0 < len) + Right ((notes >>= encode_note_on channel) ++ encode_rest lcd len ++ (notes >>= encode_note_off channel)) + encode_tempo :: Time -> Int -> Err [Word8] + encode_tempo time tempo = + do + let tempo' = microseconds_in_quarter_note time tempo + check_range "Tempo" 1 max_tempo tempo' + Right (encode_meta_event_0 81 (encode_int_fixed 3 tempo')) + encode_text :: Int -> Rat -> [Word8] -> [Word8] + encode_text lcd time = encode_meta_event lcd time 1 + encode_time :: Int -> Rat -> [Word8] + encode_time lcd time = encode_int_flexible (length_in_ticks lcd time) + encode_track :: Int -> Word8 -> Track -> Err [Word8] + encode_track lcd channel (Track instrument sequential) = + do + sequential' <- encode_sequential lcd channel sequential + Right (encode_instrument channel instrument ++ sequential') + encode_tracks :: [[Word8]] -> Err [Word8] + encode_tracks tracks = + do + let track = join tracks ++ encode_end_track + check_range "Track length" 0 max_track_length (length track) + Right (encode_chunk [77, 84, 114, 107] track) + lcd_of_part :: Part -> Int + lcd_of_part (Part time_and_initial_position _ tracks) = + lcm (lcd_of_time_and_position time_and_initial_position) (lcm_all (lcd_of_track <$> tracks)) + lcd_of_sequential :: [Simultaneous] -> Int + lcd_of_sequential sequential = lcm_all (lcd_of_simultaneous <$> sequential) + lcd_of_simultaneous :: Simultaneous -> Int + lcd_of_simultaneous (Simultaneous _ len) = denominator len + lcd_of_time_and_position :: Time_and_position -> Int + lcd_of_time_and_position (Time_and_position time position) = lcm (time_denominator time) (denominator position) + lcd_of_track :: Track -> Int + lcd_of_track (Track _ sequential) = lcd_of_sequential sequential + lcm_all :: Integral t => [t] -> t + lcm_all = foldr lcm 1 + length_in_ticks :: Int -> Rat -> Int + length_in_ticks lcd time = numerator time * div lcd (denominator time) + max_note :: Note + max_note = Note 9 G + max_note_length :: Int + max_note_length = 2 ^ (32 :: Integer) - 1 + max_tempo :: Int + max_tempo = 2 ^ (24 :: Integer) - 1 + microseconds_in_minute :: Int + microseconds_in_minute = 60000000 + microseconds_in_quarter_note :: Time -> Int -> Int + microseconds_in_quarter_note (Time _ den) tempo = round (microseconds_in_minute * den % (4 * tempo)) + min_note :: Note + min_note = Note -2 B_sharp + number_of_tracks_in_part :: Part -> Int + number_of_tracks_in_part (Part _ _ tracks) = length tracks + time_denominator :: Time -> Int + time_denominator (Time _ den) = den + track_length :: Track -> Rat + track_length (Track _ sequential) = sequential_length sequential + velocity :: Word8 + velocity = 127 +-------------------------------------------------------------------------------------------------------------------------------- diff --git a/Composition/Notes.hs b/Composition/Notes.hs new file mode 100644 --- /dev/null +++ b/Composition/Notes.hs @@ -0,0 +1,458 @@ +-------------------------------------------------------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE DeriveLift, StandaloneDeriving, TemplateHaskell #-} +{-| +Description: A module for basic musical data structures. + +This module contains some data structures for describing note sequences and time signatures, and a QuasiQuoter for note +sequences. +-} +module Composition.Notes ( + Accidental (..), + Natural_note_name (..), + Note (..), + Note_name (..), + Note_name' (..), + Rat, + Simultaneous (..), + Time (..), + Time_and_position (..), + construct_note_name, + deconstruct_note_name, + ly, + measure_length, + sequential_length, + simultaneous_length, + subdivision) where + import Control.Monad.Except (MonadError (..)) + import Control.Monad.RWS.Strict (RWS, RWST (..), runRWS) + import Control.Monad.State.Strict (MonadState (..), modify) + import Control.Monad.Writer.Strict (MonadWriter (..)) + import Data.Char (isDigit) + import Data.Maybe (fromJust) + import Data.Ratio ((%), Ratio) + import Data.Tuple (swap) + import Language.Haskell.TH (Exp, Q) + import Language.Haskell.TH.Quote (QuasiQuoter (..)) + import Language.Haskell.TH.Syntax (Lift (..)) + -- | Accidentals. + data Accidental = Flat | Natural | Sharp + data Char' = Delimiter_char Token | Nat_char Char | Negation_char | Space_char + data Counter = Counter Integer + -- | Natural note names for algorithmic convenience. + data Natural_note_name = C_natural | D_natural | E_natural | F_natural | G_natural | A_natural | B_natural + -- | Note. The first argument is the octave. + data Note = Note Int Note_name + -- | Note names. Double accidentals are not supported. + data Note_name = + C_flat | + C | + C_sharp | + D_flat | + D | + D_sharp | + E_flat | + E | + F_flat | + E_sharp | + F | + F_sharp | + G_flat | + G | + G_sharp | + A_flat | + A | + A_sharp | + B_flat | + B | + B_sharp + -- | An alternative representation of note names that is more convenient for algorithms. + data Note_name' = + Note_name' Natural_note_name Accidental + type Parser = WST Counter [Token] Maybe + -- | Rationals with limited numerators and denominators for representing note lengths. + type Rat = Ratio Int + -- | A collection of notes of same length that sound simultaneously. Non-positive length will result in runtime errors when + -- attempting to generate Lilypond and MIDI files. + data Simultaneous = Simultaneous [Note] Rat + -- | Time signature. The first argument describes the subdivisions of the bar. For example, 2 beats per bar is encoded as [2], + -- 3 as [3], 4 as [2, 2], 6 as [2, 3], 9 as [3, 3]. The second argument is the inverse of the length of the beat. Note that + -- non-positive numbers in either numerator or denominator will result in errors, and Lilypond does not accept denominators + -- that are not a power of two. + data Time = Time [Int] Int + -- | Time signature and the starting position of the first bar. For example, if the piece starts with a full bar, the initial + -- position is 0. If the piece is in 3/4 and starts with a 1/4-note bar, the initial position is 1/2. + data Time_and_position = Time_and_position Time Rat + data Token = + Dot_token | + End_token | + Flat_token | + Left_angular_token | + Nat_token Int | + Negation_token | + Note_name_token Natural_note_name | + Right_angular_token | + Sharp_token | + Tie_token + type Tokeniser = WS [Token] [Char'] + type WS output state = RWS () output state + type WST = RWST () + infixl 3 <+> + (<+>) :: Parser t -> Parser t -> Parser t + parse_0 <+> parse_1 = + wst + (\tokens -> + case (runWST parse_0 tokens, runWST parse_1 tokens) of + (Nothing, Nothing) -> Nothing + (Nothing, Just result) -> Just result + (Just result, Nothing) -> Just result + (Just result_0, Just result_1) -> + case compare (get_token_counter result_0) (get_token_counter result_1) of + LT -> Just result_1 + EQ -> Nothing + GT -> Just result_0) + deriving instance Enum Natural_note_name + instance Enum Note where + fromEnum (Note octave note_name) = + ( + 21 * octave + + fromEnum note_name - + case note_name of + C_flat -> 2 + B_sharp -> 0 + _ -> 1) + toEnum i = + let + octave = div i 21 + in + case mod i 21 of + 19 -> Note (1 + octave) C_flat + 20 -> Note octave B_sharp + j -> Note octave (toEnum (1 + j)) + deriving instance Enum Note_name + deriving instance Eq Accidental + deriving instance Eq Counter + deriving instance Eq Natural_note_name + deriving instance Eq Note + deriving instance Eq Note_name + deriving instance Eq Note_name' + deriving instance Eq Token + deriving instance Lift Note + deriving instance Lift Note_name + deriving instance Lift Simultaneous + instance Monoid Counter where + mempty = 0 + instance Num Counter where + Counter i * Counter j = Counter (i * j) + Counter i + Counter j = Counter (i + j) + abs (Counter i) = Counter (abs i) + fromInteger i = Counter i + negate (Counter i) = Counter (negate i) + signum (Counter i) = Counter (signum i) + deriving instance Ord Counter + instance Ord Note where + compare (Note octave_0 note_name_0) (Note octave_1 note_name_1) = + case compare octave_0 octave_1 of + LT -> + case (note_name_0, note_name_1) of + (B_sharp, C_flat) -> GT + _ -> LT + EQ -> compare note_name_0 note_name_1 + GT -> + case (note_name_0, note_name_1) of + (C_flat, B_sharp) -> LT + _ -> GT + deriving instance Ord Note_name + instance Semigroup Counter where + (<>) = (+) + deriving instance Show Accidental + deriving instance Show Char' + deriving instance Show Counter + deriving instance Show Natural_note_name + deriving instance Show Note + deriving instance Show Note_name + deriving instance Show Note_name' + deriving instance Show Simultaneous + deriving instance Show Time + deriving instance Show Time_and_position + deriving instance Show Token + add_token :: Token -> Tokeniser () + add_token token = tell [token] + certain_token :: Token -> Token -> Maybe () + certain_token token token' = + case token == token' of + False -> Nothing + True -> Just () + classify_char :: Char -> Char' + classify_char c = + case c of + ' ' -> Space_char + '#' -> Delimiter_char Sharp_token + '-' -> Negation_char + '.' -> Delimiter_char Dot_token + '<' -> Delimiter_char Left_angular_token + '>' -> Delimiter_char Right_angular_token + 'A' -> Delimiter_char (Note_name_token A_natural) + 'B' -> Delimiter_char (Note_name_token B_natural) + 'C' -> Delimiter_char (Note_name_token C_natural) + 'D' -> Delimiter_char (Note_name_token D_natural) + 'E' -> Delimiter_char (Note_name_token E_natural) + 'F' -> Delimiter_char (Note_name_token F_natural) + 'G' -> Delimiter_char (Note_name_token G_natural) + 'b' -> Delimiter_char Flat_token + '~' -> Delimiter_char Tie_token + _ -> + case isDigit c of + False -> error "Invalid character." + True -> Nat_char c + -- | Construct the note name from a natural note name and an accidental. + construct_note_name :: Note_name' -> Note_name + construct_note_name note_name = fromJust (lookup note_name (swap <$> note_names)) + -- | Deconstruct a note name into the natural note name and the accidental. + deconstruct_note_name :: Note_name -> Note_name' + deconstruct_note_name note_name = fromJust (lookup note_name note_names) + gather_nat :: Tokeniser String + gather_nat = + do + maybe_char <- get_char 0 + case maybe_char of + Just (Nat_char c) -> + do + next_char + i <- gather_nat + return (c : i) + _ -> return "" + get_char :: Integer -> Tokeniser (Maybe Char') + get_char i = index i <$> get + get_token_counter :: (t, [Token], Counter) -> Counter + get_token_counter (_, _, token_counter) = token_counter + index :: Integer -> [t] -> Maybe t + index i x = + case x of + [] -> Nothing + y : z -> + case i of + 0 -> Just y + _ -> index (i - 1) z + invalid_template_location :: String -> Q t + invalid_template_location = template_error "Invalid location for template ly." + -- | A QuasiQuoter for compile-time parsing of note sequences. The syntax is loosely based on Lilypond. Some example of use: + -- + -- * An empty note sequence: @[ly||]@. + -- * A single note: @[ly|\1|]@. + -- * Two consecutive notes: @[ly|\1 \1|]@. + -- * A rest, a single note and two simultaneous notes: @[ly|\<>1 \1 \1|]@. + -- * All natural notes from C to B: @[ly|\1|]@. + -- * Accidentals: @[ly|\1|]@. + -- * Different octaves: @[ly|\1|]@. + -- * Rests of length 1\/3, 1\/2, 2\/3, 1, 3\/2, 2 and 3: @[ly|\<>3 \<>2 \<>3~3 \<>1 \<>1. \<>1~1 \<>1~1~1|]@. + ly :: QuasiQuoter + ly = QuasiQuoter ly_exp invalid_template_location invalid_template_location invalid_template_location + ly_exp :: String -> Q Exp + ly_exp = parse parse_sequential + -- | The length of one measure. + measure_length :: Time -> Rat + measure_length (Time numerator denominator) = product numerator % denominator + nat_token :: Token -> Maybe Int + nat_token token = + case token of + Nat_token i -> Just i + _ -> Nothing + next_char :: Tokeniser () + next_char = modify tail + note_name_token :: Token -> Maybe Natural_note_name + note_name_token token = + case token of + Note_name_token natural_note_name -> Just natural_note_name + _ -> Nothing + note_names :: [(Note_name, Note_name')] + note_names = + [ + (C_flat, Note_name' C_natural Flat), + (C, Note_name' C_natural Natural), + (C_sharp, Note_name' C_natural Sharp), + (D_flat, Note_name' D_natural Flat), + (D, Note_name' D_natural Natural), + (D_sharp, Note_name' D_natural Sharp), + (E_flat, Note_name' E_natural Flat), + (E, Note_name' E_natural Natural), + (E_sharp, Note_name' E_natural Sharp), + (F_flat, Note_name' F_natural Flat), + (F, Note_name' F_natural Natural), + (F_sharp, Note_name' F_natural Sharp), + (G_flat, Note_name' G_natural Flat), + (G, Note_name' G_natural Natural), + (G_sharp, Note_name' G_natural Sharp), + (A_flat, Note_name' A_natural Flat), + (A, Note_name' A_natural Natural), + (A_sharp, Note_name' A_natural Sharp), + (B_flat, Note_name' B_natural Flat), + (B, Note_name' B_natural Natural), + (B_sharp, Note_name' B_natural Sharp)] + parse :: Lift t => Parser t -> String -> Q Exp + parse parse_t text = + let + x = parse' parse_t (tokenise text) + in + [e|x|] + parse' :: Parser t -> [Token] -> t + parse' parse_t tokens = + case runWST (parse_end parse_t) tokens of + Nothing -> template_error "Parse error." + Just (x, _, _) -> x + parse_accidental :: Parser Accidental + parse_accidental = parse_flat <+> parse_natural <+> parse_sharp + parse_angular :: Parser t -> Parser t + parse_angular = parse_brackets Left_angular_token Right_angular_token + parse_base_length :: Parser Rat + parse_base_length = (%) 1 <$> parse_nat + parse_brackets :: Token -> Token -> Parser t -> Parser t + parse_brackets left_bracket right_bracket parse_t = + do + parse_token left_bracket + x <- parse_t + parse_token right_bracket + return x + parse_dots :: Parser Int + parse_dots = length <$> parse_many (parse_token Dot_token) + parse_element :: Token -> Parser t -> Parser t + parse_element separator parse_t = + do + parse_token separator + parse_t + parse_empty :: Parser [t] + parse_empty = return [] + parse_end :: Parser t -> Parser t + parse_end parse_t = + do + x <- parse_t + parse_token End_token + return x + parse_flat :: Parser Accidental + parse_flat = + do + parse_token Flat_token + return Flat + parse_int :: Parser Int + parse_int = parse_negative_int <+> parse_nat + parse_length :: Parser Rat + parse_length = sum <$> parse_list Tie_token parse_simple_length + parse_list :: Token -> Parser t -> Parser [t] + parse_list separator parse_t = (:) <$> parse_t <*> parse_many (parse_element separator parse_t) + parse_many :: Parser t -> Parser [t] + parse_many parse_t = parse_empty <+> parse_some parse_t + parse_nat :: Parser Int + parse_nat = parse_token' nat_token + parse_natural :: Parser Accidental + parse_natural = return Natural + parse_natural_note_name :: Parser Natural_note_name + parse_natural_note_name = parse_token' note_name_token + parse_negative_int :: Parser Int + parse_negative_int = + do + parse_token Negation_token + i <- parse_nat + return (negate i) + parse_note :: Parser Note + parse_note = + do + note_name <- parse_note_name + octave <- parse_int + return (Note octave note_name) + parse_note_name :: Parser Note_name + parse_note_name = construct_note_name <$> (Note_name' <$> parse_natural_note_name <*> parse_accidental) + parse_notes :: Parser [Note] + parse_notes = parse_angular (parse_many parse_note) + parse_sequential :: Parser [Simultaneous] + parse_sequential = parse_many parse_simultaneous + parse_sharp :: Parser Accidental + parse_sharp = + do + parse_token Sharp_token + return Sharp + parse_simple_length :: Parser Rat + parse_simple_length = + do + base_length <- parse_base_length + dots <- parse_dots + return (base_length * (2 - 1 / 2 ^ dots)) + parse_simultaneous :: Parser Simultaneous + parse_simultaneous = Simultaneous <$> parse_notes <*> parse_length + parse_some :: Parser t -> Parser [t] + parse_some parse_t = (:) <$> parse_t <*> parse_many parse_t + parse_token :: Token -> Parser () + parse_token token = parse_token' (certain_token token) + parse_token' :: (Token -> Maybe t) -> Parser t + parse_token' f = + do + token : tokens <- get + case f token of + Nothing -> throwError () + Just x -> + do + tell 1 + put tokens + return x + runWS :: WS output state t -> state -> (t, state, output) + runWS f st = runRWS f () st + runWST :: WST output state f t -> state -> f (t, state, output) + runWST f = runRWST f () + -- | The length of a note sequence. + sequential_length :: [Simultaneous] -> Rat + sequential_length sequential = sum (simultaneous_length <$> sequential) + -- | The length of a collection of notes. + simultaneous_length :: Simultaneous -> Rat + simultaneous_length (Simultaneous _ len) = len + -- | Discards the topmost division of the bar. For example, 1\/1 is transformed into 1\/2, 2\/2 into 1\/2, 3\/4 into 1\/4, + -- 4\/4 into 2\/4, 6\/8 into 3\/8, 9\/16 into 3\/16. + subdivision :: Time -> Time + subdivision (Time numerator denominator) = + case numerator of + [] -> Time [] (2 * denominator) + _ : numerator' -> Time numerator' denominator + template_error :: String -> t + template_error err = error ("Template error. " ++ err) + tokenise :: String -> [Token] + tokenise text = + let + ((), _, tokens) = runWS tokenise' (classify_char <$> text) + in + tokens + tokenise' :: Tokeniser () + tokenise' = + do + maybe_char <- get_char 0 + maybe_char' <- get_char 1 + case maybe_char of + Nothing -> add_token End_token + Just char -> + do + case char of + Delimiter_char token -> + do + add_token token + next_char + Nat_char c -> + case (c, maybe_char') of + ('0', Just (Nat_char _)) -> template_error "Int starting with zero." + _ -> tokenise_nat + Negation_char -> + case maybe_char' of + Just (Nat_char c) -> + case c of + '0' -> template_error "Negation of int starting with zero." + _ -> + do + add_token Negation_token + next_char + _ -> template_error "Standalone negation sign." + Space_char -> next_char + tokenise' + tokenise_nat :: Tokeniser () + tokenise_nat = + do + i <- gather_nat + add_token (Nat_token (read i)) + wst :: (state -> f (t, state, output)) -> WST output state f t + wst f = RWST (\() -> f) +-------------------------------------------------------------------------------------------------------------------------------- diff --git a/Composition/Theory.hs b/Composition/Theory.hs new file mode 100644 --- /dev/null +++ b/Composition/Theory.hs @@ -0,0 +1,129 @@ +-------------------------------------------------------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE StandaloneDeriving #-} +{-| +Description: A module for basic music theory. + +This module contains functions for computing intervals and classifying chords. +-} +module Composition.Theory ( + Interval_name (..), + Interval_number (..), + Interval_quality (..), + accidental_semitones, + compute_interval_name, + invert_interval_name, + semitones_from_c, + steps_from_c) where + import Composition.Notes (Accidental (..), Natural_note_name (..), Note_name, Note_name' (..), deconstruct_note_name) + -- | Interval name. + data Interval_name = Interval_name Interval_quality Interval_number + -- | Interval numbers. + data Interval_number = Prime | Second | Third | Fourth | Fifth | Sixth | Seventh + -- | Interval qualities, allowing for up to three levels of augmentation. + data Interval_quality = + Thrice_diminished | Twice_diminished | Diminished | Minor | Perfect | Major | Augmented | Twice_augmented | Thrice_augmented + deriving instance Enum Interval_number + deriving instance Eq Interval_number + deriving instance Ord Interval_number + deriving instance Show Interval_name + deriving instance Show Interval_number + deriving instance Show Interval_quality + -- | Returns the number of semitones by which the accidental adjusts the pitch. + accidental_semitones :: Accidental -> Int + accidental_semitones accidental = + case accidental of + Flat -> -1 + Natural -> 0 + Sharp -> 1 + -- | Computes the interval between two note names. + compute_interval_name :: Note_name -> Note_name -> Interval_name + compute_interval_name note_name_0 note_name_1 = + case compare note_name_0 note_name_1 of + LT -> compute_interval_name' note_name_0 note_name_1 + EQ -> Interval_name Perfect Prime + GT -> invert_interval_name (compute_interval_name' note_name_1 note_name_0) + compute_interval_name' :: Note_name -> Note_name -> Interval_name + compute_interval_name' note_name_0 note_name_1 = + let + interval_number = toEnum (mod (steps_from_c note_name_1 - steps_from_c note_name_0) 7) + in + Interval_name + (compute_interval_quality interval_number (semitones_from_c note_name_1 - semitones_from_c note_name_0)) + interval_number + compute_interval_quality :: Interval_number -> Int -> Interval_quality + compute_interval_quality interval_number = + case interval_number of + Prime -> compute_perfect_interval_quality 0 + Second -> compute_minor_or_major_interval_quality 1 + Third -> compute_minor_or_major_interval_quality 3 + Fourth -> compute_perfect_interval_quality 5 + Fifth -> compute_perfect_interval_quality 7 + Sixth -> compute_minor_or_major_interval_quality 8 + Seventh -> compute_minor_or_major_interval_quality 10 + compute_minor_or_major_interval_quality :: Int -> Int -> Interval_quality + compute_minor_or_major_interval_quality minor_semitones semitones = + case mod (semitones - minor_semitones) 12 of + 0 -> Minor + 1 -> Major + 2 -> Augmented + 3 -> Twice_augmented + 4 -> Thrice_augmented + 9 -> Thrice_diminished + 10 -> Twice_diminished + 11 -> Diminished + _ -> undefined + compute_perfect_interval_quality :: Int -> Int -> Interval_quality + compute_perfect_interval_quality perfect_semitones semitones = + case semitones - perfect_semitones of + -3 -> Thrice_diminished + -2 -> Twice_diminished + -1 -> Diminished + 0 -> Perfect + 1 -> Augmented + 2 -> Twice_augmented + 3 -> Thrice_augmented + _ -> undefined + -- | Inverts the interval name. + invert_interval_name :: Interval_name -> Interval_name + invert_interval_name (Interval_name quality interval_number) = + Interval_name (invert_interval_quality quality) (invert_interval_number interval_number) + invert_interval_quality :: Interval_quality -> Interval_quality + invert_interval_quality quality = + case quality of + Thrice_diminished -> Thrice_augmented + Twice_diminished -> Twice_augmented + Diminished -> Augmented + Minor -> Major + Perfect -> Perfect + Major -> Minor + Augmented -> Diminished + Twice_augmented -> Twice_diminished + Thrice_augmented -> Thrice_diminished + invert_interval_number :: Interval_number -> Interval_number + invert_interval_number interval_number = toEnum (mod (negate (fromEnum interval_number)) 7) + -- | Computes the number of semitones from C. C♭ is considered to be -1 semitone from C and B♯ 12 semitones from C. + semitones_from_c :: Note_name -> Int + semitones_from_c note_name = + let + Note_name' natural_note_name accidental = deconstruct_note_name note_name + in + semitones_from_c_natural natural_note_name + accidental_semitones accidental + semitones_from_c_natural :: Natural_note_name -> Int + semitones_from_c_natural natural_note_name = + case natural_note_name of + C_natural -> 0 + D_natural -> 2 + E_natural -> 4 + F_natural -> 5 + G_natural -> 7 + A_natural -> 9 + B_natural -> 11 + -- | Computes the number of steps from C. + steps_from_c :: Note_name -> Int + steps_from_c note_name = + let + Note_name' natural_note_name _ = deconstruct_note_name note_name + in + fromEnum natural_note_name +-------------------------------------------------------------------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Liisi Kerik + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Liisi Kerik nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain