Aoide (empty) → 0.1.0.0
raw patch · 7 files changed
+1358/−0 lines, 7 filesdep +basedep +bytestringdep +mtlsetup-changed
Dependencies added: base, bytestring, mtl, process, template-haskell
Files
- Aoide.cabal +30/−0
- Composition/Lilypond.hs +461/−0
- Composition/Midi.hs +248/−0
- Composition/Notes.hs +458/−0
- Composition/Theory.hs +129/−0
- LICENSE +30/−0
- Setup.hs +2/−0
+ Aoide.cabal view
@@ -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
+ Composition/Lilypond.hs view
@@ -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')+--------------------------------------------------------------------------------------------------------------------------------
+ Composition/Midi.hs view
@@ -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+--------------------------------------------------------------------------------------------------------------------------------
+ Composition/Notes.hs view
@@ -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|\<C0>1|]@.+ -- * Two consecutive notes: @[ly|\<C0>1 \<C0>1|]@.+ -- * A rest, a single note and two simultaneous notes: @[ly|\<>1 \<C0>1 \<C0 D0>1|]@.+ -- * All natural notes from C to B: @[ly|\<C0 D0 E0 F0 G0 A0 B0>1|]@.+ -- * Accidentals: @[ly|\<Cb0 C0 C#0>1|]@.+ -- * Different octaves: @[ly|\<C-1 C0 C1>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)+--------------------------------------------------------------------------------------------------------------------------------
+ Composition/Theory.hs view
@@ -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+--------------------------------------------------------------------------------------------------------------------------------
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain