Aoide 0.1.0.2 → 1.0.0.0
raw patch · 15 files changed
+3117/−1324 lines, 15 filesdep +Kawaii-Parserdep +barbiesdep +containersdep −template-haskelldep ~basedep ~bytestringdep ~mtlsetup-changednew-component:exe:Aoide
Dependencies added: Kawaii-Parser, barbies, containers, directory, filepath, generic-lens, lens, transformers
Dependencies removed: template-haskell
Dependency ranges changed: base, bytestring, mtl, process
Files
- Aoide.cabal +65/−29
- Composition/Errors.hs +95/−0
- Composition/Keyboard.hs +710/−0
- Composition/Lilypond.hs +394/−461
- Composition/MIDI.hs +203/−0
- Composition/Midi.hs +0/−248
- Composition/Notes.hs +185/−448
- Composition/Parser.hs +496/−0
- Composition/Score.hs +301/−0
- Composition/Theory.hs +164/−106
- Composition/Time.hs +70/−0
- Composition/Write.hs +137/−0
- LICENSE +30/−30
- Main.hs +267/−0
- Setup.hs +0/−2
Aoide.cabal view
@@ -1,30 +1,66 @@-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.2 -library - build-depends: - base >= 4.12.0 && < 4.15, - bytestring >= 0.10.8 && < 0.11, - mtl >= 2.2.2 && < 2.3, - process >= 1.6.3 && < 1.7, - template-haskell >= 2.14.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.git +cabal-version: 3.8+author: Liisi Kerik+category: Composition, Lilypond, MIDI, Music+description:+ This library provides data structures and a custom file format for describing music and generates Lilypond and MIDI files. In+ addition it contains a module with some music-theoretical functions. 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.+license: BSD-3-Clause+license-file: LICENSE+maintainer: liisikerik@hotmail.com+name: Aoide+synopsis: A simple music library that can generate Lilypond and MIDI files.+version: 1.0.0.0+common Common+ build-depends:+ Kawaii-Parser, barbies, base < 4.22, bytestring, containers, directory, filepath, generic-lens, lens, mtl, process, transformers+ default-extensions:+ DeriveGeneric,+ DuplicateRecordFields,+ FlexibleContexts,+ FlexibleInstances,+ GADTs,+ NamedFieldPuns,+ NegativeLiterals,+ NoFieldSelectors,+ OrPatterns,+ OverloadedLabels,+ QuantifiedConstraints,+ RankNTypes,+ ScopedTypeVariables,+ StandaloneDeriving,+ TypeData,+ UndecidableInstances+ default-language: Haskell2010+ ghc-options: -Wall -Wno-x-partial+library+ import: Common+ exposed-modules:+ Composition.Errors,+ Composition.Keyboard,+ Composition.Lilypond,+ Composition.MIDI,+ Composition.Notes,+ Composition.Parser,+ Composition.Score,+ Composition.Theory,+ Composition.Time,+ Composition.Write+executable Aoide+ import: Common+ main-is: Main.hs+ other-modules:+ Composition.Errors,+ Composition.Keyboard,+ Composition.Lilypond,+ Composition.MIDI,+ Composition.Notes,+ Composition.Parser,+ Composition.Score,+ Composition.Theory,+ Composition.Time,+ Composition.Write+source-repository head+ location: https://github.com/liisikerik/aoide.git type: git
+ Composition/Errors.hs view
@@ -0,0 +1,95 @@+{-|+Description: Errors.+-}+module Composition.Errors (Error (..), Is_out_of_range_type (..), write_error) where+ import Parser.Files+ import Parser.Locations+ import Parser.Utilities+ -- | Errors.+ data Error =+ An_event_crosses_the_bar_line | ---+ Conflicting_key_signature | ---+ Duplicate_header_fields Location | ---+ Duplicate_keys Location | ---+ Duplicate_note_names_in_key_signature Location | ---+ Duplicate_notes Location | ---+ Empty_triplet | ---+ File_error File_error | ---+ Invalid_character_in_text | ---+ Invalid_keyword String | ---+ Invalid_note_length Location | ---+ Invalid_note_name Location | ---+ Invalid_time_numerator_factor Location | ---+ Invalid_word String Location | ---+ Is_out_of_range_with_location Is_out_of_range_type Location |+ Is_out_of_range_without_location Is_out_of_range_type |+ Non_positive_note_length | ---+ Note_length_denominator_contains_factors_other_than_2_and_3 | ---+ Parse_error Location | ---+ Track_ends_with_an_incomplete_triplet | ---+ Track_length_mismatch | ---+ Velocity_out_of_range Location ---+ -- | Out of range error types.+ data Is_out_of_range_type =+ Event_or_part_length_IOOR |+ Initial_position_IOOR |+ Key_IOOR |+ MIDI_instrument_code_IOOR |+ Note_IOOR |+ Note_length_denominator_IOOR | ---+ Tempo_IOOR |+ The_least_common_denominator_of_note_lengths_IOOR |+ The_number_of_pitched_tracks_IOOR |+ The_number_of_tracks_IOOR |+ Track_length_IOOR |+ Velocity_IOOR+ deriving instance Show Error+ deriving instance Show Is_out_of_range_type+ -- | Writing errors. ---+ write_error :: Error -> String ---+ write_error err = ---+ case err of ---+ An_event_crosses_the_bar_line -> "An event crosses the bar line." ---+ Conflicting_key_signature -> "Conflicting key signature." ---+ Duplicate_header_fields location -> "Duplicate header fields at " <> write_location location <> "." ---+ Duplicate_keys location -> "Duplicate keys at " <> write_location location <> "." ---+ Duplicate_note_names_in_key_signature location -> ---+ "Duplicate note names in key signature at " <> write_location location <> "." ---+ Duplicate_notes location -> "Duplicate notes at " <> write_location location <> "." ---+ Empty_triplet -> "Empty triplet." ---+ File_error err' -> ---+ case err' of ---+ Failed_to_find_the_file file_path -> "Failed to find the file " <> file_path <> "." ---+ Invalid_file_path -> "Invalid file path." ---+ Unexpected_extension ext -> "Unexpected extension ." <> ext <> "." ---+ Invalid_character_in_text -> "Invalid character in text." ---+ Invalid_keyword keyword -> "Invalid keyword " <> keyword <> "." ---+ Invalid_note_length location -> "Invalid note length at " <> write_location location <> "." ---+ Invalid_note_name location -> "Invalid note name at " <> write_location location <> "."+ Invalid_time_numerator_factor location -> "Invalid time numerator at " <> write_location location <> "." ---+ Invalid_word word location -> "Invalid word " <> word <> " at " <> write_location location <> "." ---+ Is_out_of_range_with_location typ location ->+ write_is_out_of_range_type typ <-> "at" <-> write_location location <-> "is out of range."+ Is_out_of_range_without_location typ -> write_is_out_of_range_type typ <-> "is out of range."+ Non_positive_note_length -> "Non-positive note length." ---+ Note_length_denominator_contains_factors_other_than_2_and_3 -> ---+ "Note length denominator contains factors other than 2 and 3." ---+ Parse_error location -> "Parse error at " <> write_location location <> "." ---+ Track_ends_with_an_incomplete_triplet -> "Track ends with an incomplete triplet." ---+ Track_length_mismatch -> "Track length mismatch." ---+ Velocity_out_of_range location -> "Velocity out of range at " <> write_location location <> "." ---+ write_is_out_of_range_type :: Is_out_of_range_type -> String+ write_is_out_of_range_type typ =+ case typ of+ Event_or_part_length_IOOR -> "Event or part length"+ Initial_position_IOOR -> "Initial position"+ Key_IOOR -> "Key"+ MIDI_instrument_code_IOOR -> "MIDI instrument code"+ Note_IOOR -> "Note"+ Note_length_denominator_IOOR -> "Note length denominator"+ Tempo_IOOR -> "Tempo"+ The_least_common_denominator_of_note_lengths_IOOR -> "The least common denominator of note lengths"+ The_number_of_pitched_tracks_IOOR -> "The number of pitched tracks"+ The_number_of_tracks_IOOR -> "The number of tracks"+ Track_length_IOOR -> "Track length"+ Velocity_IOOR -> "Velocity"
+ Composition/Keyboard.hs view
@@ -0,0 +1,710 @@+{-| ---+Description: Functions that deal with keyboard instruments. ---+ ---+* Checking whether a set of notes is playable on the keyboard ---+* Keyboard transcriptions ---+-} ---+module Composition.Keyboard (Keyboard (..), Playable (..), is_playable, keyboard, parse_playable, set_is_playable) where ---+ import Composition.Errors ---+ import Composition.Notes ---+ import Composition.Score ---+ import Composition.Theory ---+ import Control.Lens.Combinators hiding (parts) ---+ import Control.Monad.Except ---+ import Control.Monad.Trans.Except ---+ import Data.Char ---+ import Data.Foldable as Foldable ---+ import Data.Functor ---+ import Data.List as List ---+ import Data.Map.Strict as Map hiding (keys) ---+ import Data.Maybe as Maybe ---+ import Data.Ord ---+ import Data.Set as Set ---+ import Parser.Files ---+ import Parser.Locations ---+ import Parser.Parser ---+ import Parser.Utilities ---+ data Char_class = Delimiter_char Token | Invalid_char | Nonzero_nat_char Char | Whitespace_char | Zero_char ---+ -- | Data structure for storing the left and right hand part of a chord or a piece. ---+ data Keyboard t = Keyboard t t ---+ data Notes_in = Notes_in (Set (Note Pitched)) (Set (Note Pitched)) ---+ data Notes_in' = Notes_in' (Set (Note Pitched)) | Tie_in' (Set (Note Pitched)) ---+ data Notes_out = Rest_out | Notes_out (Set (Note Pitched)) | Tie_out ---+ type Parser = Parser' Token Error ---+ -- | Data structure for describing playable note combinations. For example, [15] [3 10] means that two notes with an interval ---+ -- of 15 semitones are playable only starting from D#/Eb and A#/Bb. ---+ data Playable = Playable {intervals :: [Int], starting_keys :: Set Int} ---+ data Token = Left_square_bracket_token | Newline_token | Positive_int_token Int | Right_square_bracket_token | Zero_token ---+ type Tokeniser = Tokeniser' Char_class Token Error ---+ instance Applicative Keyboard where ---+ Keyboard f g <*> Keyboard left_hand right_hand = Keyboard (f left_hand) (g right_hand) ---+ pure x = Keyboard x x ---+ deriving instance Eq Char_class ---+ deriving instance Eq Token ---+ instance Foldable Keyboard where ---+ foldr f x (Keyboard left_hand right_hand) = f left_hand (f right_hand x) ---+ instance Functor Keyboard where ---+ fmap f (Keyboard left_hand right_hand) = Keyboard (f left_hand) (f right_hand) ---+ instance Traversable Keyboard where ---+ traverse f (Keyboard left_hand right_hand) = Keyboard <$> f left_hand <*> f right_hand ---+ classify_char :: Char -> Char_class ---+ classify_char c = ---+ case c of ---+ '\n' -> Delimiter_char Newline_token ---+ ' ' -> Whitespace_char ---+ '0' -> Zero_char ---+ _ | isDigit c && c /= '0' -> Nonzero_nat_char c ---+ '[' -> Delimiter_char Left_square_bracket_token ---+ ']' -> Delimiter_char Right_square_bracket_token ---+ _ -> Invalid_char ---+ construct_keys :: [Int] -> Either (Location -> Error) (Set Int) ---+ construct_keys keys = ---+ case construct_set keys of ---+ Nothing -> Left Duplicate_keys ---+ Just keys' -> Right keys' ---+ crossing_middle_c :: Keyboard (Set (Note Pitched)) -> Int ---+ crossing_middle_c (Keyboard l r) = crossing_middle_c' id Set.findMax l `max` crossing_middle_c' flip Set.findMin r ---+ crossing_middle_c' :: ---+ ( ---+ ((Note Pitched -> Note Pitched -> Int) -> Note Pitched -> Note Pitched -> Int) -> ---+ (Set (Note Pitched) -> Note Pitched) -> ---+ Set (Note Pitched) -> ---+ Int) ---+ crossing_middle_c' maybeflip aggr notes = ---+ (maybeflip distance_in_semitones (Pitched_note 4 C)) (aggr (Set.insert (Pitched_note 4 C) notes)) ---+ delimiter_char :: Char_class -> Maybe Token ---+ delimiter_char char_class = ---+ case char_class of ---+ Delimiter_char token -> Just token ---+ _ -> Nothing ---+ events_to_events_in :: [[Event' (Set (Note Pitched))]] -> [Event' Notes_in] ---+ events_to_events_in events = events_to_events_in' ((<$>) (over #event_notes Notes_in') <$> events) ---+ events_to_events_in' :: [[Event' (Notes_in')]] -> [Event' Notes_in] ---+ events_to_events_in' events = ---+ case () of ---+ () | all Foldable.null events -> [] ---+ () -> ---+ let ---+ len = minimum (view #event_length <$> head <$> events) ---+ heads_and_tails = head_and_tail len <$> events in ---+ ( ---+ Event' (Foldable.foldr join_notes (Notes_in Set.empty Set.empty) (fst <$> heads_and_tails)) len : ---+ events_to_events_in' (snd <$> heads_and_tails)) ---+ filter_by_key :: (Eq t) => ([t] -> t) -> (u -> t) -> [u] -> [u] ---+ filter_by_key fold_keys compute_key x = List.filter (\ y -> fold_keys (compute_key <$> x) == compute_key y) x ---+ gen_hands :: [Playable] -> [Note Pitched] -> [Set (Note Pitched)] ---+ gen_hands playable notes = ---+ Set.empty : gen_hands' Set.empty notes where ---+ gen_hands' :: Set (Note Pitched) -> [Note Pitched] -> [Set (Note Pitched)] ---+ gen_hands' picked_notes potential_notes = ---+ case potential_notes of ---+ [] -> [] ---+ note : potential_notes' -> ---+ let ---+ picked_notes' = Set.insert note picked_notes in ---+ case is_acceptable playable picked_notes' of ---+ False -> gen_hands' picked_notes potential_notes' ---+ True -> picked_notes' : gen_hands' picked_notes' potential_notes' ---+ gen_keyboard_confs :: [Note Pitched] -> [Keyboard (Set (Note Pitched))] ---+ gen_keyboard_confs notes = Keyboard Set.empty (Set.fromList notes) : gen_keyboard_confs' Set.empty notes ---+ gen_keyboard_confs' :: Set (Note Pitched) -> [Note Pitched] -> [Keyboard (Set (Note Pitched))] ---+ gen_keyboard_confs' l r = ---+ case r of ---+ [] -> [] ---+ note : r' -> ---+ let ---+ l' = Set.insert note l in ---+ Keyboard l' (Set.fromList r') : gen_keyboard_confs' l' r' ---+ hand_span :: Set (Note Pitched) -> Int ---+ hand_span notes = ---+ case Set.elems notes of ---+ [] -> -1 ---+ _ -> distance_in_semitones (minimum notes) (maximum notes) ---+ head_and_tail :: Length_fraction -> [Event' (Notes_in')] -> (Notes_in, [Event' (Notes_in')]) ---+ head_and_tail target_len events = ---+ case events of ---+ [] -> undefined ---+ Event' notes len : events' -> ---+ ( ---+ transf_notes_in notes, ---+ case () of ---+ () | target_len == len -> events' ---+ () -> Event' (notes_to_tie notes) (len - target_len) : events') ---+ is_acceptable :: [Playable] -> Set (Note Pitched) -> Bool ---+ is_acceptable playable notes = ---+ case Set.elems notes of ---+ [] -> True ---+ note@(Pitched_note _ note_name) : notes' -> ---+ any ---+ (\ (Playable intervs starts) -> intervs == tointervs note notes' && any ((==) (semitones_from_c note_name)) starts) ---+ playable ---+ -- | Check if this configuration is playable on the keyboard. ---+ is_playable :: [Playable] -> Keyboard (Set (Note Pitched)) -> Bool ---+ is_playable playable k@(Keyboard l r) = ---+ is_acceptable (mirror_playable <$> playable) l && is_acceptable playable r && not_crossing k ---+ join_notes :: Notes_in -> Notes_in -> Notes_in ---+ join_notes (Notes_in notes_0 ties_0) (Notes_in notes_1 ties_1) = ---+ Notes_in (Set.union notes_0 notes_1) (Set.union ties_0 ties_1) ---+ join_notes_out :: [Event' Notes_out] -> [Event_fraction Pitched] ---+ join_notes_out events = ---+ case events of ---+ [] -> [] ---+ Event' notes len : events' -> join_notes_out' (Event' (notes_to_set notes) len) events' ---+ join_notes_out' :: Event_fraction Pitched -> [Event' Notes_out] -> [Event_fraction Pitched] ---+ join_notes_out' (Event' notes_0 len_0) events = ---+ case events of ---+ [] -> [Event' notes_0 len_0] ---+ Event' maybe_notes_1 len_1 : events' -> ---+ case maybe_notes_1 of ---+ Rest_out -> ---+ case Set.elems notes_0 of ---+ [] -> join_notes_out' (Event' Set.empty (len_0 + len_1)) events' ---+ _ : _ -> Event' notes_0 len_0 : join_notes_out' (Event' Set.empty len_1) events' ---+ Notes_out notes_1 -> Event' notes_0 len_0 : join_notes_out' (Event' notes_1 len_1) events' ---+ Tie_out -> join_notes_out' (Event' notes_0 (len_0 + len_1)) events' ---+ keyboard :: [Playable] -> Maybe String -> MIDI_instrument -> Score -> Either Error Score ---+ keyboard playable header_instrument midi_instrument (Score {title = score_title, header, parts}) = ---+ do ---+ keyboard_parts <- traverse keyboard_part parts ---+ Right (Score {title = score_title, header = keyboard_header, parts = keyboard_parts}) where ---+ gen_variants :: Set (Note Pitched) -> [Keyboard (Set (Note Pitched))] ---+ gen_variants notes = ---+ List.filter ---+ not_crossing ---+ ( ---+ Keyboard <$> ---+ gen_hands (mirror_playable <$> playable) (Set.elems notes) <*> ---+ gen_hands playable (reverse (Set.elems notes))) ---+ keyb :: Keyboard (Set (Note Pitched)) -> [Event' Notes_in] -> Keyboard [Event' Notes_out] ---+ keyb (Keyboard old_notes_lft old_notes_rght) events = ---+ case events of ---+ [] -> pure [] ---+ Event' (Notes_in notes ties) len : events' -> ---+ let ---+ Keyboard lft rght = ---+ head ---+ (( ---+ filter_by_key maximum right_hand_note_count <$> ---+ filter_by_key minimum narrower_hand_span <$> ---+ filter_by_key minimum wider_hand_note_count <$> ---+ filter_by_key minimum wider_hand_span <$> ---+ filter_by_key minimum crossing_middle_c <$> ---+ filter_by_key maximum number_of_notes) ---+ (gen_variants notes)) ---+ (cont_notes_arg_lft, cont_notes_res_lft) = ---+ case Set.elems lft of ---+ [] -> ---+ case Set.elems (Set.union old_notes_lft ties) of ---+ [] -> (Set.empty, Rest_out) ---+ _ : _ -> (old_notes_lft, Tie_out) ---+ _ : _ -> (lft, Notes_out lft) ---+ (cont_notes_arg_rght, cont_notes_res_rght) = ---+ case Set.elems rght of ---+ [] -> ---+ case Set.elems (Set.union old_notes_rght ties) of ---+ [] -> (Set.empty, Rest_out) ---+ _ : _ -> (old_notes_rght, Tie_out) ---+ _ : _ -> (rght, Notes_out rght) in ---+ ( ---+ (:) <$> ---+ ((\ n -> Event' n len) <$> Keyboard cont_notes_res_lft cont_notes_res_rght) <*> ---+ keyb (Keyboard cont_notes_arg_lft cont_notes_arg_rght) events') ---+ keyboard_header :: Map Header_field String ---+ keyboard_header = ---+ case header_instrument of ---+ Nothing -> header ---+ Just header_instrument' -> Map.insert Instrument header_instrument' header ---+ keyboard_part :: Part -> Either Error Part ---+ keyboard_part (Part {title = part_title, key, time, initial_position, tempo, stave_groups}) = ---+ do ---+ let tracks = remove_notational_information stave_groups ---+ _ <- tracks_length tracks ---+ Keyboard left_hand_track right_hand_track <- ---+ traverse ---+ (notate time initial_position) ---+ ( ---+ join_notes_out <$> ---+ (keyb ---+ (pure Set.empty) ---+ (events_to_events_in ---+ (Maybe.mapMaybe ---+ (pitched_or_unpitched (\ (Track {events}) -> Just events) (\ _ -> Nothing)) ---+ (remove_notational_information stave_groups))))) ---+ Right ---+ (Part { ---+ title = part_title, ---+ key, ---+ time, ---+ initial_position, ---+ tempo, ---+ stave_groups = ---+ [ ---+ [ ---+ Pitched ---+ (Instrument_clefs_and_staves { ---+ instrument_name = "", ---+ midi_instrument, ---+ velocity = max_velocity, ---+ clefs_and_staves = ---+ [ ---+ Clef_and_stave { ---+ clef = Pitched_clef {clef_name = Treble, transposition = 0}, ---+ stave = One_track right_hand_track}, ---+ Clef_and_stave { ---+ clef = Pitched_clef {clef_name = Bass, transposition = 0}, ---+ stave = One_track left_hand_track}]})]]}) ---+ mirror_key :: Int -> Int ---+ mirror_key key = mod (4 - key) 12 ---+ mirror_playable :: Playable -> Playable ---+ mirror_playable (Playable intervals keys) = Playable (reverse intervals) (Set.fromList (mirror_key <$> Set.elems keys)) ---+ nat_char :: Char_class -> Maybe Char ---+ nat_char char_class = ---+ case char_class of ---+ Zero_char -> Just '0' ---+ Nonzero_nat_char c -> Just c ---+ _ -> Nothing ---+ narrower_hand_span :: Keyboard (Set (Note Pitched)) -> Int ---+ narrower_hand_span k = minimum (hand_span <$> k) ---+ next_location :: Char_class -> Location -> Location ---+ next_location char_class = ---+ case char_class of ---+ Delimiter_char Newline_token -> next_line ---+ _ -> next_char ---+ nonzero_nat_char :: Char_class -> Maybe Char ---+ nonzero_nat_char char_class = ---+ case char_class of ---+ Nonzero_nat_char c -> Just c ---+ _ -> Nothing ---+ not_crossing :: Keyboard (Set (Note Pitched)) -> Bool ---+ not_crossing (Keyboard l r) = ---+ case (Set.elems l, Set.elems r) of ---+ (_ : _, _ : _) -> Set.findMax l < Set.findMin r ---+ _ -> True ---+ notes_to_set :: Notes_out -> Set (Note Pitched) ---+ notes_to_set maybe_notes = ---+ case maybe_notes of ---+ Rest_out -> Set.empty ---+ Notes_out notes -> notes ---+ Tie_out -> Set.empty ---+ notes_to_tie :: Notes_in' -> Notes_in' ---+ notes_to_tie maybe_notes = ---+ case maybe_notes of ---+ Notes_in' notes -> Tie_in' notes ---+ Tie_in' notes -> Tie_in' notes ---+ number_of_notes :: Keyboard (Set (Note Pitched)) -> Int ---+ number_of_notes k = sum (Set.size <$> k) ---+ parse_key :: Parser Int ---+ parse_key = filter_parser ((>=) 11) (Is_out_of_range_with_location Key_IOOR) parse_nat ---+ parse_keys :: Parser (Set Int) ---+ parse_keys = fmap_filter_parser construct_keys (parse_list' parse_key) ---+ parse_list' :: Parser t -> Parser [t] ---+ parse_list' parse_t = parse_square_brackets (parse_many parse_t) ---+ parse_nat :: Parser Int ---+ parse_nat = parse_zero <+> parse_positive_int ---+ parse_playable :: File_path -> ExceptT Error IO [Playable] ---+ parse_playable file_path = ---+ do ---+ file <- read_file "key" readFile File_error file_path ---+ except (fromJust (parse' classify_char next_location tokenise parse_playable' Parse_error file)) ---+ parse_playable' :: Parser [Playable] ---+ parse_playable' = parse_list Newline_token (Playable <$> parse_list' parse_positive_int <*> parse_keys) ---+ parse_positive_int :: Parser Int ---+ parse_positive_int = parse_token' positive_int_token ---+ parse_square_brackets :: Parser t -> Parser t ---+ parse_square_brackets = parse_brackets Left_square_bracket_token Right_square_bracket_token ---+ parse_zero :: Parser Int ---+ parse_zero = ---+ do ---+ parse_token Zero_token ---+ return 0 ---+ positive_int_token :: Token -> Maybe Int ---+ positive_int_token token = ---+ case token of ---+ Positive_int_token i -> Just i ---+ _ -> Nothing ---+ right_hand_note_count :: Keyboard (Set (Note Pitched)) -> Int ---+ right_hand_note_count (Keyboard _ r) = Set.size r ---+ -- | Check if the set of notes is playable on the keyboard. ---+ set_is_playable :: [Playable] -> Set (Note Pitched) -> Bool ---+ set_is_playable playable notes = any (is_playable playable) (gen_keyboard_confs (Set.elems notes)) ---+ tointervs :: Note Pitched -> [Note Pitched] -> [Int] ---+ tointervs note_0 notes = ---+ case notes of ---+ [] -> [] ---+ note_1 : notes' -> distance_in_semitones note_0 note_1 : tointervs note_1 notes' ---+ tokenise :: Tokeniser () ---+ tokenise = void (parse_many tokenise_1) ---+ tokenise_1 :: Tokeniser () ---+ tokenise_1 = tokenise_delimiter <+> tokenise_nat <+> tokenise_whitespace ---+ tokenise_delimiter :: Tokeniser () ---+ tokenise_delimiter = add_token (parse_token' delimiter_char) ---+ tokenise_nat :: Tokeniser () ---+ tokenise_nat = add_token (tokenise_zero <+> tokenise_positive_int) ---+ tokenise_positive_int :: Tokeniser Token ---+ tokenise_positive_int = ---+ Positive_int_token <$> read <$> ((:) <$> parse_token' nonzero_nat_char <*> parse_many (parse_token' nat_char)) ---+ tokenise_whitespace :: Tokeniser () ---+ tokenise_whitespace = parse_token Whitespace_char ---+ tokenise_zero :: Tokeniser Token ---+ tokenise_zero = ---+ do ---+ parse_token Zero_char ---+ return Zero_token ---+ transf_notes_in :: Notes_in' -> Notes_in ---+ transf_notes_in maybe_notes = ---+ case maybe_notes of ---+ Notes_in' notes -> Notes_in notes Set.empty ---+ Tie_in' notes -> Notes_in Set.empty notes ---+ wider_hand_span :: Keyboard (Set (Note Pitched)) -> Int ---+ wider_hand_span k = maximum (hand_span <$> k) ---+ wider_hand_note_count :: Keyboard (Set (Note Pitched)) -> Int ---+ wider_hand_note_count k = Set.size (maximumBy (comparing hand_span) k) ---+{- ---+ calc_intervs :: Note Pitched -> [Note Pitched] -> [Int] ---+ calc_intervs note notes = ---+ case notes of ---+ [] -> [] ---+ note' : notes' -> distance_in_semitones note note' : calc_intervs note' notes' ---+ cat_head_tail :: Length_fraction -> Notes_in -> [Event_out] -> [Event_out] ---+ cat_head_tail len notes_in evs = ---+ case (notes_in, evs) of ---+ (Rest_in, []) -> [Event_out Rest_out len] ---+ (Rest_in, Event_out Rest_out len' : evs') -> Event_out Rest_out (len + len') : evs' ---+ (Rest_in, Event_out (Notes_out notes') len' : evs') -> Event_out Rest_out len : Event_out (Notes_out notes') len' : evs' ---+ (Rest_in, Event_out Tie_out _ : _) -> undefined ---+ (Notes_in notes, []) -> [Event_out (Notes_out notes) len] ---+ (Notes_in notes, Event_out Rest_out len' : evs') -> Event_out (Notes_out notes) len : Event_out Rest_out len' : evs' ---+ (Notes_in notes, Event_out (Notes_out notes') len' : evs') -> ---+ Event_out (Notes_out notes) len : Event_out (Notes_out notes') len' : evs' ---+ (Notes_in notes, Event_out Tie_out len' : evs') -> Event_out (Notes_out notes) (len + len') : evs' ---+ (Tie_in _, []) -> [Event_out Tie_out len] ---+ (Tie_in _, Event_out Rest_out len' : evs') -> Event_out Tie_out len : Event_out Rest_out len' : evs' ---+ (Tie_in _, Event_out (Notes_out notes') len' : evs') -> Event_out Tie_out len : Event_out (Notes_out notes') len' : evs' ---+ (Tie_in _, Event_out Tie_out len' : evs') -> Event_out Tie_out (len + len') : evs' ---+ choose_next_chord :: [([Int], [Int])] -> Keyboard Old_notes -> Set (Note Pitched) -> Set (Note Pitched) -> Keyboard Notes_in ---+ choose_next_chord acceptable_combinations old_notes potential_tied_notes potential_new_notes = ---+ min_wider_hand_range = minimum (wider_hand_range <$> all_lrs_3) ---+ all_lrs_4 = List.filter (\ var -> min_wider_hand_range == wider_hand_range var) all_lrs_3 ---+ min_max_notes = minimum (max_notes <$> all_lrs_4) ---+ all_lrs_5 = List.filter (\ var -> min_max_notes == max_notes var) all_lrs_4 ---+ min_narrower_hand_range = minimum (narrower_hand_range <$> all_lrs_5) ---+ all_lrs_6 = List.filter (\ var -> min_narrower_hand_range == narrower_hand_range var) all_lrs_5 ---+ max_right_hand_notes = maximum (right_hand_notes <$> all_lrs_6) ---+ all_lrs_7 = List.filter (\ var -> max_right_hand_notes == right_hand_notes var) all_lrs_6 in ---+ find_res potential_tied_notes <$> old_notes <*> head all_lrs_7 ---+ constr_events_in :: [Event_fraction Pitched] -> Events_in ---+ constr_events_in events = ---+ case events of ---+ [] -> Empty_events_in ---+ Event_fraction notes len : events' -> Construct_events_in (First_event_in (constr_notes_in notes) len) events' ---+ constr_notes_in :: Set (Note Pitched) -> Notes_in ---+ constr_notes_in notes = ---+ case Set.elems notes of ---+ [] -> Rest_in ---+ _ -> Notes_in notes ---+ constr_events_out :: Time -> Initial_position -> [Event_out] -> Either Error [Event Pitched] ---+ constr_events_out time initial_position events = notate time initial_position (constr_events_out' events) ---+ constr_events_out' :: [Event_out] -> [Event_fraction Pitched] ---+ constr_events_out' events = ---+ case events of ---+ [] -> [] ---+ [Event_out notes len] -> ---+ [ ---+ Event_fraction ---+ (case notes of ---+ Rest_out -> Set.empty ---+ Notes_out notes' -> notes' ---+ Tie_out -> undefined) ---+ len] ---+ Event_out notes_0 len_0 : Event_out notes_1 len_1 : events' -> ---+ case (notes_0, notes_1) of ---+ (Rest_out, Rest_out) -> constr_events_out' (Event_out Rest_out (len_0 + len_1) : events') ---+ (Rest_out, Notes_out _) -> ---+ Event_fraction Set.empty len_0 : constr_events_out' (Event_out notes_1 len_1 : events') ---+ (Notes_out notes'_0, Rest_out) -> ---+ Event_fraction notes'_0 len_0 : constr_events_out' (Event_out notes_1 len_1 : events') ---+ (Notes_out notes'_0, Notes_out _) -> ---+ Event_fraction notes'_0 len_0 : constr_events_out' (Event_out notes_1 len_1 : events') ---+ (Notes_out _, Tie_out) -> constr_events_out' (Event_out notes_0 (len_0 + len_1) : events') ---+ _ -> undefined ---+-} ---+{- ---+ filter_new_notes :: Notes_in -> Maybe (Set (Note Pitched)) ---+ filter_new_notes notes_in = ---+ case notes_in of ---+ New_notes_in notes -> Just notes ---+ _ -> Nothing ---+ filter_old_notes :: Notes_in -> Maybe (Set (Note Pitched)) ---+ filter_old_notes notes_in = ---+ case notes_in of ---+ Old_notes_in notes -> Just notes ---+ _ -> Nothing ---+ filters :: Keyboard (Set (Note Pitched)) -> [Keyboard (Set (Note Pitched))] -> Keyboard (Set (Note Pitched)) ---+ filters current_notes = _ ---+-} ---+{- ---+ find_res :: Set (Note Pitched) -> Old_notes -> Set (Note Pitched) -> Notes_in ---+ find_res potential_tied_notes old_notes new_notes = ---+ case Set.null new_notes of ---+ False -> Notes_in new_notes ---+ True -> ---+ case old_notes of ---+ Old_notes_rest -> Rest_in ---+ Old_notes_notes old_notes' -> ---+ case Set.null (Set.intersection potential_tied_notes old_notes') of ---+ False -> Tie_in old_notes' ---+ True -> Rest_in ---+ is_acceptable :: Playable -> [Note Pitched] -> Bool ---+ is_acceptable acceptable_combinations notes = ---+ case notes of ---+ [] -> True ---+ note : notes' -> any (is_acceptable' note notes') acceptable_combinations ---+ is_acceptable' :: Note Pitched -> [Note Pitched] -> ([Int], [Int]) -> Bool ---+ is_acceptable' note@(Pitched_note _ note_name) notes (intervs, strts) = ---+ calc_intervs note notes == intervs && elem (semitones_from_c note_name) strts ---+ keyb :: [Playable] -> Keyboard Old_notes -> [[Event' Notes_in]] -> Keyboard [Event' Notes_out] ---+ keyb playable old_notes tracks = ---+ case all ((==) Empty_events_in) tracks of ---+ False -> ---+ let ---+ (len, cont_notes, new_notes, tracks') = head_and_tail tracks ---+ next_notes = choose_next_chord acceptable_combinations old_notes cont_notes new_notes ---+ next_events = keyb acceptable_combinations (transf_notes' <$> next_notes) tracks' in ---+ cat_head_tail len <$> next_notes <*> next_events ---+ True -> pure [] ---+ keyboard :: File_path -> String -> Instrument Pitched -> File_path -> Directory -> String -> IO () ---+ keyboard acceptable_combinations_file_path instrument_name midi_instrument score_file_path dir fname = ---+ do ---+ res <- runExceptT (keyboard_h acceptable_combinations_file_path instrument_name midi_instrument score_file_path) ---+ case res of ---+ Left err -> putStrLn (write_error err) ---+ Right score -> write dir fname score ---+ keyboard_h :: File_path -> String -> Instrument Pitched -> File_path -> ExceptT Error IO Score ---+ keyboard_h acceptable_combinations_file_path instrument_name midi_instrument score_file_path = ---+ do ---+ acceptable_combinations <- parse_keyboard acceptable_combinations_file_path ---+ score <- parse score_file_path ---+ ExceptT (return (keyboard_help acceptable_combinations instrument_name midi_instrument score)) ---+-} ---+{- ---+ let keyb_res = ---+ keyb ---+ acceptable_combinations ---+ (pure Old_notes_rest) ---+ (catMaybes ---+ (pitched_or_unpitched (\ (Track {events}) -> Just (constr_events_in events)) (return Nothing) <$> tracks)) ---+ Keyboard left_hand_track right_hand_track <- traverse (constr_events_out time initial_position) keyb_res ---+ max_notes :: Keyboard (Set (Note Pitched)) -> Int ---+ max_notes k = maximum (Set.size <$> k) ---+ narrower_hand_range :: Keyboard (Set (Note Pitched)) -> Int ---+ narrower_hand_range k = minimum (hand_range <$> k) ---+-} ---+{- ---+ notes_out_to_notes_0 :: Notes_out -> Set (Note Pitched) ---+ notes_out_to_notes_0 notes_out = ---+ case notes_out of ---+ New_notes_out notes -> notes ---+ Old_notes_out notes -> Tie ---+ Rest_notes_out -> Set.empty ---+-} ---+{- ---+ notes_out_to_notes_1 :: Notes' -> Notes Pitched ---+ notes_out_to_notes_1 notes_out = ---+ case notes_out of ---+ Notes'_rest -> Notes (Set.empty) ---+ Notes'_notes notes -> Notes notes ---+ Notes'_tie _ -> Tie ---+-} ---+{- ---+ notes_to_notes_in :: Set (Note Pitched) -> Notes Pitched -> (Notes_in, Set (Note Pitched)) ---+ notes_to_notes_in prev_notes maybe_notes = ---+ case maybe_notes of ---+ Notes notes -> ---+ ( ---+ case Set.size notes of ---+ 0 -> Rest_notes_in ---+ _ -> New_notes_in notes, ---+ notes) ---+ Tie -> (Old_notes_in prev_notes, prev_notes) ---+-} ---+{- ---+ only_new :: Notes_in -> Set (Note Pitched) ---+ only_new notes_in = ---+ case notes_in of ---+ Notes_in notes -> notes ---+ _ -> Set.empty ---+ only_ties :: Notes_in -> Set (Note Pitched) ---+ only_ties notes_in = ---+ case notes_in of ---+ Tie_in notes -> notes ---+ _ -> Set.empty ---+ right_hand_notes :: Keyboard (Set (Note Pitched)) -> Int ---+ right_hand_notes (Keyboard _ r) = Set.size r ---+-} ---+{- ---+ select_new_notes :: Set (Note Pitched) -> Set (Note Pitched) -> Set (Note Pitched) -> Notes_out ---+ select_new_notes old_notes current_notes new_notes = ---+ case () of ---+ () | Set.null new_notes -> ---+ case () of ---+ () | not (Set.null current_notes) && isSubsetOf current_notes old_notes -> Old_notes_out ---+ () -> Rest_notes_out ---+ _ -> New_notes_out new_notes ---+ seq2 :: Set (Note Pitched) -> [Event Pitched] -> Either String [Simultaneous_in] ---+ seq2 prev_notes evs = ---+ case evs of ---+ [] -> Right [] ---+ ev : evs' -> ---+ do ---+ (ev2, nxt_notes) <- simultaneous_to_simultaneous_in prev_notes ev ---+ evs2 <- seq2 nxt_notes evs' ---+ Right (ev2 : evs2) ---+-} ---+{- ---+ sequential_in_tail_to_sequential_in :: [Simultaneous_in] -> Sequential_in ---+ sequential_in_tail_to_sequential_in sequential_in_tail = ---+ case sequential_in_tail of ---+ [] -> Empty_sequential_in ---+ simultaneous_in : sequential_in_tail' -> Construct_sequential_in simultaneous_in sequential_in_tail' ---+-} ---+{- ---+ sequential_out_to_sequential :: Sequential_out -> [Event Pitched] ---+ sequential_out_to_sequential sequential_out = ---+ case sequential_out of ---+ Empty_sequential_out -> [] ---+ Construct_sequential_out simultaneous_out sequential -> simultaneous_out_to_simultaneous simultaneous_out : sequential ---+ sequential_to_sequential_in :: Old_notes -> [Event Pitched] -> Either String ([Event'], Old_notes) ---+ sequential_to_sequential_in maybe_old_notes sequential = ---+ case sequential of ---+ [] -> Right ([], maybe_old_notes) ---+ ev : sequential' -> ---+ case ev of ---+ Event maybe_new_notes len -> ---+ case maybe_new_notes of ---+ Notes new_notes -> ---+ case Set.size new_notes of ---+ 0 -> first ((:) (Event' Notes'_rest len)) <$> sequential_to_sequential_in Old_notes_rest sequential' ---+ _ -> ---+ ( ---+ first ((:) (Event' (Notes'_notes new_notes) len)) <$> ---+ sequential_to_sequential_in (Old_notes_notes new_notes) sequential') ---+ Tie -> ---+ case maybe_old_notes of ---+ Old_notes_rest -> ---+ first ((:) (Event' Notes'_rest len)) <$> sequential_to_sequential_in Old_notes_rest sequential' ---+ Old_notes_notes old_notes -> ---+ ( ---+ first ((:) (Event' (Notes'_tie old_notes) len)) <$> ---+ sequential_to_sequential_in (Old_notes_notes old_notes) sequential') ---+ Tuplet rat evs -> ---+ do ---+ (evs', maybe_old_notes') <- sequential_to_sequential_in maybe_old_notes evs ---+ (evs'', maybe_old_notes'') <- sequential_to_sequential_in maybe_old_notes' sequential' ---+ Right (Tuplet' rat evs' : evs'', maybe_old_notes'') ---+ simultaneous_out_to_simultaneous :: Event' -> Event Pitched ---+ simultaneous_out_to_simultaneous ev = ---+ case ev of ---+ Event' notes_out len -> Event (notes_out_to_notes_1 notes_out) len ---+ Tuplet' rat evs -> Tuplet rat (simultaneous_out_to_simultaneous <$> evs) ---+-} ---+{- ---+ simultaneous_to_simultaneous_in :: Set (Note Pitched) -> Event Pitched -> Either String (Simultaneous_in, Set (Note Pitched)) ---+ simultaneous_to_simultaneous_in prev_notes (Event notes len) = ---+ do ---+ check "Non-positive note length." (0 < len) ---+ let (notes', notes'') = notes_to_notes_in prev_notes notes ---+ Right (Simultaneous_in notes' len, notes'') ---+ tail_notes :: Notes_in -> Notes_in ---+ tail_notes notes_in = ---+ case notes_in of ---+ New_notes_in notes -> Old_notes_in notes ---+ Old_notes_in notes -> Old_notes_in notes ---+ Rest_notes_in -> Rest_notes_in ---+-} ---+{- ---+ transf_notes' :: Notes_in -> Old_notes ---+ transf_notes' notes_in = ---+ case notes_in of ---+ Rest_in -> Old_notes_rest ---+ Notes_in notes -> Old_notes_notes notes ---+ Tie_in notes -> Old_notes_notes notes ---+ transf_old_pos :: Old_notes -> Set (Note Pitched) ---+ transf_old_pos notes' = ---+ case notes' of ---+ Old_notes_rest -> Set.empty ---+ Old_notes_notes notes -> notes ---+ var_size :: Keyboard (Set (Note Pitched)) -> Int ---+ var_size k = sum (Set.size <$> k) ---+ compute_distance :: Keyboard (Set Note) -> Keyboard (Set Note) -> Semitones ---+ compute_distance keyboard_notes_0 keyboard_notes_1 = sum (compute_distance' <$> keyboard_notes_0 <*> keyboard_notes_1) ---+ compute_distance' :: Set Note -> Set Note -> Semitones ---+ compute_distance' notes_0 notes_1 = sum (abs <$> (distance_in_semitones <$> elems notes_0 <*> elems notes_1)) ---+ compute_distances_in_semitones :: [Note] -> [Semitones] ---+ compute_distances_in_semitones notes = zipWith distance_in_semitones (init notes) (tail notes) ---+ -- | The lowest and highest voices are always included. The algorithm attempts to include as many middle voices as possible ---+ -- while keeping the score playable. ---+ number_of_notes :: Keyboard (Set Note) -> Int ---+ number_of_notes keyboard_notes = sum (fmap size keyboard_notes) ---+ order :: Ord t => t -> t -> (t, t) ---+ order x y = ---+ case compare' x y of ---+ LT' -> (x, y) ---+ EQ' z -> (z, z) ---+ GT' -> (y, x) ---+ -- | Checks whether a set of notes is playable on the keyboard. ---+ playable :: Set Note -> Bool ---+ playable notes = any playable' (divide_between_hands (elems notes)) ---+ playable' :: Keyboard (Set Note) -> Bool ---+ playable' (Keyboard left_hand_notes right_hand_notes) = ---+ playable_with_the_left_hand left_hand_notes && playable_with_the_right_hand right_hand_notes ---+ playable_with_one_hand :: ---+ (Set Note -> Maybe Note) -> (Semitones -> Semitones) -> ([Semitones] -> [Semitones]) -> Set Note -> Bool ---+ playable_with_one_hand reference_note mirror_semitones_from_c mirror_distances_in_semitones notes = ---+ case reference_note notes of ---+ Nothing -> True ---+ Just (Note _ note_name) -> ---+ elem ---+ (mirror_semitones_from_c (semitones_from_c note_name)) ---+ (playable_with_the_right_hand_table (mirror_distances_in_semitones (compute_distances_in_semitones (elems notes)))) ---+ playable_with_the_left_hand :: Set Note -> Bool ---+ playable_with_the_left_hand = playable_with_one_hand lookupMax (\) reverse ---+ playable_with_the_right_hand :: Set Note -> Bool ---+ playable_with_the_right_hand = playable_with_one_hand lookupMin id id ---+ range :: Keyboard (Set Note) -> Range ---+ range (Keyboard left_hand_notes right_hand_notes) = ---+ uncurry Range (swap (order (range' left_hand_notes) (range' right_hand_notes))) ---+ range' :: Set Note -> Maybe Semitones ---+ range' notes = distance_in_semitones <$> lookupMin notes <*> lookupMax notes ---+ shape :: Keyboard (Set Note) -> Shape ---+ shape (Keyboard left_hand_notes right_hand_notes) = ---+ construct_shape (shape' id lookupMin reverse left_hand_notes) (shape' flip lookupMax id right_hand_notes) ---+ shape' :: ---+ ( ---+ ((Note -> Note -> Semitones) -> Note -> Note -> Semitones) -> ---+ (Set Note -> Maybe Note) -> ---+ ([Note] -> [Note]) -> ---+ Set Note -> ---+ Maybe [Semitones]) ---+ shape' flip_or_not get_reference_note reverse_or_not notes = ---+ do ---+ reference_note <- get_reference_note notes ---+ Just (flip_or_not distance_in_semitones reference_note <$> reverse_or_not (elems (delete reference_note notes))) ---+ wrong_order :: Maybe Note -> Maybe Note -> Maybe Semitones -> Keyboard (Set Note) -> Maybe Semitones ---+ wrong_order left_hand_limit right_hand_limit if_distance_zero (Keyboard left_hand_notes right_hand_notes) = ---+ let ---+ f = wrong_order' if_distance_zero ---+ in ---+ max (f (lookupMax left_hand_notes) left_hand_limit) (f right_hand_limit (lookupMin right_hand_notes)) ---+ wrong_order' :: Maybe Semitones -> Maybe Note -> Maybe Note -> Maybe Semitones ---+ wrong_order' if_distance_zero maybe_note_0 maybe_note_1 = ---+ do ---+ note_0 <- maybe_note_0 ---+ note_1 <- maybe_note_1 ---+ let distance = distance_in_semitones note_0 note_1 ---+ case compare distance 0 of ---+ LT -> Just (negate distance) ---+ EQ -> if_distance_zero ---+ GT -> Nothing ---+ wrong_stave :: Keyboard (Set Note) -> Maybe Semitones ---+ wrong_stave = wrong_order (Just (Note 4 C)) (Just (Note 4 C)) Nothing ---+-} ---
Composition/Lilypond.hs view
@@ -1,461 +1,394 @@----------------------------------------------------------------------------------------------------------------------------------{-# 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')---------------------------------------------------------------------------------------------------------------------------------+{-| ---+Description: Generating Lilypond files. ---+ ---+* Generating Lilypond files ---+-} ---+module Composition.Lilypond (lilypond) where ---+ import Composition.Errors ---+ import Composition.Notes ---+ import Composition.Score ---+ import Composition.Theory ---+ import Composition.Time ---+ import Control.Lens.Combinators hiding (index, parts) ---+ import Control.Lens.Operators ---+ import Control.Monad.Except ---+ import Control.Monad.State.Strict ---+ import Control.Monad.Trans.Except ---+ import Data.Bifunctor ---+ import Data.Char ---+ import Data.Foldable ---+ import Data.Generics.Labels () ---+ import Data.List ---+ import Data.Map.Strict as Map ---+ import Data.Set as Set ---+ import GHC.Generics ---+ import GHC.Real ---+ import Parser.Files ---+ import Parser.Utilities ---+ data Header_field' = Header_field' String String ---+ data State = State {state_notes :: Bool, state_position :: Position} ---+ deriving instance Generic Composition.Lilypond.State ---+ deriving instance Show Header_field' ---+ check_char :: Char -> Either Error () ---+ check_char c = check Invalid_character_in_text (elem c " !#$%&'()*+,-./:;<=>?@[]^_`{|}~" || isDigit c || isLetter c) ---+ convert_header_field :: (Header_field, String) -> Header_field' ---+ convert_header_field (name, value) = Header_field' (write_header_field_name name) value ---+ convert_events_to_pitched :: Note Pitched -> [Event note_type] -> [Event Pitched] ---+ convert_events_to_pitched unpitched_note = (<$>) convert_event_to_pitched where ---+ convert_event_to_pitched :: Event note_type -> Event Pitched ---+ convert_event_to_pitched event = ---+ case event of ---+ Event notes len -> Event (convert_notes_to_pitched notes) len ---+ Triplet events -> Triplet (convert_events_to_pitched unpitched_note events) ---+ convert_note_to_pitched :: Note note_type -> Note Pitched ---+ convert_note_to_pitched note = ---+ case note of ---+ Pitched_note _ _ -> note ---+ Unpitched_note -> unpitched_note ---+ convert_notes_to_pitched :: Notes note_type -> Notes Pitched ---+ convert_notes_to_pitched maybe_notes = ---+ case maybe_notes of ---+ Notes notes -> Notes (Set.mapMonotonic convert_note_to_pitched notes) ---+ Tie -> Tie ---+ delete_default_tagline :: Header_field' ---+ delete_default_tagline = Header_field' "tagline" "" ---+ -- | Encodes the score in Lilypond format and writes it to the specified file. ---+ lilypond :: File_path -> Score -> ExceptT Error IO () ---+ lilypond file_path score = ---+ do ---+ written_score <- except (write_score score) ---+ write_file "ly" writeFile File_error file_path written_score ---+ write_accidental :: Accidental -> String ---+ write_accidental accidental = ---+ case accidental of ---+ Flat -> "f" ---+ Natural -> "" ---+ Sharp -> "s" ---+ write_angular_brackets :: String -> String ---+ write_angular_brackets = write_brackets "<" ">" ---+ write_angular_brackets_2 :: String -> String ---+ write_angular_brackets_2 = write_brackets "<<" ">>" ---+ write_basic_length :: Basic_length -> String ---+ write_basic_length len = show (denominator (basic_length_to_fraction len)) ---+ write_brackets :: String -> String -> String -> String ---+ write_brackets left_bracket right_bracket x = left_bracket <> x <> right_bracket ---+ write_clef :: Clef note_type -> String ---+ write_clef clef = ---+ case clef of ---+ Percussion_clef -> "percussion" ---+ Pitched_clef {clef_name, transposition} -> write_clef_name clef_name <> write_clef_transposition transposition ---+ write_clef_name :: Clef_name -> String ---+ write_clef_name clef_name = ---+ case clef_name of ---+ Subbass -> "subbass" ---+ Bass -> "bass" ---+ Baritone_F -> "baritonevarF" ---+ Baritone_C -> "baritone" ---+ Tenor -> "tenor" ---+ Alto -> "alto" ---+ Mezzosoprano -> "mezzosoprano" ---+ Soprano -> "soprano" ---+ Treble -> "treble" ---+ French -> "french" ---+ write_clef_transposition :: Steps -> String ---+ write_clef_transposition transposition = ---+ case compare transposition 0 of ---+ LT -> write_clef_transposition' "_" (negate transposition) ---+ EQ -> "" ---+ GT -> write_clef_transposition' "^" transposition ---+ write_clef_transposition' :: String -> Steps -> String ---+ write_clef_transposition' index transposition = index <> show transposition ---+ write_curly_brackets :: String -> String ---+ write_curly_brackets = write_brackets "{" "}" ---+ write_dot :: Dot -> Char ---+ write_dot Dot = '.' ---+ write_end_bar_line :: String ---+ write_end_bar_line = "\\bar" <-> "\"|.\"" ---+ write_eq :: String -> String -> String ---+ write_eq x y = x <-> "=" <-> y ---+ write_header :: [Header_field'] -> Either Error String ---+ write_header header = ---+ do ---+ written_header_fields <- traverse write_header_field header ---+ Right ("\\header" <-> write_curly_brackets (intercalate " " written_header_fields)) ---+ write_header_field :: Header_field' -> Either Error String ---+ write_header_field (Header_field' name value) = write_eq name <$> write_quotes value ---+ write_header_field_name :: Header_field -> String ---+ write_header_field_name name = ---+ case name of ---+ Composer -> "composer" ---+ Instrument -> "instrument" ---+ Subtitle -> "subtitle" ---+ write_key :: Key -> Either Error String ---+ write_key key = ---+ do ---+ note_names <- ---+ traverse ---+ (write_key_note_name (fromListWith (<>) (second return <$> deconstruct_note_name <$> Set.elems key))) ---+ (enumFromTo C_natural B_natural) ---+ Right (write_note_name C <-> "#" <> "`" <> write_round_brackets (intercalate " " note_names)) ---+ write_key_accidental :: Accidental -> String ---+ write_key_accidental accidental = ---+ case accidental of ---+ Flat -> "FLAT" ---+ Natural -> "NATURAL" ---+ Sharp -> "SHARP" ---+ write_key_natural_note_name :: Natural_note_name -> String ---+ write_key_natural_note_name natural_note_name = show (fromEnum natural_note_name) ---+ write_key_note_name :: Map Natural_note_name [Accidental] -> Natural_note_name -> Either Error String ---+ write_key_note_name key natural_note_name = ---+ case Map.lookup natural_note_name key of ---+ Nothing -> write_key_note_name' natural_note_name Natural ---+ Just accidentals' -> ---+ case accidentals' of ---+ [accidental] -> write_key_note_name' natural_note_name accidental ---+ _ -> Left Conflicting_key_signature ---+ write_key_note_name' :: Natural_note_name -> Accidental -> Either Error String ---+ write_key_note_name' natural_note_name accidental = ---+ Right ---+ (write_round_brackets (write_key_natural_note_name natural_note_name <-> "." <-> "," <> write_key_accidental accidental)) ---+ write_language :: Either Error String ---+ write_language = ---+ do ---+ written_language <- write_quotes "english.ly" ---+ Right ("\\include" <-> written_language) ---+ write_length :: Length -> String ---+ write_length (Length len dots) = write_basic_length len <> (write_dot <$> dots) ---+ 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 Pitched -> String ---+ write_note (Pitched_note octave note_name) = write_note_name note_name <> write_octave octave ---+ write_note_name :: Note_name -> String ---+ write_note_name note_name = ---+ let ---+ (natural_note_name, accidental) = deconstruct_note_name note_name ---+ in ---+ write_natural_note_name natural_note_name <> write_accidental accidental ---+ write_notes :: Notes Pitched -> StateT Composition.Lilypond.State (Either Error) (Bool, String) ---+ write_notes maybe_notes = ---+ case maybe_notes of ---+ Notes notes -> ---+ do ---+ #state_notes .= not (Set.null notes) ---+ return ---+ ( ---+ False, ---+ case Set.elems notes of ---+ [] -> "r" ---+ notes' -> write_angular_brackets (intercalate " " (write_note <$> notes'))) ---+ Tie -> ---+ do ---+ -- Composition.Lilypond.State {state_notes} <- get ---+ notes <- use #state_notes ---+ return ---+ ( ---+ notes, ---+ case notes of ---+ False -> "r" ---+ True -> "") ---+ write_octave :: Octave -> String ---+ write_octave octave = ---+ case compare octave 3 of ---+ LT -> replicate (3 - octave) ',' ---+ EQ -> "" ---+ GT -> replicate (octave - 3) '\'' ---+ write_option :: String -> String -> String ---+ write_option option value = "#" <> write_round_brackets ("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_override :: String -> String -> String ---+ write_override name value = "\\override" <-> write_eq name value ---+ write_part :: Part -> Either Error String ---+ write_part (Part {title, key, time, initial_position, stave_groups}) = ---+ do ---+ written_header <- write_header [Header_field' "piece" title] ---+ written_set_key <- write_set_key key ---+ written_time_and_initial_position <- write_time_and_initial_position ---+ _ <- tracks_length (remove_notational_information stave_groups) ---+ written_stave_groups <- traverse write_stave_group stave_groups ---+ Right ---+ ( ---+ written_set_key <-> ---+ written_time_and_initial_position <-> ---+ "\\score" <-> ---+ write_curly_brackets (written_header <-> write_angular_brackets_2 (intercalate " " written_stave_groups))) where ---+ write_clef_and_stave :: Clef_and_stave note_type -> Either Error String ---+ write_clef_and_stave (Clef_and_stave {clef, stave}) = ---+ do ---+ written_set_clef <- write_set_clef clef ---+ written_tracks <- ---+ case stave of ---+ One_track events -> write_events (convert_events_to_pitched (Pitched_note 4 C) events) ---+ Two_tracks events_0 events_1 -> ---+ do ---+ written_voice_0 <- write_voice "\\voiceOne" (convert_events_to_pitched (Pitched_note 4 D) events_0) ---+ written_voice_1 <- write_voice "\\voiceTwo" (convert_events_to_pitched (Pitched_note 3 B) events_1) ---+ Right (write_angular_brackets_2 (written_voice_0 <-> written_voice_1)) ---+ Right ---+ ( ---+ "\\new" <-> ---+ "Staff" <-> ---+ "\\with" <-> ---+ write_curly_brackets ---+ (case clef of ---+ Percussion_clef -> ---+ ( ---+ write_override "StaffSymbol.line-count" (show (length written_tracks)) <-> ---+ write_override "Stem.neutral-direction" "1") ---+ Pitched_clef {} -> "") <-> ---+ write_curly_brackets ---+ ( ---+ intercalate ---+ " " ---+ ( ---+ (case clef of ---+ Percussion_clef -> [] ---+ Pitched_clef {} -> ["\\Key"]) <> ---+ ["\\Time_and_initial_position", written_set_clef]) <-> ---+ written_tracks <-> ---+ write_end_bar_line)) ---+ write_event :: Int -> Event Pitched -> StateT Composition.Lilypond.State (Either Error) (Bool, String) ---+ write_event triplets event = ---+ case event of ---+ Event notes len -> ---+ do ---+ Composition.Lilypond.State {state_position} <- get ---+ let position' = state_position + (2 % 3) ^ triplets * length_to_fraction len ---+ position'' <- ---+ case compare position' (measure_length time) of ---+ LT -> return position' ---+ EQ -> return 0 ---+ GT -> throwError An_event_crosses_the_bar_line ---+ #state_position .= position'' ---+ (tie, written_notes) <- write_notes notes ---+ return (tie, written_notes <> write_length len) ---+ Triplet events -> ---+ do ---+ maybe_written_events <- write_events' (1 + triplets) events ---+ case maybe_written_events of ---+ Nothing -> throwError Empty_triplet ---+ Just (tie, written_events) -> return (tie, "\\tuplet" <-> "3/2" <-> write_curly_brackets written_events) ---+ write_events :: [Event Pitched] -> Either Error String ---+ write_events events = ---+ do ---+ maybe_written_events <- ---+ evalStateT ---+ (write_events' 0 events) ---+ (Composition.Lilypond.State {state_notes = False, state_position = initial_position_to_fraction initial_position}) ---+ Right ---+ (case maybe_written_events of ---+ Nothing -> "" ---+ Just (_, written_events) -> written_events) ---+ write_events' :: Int -> [Event Pitched] -> StateT Composition.Lilypond.State (Either Error) (Maybe (Bool, String)) ---+ write_events' triplets events = ---+ case events of ---+ [] -> return Nothing ---+ event : events' -> ---+ do ---+ (tie_0, written_event) <- write_event triplets event ---+ maybe_written_events <- write_events' triplets events' ---+ return ---+ (Just ---+ ( ---+ tie_0, ---+ intercalate ---+ " " ---+ ( ---+ written_event : ---+ case maybe_written_events of ---+ Nothing -> [] ---+ Just (tie_1, written_events) -> ---+ ( ---+ (case tie_1 of ---+ False -> [] ---+ True -> ["~"]) <> ---+ [written_events])))) ---+ write_initial_position :: Either Error String ---+ write_initial_position = ---+ do ---+ let initial_position' = initial_position_to_fraction initial_position ---+ check+ (Is_out_of_range_without_location Initial_position_IOOR)+ (between 0 (measure_length time - 1 % 128) initial_position') ---+ let num :% den = measure_length time - initial_position' ---+ Right (show den <-> "*" <-> show num) ---+ write_instrument_clefs_and_staves :: Pitched_or_unpitched Instrument_clefs_and_staves -> Either Error String ---+ write_instrument_clefs_and_staves = pitched_and_unpitched write_instrument_clefs_and_staves' ---+ write_instrument_clefs_and_staves' :: Instrument_clefs_and_staves note_type -> Either Error String ---+ write_instrument_clefs_and_staves' (Instrument_clefs_and_staves {instrument_name, clefs_and_staves}) = ---+ do ---+ written_instrument_name <- write_quotes instrument_name ---+ written_clefs_and_staves <- traverse write_clef_and_stave clefs_and_staves ---+ Right ---+ ( ---+ "\\new" <-> ---+ "PianoStaff" <-> ---+ "\\with" <-> ---+ write_curly_brackets (write_eq "instrumentName" written_instrument_name) <-> ---+ write_angular_brackets_2 (intercalate " " written_clefs_and_staves)) ---+ write_set_initial_position :: Either Error String ---+ write_set_initial_position = ---+ do ---+ written_initial_position <- write_initial_position ---+ Right ("\\partial" <-> written_initial_position) ---+ write_stave_group :: [Pitched_or_unpitched Instrument_clefs_and_staves] -> Either Error String ---+ write_stave_group stave_group = ---+ case stave_group of ---+ [instrument_clefs_and_staves] -> write_instrument_clefs_and_staves instrument_clefs_and_staves ---+ _ -> ---+ do ---+ written_instruments_clefs_and_staves <- traverse write_instrument_clefs_and_staves stave_group ---+ Right ("\\new" <-> "StaffGroup" <-> write_angular_brackets_2 (intercalate " " written_instruments_clefs_and_staves)) ---+ write_time_and_initial_position :: Either Error String ---+ write_time_and_initial_position = ---+ do ---+ written_set_initial_position <- write_set_initial_position ---+ Right ( ---+ write_eq ---+ "Time_and_initial_position" ---+ (write_curly_brackets ---+ (intercalate " " (["\\numericTimeSignature", write_set_time time, written_set_initial_position])))) ---+ write_voice :: String -> [Event Pitched] -> Either Error String ---+ write_voice voice_name events = ---+ do ---+ written_events <- write_events events ---+ Right ("\\new" <-> "Voice" <-> write_curly_brackets (voice_name <-> write_curly_brackets written_events)) ---+ write_quotes :: String -> Either Error String ---+ write_quotes text = ---+ do ---+ traverse_ check_char text ---+ Right (write_brackets "\"" "\"" text) ---+ write_round_brackets :: String -> String ---+ write_round_brackets = write_brackets "(" ")" ---+ write_score :: Score -> Either Error String ---+ write_score (Score {title, header, parts}) = ---+ do ---+ written_parts <- traverse write_part parts ---+ written_language <- write_language ---+ written_header <- ---+ write_header (delete_default_tagline : Header_field' "title" title : (convert_header_field <$> assocs header)) ---+ Right (write_options <-> written_language <-> written_header <-> intercalate " " written_parts) ---+ write_set_clef :: Clef note_type -> Either Error String ---+ write_set_clef clef = ---+ do ---+ written_clef <- write_quotes (write_clef clef) ---+ Right ("\\clef" <-> written_clef) ---+ write_set_key :: Key -> Either Error String ---+ write_set_key key = ---+ do ---+ written_key <- write_key key ---+ Right (write_eq "Key" (write_curly_brackets ("\\key" <-> written_key))) ---+ write_set_time :: Time -> String ---+ write_set_time time = "\\time" <-> write_time time ---+ write_time :: Time -> String ---+ write_time (Time num den) = write_time_numerator num <> "/" <> write_basic_length den ---+ write_time_numerator :: [Time_numerator_factor] -> String ---+ write_time_numerator num = show (time_numerator_to_int num) ---
+ Composition/MIDI.hs view
@@ -0,0 +1,203 @@+{-|+Description: Generating MIDI files.+-}+module Composition.MIDI (midi) where+ import Composition.Errors+ import Composition.Notes+ import Composition.Score+ import Composition.Theory+ import Composition.Time+ import Control.Monad+ import Control.Monad.Except+ import Control.Monad.State.Strict+ import Control.Monad.Trans.Except+ import Data.ByteString as ByteString+ import Data.Foldable as Foldable+ import Data.List as List+ import Data.Ratio+ import Data.Set as Set+ import Data.Word+ import Parser.Files+ import Parser.Utilities+ data MIDI_part = MIDI_part {time_denominator :: Basic_length, tempo :: Tempo, tracks :: [Pitched_or_unpitched Track]}+ deriving instance Show MIDI_part+ encode_chunk :: [Word8] -> [Word8] -> Either Error [Word8]+ encode_chunk typ dat =+ do+ len <- encode_int_fixed 4 Track_length_IOOR (Foldable.length dat)+ Right (typ <> len <> dat)+ encode_format :: [Word8]+ encode_format = [0, 1]+ encode_int_fixed :: (MonadError Error f) => Integer -> Is_out_of_range_type -> Int -> f [Word8]+ encode_int_fixed bytes typ i =+ case bytes of+ 0 ->+ case i of+ 0 -> return []+ _ -> throwError (Is_out_of_range_without_location typ)+ _ ->+ do+ let (i', last_byte) = divMod i 256+ encoded_i' <- encode_int_fixed (bytes - 1) typ i'+ return (encoded_i' <> [fromIntegral last_byte])+ encode_int_flexible :: (MonadError Error f) => Int -> f [Word8]+ encode_int_flexible = encode_int_flexible' 4 0+ encode_int_flexible' :: (MonadError Error f) => Integer -> Word8 -> Int -> f [Word8]+ encode_int_flexible' max_bytes msb i =+ case max_bytes of+ 0 -> throwError (Is_out_of_range_without_location Event_or_part_length_IOOR)+ _ ->+ do+ let (i', last_byte) = divMod i 128+ encoded_i' <-+ case i' of+ 0 -> return []+ _ -> encode_int_flexible' (max_bytes - 1) 128 i'+ return (encoded_i' <> [msb + fromIntegral last_byte])+ encode_score :: [MIDI_part] -> Either Error [Word8]+ encode_score parts =+ do+ header <- encode_header+ encoded_parts <- traverse encode_part parts+ tracks <- traverse encode_complete_track (List.transpose encoded_parts)+ Right (header <> join tracks) where+ encode_complete_track :: [[Word8]] -> Either Error [Word8]+ encode_complete_track track_parts =+ do+ end_track <- encode_end_track+ encode_chunk [77, 84, 114, 107] (join track_parts <> end_track)+ encode_end_track :: Either Error [Word8]+ encode_end_track = encode_metaevent 0 47 []+ encode_events :: forall note_type .+ MIDI_instrument -> Word8 -> Velocity -> [Event_fraction note_type] -> StateT [Word8] (Either Error) [Word8]+ encode_events instrument channel velocity events =+ do+ check (Is_out_of_range_without_location Velocity_IOOR) (between 0 max_velocity velocity)+ check (Is_out_of_range_without_location MIDI_instrument_code_IOOR) (between 0 127 instrument)+ join <$> traverse encode_event (events <> [Event' Set.empty rest_after_part]) where+ encode_event :: Event_fraction note_type -> StateT [Word8] (Either Error) [Word8]+ encode_event (Event' notes len) =+ do+ encoded_notes <- traverse encode_note (elems notes)+ notes_on <- traverse encode_note_on encoded_notes+ rest <- encode_rest+ notes_off <- traverse encode_note_off encoded_notes+ return (join notes_on <> rest <> join notes_off) where+ encode_rest :: StateT [Word8] (Either Error) [Word8]+ encode_rest = encode_metaevent len 1 []+ encode_note :: Note note_type -> StateT [Word8] (Either Error) Word8+ encode_note note =+ case note of+ Pitched_note _ _ ->+ do+ check (Is_out_of_range_without_location Note_IOOR) (between min_note max_note note)+ return (fromIntegral (distance_in_semitones min_note note))+ Unpitched_note -> return instrument+ encode_note_event :: Word8 -> Word8 -> StateT [Word8] (Either Error) [Word8]+ encode_note_event typ note = encode_midi_event channel typ [note, velocity]+ encode_note_off :: Word8 -> StateT [Word8] (Either Error) [Word8]+ encode_note_off = encode_note_event 8+ encode_note_on :: Word8 -> StateT [Word8] (Either Error) [Word8]+ encode_note_on = encode_note_event 9+ encode_metaevent :: (MonadError Error f) => Ratio Int -> Word8 -> [Word8] -> f [Word8]+ encode_metaevent time typ dat = encode_midi_or_metaevent time ([255, typ, fromIntegral (Foldable.length dat)] <> dat)+ encode_header :: Either Error [Word8]+ encode_header =+ do+ encoded_number_of_tracks <- encode_int_fixed 2 The_number_of_tracks_IOOR number_of_tracks+ length_of_quarter_note_in_ticks <-+ encode_int_fixed 2 The_least_common_denominator_of_note_lengths_IOOR (length_in_ticks (1 % 4))+ encode_chunk [77, 84, 104, 100] (encode_format <> encoded_number_of_tracks <> length_of_quarter_note_in_ticks)+ encode_midi_event :: Word8 -> Word8 -> [Word8] -> StateT [Word8] (Either Error) [Word8]+ encode_midi_event channel typ dat = encode_midi_or_metaevent 0 ([channel + 16 * typ] <> dat)+ encode_midi_or_metaevent :: (MonadError Error f) => Ratio Int -> [Word8] -> f [Word8]+ encode_midi_or_metaevent time event =+ do+ encoded_time <- encode_length+ return (encoded_time <> event) where+ encode_length :: (MonadError Error f) => f [Word8]+ encode_length = encode_int_flexible (length_in_ticks time)+ encode_part :: MIDI_part -> Either Error [[Word8]]+ encode_part (MIDI_part {time_denominator, tempo, tracks}) =+ do+ encoded_tempo <- encode_tempo+ empty_track <- create_empty_track+ encoded_tracks <- encode_tracks (tracks <> List.replicate (number_of_tracks - Foldable.length tracks) empty_track)+ Right+ (case encoded_tracks of+ [] -> []+ track : tracks' -> (encoded_tempo <> track) : tracks') where+ create_empty_track :: Either Error (Pitched_or_unpitched Track)+ create_empty_track =+ do+ len <- tracks_length tracks+ Right (Unpitched (Track {instrument = 0, velocity = 0, events = [Event' Set.empty len]}))+ encode_tempo :: Either Error [Word8]+ encode_tempo =+ do+ encoded_tempo <- encode_int_fixed 3 Tempo_IOOR quarter_note_length_in_microseconds+ encode_metaevent 0 81 encoded_tempo+ quarter_note_length_in_microseconds :: Int+ quarter_note_length_in_microseconds =+ round (60000000 * denominator (basic_length_to_fraction time_denominator) % (4 * tempo))+ encode_pitched_track :: Track Pitched -> StateT [Word8] (Either Error) [Word8]+ encode_pitched_track (Track {instrument, velocity, events}) =+ do+ channel <- new_channel+ encoded_instrument <- encode_instrument channel+ encoded_events <- encode_events instrument channel velocity events+ return (encoded_instrument <> encoded_events) where+ encode_instrument :: Word8 -> StateT [Word8] (Either Error) [Word8]+ encode_instrument channel = encode_midi_event channel 12 [instrument]+ encode_track :: Pitched_or_unpitched Track -> StateT [Word8] (Either Error) [Word8]+ encode_track = pitched_or_unpitched encode_pitched_track encode_unpitched_track+ encode_tracks :: [Pitched_or_unpitched Track] -> Either Error [[Word8]]+ encode_tracks tracks = evalStateT (traverse encode_track tracks) pitched_channels+ encode_unpitched_track :: Track Unpitched -> StateT [Word8] (Either Error) [Word8]+ encode_unpitched_track (Track {instrument, velocity, events}) = encode_events instrument unpitched_channel velocity events+ lcd :: Int+ lcd = 4 `lcm` lcm_all (lcd_part <$> parts)+ length_in_ticks :: Length_fraction -> Int+ length_in_ticks len = numerator (fromIntegral lcd * len)+ number_of_tracks :: Int+ number_of_tracks = Foldable.maximum (0 : (number_of_tracks_in_part <$> parts))+ lcd_event :: Event_fraction note_type -> Int+ lcd_event (Event' _ len) = denominator len+ lcd_part :: MIDI_part -> Int+ lcd_part (MIDI_part {time_denominator, tracks}) =+ denominator (basic_length_to_fraction time_denominator) `lcm` lcm_all (pitched_and_unpitched lcd_track <$> tracks)+ lcd_track :: Track note_type -> Int+ lcd_track (Track {events}) = lcm_all (lcd_event <$> events)+ max_note :: Note Pitched+ max_note = Pitched_note 9 G+ -- | Encode the score in MIDI format and write it to the specified file.+ midi :: Score -> File_path -> ExceptT Error IO ()+ midi score file_path =+ do+ encoded_score <- except (encode_score (midi_score score))+ write_file "mid" ByteString.writeFile File_error file_path (pack encoded_score) where+ midi_score :: Score -> [MIDI_part]+ midi_score (Score {parts}) = midi_part <$> parts+ midi_part :: Part -> MIDI_part+ midi_part (Part {time = Time _ time_denominator, tempo, stave_groups}) =+ MIDI_part {time_denominator, tempo, tracks = remove_notational_information stave_groups}+ min_note :: Note Pitched+ min_note = Pitched_note -1 C+ new_channel :: StateT [Word8] (Either Error) Word8+ new_channel =+ do+ channels <- get+ case channels of+ [] -> throwError (Is_out_of_range_without_location The_number_of_pitched_tracks_IOOR)+ channel : channels' ->+ do+ put channels'+ return channel+ number_of_tracks_in_part :: MIDI_part -> Int+ number_of_tracks_in_part (MIDI_part {tracks}) = Foldable.length tracks+ pitched_channels :: [Word8]+ pitched_channels = List.delete unpitched_channel [0 .. 15]+ rest_after_part :: Length_fraction+ rest_after_part = 1+ unpitched_channel :: Word8+ unpitched_channel = 9
− Composition/Midi.hs
@@ -1,248 +0,0 @@----------------------------------------------------------------------------------------------------------------------------------{-# 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
@@ -1,458 +1,195 @@----------------------------------------------------------------------------------------------------------------------------------{-# 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.+Basic musical data structures: notes, lengths and events. -} module Composition.Notes (+ Note_type (..), Accidental (..),+ Basic_length (..),+ Branch (..),+ Dot (..),+ Event (..),+ Event' (..),+ Event_fraction,+ Length (..),+ Length_fraction, Natural_note_name (..), Note (..), Note_name (..),- Note_name' (..),- Rat,- Simultaneous (..),- Time (..),- Time_and_position (..),+ Notes (..),+ Octave,+ Pitched_or_unpitched (..),+ accidentals,+ basic_length_denominator,+ basic_length_to_fraction, 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 =+ denominator_to_basic_length,+ events_length,+ length_to_fraction,+ lg,+ next_basic_length,+ pitched_and_unpitched,+ pitched_or_unpitched,+ scale_lengths) where+ import Control.Lens.Combinators ---+ import Data.Functor.Barbie ---+ import Data.Generics.Labels () ---+ import Data.Maybe ---+ import Data.Ratio ---+ import Data.Set+ import Data.Tuple ---+ import GHC.Generics ---+ import Parser.Utilities ---+ import Text.Read+ -- | Notes can be either pitched or unpitched.+ type data Note_type = Pitched | Unpitched+ -- | Accidentals. Mostly for internal use. ---+ data Accidental = Flat | Natural | Sharp ---+ -- | Basic note lengths.+ data Basic_length = Whole | Half | Quarter | Eighth | Sixteenth | Thirty_second | Sixty_fourth | One_hundred_and_twenty_eighth+ -- | A term-level representation of the pitched / unpitched type for branching over the type. Mostly for internal use. ---+ data Branch note_type where ---+ Branch_pitched :: Branch Pitched ---+ Branch_unpitched :: Branch Unpitched ---+ -- | Dots. ---+ data Dot = Dot ---+ -- | Events. ---+ data Event note_type = Event (Notes note_type) Length | Triplet [Event note_type] ---+ -- | Generalised events with arbitrary notes type stripped of note length display information. Mostly for internal use.+ data Event' notes = Event' {event_notes :: notes, event_length :: Length_fraction}+ -- | Events stripped of note length display information. Mostly for internal use. ---+ type Event_fraction note_type = Event' (Set (Note note_type)) ---+ -- | Note lengths. ---+ data Length = Length Basic_length [Dot] ---+ -- | Note length as a fraction. Mostly for internal use. ---+ type Length_fraction = Ratio Int ---+ -- | Natural note names. Mostly for internal use. ---+ data Natural_note_name = C_natural | D_natural | E_natural | F_natural | G_natural | A_natural | B_natural ---+ -- | Pitched and unpitched notes. ---+ data Note note_type where ---+ Pitched_note :: Octave -> Note_name -> Note Pitched ---+ Unpitched_note :: Note Unpitched ---+ -- | Note names. ---+ data Note_name = ---+ C | C_sharp | D_flat | D | D_sharp | E_flat | E | F | F_sharp | G_flat | G | G_sharp | A_flat | A | A_sharp | B_flat | B ---+ -- | Play a new set of notes or continue the previous set of notes. ---+ data Notes note_type = Notes (Set (Note note_type)) | Tie ---+ -- | Octaves in scientific pitch notation. ---+ type Octave = Int ---+ -- | This data type allows you to, for example, mix pitched and unpitched tracks in one list. ---+ data Pitched_or_unpitched f = Pitched (f Pitched) | Unpitched (f Unpitched) ---+ deriving instance Eq Accidental ---+ deriving instance Bounded Accidental+ deriving instance Bounded Natural_note_name ---+ deriving instance Bounded Note_name ---+ deriving instance Enum Accidental+ deriving instance Enum Basic_length+ deriving instance Enum Natural_note_name ---+ instance Enum (Note Pitched) where ---+ fromEnum (Pitched_note octave note_name) = 17 * octave + fromEnum note_name ---+ toEnum i = Pitched_note (div i 17) (toEnum (mod i 17)) ---+ deriving instance Enum Note_name ---+ deriving instance Generic (Event' notes) ---+ deriving instance Eq Basic_length ---+ deriving instance Eq Natural_note_name ---+ deriving instance Eq (Note note_type) ---+ deriving instance Eq Note_name ---+ instance FunctorB Pitched_or_unpitched where ---+ bmap f = pitched_or_unpitched (Pitched <$> f) (Unpitched <$> f) ---+ deriving instance Ord Accidental+ deriving instance Ord Basic_length+ deriving instance Ord Natural_note_name ---+ deriving instance Ord (Note note_type) ---+ deriving instance Ord Note_name ---+ deriving instance Read Natural_note_name+ deriving instance Read Note_name+ deriving instance Show Accidental ---+ deriving instance Show Basic_length ---+ deriving instance Show (Branch note_type) ---+ deriving instance Show Dot ---+ deriving instance Show (Event note_type) ---+ deriving instance (Show notes) => Show (Event' notes)+ deriving instance Show Length ---+ deriving instance Show Natural_note_name ---+ deriving instance Show (Note note_type) ---+ deriving instance Show Note_name ---+ deriving instance Show (Notes note_type) ---+ deriving instance (forall note_type . Show (f note_type)) => Show (Pitched_or_unpitched f) ---+ instance TraversableB Pitched_or_unpitched where ---+ btraverse f = pitched_or_unpitched ((<$>) Pitched <$> f) ((<$>) Unpitched <$> f) ---+ -- | String representations of accidentals. Mostly for internal use.+ accidentals :: [(Accidental, String)]+ accidentals = [(Flat, "b"), (Natural, ""), (Sharp, "#")]+ accidentals' :: [(Accidental, String)]+ accidentals' = [(Flat, "_flat"), (Natural, ""), (Sharp, "_sharp")]+ -- | Convert basic length to fraction denominator. Mostly for internal use. ---+ basic_length_denominator :: Basic_length -> Int ---+ basic_length_denominator len = 2 ^ basic_length_to_lg_denominator len ---+ -- | Convert basic length to fraction. Mostly for internal use. ---+ basic_length_to_fraction :: Basic_length -> Length_fraction ---+ basic_length_to_fraction len = 1 % basic_length_denominator len ---+ basic_length_to_lg_denominator :: Basic_length -> Int ---+ basic_length_to_lg_denominator len = fromJust (lookup len basic_lengths) ---+ basic_lengths :: [(Basic_length, Int)] ---+ basic_lengths = ---+ [ ---+ (Whole, 0), ---+ (Half, 1), ---+ (Quarter, 2), ---+ (Eighth, 3), ---+ (Sixteenth, 4), ---+ (Thirty_second, 5), ---+ (Sixty_fourth, 6), ---+ (One_hundred_and_twenty_eighth, 7)] ---+ -- | Construct the note name from a natural note name and an accidental. Mostly for internal use.+ construct_note_name :: Natural_note_name -> Accidental -> Maybe Note_name+ construct_note_name natural_note_name accidental =+ readMaybe (head (show natural_note_name) : fromJust (lookup accidental accidentals'))+ -- | Deconstruct a note name into the natural note name and the accidental. Mostly for internal use.+ deconstruct_note_name :: Note_name -> (Natural_note_name, Accidental)+ deconstruct_note_name note_name =+ case show note_name of+ "" -> undefined+ natural_note_name : accidental ->+ (read (natural_note_name : "_natural"), fromJust (lookup accidental (swap <$> accidentals')))+ -- | Convert fraction denominator to basic length. Mostly for internal use. ---+ denominator_to_basic_length :: Int -> Maybe Basic_length ---+ denominator_to_basic_length i = lg i >>= lg_denominator_to_basic_length ---+ -- | Events length. ---+ events_length :: [Event' notes] -> Length_fraction ---+ events_length events = sum (view #event_length <$> events) ---+ -- | Convert length to fraction. Mostly for internal use. ---+ length_to_fraction :: Length -> Length_fraction ---+ length_to_fraction (Length len dots) = basic_length_to_fraction len * (2 - 1 % (1 + length dots)) ---+ -- | Binary logarithm. Mostly for internal use. ---+ lg :: Int -> Maybe Int ---+ lg i = ---+ do ---+ check () (i > 0) ---+ lg' i ---+ lg' :: Int -> Maybe Int ---+ lg' i = ---+ case i of ---+ 1 -> Just 0 ---+ _ -> ---+ case mod i 2 of ---+ 0 -> (+) 1 <$> lg' (div i 2) ---+ 1 -> Nothing ---+ _ -> undefined ---+ lg_denominator_to_basic_length :: Int -> Maybe Basic_length ---+ lg_denominator_to_basic_length i = lookup i (swap <$> basic_lengths) ---+ -- | Divide basic note length by two. ---+ next_basic_length :: Basic_length -> Maybe Basic_length ---+ next_basic_length len = lg_denominator_to_basic_length (1 + basic_length_to_lg_denominator len) ---+ -- | Perform an operation that doesn't depend on whether the underlying structure contains pitched or unpitched notes. ---+ pitched_and_unpitched :: (forall note_type . f note_type -> t) -> Pitched_or_unpitched f -> t ---+ pitched_and_unpitched f = pitched_or_unpitched f f ---+ -- | Perform an operation that behaves differently when the underlying structure contains pitched or unpitched notes.+ pitched_or_unpitched :: (f Pitched -> t) -> (f Unpitched -> t) -> Pitched_or_unpitched f -> t+ pitched_or_unpitched f_pitched f_unpitched 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)---------------------------------------------------------------------------------------------------------------------------------+ Pitched x' -> f_pitched x'+ Unpitched x' -> f_unpitched x'+ -- | Scale the length of events. Mostly for internal use. ---+ scale_lengths :: Ratio Int -> [Event' notes] -> [Event' notes] ---+ scale_lengths x events = over #event_length ((*) x) <$> events ---
+ Composition/Parser.hs view
@@ -0,0 +1,496 @@+{-|+Parse the custom file format for scores.+-}+module Composition.Parser (parse) where+ import Composition.Errors+ import Composition.Notes+ import Composition.Score+ import Composition.Time+ import Control.Applicative+ import Control.Monad.Except+ import Control.Monad.Trans.Except+ import Data.Char+ import Data.Functor+ import Data.List as List+ import Data.Map.Strict+ import Data.Maybe+ import Data.Set+ import Data.Tuple+ import Parser.Files+ import Parser.Locations+ import Parser.Parser+ import Parser.Utilities+ import Text.Read+ data Char_class =+ Delimiter_char Token |+ Invalid_char |+ Letter_char Char |+ Minus_char |+ Nonzero_nat_char Char |+ Newline_char |+ Quote_char |+ Whitespace_char |+ Zero_char+ type Parser = Parser' Token Error+ data Token =+ Clef_and_stave_token |+ Clef_name_name_token |+ Clef_name_value_token Clef_name |+ Clef_token |+ Clefs_and_staves_token |+ Dot_token |+ Eq_token |+ Header_field_token Header_field |+ Header_token |+ Initial_position_token |+ Instrument_clefs_and_staves_token |+ Instrument_name_token |+ Key_token |+ Left_curly_bracket_token |+ Left_square_bracket_token |+ MIDI_instrument_token |+ Negative_int_token Int |+ Note_name_token Note_name |+ Part_token |+ Parts_token |+ Percussion_clef_token |+ Pitched_clef_token |+ Pitched_token |+ Positive_int_token Int |+ Right_curly_bracket_token |+ Right_square_bracket_token |+ Score_token |+ Slash_token |+ Stave_groups_token |+ Stave_token |+ Tempo_token |+ Text_token String |+ Tie_token |+ Time_name_token |+ Time_value_token |+ Title_token |+ Transposition_token |+ Unpitched_note_token |+ Unpitched_token |+ Velocity_token |+ Zero_token+ type Tokeniser = Tokeniser' Char_class Token Error+ deriving instance Eq Char_class+ deriving instance Eq Token+ deriving instance Ord Token+ deriving instance Show Char_class+ deriving instance Show Token+ classify_char :: Char -> Char_class+ classify_char c =+ case c of+ '\n' -> Newline_char+ ' ' -> Whitespace_char+ _ | elem c "!#$%&'()*,:;<>?@^_`|~" || isLetter c -> Letter_char c+ '"' -> Quote_char+ _ | elem c (fst <$> delimiters) -> Delimiter_char (fromJust (List.lookup c delimiters))+ '-' -> Minus_char+ '0' -> Zero_char+ _ | isDigit c && c /= '0' -> Nonzero_nat_char c+ '=' -> Delimiter_char Eq_token+ _ -> Invalid_char+ clef_name_token :: Token -> Maybe Clef_name+ clef_name_token token =+ case token of+ Clef_name_value_token clef_name -> Just clef_name+ _ -> Nothing+ construct_basic_length :: Int -> Either (Location -> Error) Basic_length+ construct_basic_length len =+ case denominator_to_basic_length len of+ Nothing -> Left Invalid_note_length+ Just len' -> Right len'+ construct_header :: [(Header_field, String)] -> Either (Location -> Error) (Map Header_field String)+ construct_header header =+ case construct_map header of+ Nothing -> Left Duplicate_header_fields+ Just header' -> Right header'+ construct_key :: [Note_name] -> Either (Location -> Error) (Set Note_name)+ construct_key key =+ case construct_set key of+ Nothing -> Left Duplicate_note_names_in_key_signature+ Just key' -> Right key'+ construct_notes :: [Note note_type] -> Either (Location -> Error) (Notes note_type)+ construct_notes notes =+ case construct_set notes of+ Nothing -> Left Duplicate_notes+ Just notes' -> Right (Notes (notes'))+ construct_word :: String -> Either (Location -> Error) Token+ construct_word word =+ (case construct_clef_name <|> construct_header_field <|> construct_keyword <|> construct_note_name' of+ Nothing -> Left (Invalid_word word)+ Just token -> Right token) where+ construct_clef_name :: Maybe Token+ construct_clef_name = Clef_name_value_token <$> readMaybe word+ construct_header_field :: Maybe Token+ construct_header_field = Header_field_token <$> readMaybe word+ construct_keyword :: Maybe Token+ construct_keyword =+ case word of+ "Clef_and_stave" -> Just Clef_and_stave_token+ "Instrument_clefs_and_staves" -> Just Instrument_clefs_and_staves_token+ "Part" -> Just Part_token+ "Percussion_clef" -> Just Percussion_clef_token+ "Pitched" -> Just Pitched_token+ "Pitched_clef" -> Just Pitched_clef_token+ "Score" -> Just Score_token+ "Time" -> Just Time_value_token+ "Unpitched" -> Just Unpitched_token+ "clef" -> Just Clef_token+ "clef_name" -> Just Clef_name_name_token+ "clefs_and_staves" -> Just Clefs_and_staves_token+ "header" -> Just Header_token+ "initial_position" -> Just Initial_position_token+ "instrument_name" -> Just Instrument_name_token+ "key" -> Just Key_token+ "midi_instrument" -> Just MIDI_instrument_token+ "parts" -> Just Parts_token+ "stave" -> Just Stave_token+ "stave_groups" -> Just Stave_groups_token+ "tempo" -> Just Tempo_token+ "time" -> Just Time_name_token+ "title" -> Just Title_token+ "transposition" -> Just Transposition_token+ "velocity" -> Just Velocity_token+ "x" -> Just Unpitched_note_token+ _ -> Nothing+ construct_note_name' :: Maybe Token+ construct_note_name' =+ case word of+ "" -> Nothing+ natural_note_name : accidental ->+ do+ natural_note_name' <- read_natural_note_name natural_note_name+ accidental' <- read_accidental accidental+ Note_name_token <$> construct_note_name natural_note_name' accidental'+ convert_midi_instrument :: Int -> Either (Location -> Error) MIDI_instrument+ convert_midi_instrument midi_instrument =+ do+ check (Is_out_of_range_with_location MIDI_instrument_code_IOOR) (between 0 127 midi_instrument)+ Right (fromIntegral midi_instrument)+ convert_time_numerator_factor :: Int -> Either (Location -> Error) Time_numerator_factor+ convert_time_numerator_factor time_numerator_factor =+ case int_to_time_numerator_factor time_numerator_factor of+ Nothing -> Left Invalid_time_numerator_factor+ Just time_numerator_factor' -> Right time_numerator_factor'+ convert_velocity :: Int -> Either (Location -> Error) Velocity+ convert_velocity velocity =+ do+ check Velocity_out_of_range (between 0 (fromIntegral max_velocity) velocity)+ Right (fromIntegral velocity)+ delimiter_char :: Char_class -> Maybe Token+ delimiter_char char_class =+ case char_class of+ Delimiter_char token -> Just token+ _ -> Nothing+ delimiters :: [(Char, Token)]+ delimiters =+ [+ ('+', Tie_token),+ ('.', Dot_token),+ ('/', Slash_token),+ ('=', Eq_token),+ ('[', Left_square_bracket_token),+ (']', Right_square_bracket_token),+ ('{', Left_curly_bracket_token),+ ('}', Right_curly_bracket_token)]+ header_field_token :: Token -> Maybe Header_field+ header_field_token token =+ case token of+ Header_field_token header_field -> Just header_field+ _ -> Nothing+ letter_char :: Char_class -> Maybe Char+ letter_char char_class =+ case char_class of+ Letter_char c -> Just c+ _ -> Nothing+ nat_char :: Char_class -> Maybe Char+ nat_char char_class =+ case char_class of+ Zero_char -> Just '0'+ Nonzero_nat_char c -> Just c+ _ -> Nothing+ negative_int_token :: Token -> Maybe Int+ negative_int_token token =+ case token of+ Negative_int_token i -> Just i+ _ -> Nothing+ next_location :: Char_class -> Location -> Location+ next_location char_class =+ case char_class of+ Newline_char -> next_line+ _ -> next_char+ nonzero_nat_char :: Char_class -> Maybe Char+ nonzero_nat_char char_class =+ case char_class of+ Nonzero_nat_char c -> Just c+ _ -> Nothing+ note_name_token :: Token -> Maybe Note_name+ note_name_token token =+ case token of+ Note_name_token note_name -> Just note_name+ _ -> Nothing+ parse :: File_path -> ExceptT Error IO Score+ parse file_path =+ do+ score <- read_file "aoi" readFile File_error file_path+ except (fromJust (parse' classify_char next_location tokenise parse_score Parse_error score))+ parse_basic_length :: Parser Basic_length+ parse_basic_length = fmap_filter_parser construct_basic_length parse_positive_int+ parse_clef_name :: Parser Clef_name+ parse_clef_name = parse_token' clef_name_token+ parse_curly_brackets :: Parser t -> Parser t+ parse_curly_brackets = parse_brackets Left_curly_bracket_token Right_curly_bracket_token+ parse_dot :: Parser Dot+ parse_dot =+ do+ parse_token Dot_token+ return Dot+ parse_eq :: Parser ()+ parse_eq = parse_token Eq_token+ parse_field :: Token -> Parser t -> Parser t+ parse_field name parse_t =+ do+ parse_token name+ parse_eq+ parse_t+ parse_header :: Parser (Map Header_field String)+ parse_header = fmap_filter_parser construct_header (parse_list' parse_header_field)+ parse_header_field :: Parser (Header_field, String)+ parse_header_field =+ do+ name <- parse_header_field_name+ parse_eq+ value <- parse_text+ return (name, value)+ parse_header_field_name :: Parser Header_field+ parse_header_field_name = parse_token' header_field_token+ parse_initial_position :: Parser Initial_position+ parse_initial_position = parse_zero_initial_position <+> parse_nonzero_initial_position+ parse_instrument_clefs_and_staves :: Parser (Pitched_or_unpitched Instrument_clefs_and_staves)+ parse_instrument_clefs_and_staves =+ (+ Pitched <$> parse_instrument_clefs_and_staves' Branch_pitched <+>+ Unpitched <$> parse_instrument_clefs_and_staves' Branch_unpitched)+ parse_instrument_clefs_and_staves' :: forall note_type . Branch note_type -> Parser (Instrument_clefs_and_staves note_type)+ parse_instrument_clefs_and_staves' branch =+ do+ parse_pitched_or_unpitched+ parse_struct+ Instrument_clefs_and_staves_token+ (do+ instrument_name <- parse_field Instrument_name_token parse_text+ midi_instrument <- parse_field MIDI_instrument_token parse_midi_instrument+ velocity <- parse_field Velocity_token parse_velocity+ clefs_and_staves <- parse_field Clefs_and_staves_token (parse_list' parse_clef_and_stave)+ return (Instrument_clefs_and_staves {instrument_name, midi_instrument, velocity, clefs_and_staves})) where+ parse_clef :: Parser (Clef note_type)+ parse_clef =+ case branch of+ Branch_pitched -> parse_pitched_clef+ Branch_unpitched -> parse_unpitched_clef+ parse_clef_and_stave :: Parser (Clef_and_stave note_type)+ parse_clef_and_stave =+ parse_struct+ Clef_and_stave_token+ (do+ clef <- parse_field Clef_token parse_clef+ stave <- parse_field Stave_token parse_stave+ return (Clef_and_stave {clef, stave}))+ parse_event :: Parser (Event note_type)+ parse_event = parse_event' <+> parse_triplet+ parse_event' :: Parser (Event note_type)+ parse_event' = Event <$> parse_notes <*> parse_length+ parse_events :: Parser [Event note_type]+ parse_events = parse_list' parse_event+ parse_note :: Parser (Note note_type)+ parse_note =+ case branch of+ Branch_pitched -> parse_pitched_note+ Branch_unpitched -> parse_unpitched_note+ parse_notes :: Parser (Notes note_type)+ parse_notes = parse_notes' <+> parse_tie+ parse_notes' :: Parser (Notes note_type)+ parse_notes' = fmap_filter_parser construct_notes (parse_list' parse_note)+ parse_one_track :: Parser (Stave note_type)+ parse_one_track = One_track <$> parse_events+ parse_pitched_or_unpitched :: Parser ()+ parse_pitched_or_unpitched = parse_token' pitched_or_unpitched_token+ parse_stave :: Parser (Stave note_type)+ parse_stave = parse_square_brackets (parse_one_track <+> parse_two_tracks)+ parse_triplet :: Parser (Event note_type)+ parse_triplet = Triplet <$> parse_events+ parse_two_tracks :: Parser (Stave note_type)+ parse_two_tracks = Two_tracks <$> parse_events <*> parse_events+ pitched_or_unpitched_token :: Token -> Maybe ()+ pitched_or_unpitched_token token =+ case (branch, token) of+ (Branch_pitched, Pitched_token) -> Just ()+ (Branch_unpitched, Unpitched_token) -> Just ()+ _ -> Nothing+ parse_int :: Parser Int+ parse_int = parse_negative_int <+> parse_nat+ parse_key :: Parser Key+ parse_key = fmap_filter_parser construct_key (parse_list' parse_note_name)+ parse_length :: Parser Length+ parse_length = Length <$> parse_basic_length <*> parse_many parse_dot+ parse_list' :: Parser t -> Parser [t]+ parse_list' parse_t = parse_square_brackets (parse_many parse_t)+ parse_midi_instrument :: Parser MIDI_instrument+ parse_midi_instrument = fmap_filter_parser convert_midi_instrument parse_nat+ parse_nat :: Parser Int+ parse_nat = parse_zero <+> parse_positive_int+ parse_negative_int :: Parser Int+ parse_negative_int = parse_token' negative_int_token+ parse_nonzero_initial_position :: Parser Initial_position+ parse_nonzero_initial_position =+ do+ num <- parse_positive_int+ parse_slash+ den <- parse_basic_length+ return (Initial_position num den)+ parse_note_name :: Parser Note_name+ parse_note_name = parse_token' note_name_token+ parse_part :: Parser Part+ parse_part =+ parse_struct+ Part_token+ (do+ title <- parse_field Title_token parse_text+ key <- parse_field Key_token parse_key+ time <- parse_field Time_name_token parse_time+ initial_position <- parse_field Initial_position_token parse_initial_position+ tempo <- parse_field Tempo_token parse_positive_int+ stave_groups <- parse_field Stave_groups_token (parse_list' (parse_list' parse_instrument_clefs_and_staves))+ return (Part {title, key, time, initial_position, tempo, stave_groups}))+ parse_pitched_clef :: Parser (Clef Pitched)+ parse_pitched_clef =+ parse_struct+ Pitched_clef_token+ (do+ clef_name <- parse_field Clef_name_name_token parse_clef_name+ transposition <- parse_field Transposition_token parse_int+ return (Pitched_clef {clef_name, transposition}))+ parse_pitched_note :: Parser (Note Pitched)+ parse_pitched_note = flip Pitched_note <$> parse_note_name <*> parse_int+ parse_positive_int :: Parser Int+ parse_positive_int = parse_token' positive_int_token+ parse_score :: Parser Score+ parse_score =+ parse_struct+ Score_token+ (do+ title <- parse_field Title_token parse_text+ header <- parse_field Header_token parse_header+ parts <- parse_field Parts_token (parse_list' parse_part)+ return (Score {title, header, parts}))+ parse_slash :: Parser ()+ parse_slash = parse_token Slash_token+ parse_square_brackets :: Parser t -> Parser t+ parse_square_brackets = parse_brackets Left_square_bracket_token Right_square_bracket_token+ parse_struct :: Token -> Parser t -> Parser t+ parse_struct name parse_fields =+ do+ parse_token name+ parse_curly_brackets parse_fields+ parse_text :: Parser String+ parse_text = parse_token' text_token+ parse_tie :: Parser (Notes note_type)+ parse_tie =+ do+ parse_token Tie_token+ return Tie+ parse_time :: Parser Time+ parse_time =+ do+ parse_token Time_value_token+ num <- parse_list' parse_time_numerator_factor+ den <- parse_basic_length+ return (Time num den)+ parse_time_numerator_factor :: Parser Time_numerator_factor+ parse_time_numerator_factor = fmap_filter_parser convert_time_numerator_factor parse_positive_int+ parse_unpitched_clef :: Parser (Clef Unpitched)+ parse_unpitched_clef =+ do+ parse_token Percussion_clef_token+ return Percussion_clef+ parse_unpitched_note :: Parser (Note Unpitched)+ parse_unpitched_note =+ do+ parse_token Unpitched_note_token+ return Unpitched_note+ parse_velocity :: Parser Velocity+ parse_velocity = fmap_filter_parser convert_velocity parse_nat+ parse_zero :: Parser Int+ parse_zero =+ do+ parse_token Zero_token+ return 0+ parse_zero_initial_position :: Parser Initial_position+ parse_zero_initial_position =+ do+ _ <- parse_zero+ return (Initial_position 0 Whole)+ positive_int_token :: Token -> Maybe Int+ positive_int_token token =+ case token of+ Positive_int_token i -> Just i+ _ -> Nothing+ read_accidental :: String -> Maybe Accidental+ read_accidental accidental = List.lookup accidental (swap <$> accidentals)+ read_natural_note_name :: Char -> Maybe Natural_note_name+ read_natural_note_name natural_note_name = readMaybe (natural_note_name : "_natural")+ text_char :: Char_class -> Maybe Char+ text_char char_class =+ case char_class of+ Delimiter_char token -> List.lookup token (swap <$> delimiters)+ Invalid_char -> Nothing+ Letter_char c -> Just c+ Minus_char -> Just '-'+ Nonzero_nat_char c -> Just c+ Newline_char -> Nothing+ Quote_char -> Nothing+ Whitespace_char -> Just ' '+ Zero_char -> Just '0'+ text_token :: Token -> Maybe String+ text_token token =+ case token of+ Text_token text -> Just text+ _ -> Nothing+ tokenise :: Tokeniser ()+ tokenise = void (parse_many tokenise_1)+ tokenise_1 :: Tokeniser ()+ tokenise_1 =+ tokenise_delimiter <+> tokenise_int <+> tokenise_newline <+> tokenise_text <+> tokenise_whitespace <+> tokenise_word+ tokenise_delimiter :: Tokeniser ()+ tokenise_delimiter = add_token (parse_token' delimiter_char)+ tokenise_int :: Tokeniser ()+ tokenise_int = add_token (tokenise_negative_int <+> tokenise_zero <+> tokenise_positive_int)+ tokenise_negative_int :: Tokeniser Token+ tokenise_negative_int =+ do+ parse_token Minus_char+ i <- tokenise_positive_int'+ return (Negative_int_token (negate i))+ tokenise_newline :: Tokeniser ()+ tokenise_newline = parse_token Newline_char+ tokenise_positive_int :: Tokeniser Token+ tokenise_positive_int = Positive_int_token <$> tokenise_positive_int'+ tokenise_positive_int' :: Tokeniser Int+ tokenise_positive_int' = read <$> ((:) <$> parse_token' nonzero_nat_char <*> parse_many (parse_token' nat_char))+ tokenise_text :: Tokeniser ()+ tokenise_text = add_token (Text_token <$> tokenise_quotes (parse_many (parse_token' text_char)))+ tokenise_quotes :: Tokeniser t -> Tokeniser t+ tokenise_quotes = parse_brackets Quote_char Quote_char+ tokenise_whitespace :: Tokeniser ()+ tokenise_whitespace = parse_token Whitespace_char+ tokenise_word :: Tokeniser ()+ tokenise_word = add_token (fmap_filter_parser construct_word (parse_some (parse_token' letter_char)))+ tokenise_zero :: Tokeniser Token+ tokenise_zero =+ do+ parse_token Zero_char+ return Zero_token
+ Composition/Score.hs view
@@ -0,0 +1,301 @@+{-| ---+Description: Lilypond + MIDI capable scores. ---+ ---+* Lilypond + MIDI capable scores ---+-} ---+module Composition.Score ( ---+ Clef (..), ---+ Clef_and_stave (..), ---+ Clef_name (..), ---+ Header_field (..), ---+ Instrument_clefs_and_staves (..), ---+ Key, ---+ MIDI_instrument, ---+ Part (..), ---+ Score (..), ---+ Stave (..), ---+ Tempo, ---+ Track (..), ---+ Velocity, ---+ max_velocity, ---+ notate, ---+ remove_notational_information, ---+ stave_to_events, ---+ tracks_length) where ---+ import Composition.Errors ---+ import Composition.Notes ---+ import Composition.Theory ---+ import Composition.Time ---+ import Control.Monad ---+ import Data.Fixed ---+ import Data.Foldable ---+ import Data.Functor.Barbie ---+ import Data.Map.Strict ---+ import Data.Maybe ---+ import Data.Ratio ---+ import Data.Set as Set ---+ import Data.Word ---+ import GHC.Real ---+ import Parser.Utilities ---+ -- | Clefs (with transposition). ---+ data Clef note_type where ---+ Pitched_clef :: {clef_name :: Clef_name, transposition :: Steps} -> Clef Pitched ---+ Percussion_clef :: Clef Unpitched ---+ -- | Clef names. ---+ data Clef_name = Subbass | Bass | Baritone_F | Baritone_C | Tenor | Alto | Mezzosoprano | Soprano | Treble | French ---+ -- | Stave with clef. ---+ data Clef_and_stave note_type = Clef_and_stave {clef :: Clef note_type, stave :: Stave note_type} ---+ -- Score header fields. ---+ data Header_field = Composer | Instrument | Subtitle ---+ -- | A group of staves for one instrument. ---+ data Instrument_clefs_and_staves note_type = ---+ Instrument_clefs_and_staves { ---+ instrument_name :: String, ---+ midi_instrument :: MIDI_instrument, ---+ velocity :: Velocity, ---+ clefs_and_staves :: [Clef_and_stave note_type]} ---+ -- | A set of note names that serves as a key signature. For example, the key signature of C minor would be @[E_flat, A_flat, ---+ -- B_flat]@. Naturals and conflicting accidentals will result in an error. ---+ type Key = Set Note_name ---+ -- MIDI instrument code. ---+ type MIDI_instrument = Word8 ---+ data Notate_notes note_type = Notate_rest | Notate_notes (Set (Note note_type)) | Notate_tie ---+ -- | Each part can have a different key, time signature and instrumentation. ---+ data Part = ---+ Part { ---+ title :: String, ---+ key :: Key, ---+ time :: Time, ---+ initial_position :: Initial_position, ---+ tempo :: Tempo, ---+ stave_groups :: [[Pitched_or_unpitched Instrument_clefs_and_staves]]} ---+ -- A Lilypond + MIDI capable score. ---+ data Score = Score {title :: String, header :: Map Header_field String, parts :: [Part]} ---+ -- | A stave with one or two voices. Rhythmically independent voices require separate tracks. ---+ data Stave note_type = One_track [Event note_type] | Two_tracks [Event note_type] [Event note_type] ---+ -- | Tempo in beats per minute. ---+ type Tempo = Int ---+ -- | Tracks stripped of notational information (brackets, instrument names, clefs and note length display information). Mostly ---+ -- for internal use. ---+ data Track note_type = Track {instrument :: MIDI_instrument, velocity :: Velocity, events :: [Event_fraction note_type]} ---+ -- | MIDI volume ranges from 0 to 127. ---+ type Velocity = Word8 ---+ deriving instance Eq Clef_name ---+ deriving instance Eq Header_field ---+ deriving instance Ord Clef_name ---+ deriving instance Ord Header_field ---+ deriving instance Read Clef_name+ deriving instance Read Header_field+ deriving instance Show (Clef note_type) ---+ deriving instance Show (Clef_and_stave note_type) ---+ deriving instance Show Clef_name ---+ deriving instance Show Header_field ---+ deriving instance Show (Instrument_clefs_and_staves note_type) ---+ deriving instance Show (Notate_notes note_type) ---+ deriving instance Show Part ---+ deriving instance Show Score ---+ deriving instance Show (Stave note_type) ---+ deriving instance Show (Track note_type) ---+ check_length :: Event' notes -> Either Error () ---+ check_length (Event' _ (num :% den)) = ---+ do ---+ check Non_positive_note_length (0 < num) ---+ check Note_length_denominator_contains_factors_other_than_2_and_3 (is_smooth [2, 3] den) ---+ return () ---+ is_smooth :: [Int] -> Int -> Bool ---+ is_smooth factors i = ---+ case i of ---+ 1 -> True ---+ _ -> ---+ case factors of ---+ [] -> False ---+ factor : factors' -> is_smooth factors' (remove_factor factor i) ---+ join_events :: [Event' (Notes note_type)] -> [Event_fraction note_type] ---+ join_events events = ---+ case events of ---+ [] -> [] ---+ Event' notes len : events' -> join_events' (Event' (notes_to_set notes) len) events' ---+ join_events' :: Event_fraction note_type -> [Event' (Notes note_type)] -> [Event_fraction note_type] ---+ join_events' (Event' notes_0 len_0) events = ---+ case events of ---+ [] -> [Event' notes_0 len_0] ---+ Event' maybe_notes_1 len_1 : events' -> ---+ case join_notes notes_0 maybe_notes_1 of ---+ Nothing -> join_events' (Event' notes_0 (len_0 + len_1)) events' ---+ Just notes_1' -> Event' notes_0 len_0 : join_events' (Event' notes_1' len_1) events' ---+ join_notes :: Set (Note note_type) -> Notes note_type -> Maybe (Set (Note note_type)) ---+ join_notes notes_0 maybe_notes_1 = ---+ case maybe_notes_1 of ---+ Notes notes_1 -> ---+ case (Set.elems notes_0, Set.elems notes_1) of ---+ ([], []) -> Nothing ---+ _ -> Just notes_1 ---+ Tie -> Nothing ---+ -- | Maximum MIDI volume. ---+ max_velocity :: Velocity ---+ max_velocity = 127 ---+ -- | Add note length display information to events. Mostly for internal use. ---+ notate :: Time -> Initial_position -> [Event_fraction note_type] -> Either Error [Event note_type] ---+ notate time initial_position events = ---+ do ---+ traverse_ check_length events ---+ notate_events time (initial_position_to_fraction initial_position) (transform_event <$> events) ---+ notate_basic_length :: Length_fraction -> Maybe Basic_length ---+ notate_basic_length (num :% den) = ---+ case num of ---+ 1 -> ---+ case den of ---+ 1 -> Just Whole ---+ 2 -> Just Half ---+ 4 -> Just Quarter ---+ 8 -> Just Eighth ---+ 16 -> Just Sixteenth ---+ 32 -> Just Thirty_second ---+ 64 -> Just Sixty_fourth ---+ 128 -> Just One_hundred_and_twenty_eighth ---+ _ -> Nothing ---+ _ -> Nothing ---+ notate_binary_block :: Time -> (Position, [Event' (Notate_notes note_type)]) -> Either Error [Event note_type] ---+ notate_binary_block time (position, events) = ---+ case events of ---+ [event] -> notate_event time position event ---+ _ -> ---+ let ---+ num :% den = events_length events in ---+ ( ---+ (\ evs -> [Triplet evs]) <$> ---+ case num of ---+ 1 -> ---+ case denominator_to_basic_length (2 * den) of ---+ Nothing -> Left (Is_out_of_range_without_location Note_length_denominator_IOOR) ---+ Just den' -> notate_measure (Time [Three] den') (0, scale_lengths (3 % 2) events) ---+ _ -> ---+ do ---+ time' <- time_subdivision time ---+ notate_events time' (mod' position (measure_length time')) events) ---+ notate_event :: Time -> Position -> Event' (Notate_notes note_type) -> Either Error [Event note_type] ---+ notate_event time position event@(Event' notes len) = ---+ case notate_simple_length len of ---+ Nothing -> ---+ do ---+ time' <- time_subdivision time ---+ notate_events time' (mod' position (measure_length time')) [event] ---+ Just len' -> Right [Event (notate_notes notes) len'] ---+ notate_events :: Time -> Position -> [Event' (Notate_notes note_type)] -> Either Error [Event note_type] ---+ notate_events time position events = join <$> traverse (notate_measure time) (separate_measures time position events) ---+ notate_measure :: Time -> (Position, [Event' (Notate_notes note_type)]) -> Either Error [Event note_type] ---+ notate_measure time (position, events) = ---+ do ---+ binary_blocks <- separate_binary_blocks time position events ---+ join <$> traverse (notate_binary_block time) binary_blocks ---+ notate_notes :: Notate_notes note_type -> Notes note_type ---+ notate_notes notes = ---+ case notes of ---+ Notate_rest -> Notes Set.empty ---+ Notate_notes notes' -> Notes notes' ---+ Notate_tie -> Tie ---+ notate_simple_length :: Length_fraction -> Maybe Length ---+ notate_simple_length (num :% den) = ---+ do ---+ dots <- (\ i -> i - 1) <$> lg (1 + num) ---+ basic_length <- notate_basic_length (2 ^ dots % den) ---+ Just (Length basic_length (replicate dots Dot)) ---+ notes_tie :: Notate_notes note_type -> Notate_notes note_type ---+ notes_tie notes = ---+ case notes of ---+ Notate_rest -> Notate_rest ---+ Notate_notes _ -> Notate_tie ---+ Notate_tie -> Notate_tie ---+ notes_to_set :: Notes note_type -> Set (Note note_type) ---+ notes_to_set maybe_notes = ---+ case maybe_notes of ---+ Notes notes -> notes ---+ Tie -> Set.empty ---+ remove_factor :: Int -> Int -> Int ---+ remove_factor factor i = ---+ case mod i factor of ---+ 0 -> remove_factor factor (div i factor) ---+ _ -> i ---+ -- | Strip tracks of notational information (brackets, instrument names, clefs, note length display information). Mostly for ---+ -- internal use. ---+ remove_notational_information :: [[Pitched_or_unpitched Instrument_clefs_and_staves]] -> [Pitched_or_unpitched Track] ---+ remove_notational_information stave_groups = ---+ stave_groups >>= flip (>>=) (btraverse remove_notational_information_instrument_clefs_and_staves) ---+ remove_notational_information_clef_and_stave :: Clef_and_stave note_type -> [[Event_fraction note_type]] ---+ remove_notational_information_clef_and_stave (Clef_and_stave {stave}) = ---+ remove_notational_information_events <$> stave_to_events stave ---+ remove_notational_information_events :: [Event note_type] -> [Event_fraction note_type] ---+ remove_notational_information_events events = join_events (remove_notational_information_events' events) ---+ remove_notational_information_events' :: [Event note_type] -> [Event' (Notes note_type)] ---+ remove_notational_information_events' events = events >>= remove_notational_information_event ---+ remove_notational_information_event :: Event note_type -> [Event' (Notes note_type)] ---+ remove_notational_information_event event = ---+ case event of ---+ Event notes len -> [Event' notes (length_to_fraction len)] ---+ Triplet events -> scale_lengths (2 % 3) (remove_notational_information_events' events) ---+ remove_notational_information_instrument_clefs_and_staves :: Instrument_clefs_and_staves note_type -> [Track note_type] ---+ remove_notational_information_instrument_clefs_and_staves ---+ (Instrument_clefs_and_staves {midi_instrument, velocity, clefs_and_staves}) = ---+ ( ---+ (\ events -> Track {instrument = midi_instrument, velocity, events}) <$> ---+ (clefs_and_staves >>= remove_notational_information_clef_and_stave)) ---+ separate_binary_blocks :: ---+ Time -> Position -> [Event' (Notate_notes note_type)] -> Either Error [(Position, [Event' (Notate_notes note_type)])] ---+ separate_binary_blocks time position events = ---+ case events of ---+ [] -> Right [] ---+ event@(Event' _ len) : events' -> ---+ do ---+ let position' = position + len ---+ case is_smooth [2] (denominator position') of ---+ False -> ---+ do ---+ binary_blocks <- separate_binary_blocks time position' events' ---+ case binary_blocks of ---+ [] -> Left Track_ends_with_an_incomplete_triplet ---+ (_, events'') : binary_blocks' -> Right ((position, event : events'') : binary_blocks') ---+ True -> (:) (position, [event]) <$> separate_binary_blocks time position' events' ---+ separate_measures :: ---+ Time -> Position -> [Event' (Notate_notes note_type)] -> [(Length_fraction, [Event' (Notate_notes note_type)])] ---+ separate_measures time initial_position events = ---+ case separate_measures' time initial_position events of ---+ [] -> [] ---+ measure : measures' -> (initial_position, measure) : ((,) 0 <$> measures') ---+ separate_measures' :: Time -> Position -> [Event' (Notate_notes note_type)] -> [[Event' (Notate_notes note_type)]] ---+ separate_measures' time position events = ---+ case events of ---+ [] -> [] ---+ Event' notes len : events' -> ---+ let ---+ position' = position + len in ---+ case compare position' (measure_length time) of ---+ LT -> ---+ case separate_measures' time position' events' of ---+ [] -> [[Event' notes len]] ---+ measure : measures -> (Event' notes len : measure) : measures ---+ EQ -> [Event' notes len] : separate_measures' time 0 events' ---+ GT -> ---+ let ---+ len' = measure_length time - position in ---+ [Event' notes len'] : separate_measures' time 0 (Event' (notes_tie notes) (len - len') : events') ---+ -- | Convert the stave to a list of voices. Mostly for internal use. ---+ stave_to_events :: Stave note_type -> [[Event note_type]] ---+ stave_to_events stave = ---+ case stave of ---+ One_track events -> [events] ---+ Two_tracks events_0 events_1 -> [events_0, events_1] ---+ track_length :: Track note_type -> Ratio Int ---+ track_length (Track {events}) = events_length events ---+ -- | Calculate part length. Returns Nothing if there is a track length mismatch. ---+ tracks_length :: [Pitched_or_unpitched Track] -> Either Error Length_fraction ---+ tracks_length tracks = ---+ case all_equal (pitched_and_unpitched track_length <$> tracks) of ---+ Nothing -> Left Track_length_mismatch ---+ Just maybe_len -> Right (fromMaybe 0 maybe_len) ---+ transform_event :: Event_fraction note_type -> Event' (Notate_notes note_type) ---+ transform_event (Event' notes len) = Event' (transform_notes notes) len ---+ transform_notes :: Set (Note note_type) -> Notate_notes note_type ---+ transform_notes notes = ---+ case Set.elems notes of ---+ [] -> Notate_rest ---+ _ -> Notate_notes notes ---
Composition/Theory.hs view
@@ -1,115 +1,179 @@----------------------------------------------------------------------------------------------------------------------------------{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE StandaloneDeriving #-} {-|-Description: A module for basic music theory.--This module contains functions for computing intervals and classifying chords.+Basic music theory. -} module Composition.Theory (+ Interval (..), Interval_name (..),- Interval_number (..),- Interval_quality (..),- accidental_semitones,- compute_interval_name,+ Semitones,+ Steps,+ distance_in_semitones,+ distance_in_steps,+ find_interval,+ interval_to_semitones,+ interval_to_steps,+ intervals_enharmonic, 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+ notes_enharmonic,+ semitones_from_c) where+ import Composition.Notes+ import Data.Maybe+ import Data.Tuple+ -- | Intervals.+ data Interval = Interval Octave Interval_name+ -- | Interval names.+ data Interval_name =+ Twice_diminished_prime |+ Diminished_prime |+ Perfect_prime |+ Diminished_second |+ Augmented_prime |+ Minor_second |+ Twice_augmented_prime |+ Major_second |+ Diminished_third |+ Augmented_second |+ Minor_third |+ Twice_diminished_fourth |+ Twice_augmented_second |+ Major_third |+ Diminished_fourth |+ Augmented_third |+ Perfect_fourth |+ Twice_diminished_fifth |+ Augmented_fourth |+ Diminished_fifth |+ Twice_augmented_fourth |+ Perfect_fifth |+ Diminished_sixth |+ Augmented_fifth |+ Minor_sixth |+ Twice_diminished_seventh |+ Twice_augmented_fifth |+ Major_sixth |+ Diminished_seventh |+ Augmented_sixth |+ Minor_seventh |+ Major_seventh |+ Augmented_seventh+ -- | Distance in semitones.+ type Semitones = Int+ -- | Distance in steps.+ type Steps = Int+ deriving instance Eq Interval+ deriving instance Eq Interval_name+ deriving instance Show Interval 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 =+ accidental_to_semitones :: Accidental -> Semitones+ accidental_to_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 =+ construct_interval_name :: Semitones -> Steps -> Interval_name+ construct_interval_name semitones steps = fromJust (lookup (semitones, steps) (swap <$> interval_names))+ deconstruct_interval_name :: Interval_name -> (Semitones, Steps)+ deconstruct_interval_name interval_name = fromJust (lookup interval_name interval_names)+ -- | The distance in semitones between two notes.+ distance_in_semitones :: Note Pitched -> Note Pitched -> Semitones+ distance_in_semitones note_0 note_1 = interval_to_semitones (find_interval note_0 note_1)+ -- | The distance in steps between two notes.+ distance_in_steps :: Note Pitched -> Note Pitched -> Steps+ distance_in_steps note_0 note_1 = interval_to_steps (find_interval note_0 note_1)+ -- | Note that this function assumes that the inputs are ordered. If the inputs are not ordered the function will return the+ -- complement interval with a negative octave number.+ find_interval :: Note Pitched -> Note Pitched -> Interval+ find_interval (Pitched_note octave_0 note_name_0) (Pitched_note octave_1 note_name_1) =+ Interval+ (+ octave_1 -+ octave_0 -+ case compare (steps_from_c note_name_0) (steps_from_c note_name_1) of+ (LT; EQ) -> 0+ GT -> 1)+ (find_interval_name note_name_0 note_name_1)+ find_interval_name :: Note_name -> Note_name -> Interval_name+ find_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.+ LT -> find_interval_name' note_name_0 note_name_1+ EQ -> Perfect_prime+ GT -> invert_interval_name (find_interval_name' note_name_1 note_name_0)+ find_interval_name' :: Note_name -> Note_name -> Interval_name+ find_interval_name' note_name_0 note_name_1 =+ construct_interval_name+ (semitones_from_c note_name_1 - semitones_from_c note_name_0)+ (steps_from_c note_name_1 - steps_from_c note_name_0)+ interval_name_to_semitones :: Interval_name -> Semitones+ interval_name_to_semitones interval_name = fst (deconstruct_interval_name interval_name)+ interval_name_to_steps :: Interval_name -> Steps+ interval_name_to_steps interval_name = snd (deconstruct_interval_name interval_name)+ interval_names :: [(Interval_name, (Semitones, Steps))]+ interval_names =+ [+ (Twice_diminished_prime, (-2, 0)),+ (Diminished_prime, (-1, 0)),+ (Perfect_prime, (0, 0)),+ (Diminished_second, (0, 1)),+ (Augmented_prime, (1, 0)),+ (Minor_second, (1, 1)),+ (Twice_augmented_prime, (2, 0)),+ (Major_second, (2, 1)),+ (Diminished_third, (2, 2)),+ (Augmented_second, (3, 1)),+ (Minor_third, (3, 2)),+ (Twice_diminished_fourth, (3, 3)),+ (Twice_augmented_second, (4, 1)),+ (Major_third, (4, 2)),+ (Diminished_fourth, (4, 3)),+ (Augmented_third, (5, 2)),+ (Perfect_fourth, (5, 3)),+ (Twice_diminished_fifth, (5, 4)),+ (Augmented_fourth, (6, 3)),+ (Diminished_fifth, (6, 4)),+ (Twice_augmented_fourth, (7, 3)),+ (Perfect_fifth, (7, 4)),+ (Diminished_sixth, (7, 5)),+ (Augmented_fifth, (8, 4)),+ (Minor_sixth, (8, 5)),+ (Twice_diminished_seventh, (8, 6)),+ (Twice_augmented_fifth, (9, 4)),+ (Major_sixth, (9, 5)),+ (Diminished_seventh, (9, 6)),+ (Augmented_sixth, (10, 5)),+ (Minor_seventh, (10, 6)),+ (Major_seventh, (11, 6)),+ (Augmented_seventh, (12, 6))]+ -- | The size of an interval in semitones.+ interval_to_semitones :: Interval -> Semitones+ interval_to_semitones (Interval octave interval_name) = 12 * octave + interval_name_to_semitones interval_name+ -- | The size of an interval in steps.+ interval_to_steps :: Interval -> Steps+ interval_to_steps (Interval octave interval_name) = 7 * octave + interval_name_to_steps interval_name+ -- | Checks whether two intervals are enharmonic.+ intervals_enharmonic :: Interval -> Interval -> Bool+ intervals_enharmonic interval_0 interval_1 = interval_to_semitones interval_0 == interval_to_semitones interval_1+ -- | Invert 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+ invert_interval_name interval_name =+ let+ (semitones, steps) = deconstruct_interval_name interval_name in+ construct_interval_name (invert_interval_semitones steps semitones) (invert_interval_steps steps)+ invert_interval_semitones :: Steps -> Semitones -> Semitones+ invert_interval_semitones steps semitones =+ case steps of+ 0 -> negate semitones+ _ -> 12 - semitones+ invert_interval_steps :: Steps -> Steps+ invert_interval_steps steps = mod (negate steps) 7+ -- | Checks whether two notes are enharmonic.+ notes_enharmonic :: Note Pitched -> Note Pitched -> Bool+ notes_enharmonic note_0 note_1 = 0 == distance_in_semitones note_0 note_1+ -- | Distance from C in semitones.+ semitones_from_c :: Note_name -> Semitones 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+ (natural_note_name, accidental) = deconstruct_note_name note_name in+ semitones_from_c_natural natural_note_name + accidental_to_semitones accidental+ semitones_from_c_natural :: Natural_note_name -> Semitones semitones_from_c_natural natural_note_name = case natural_note_name of C_natural -> 0@@ -119,11 +183,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---------------------------------------------------------------------------------------------------------------------------------+ steps_from_c :: Note_name -> Steps+ steps_from_c note_name = fromEnum (fst (deconstruct_note_name note_name))
+ Composition/Time.hs view
@@ -0,0 +1,70 @@+{-| ---+Description: Rhythmic organisation. ---+ ---+* Time signatures ---+* Note positions ---+* Measure subdivisions ---+-} ---+module Composition.Time ( ---+ Initial_position (..), ---+ Position, ---+ Time (..), ---+ Time_numerator_factor (..), ---+ initial_position_to_fraction, ---+ int_to_time_numerator_factor,+ measure_length, ---+ time_numerator_factor_to_int, ---+ time_numerator_to_int, ---+ time_subdivision) where ---+ import Composition.Errors+ import Composition.Notes+ import Data.Maybe+ import Data.Ratio+ import Data.Tuple+ -- | The timing of the first event relative to the start of the measure. For example, if the piece is in 3/4 and starts with a ---+ -- 1/4 pickup bar, the initial position can be written as @Initial_position 1 Half@ or @Initial_position 2 Quarter@. If the ---+ -- piece starts with a full bar, the numerator is 0 (and you can use any length as the denominator). ---+ data Initial_position = Initial_position Int Basic_length ---+ -- | The position of an event relative to the start of the measure. Mostly for internal use. ---+ type Position = Ratio Int ---+ -- | Time signature numerators are written as a list of factors. For example, 2 is written as @[Two]@, 3 as @[Three]@, 4 as ---+ -- @[Two Two]@, 6 as @[Two Three]@, 8 as @[Two Two Two]@, 9 as @[Three Three]@, 12 as @[Two Two Three]@, and so on. Note that ---+ -- in some applications the order matters. For example, 18 as @[Three Two Three]@ means that the bar is divided into three ---+ -- parts, each part is divided in half and then each half is divided into three parts. But 18 as @[Two Three Three]@ means ---+ -- that the bar is divided in half, each half is divided into three parts and then each part is divided into three parts. This ---+ -- will affect the placement of ties in keyboard transcriptions. ---+ data Time_numerator_factor = Two | Three ---+ -- | Time signatures. For example, 2/2 is written as @Time [Two] Half@, 3/2 as @Time [Three] Half@, 2/4 as @Time [Two] ---+ -- Quarter@, and so on. ---+ data Time = Time [Time_numerator_factor] Basic_length ---+ deriving instance Eq Time_numerator_factor+ deriving instance Show Initial_position+ deriving instance Show Time+ deriving instance Show Time_numerator_factor+ -- | Convert initial position to fraction. Mostly for internal use. ---+ initial_position_to_fraction :: Initial_position -> Position ---+ initial_position_to_fraction (Initial_position num den) = fromIntegral num * basic_length_to_fraction den ---+ -- | Convert int to time numerator factor. Mostly for internal use.+ int_to_time_numerator_factor :: Int -> Maybe Time_numerator_factor+ int_to_time_numerator_factor time_numerator_factor = lookup time_numerator_factor (swap <$> time_numerator_factors)+ -- | The length of one measure. ---+ measure_length :: Time -> Length_fraction ---+ measure_length (Time num den) = fromIntegral (time_numerator_to_int num) * basic_length_to_fraction den ---+ -- | Convert time numerator factor to int. Mostly for internal use.+ time_numerator_factor_to_int :: Time_numerator_factor -> Int+ time_numerator_factor_to_int time_numerator_factor = fromJust (lookup time_numerator_factor time_numerator_factors)+ time_numerator_factors :: [(Time_numerator_factor, Int)]+ time_numerator_factors = [(Two, 2), (Three, 3)]+ -- | Convert time numerator to int. Mostly for internal use. ---+ time_numerator_to_int :: [Time_numerator_factor] -> Int ---+ time_numerator_to_int num = product (time_numerator_factor_to_int <$> num) ---+ -- | Remove the topmost division from time signature. For example, 4/4 gets transformed into 2/4. 1/4 gets transformed into+ -- 1/8. Mostly for internal use.+ time_subdivision :: Time -> Either Error Time+ time_subdivision (Time num den) =+ case num of+ [] ->+ case next_basic_length den of+ Nothing -> Left (Is_out_of_range_without_location Note_length_denominator_IOOR)+ Just den' -> Right (Time [] den')+ _ : num' -> Right (Time num' den)
+ Composition/Write.hs view
@@ -0,0 +1,137 @@+{-| ---+Description: Write the custom file format for scores. ---+ ---+* Write the custom file format for scores. ---+-} ---+module Composition.Write (write) where ---+ import Composition.Errors ---+ import Composition.Notes ---+ import Composition.Score ---+ import Composition.Time ---+ import Control.Monad.Except ---+ import Data.List ---+ import Data.Map ---+ import Data.Set as Set ---+ import Parser.Files ---+ import Parser.Utilities ---+ -- | Encode the score in .aoi format and write it to the specified file. ---+ write :: File_path -> Score -> ExceptT Error IO () ---+ write file_path score = write_file "aoi" writeFile File_error file_path (write_score score) ---+ write_accidental :: Accidental -> String ---+ write_accidental accidental = ---+ case accidental of ---+ Flat -> "b" ---+ Natural -> "" ---+ Sharp -> "#" ---+ write_basic_length :: Basic_length -> String ---+ write_basic_length len = show (basic_length_denominator len) ---+ write_brackets :: String -> String -> String -> String ---+ write_brackets left_bracket right_bracket x = left_bracket <> x <> right_bracket ---+ write_clef :: Clef note_type -> String ---+ write_clef clef = ---+ case clef of ---+ Pitched_clef {clef_name, transposition} -> ---+ write_struct "Pitched_clef" [write_eq "clef_name" (show clef_name), write_eq "transposition" (show transposition)] ---+ Percussion_clef -> "Percussion_clef" ---+ write_clef_and_stave :: Clef_and_stave note_type -> String ---+ write_clef_and_stave (Clef_and_stave {clef, stave}) = ---+ write_struct "Clef_and_stave" [write_eq "clef" (write_clef clef), write_eq "stave" (write_stave stave)] ---+ write_curly_brackets :: String -> String ---+ write_curly_brackets = write_brackets "{" "}" ---+ write_dot :: Dot -> Char ---+ write_dot Dot = '.' ---+ write_eq :: String -> String -> String ---+ write_eq x y = x <-> "=" <-> y ---+ write_event :: Event note_type -> String ---+ write_event event = ---+ case event of ---+ Event notes len -> write_notes notes <> write_length len ---+ Triplet events -> write_events events ---+ write_events :: [Event note_type] -> String ---+ write_events = write_list write_event ---+ write_header :: Map Header_field String -> String ---+ write_header header = write_list write_header_field (assocs header) ---+ write_header_field :: (Header_field, String) -> String ---+ write_header_field (name, value) = write_eq (show name) (write_quotes value) ---+ write_initial_position :: Initial_position -> String ---+ write_initial_position (Initial_position num den) = ---+ case num of ---+ 0 -> "0" ---+ _ -> show num <> "/" <> write_basic_length den ---+ write_instrument_clefs_and_staves :: Instrument_clefs_and_staves note_type -> String ---+ write_instrument_clefs_and_staves ---+ (Instrument_clefs_and_staves {instrument_name, midi_instrument, velocity, clefs_and_staves}) = ---+ write_struct ---+ "Instrument_clefs_and_staves" ---+ [ ---+ write_eq "instrument_name" (write_quotes instrument_name), ---+ write_eq "midi_instrument" (show midi_instrument), ---+ write_eq "velocity" (show velocity), ---+ write_eq "clefs_and_staves" (write_list write_clef_and_stave clefs_and_staves)] ---+ write_key :: Set Note_name -> String ---+ write_key key = write_list write_note_name (Set.elems key) ---+ write_length :: Length -> String ---+ write_length (Length len dots) = write_basic_length len <> (write_dot <$> dots) ---+ write_list :: (t -> String) -> [t] -> String ---+ write_list write_t x = write_square_brackets (intercalate " " (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 note_type -> String ---+ write_note note = ---+ case note of ---+ Pitched_note octave note_name -> write_note_name note_name <> show octave ---+ Unpitched_note -> "x" ---+ write_note_name :: Note_name -> String ---+ write_note_name note_name = ---+ let ---+ (natural_note_name, accidental) = deconstruct_note_name note_name in ---+ write_natural_note_name natural_note_name <> write_accidental accidental ---+ write_notes :: Notes note_type -> String ---+ write_notes maybe_notes = ---+ case maybe_notes of ---+ Notes notes -> write_list write_note (Set.elems notes) ---+ Tie -> "+" ---+ write_part :: Part -> String ---+ write_part (Part {title, key, time, initial_position, tempo, stave_groups}) = ---+ write_struct ---+ "Part" ---+ [ ---+ write_eq "title" (write_quotes title), ---+ write_eq "key" (write_key key), ---+ write_eq "time" (write_time time), ---+ write_eq "initial_position" (write_initial_position initial_position), ---+ write_eq "tempo" (show tempo), ---+ write_eq ---+ "stave_groups" ---+ (write_list (write_list (write_pitched_or_unpitched write_instrument_clefs_and_staves)) stave_groups)] ---+ write_pitched_or_unpitched :: (forall note_type . f note_type -> String) -> Pitched_or_unpitched f -> String ---+ write_pitched_or_unpitched write_f x = ---+ pitched_or_unpitched (\ _ -> "Pitched") (\ _ -> "Unpitched") x <-> pitched_and_unpitched write_f x ---+ write_quotes :: String -> String ---+ write_quotes = write_brackets "\"" "\"" ---+ write_score :: Score -> String ---+ write_score (Score {title, header, parts}) = ---+ write_struct ---+ "Score" ---+ [ ---+ write_eq "title" (write_quotes title), ---+ write_eq "header" (write_header header), ---+ write_eq "parts" (write_list write_part parts)] ---+ write_stave :: Stave note_type -> String ---+ write_stave stave = write_list write_events (stave_to_events stave) ---+ write_square_brackets :: String -> String ---+ write_square_brackets = write_brackets "[" "]" ---+ write_struct :: String -> [String] -> String ---+ write_struct name fields = name <-> write_curly_brackets (intercalate " " fields) ---+ write_time :: Time -> String ---+ write_time (Time num den) = "Time" <-> write_list write_time_numerator_factor num <-> write_basic_length den ---+ write_time_numerator_factor :: Time_numerator_factor -> String ---+ write_time_numerator_factor time_numerator_factor = show (time_numerator_factor_to_int time_numerator_factor) ---
LICENSE view
@@ -1,30 +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. +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.
+ Main.hs view
@@ -0,0 +1,267 @@+module Main (main) where --+ import Composition.Errors --+ import Composition.Lilypond --+ import Composition.MIDI --+ import Composition.Keyboard --+ import Composition.Parser --+ import Composition.Score --+ import Composition.Write --+ import Control.Monad.Except --+ import Control.Monad.Trans.Except --+ import Data.Char --+ import Data.Functor --+ import Data.List --+ import Data.Maybe --+ import Parser.Files --+ import Parser.Locations --+ import Parser.Parser --+ import Parser.Utilities --+ import System.Environment --+ data Char_class = --+ Delimiter_char Token | --+ File_path_char Char | --+ Invalid_char | --+ Keyword_char Char | --+ Nonzero_char Char | --+ Quote_char | --+ Text_char Char | --+ Whitespace_char | --+ Zero_char --+ data Command = --+ Keyboard_command { --+ playable :: File_path, --+ source :: File_path, --+ header_instrument :: Maybe String, --+ midi_instrument :: MIDI_instrument, --+ destination :: File_path} | --+ Lilypond {source :: File_path, destination :: File_path} | --+ MIDI {source :: File_path, destination :: File_path} --+ type Parser = Parser' Token Error --+ data Token = --+ Destination_token | --+ Eq_token | --+ File_path_token String | --+ Instrument_name_token | --+ Keyboard_token | --+ Left_curly_bracket_token | --+ Lilypond_token | --+ MIDI_instrument_token | --+ MIDI_token | --+ Nat_token Integer | --+ Playable_token | --+ Right_curly_bracket_token | --+ Source_token | --+ Text_token String --+ type Tokeniser = Tokeniser' Char_class Token Error --+ deriving instance Eq Char_class --+ deriving instance Eq Token --+ deriving instance Show Char_class --+ deriving instance Show Command --+ deriving instance Show Token --+ classify_char :: Char -> Char_class --+ classify_char c = --+ case c of --+ ' ' -> Whitespace_char --+ _ | elem c "!#$%&'()*+-,:;<>?@[]^`|~" -> Text_char c --+ '"' -> Quote_char --+ _ | elem c "'_" || isLetter c -> Keyword_char c --+ _ | elem c "./" -> File_path_char c --+ '0' -> Zero_char --+ _ | isDigit c && c /= '0' -> Nonzero_char c --+ '=' -> Delimiter_char Eq_token --+ '{' -> Delimiter_char Left_curly_bracket_token --+ '}' -> Delimiter_char Right_curly_bracket_token --+ _ -> Invalid_char --+ construct_keyword :: String -> Either (Location -> Error) Token --+ construct_keyword keyword = --+ case lookup keyword keywords of --+ Nothing -> Left (\ _ -> Invalid_keyword keyword) --+ Just token -> Right token --+ convert_midi_instrument :: Integer -> Either (Location -> Error) MIDI_instrument --+ convert_midi_instrument midi_instrument = --+ do --+ check (Is_out_of_range_with_location MIDI_instrument_code_IOOR) (between 0 127 midi_instrument) --+ Right (fromIntegral midi_instrument) --+ delimiter_char :: Char_class -> Maybe Token --+ delimiter_char char_class = --+ case char_class of --+ Delimiter_char token -> Just token --+ _ -> Nothing --+ file_path_char :: Char_class -> Maybe Char --+ file_path_char char_class = --+ case char_class of --+ File_path_char c -> Just c --+ Keyword_char c -> Just c --+ Nonzero_char c -> Just c --+ Zero_char -> Just '0' --+ _ -> Nothing --+ file_path_token :: Token -> Maybe String --+ file_path_token token = --+ case token of --+ File_path_token file_path -> Just file_path --+ _ -> Nothing --+ keyword_char :: Char_class -> Maybe Char --+ keyword_char char_class = --+ case char_class of --+ Keyword_char c -> Just c --+ _ -> Nothing --+ keywords :: [(String, Token)] --+ keywords = --+ [ --+ ("Keyboard", Keyboard_token), --+ ("Lilypond", Lilypond_token), --+ ("MIDI", MIDI_token), --+ ("destination", Destination_token), --+ ("instrument_name", Instrument_name_token), --+ ("midi_instrument", MIDI_instrument_token), --+ ("playable", Playable_token), --+ ("source", Source_token)] --+ main :: IO () --+ main = --+ do --+ args <- getArgs --+ result <- runExceptT (main' (intercalate " " args)) --+ case result of --+ Left err -> putStrLn (write_error err) --+ Right () -> return () --+ main' :: String -> ExceptT Error IO () --+ main' text = --+ do --+ command <- except (Main.parse text) --+ case command of --+ Keyboard_command {playable = playable_file, source, header_instrument, midi_instrument, destination} -> --+ do --+ playable <- parse_playable playable_file --+ original_score <- Composition.Parser.parse source --+ keyboard_score <- except (keyboard playable header_instrument midi_instrument original_score) --+ write destination keyboard_score --+ Lilypond {source, destination} -> --+ do --+ score <- Composition.Parser.parse source --+ lilypond destination score --+ MIDI {source, destination} -> --+ do --+ score <- Composition.Parser.parse source --+ midi score destination --+ return () --+ nat_char :: Char_class -> Maybe Char --+ nat_char char_class = --+ case char_class of --+ Zero_char -> Just '0' --+ Nonzero_char c -> Just c --+ _ -> Nothing --+ nat_token :: Token -> Maybe Integer --+ nat_token token = --+ case token of --+ Nat_token i -> Just i --+ _ -> Nothing --+ nonzero_char :: Char_class -> Maybe Char --+ nonzero_char char_class = --+ case char_class of --+ Nonzero_char c -> Just c --+ _ -> Nothing --+ parse :: String -> Either Error Command --+ parse command = fromJust (parse' classify_char (return next_char) tokenise parse_command Parse_error command) --+ parse_command :: Parser Command --+ parse_command = parse_keyboard <+> parse_lilypond <+> parse_midi --+ parse_curly_brackets :: Parser t -> Parser t --+ parse_curly_brackets = parse_brackets Left_curly_bracket_token Right_curly_bracket_token --+ parse_eq :: Parser () --+ parse_eq = parse_token Eq_token --+ parse_field :: Token -> Parser t -> Parser t --+ parse_field name parse_t = --+ do --+ parse_token name --+ parse_eq --+ parse_t --+ parse_file_path :: String -> Parser File_path --+ parse_file_path ext = fmap_filter_parser (parse_file_path' (\ err _ -> File_error err) ext) (parse_token' file_path_token) --+ parse_keyboard :: Parser Command --+ parse_keyboard = --+ parse_struct --+ Keyboard_token --+ (do --+ playable <- parse_field Playable_token (parse_file_path "key") --+ source <- parse_field Source_token (parse_file_path "aoi") --+ header_instrument <- parse_optional_field Instrument_name_token parse_text --+ midi_instrument <- parse_field MIDI_instrument_token parse_midi_instrument --+ destination <- parse_field Destination_token (parse_file_path "aoi") --+ return (Keyboard_command {playable, source, header_instrument, midi_instrument, destination})) --+ parse_lilypond :: Parser Command --+ parse_lilypond = --+ parse_struct --+ Lilypond_token --+ (do --+ source <- parse_field Source_token (parse_file_path "aoi") --+ destination <- parse_field Destination_token (parse_file_path "ly") --+ return (Lilypond {source, destination})) --+ parse_midi :: Parser Command --+ parse_midi = --+ parse_struct --+ MIDI_token --+ (do --+ source <- parse_field Source_token (parse_file_path "aoi") --+ destination <- parse_field Destination_token (parse_file_path "mid") --+ return (MIDI {source, destination})) --+ parse_midi_instrument :: Parser MIDI_instrument --+ parse_midi_instrument = fmap_filter_parser convert_midi_instrument parse_nat --+ parse_nat :: Parser Integer --+ parse_nat = parse_token' nat_token --+ parse_optional_field :: Token -> Parser t -> Parser (Maybe t) --+ parse_optional_field name parse_t = parse_default Nothing (Just <$> parse_field name parse_t) --+ parse_struct :: Token -> Parser Command -> Parser Command --+ parse_struct name parse_fields' = --+ do --+ parse_token name --+ parse_curly_brackets parse_fields' --+ parse_text :: Parser String --+ parse_text = parse_token' text_token --+ text_char :: Char_class -> Maybe Char --+ text_char char_class = --+ case char_class of --+ Delimiter_char token -> --+ Just --+ (case token of --+ Eq_token -> '=' --+ Left_curly_bracket_token -> '{' --+ Right_curly_bracket_token -> '}' --+ _ -> undefined) --+ File_path_char c -> Just c --+ Invalid_char -> Nothing --+ Keyword_char c -> Just c --+ Nonzero_char c -> Just c --+ Quote_char -> Nothing --+ Text_char c -> Just c --+ Whitespace_char -> Just ' ' --+ Zero_char -> Just '0' --+ text_token :: Token -> Maybe String --+ text_token token = --+ case token of --+ Text_token text -> Just text --+ _ -> Nothing --+ tokenise :: Tokeniser () --+ tokenise = void (parse_many tokenise_1) --+ tokenise_1 :: Tokeniser () --+ tokenise_1 = --+ tokenise_delimiter <+> ((tokenise_nat <+> tokenise_keyword) <+ tokenise_file_path) <+> tokenise_text <+> tokenise_whitespace --+ tokenise_delimiter :: Tokeniser () --+ tokenise_delimiter = add_token (parse_token' delimiter_char) --+ tokenise_file_path :: Tokeniser () --+ tokenise_file_path = add_token (File_path_token <$> parse_some (parse_token' file_path_char)) --+ tokenise_keyword :: Tokeniser () --+ tokenise_keyword = add_token (fmap_filter_parser construct_keyword (parse_some (parse_token' keyword_char))) --+ tokenise_nat :: Tokeniser () --+ tokenise_nat = add_token (Nat_token <$> (tokenise_zero <+> tokenise_positive_int)) --+ tokenise_positive_int :: Tokeniser Integer --+ tokenise_positive_int = read <$> ((:) <$> parse_token' nonzero_char <*> parse_many (parse_token' nat_char)) --+ tokenise_quotes :: Tokeniser t -> Tokeniser t --+ tokenise_quotes = parse_brackets Quote_char Quote_char --+ tokenise_text :: Tokeniser () --+ tokenise_text = add_token (Text_token <$> tokenise_quotes (parse_many (parse_token' text_char))) --+ tokenise_whitespace :: Tokeniser () --+ tokenise_whitespace = parse_token Whitespace_char --+ tokenise_zero :: Tokeniser Integer --+ tokenise_zero = --+ do --+ parse_token Zero_char --+ return 0 --
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple -main = defaultMain