├── .github └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── README.md ├── breaking-changes.md ├── docs └── GUIDE.md ├── package.json ├── spago.lock ├── spago.yaml ├── src └── Data │ ├── Abc.purs │ └── Abc │ ├── Accidentals.purs │ ├── Canonical.purs │ ├── KeySignature.purs │ ├── Meter.purs │ ├── Midi.purs │ ├── Midi │ ├── Pitch.purs │ ├── RepeatSections.purs │ └── Types.purs │ ├── Normaliser.purs │ ├── Octave.purs │ ├── Optics.purs │ ├── Parser.purs │ ├── Repeats │ ├── Section.purs │ ├── Types.purs │ └── Variant.purs │ ├── Tempo.purs │ ├── Transposition.purs │ ├── UnitNote.purs │ ├── Utils.purs │ └── Voice.purs └── test ├── Abc.purs ├── Accidentals.purs ├── KeySignature.purs ├── Main.purs ├── Metadata.purs ├── Midi.purs ├── Normaliser.purs ├── Octave.purs ├── Optics.purs ├── Tempo.purs ├── Transposition.purs ├── UnitNote.purs ├── Utils.purs └── Voice.purs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [master] 6 | pull_request: 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v4 14 | 15 | - uses: purescript-contrib/setup-purescript@main 16 | with: 17 | purescript: "0.15.15" 18 | spago: "unstable" 19 | 20 | - name: Cache PureScript dependencies 21 | uses: actions/cache@v4 22 | with: 23 | key: ${{ runner.os }}-spago-${{ hashFiles('**/spago.lock') }} 24 | path: | 25 | .spago 26 | output 27 | 28 | - name: Build source 29 | run: spago build --pure 30 | 31 | - name: Run tests 32 | run: spago test --pure 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /deprecated/ 6 | /.psc* 7 | /.psa* 8 | /.purs-repl 9 | /.spago/ 10 | /.metals/ 11 | /.vscode/ 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 John Watson 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | purescript-abc-parser 2 | ===================== 3 | 4 | [![Latest release](http://img.shields.io/github/release/newlandsvalley/purescript-abc-parser.svg)](https://github.com/newlandsvalley/purescript-abc-parser/releases) 5 | 6 | [![Build Status](https://github.com/newlandsvalley/purescript-abc-parser/workflows/CI/badge.svg)](https://github.com/newlandsvalley/purescript-abc-parser/actions) 7 | 8 | 9 | This is a parser for version 2.1 of Chris Walshaw's [ABC Notation](http://abcnotation.com/) which is primarily designed as an interchange format for scores of traditional music. Also included are functions to manipulate the parse tree in order to provide alteration of tempo, transposition, conversion to MIDI etc. 10 | 11 | For more information, see the [guide](https://github.com/newlandsvalley/purescript-abc-parser/blob/master/docs/GUIDE.md). 12 | 13 | Motivation 14 | ---------- 15 | 16 | The goal of this project is not to produce a general purpose parser for all forms of music in a wide variety of computational settings. Rather, it is to provide a tool that will parse an individual traditional tune when presented to it in a browser - either from a file or from keyed input. In particular, the parser is designed to handle the majority of tunes housed in the major Western European collections - particularly [The Session](https://thesession.org/), [FolkWiki](http://www.folkwiki.se/), [Spillefolk](https://spillefolk.dk/nodesamlingen/) and [abcnotation.com](http://abcnotation.com/). 17 | 18 | Consequently, aspects of the spec that apply to other settings or other musical forms will be ignored or curtailed. In addition, parts of the specification marked as _volatile_ will be treated as being non-normative and in some cases ignored. 19 | 20 | It is assumed that it will work in cooperation with other modules which will be responsible for such aspects as editing, displaying or playing the score. It is a particular design aim to support editor applications such that a user may, if she prefers, edit the tune body before even thinking about the headers. 21 | 22 | Support for ABC Version 2.2 23 | --------------------------- 24 | 25 | As far as I can tell, ABC version 2.2 is also supported. Unfortunately, very many sections of this spec are still marked as _volatile_. 26 | 27 | The main changes in the spec are to do with multiple voices and in particular, the manner in which clefs for a variety of (possibly transposing) instruments may be represented. This is not a problem for most traditional music collections. In this parser, clef descriptions (and all other voice properties) are parsed, but left predominantly untyped. 28 | 29 | Support for Polyphony 30 | --------------------- 31 | 32 | There is a degree of support for polyphony in the ```Voice``` module. If the ABC contains multiple ```V:``` (voice) headers, then it gives a separate ABC tune for each voice. These can then be passed to a suitable [polyphonic player](https://github.com/newlandsvalley/purescript-school-of-music/tree/master/polyphonic-player). However, the ```Midi``` module remains monophonic. 33 | 34 | Deviations from the spec 35 | ------------------------ 36 | 37 | * Tunebooks. Only one tune is allowed per file containing text entirely dedicated to that tune. Comsequently the need for ```free text``` or ```embdedded fragments``` does not arise. 38 | * Typeset text. Not supported. It is assumed that any associated score-engraving software will include its own typesetting strategy. 39 | * Chord Symbols. Parsed but ignored (intentionally) in the MIDI module. These tend to sound terrible and, in my opinion, tend to be too dictatorial. 40 | * Decorations are supported against bar lines, notes and chords but are not currently supported against (the start of) tuplets or rests. You may, of course, decorate any note in a tuplet. 41 | * Mandatory information fields (headers). In an editor application, it is important to allow the user the option of first entering the notes and only later the information fields, whilst parsing the input after each keystroke. For this reason, mandatory headers are not enforced - it is assumed that later software modules will enforce them in many circumstances. In particular, the ```X:(reference-number)``` header has no usefulness in a browser setting. 42 | * Unicode escape sequences. Browsers have full Unicode support and I would expect users to use fully unicode aware editors these days and so this feature is ignored. 43 | 44 | 45 | Issues 46 | ------ 47 | 48 | * Slurs (represented by round brackets) are awkward. They seem to be impossible to match - for instance they can span across bars or even across separate lines of music. I attach them directly to the notes (or note groups) that delineate the slur. However, where the slur is not directly attached to the note (e.g. when attached to a broken rhythm operator) then the parser is lenient, accepting but discarding the slur bracket. Where a note is prefaced both by grace note(s) and an opening slur then the grace note must come before the slur bracket. 49 | * I have found no description of how a tuplet should be validated. Currently, tuplets must be completely contained within a bar and the number of items in the tuplet must agree with the its signature. Spaces are allowed between the notes but tuplets may not be embedded, one inside the other. 50 | * Grace notes are not supported against chords. (I am unclear what the specification defines here with respect to grace notes and see note above.) 51 | * Grace notes are, however, supported against notes in all other contexts and attached to them directly, although optionally mediated by a left slur bracket. 52 | * In translating to MIDI, only a single voice is recognized. 53 | 54 | To Build 55 | -------- 56 | 57 | npm run build 58 | 59 | To Test 60 | ------- 61 | 62 | npm run test 63 | 64 | -------------------------------------------------------------------------------- /breaking-changes.md: -------------------------------------------------------------------------------- 1 | Breaking Changes in v2.0.1 2 | -------------------------- 3 | 4 | * PureScript v0.15.9 5 | * There is now a transitive dependency on ```purescript-js-bigints``` via the latest ```purescript-rationals``` 6 | 7 | Breaking Changes in v2.0.0 8 | -------------------------- 9 | 10 | * PureScript v0.15.4 11 | * Header optics have been added; profunctor-lenses is now a dependency 12 | * Some metadata header retrieval functions have been removed in favour of optics 13 | * ```MeterSignature``` - ```Tuple Int Int``` replaced by 14 | ```TimeSignature``` - ```{ numerator:: Int, denominator:: Int }``` 15 | * MIDI pitch translation for B# and B## has been corrected 16 | * Decorations can now be applied to chords and tuplets 17 | * Chord symbols appear in the ADT as simple strings (without framing double quotes) 18 | * The ```Metadata``` module has been renamed as ```Utils``` and many functions moved 19 | to modules named after the appropriate header 20 | 21 | Breaking Changes in v1.9.3 22 | -------------------------- 23 | 24 | * The definition of __Chord__ has been altered to allow for decorations and slurs 25 | * A __Tuplet__ type has been introduced 26 | 27 | Breaking Changes in v1.9.2 28 | -------------------------- 29 | 30 | * The definition of __Volta__ has changed in order to allow for volta ranges 31 | 32 | Breaking Changes in v1.9.0 33 | -------------------------- 34 | 35 | * The __Repeat__ sum type in the parse tree ADT has been removed. The __BarType__ record type has been replaced by the (simpler) __BarLine__. 36 | * The representation of begin and end repeats at a bar line has therefore changed. 37 | * The signature of __partitionTuneBody__ in the Voice module has been altered. 38 | * A new data type, __Volta__ has been introduced into the parse tree ADT. 39 | This is so as to allow more comple voltas of the form |1,2 to be represented. 40 | This, therefore replaces the simpler Int data type we had before. 41 | * Optional properties (as key-value pairs) added to the __Key__ header. -------------------------------------------------------------------------------- /docs/GUIDE.md: -------------------------------------------------------------------------------- 1 | # ABC Parser Guide 2 | 3 | ABC is a notation for describing a traditional tune such that all aspects of it can be written down in a textual format. This means that to get started, the only tooling you require is an ordinary text editor. However it is highly advisable to use one that is unicode-aware, particularly if you are transcribing tunes whose titles, descriptions and so forth use different alphabets. 4 | 5 | You will first need to learn the basics of the notation. There are good tutorials available - for example [The Lesession pages](http://www.lesession.co.uk/abc/abc_notation.htm) by Steve Mansfield or else this [Interactive tutorial](http://www.tradtunedb.org.uk/#/tutorial). There are also various online collections of tunes in ABC format and you can alternatively download your tune from one of these. Particularly recommended are [The Session](https://thesession.org/) for Irish tunes or [FolkWiki](http://www.folkwiki.se/) for Swedish ones. 6 | 7 | ## Installing Dependencies 8 | 9 | For the initial examples, the following dependencies are required: 10 | 11 | ``` 12 | dependencies = 13 | [ "abc-parser" 14 | , "aff" 15 | , "console" 16 | , "effect" 17 | , "either" 18 | , "maybe" 19 | , "node-buffer" 20 | , "node-fs-aff" 21 | , "node-path" 22 | , "prelude" 23 | ] 24 | ``` 25 | 26 | ## Basic Parsing 27 | 28 | You therefore probably start with a text file which is a representation of your tune in ABC format. Let's suppose it's called ```mytune.abc``` in a subdirectory named ```abc```. In order to do anything with it after reading it, you must first parse it into a data structure which is either of type ```Right AbcTune``` if it conforms to the notation specification or ```Left ParseError``` if it does not. In this example, we read the file using facilities in ```node-fs-aff```, parse the contents and then log the tune title. 29 | 30 | ```purs 31 | module Main where 32 | 33 | import Prelude 34 | 35 | import Data.Abc.Metadata (getTitle) 36 | import Data.Abc.Parser (parse) 37 | import Data.Either (Either(..)) 38 | import Data.Maybe (fromMaybe, maybe) 39 | import Effect (Effect) 40 | import Effect.Console (log) 41 | import Effect.Class (liftEffect) 42 | import Effect.Aff (Aff, Fiber, launchAff) 43 | import Node.Path as Path 44 | import Node.Buffer (toString) 45 | import Node.Encoding (Encoding(..)) 46 | import Node.FS.Aff (readFile) 47 | 48 | main :: Effect (Fiber Unit) 49 | main = launchAff do 50 | tuneString <- readAbcFile "abc" "mytune.abc" 51 | case parse tuneString of 52 | Right tune -> do 53 | liftEffect $ log ("tune title is " <> (fromMaybe "untitled" $ getTitle tune)) 54 | Left err -> do 55 | liftEffect $ log ("parse failed: " <> show err) 56 | 57 | 58 | -- | read the ABC file 59 | readAbcFile :: String -> String -> Aff String 60 | readAbcFile directory fileName = 61 | do 62 | buffer <- readFile (Path.concat [directory, fileName]) 63 | contents <- liftEffect $ (toString UTF8) buffer 64 | pure contents 65 | ``` 66 | 67 | ## Changing the Octave 68 | 69 | If you need to alter the pitch of the tune by an octave (either up or down), you can do so quite easily. You must additionally import the ```Octave``` module and also it is useful to import the ```Canonical``` module which converts an ```AbcTune``` back to a string with regular whitespace: 70 | 71 | ```purs 72 | import Data.Abc.Canonical (fromTune) 73 | import Data.Abc.Octave (up) as Octave 74 | ``` 75 | 76 | You may then convert the (successfully parsed) tune and redisplay it. You will see that each note in the body of the tune is an octave higher (for example ```A``` becames ```a```). 77 | 78 | ```purs 79 | case parse tuneString of 80 | Right tune -> do 81 | liftEffect $ log ("new tune is " <> (fromTune $ Octave.up tune)) 82 | ``` 83 | 84 | ## Transposition 85 | Transposing the tune to a new key is similar. You first import the ```Transposition``` module, and also you need types from the ```Abc``` module in order to describe the new key: 86 | 87 | ```purs 88 | import Data.Abc (Accidental(..), Pitch(..), PitchClass(..)) 89 | import Data.Abc.Transposition (transposeTo) 90 | ``` 91 | 92 | To transpose, you simply need to provide the new pitch. The mode of the original tune remains unaltered. For example, suppose our original tune was in the key of ```G Major``` and we want to tranapose it to ```D Major```: 93 | 94 | ```purs 95 | case parse tuneString of 96 | Right tune -> do 97 | let 98 | newPitch = Pitch { pitchClass: D, accidental: Natural } 99 | liftEffect $ log ("transposed tune is " <> (fromTune $ transposeTo newPitch tune)) 100 | ``` 101 | 102 | You will see that the pitch of each note has changed and also the ```K: - Key Signature``` header has been changed to the new key. 103 | 104 | ## Accessing the Tune Headers 105 | 106 | ABC is structured as a set of headers which contain metadata (title, key signature, tempo etc.) followed by the body which holds the actual notes. ```abc-parser``` comes equipped with a set of ```profunctor optics``` which help you to fetch or edit the metadata. As an example, suppose you want to find the ```mode``` of the tune. You will need to add ```profunctor-lenses``` to your spago dependencies and then you can import some lens functions: 107 | 108 | ```pure 109 | 110 | import Data.Abc.Optics (_headers, _ModifiedKeySignature, _keySignature, _mode) 111 | import Data.Lens.Fold (firstOf) 112 | import Data.Lens.Traversal (traversed) 113 | ``` 114 | 115 | You can then display the mode: 116 | 117 | ```purs 118 | case parse tuneString of 119 | Right tune -> do 120 | let 121 | mode = firstOf 122 | (_headers <<< traversed <<< _ModifiedKeySignature <<< _keySignature <<< _mode) tune 123 | liftEffect $ log ("mode is " <> (maybe "unknown" show mode)) 124 | ``` 125 | 126 | (The mode will be unknown if there happens to be no Key Signature header present.) 127 | 128 | There are some convenience functions for accessing the more common headers in the ```Metadata``` module such as the ```getTitle``` function we used earlier but you could equally well use the optic if you prefer (```_Title``` in this case). These functions are implemented in terms of the underlying optic. 129 | 130 | ## Generating a MIDI Recording 131 | 132 | You can generate a MIDI file from the ABC tune. You will have to add to your dependencies ```midi``` and also some mechanism for saving the binary file - this example uses James D Brock's ```arraybuffer-builder``` and you also need ```foldable-traversable```. The complete code is: 133 | 134 | ```purs 135 | module Main where 136 | 137 | import Prelude 138 | 139 | import Data.Abc.Parser (parse) 140 | import Data.Abc.Midi (toMidi) 141 | import Data.Array (fromFoldable) as A 142 | import Data.Midi as Midi 143 | import Data.List (List) 144 | import Data.Either (Either(..)) 145 | import Effect (Effect) 146 | import Effect.Console (log) 147 | import Effect.Class (class MonadEffect, liftEffect) 148 | import Effect.Aff (Aff, Fiber, launchAff) 149 | import Node.Path as Path 150 | import Node.Buffer (toString, fromArrayBuffer) 151 | import Node.Encoding (Encoding(..)) 152 | import Node.FS.Aff (readFile, writeFile) 153 | import Data.ArrayBuffer.Builder (PutM, execPut, putInt8) 154 | import Data.Foldable (traverse_) 155 | 156 | main :: Effect (Fiber Unit) 157 | main = launchAff do 158 | tuneString <- readAbcFile "abc" "mytune.abc" 159 | case parse tuneString of 160 | Right tune -> do 161 | let 162 | midi = toMidi tune 163 | writeMidiFile midi 164 | Left err -> do 165 | liftEffect $ log ("parse failed: " <> show err) 166 | 167 | 168 | -- | read the ABC file 169 | readAbcFile :: String -> String -> Aff String 170 | readAbcFile directory fileName = 171 | do 172 | buffer <- readFile (Path.concat [directory, fileName]) 173 | contents <- liftEffect $ (toString UTF8) buffer 174 | pure contents 175 | 176 | -- | write the raw MIDI file 177 | writeMidiFile :: List Midi.Byte -> Aff Unit 178 | writeMidiFile midi = 179 | do 180 | arrayBuffer <- liftEffect $ execPut $ putArrayInt8 (A.fromFoldable midi) 181 | nodeBuffer <- liftEffect $ fromArrayBuffer arrayBuffer 182 | writeFile "mytune.mid" nodeBuffer 183 | 184 | putArrayInt8 :: forall m. MonadEffect m => Array Midi.Byte -> PutM m Unit 185 | putArrayInt8 xs = do 186 | traverse_ putInt8 xs 187 | ``` 188 | 189 | You will now be able to load the MIDI file into your favourite MIDI synth and listen to it. 190 | 191 | ## More Facilities for use in the Browser 192 | 193 | If you are producing code for the browser, and in particular, if you are using [Halogen](https://github.com/purescript-halogen/purescript-halogen) for your UI, then there are further facilities you can use. 194 | 195 | You can generate a score from the tune using [purescript-abc-scores](https://github.com/newlandsvalley/purescript-abc-scores). If you would like to play the tune directly, then [purescript-abc-melody](https://github.com/newlandsvalley/purescript-abc-melody) will generate a melody which can then be played using the player widget from [purescript-halogen-components](https://github.com/newlandsvalley/purescript-halogen-components). -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "build": "spago build", 5 | "test": "spago test" 6 | }, 7 | "devDependencies": { 8 | "purescript": "^0.15.5", 9 | "purescript-psa": "^0.6.0", 10 | "spago": "^0.93.42" 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: abc-parser 3 | dependencies: 4 | - arrays 5 | - bifunctors 6 | - control 7 | - either 8 | - enums 9 | - foldable-traversable 10 | - identity 11 | - integers 12 | - js-bigints 13 | - lists 14 | - maybe 15 | - midi 16 | - newtype 17 | - ordered-collections 18 | - partial 19 | - prelude 20 | - profunctor-lenses 21 | - rationals 22 | - string-parsers 23 | - strings 24 | - stringutils 25 | - transformers 26 | - tuples 27 | - unfoldable 28 | test: 29 | main: Test.Main 30 | dependencies: 31 | - aff 32 | - effect 33 | - spec 34 | workspace: 35 | packageSet: 36 | registry: 62.3.2 37 | extraPackages: {} 38 | -------------------------------------------------------------------------------- /src/Data/Abc.purs: -------------------------------------------------------------------------------- 1 | -- | ABC data types 2 | module Data.Abc 3 | ( AbcTune 4 | , TuneHeaders 5 | , TuneBody 6 | , BodyPart(..) 7 | , MusicLine 8 | , Header(..) 9 | , Music(..) 10 | , AbcRest 11 | , AbcNote 12 | , Grace 13 | , GraceableNote 14 | , AbcChord 15 | , RestOrNote 16 | , AbcTuplet 17 | , Bar 18 | , BarLine 19 | , Thickness(..) 20 | , Volta(..) 21 | , NoteDuration 22 | , KeySignature 23 | , ModifiedKeySignature 24 | , Pitch(..) 25 | , KeySet 26 | , TempoSignature 27 | , TimeSignature 28 | , TupletSignature(..) 29 | , AnnotationPlacement(..) 30 | , Mode(..) 31 | , Accidental(..) 32 | , PitchClass(..) 33 | , SymbolDefinition 34 | , Broken(..) 35 | , VoiceDescription(..) 36 | , AmorphousProperties 37 | , middlecOctave 38 | ) where 39 | 40 | import Data.Either (Either) 41 | import Data.Enum (class Enum) 42 | import Data.Generic.Rep (class Generic) 43 | import Data.Eq.Generic (genericEq) 44 | import Data.List (List) 45 | import Data.List.NonEmpty (NonEmptyList) 46 | import Data.Map (Map) 47 | import Data.Maybe (Maybe(..)) 48 | import Data.Ordering (Ordering(..)) 49 | import Data.Rational (Rational) 50 | import Data.String (toLower) as Str 51 | import Prelude (class Show, class Eq, class Ord, (<>), compare, show) 52 | 53 | -- | A Tune. 54 | type AbcTune = 55 | { headers :: TuneHeaders 56 | , body :: TuneBody 57 | } 58 | 59 | -- | A List of Tune Headers. 60 | type TuneHeaders = 61 | List Header 62 | 63 | -- | A Tune Body. 64 | type TuneBody = 65 | List BodyPart 66 | 67 | -- | A Tune Body part 68 | data BodyPart 69 | = Score (List Bar) 70 | | BodyInfo Header 71 | 72 | -- | A music phrase is contained within a Bar which is a set of music items 73 | -- | introduced by a bar line 74 | type Bar = 75 | { decorations :: List String 76 | , startLine :: BarLine -- we only consider the start line of each bar 77 | , music :: List Music 78 | } 79 | 80 | -- | A line of musical within a bar. 81 | type MusicLine = 82 | List Music 83 | 84 | -- | A Rest. 85 | type AbcRest = 86 | { duration :: NoteDuration } 87 | 88 | -- | A Note. 89 | type AbcNote = 90 | { pitchClass :: PitchClass 91 | , accidental :: Accidental 92 | , octave :: Int 93 | , duration :: NoteDuration 94 | , tied :: Boolean -- to the next note 95 | } 96 | 97 | -- | a set of one or more grace notes 98 | type Grace = 99 | { isAcciaccatura :: Boolean 100 | , notes :: NonEmptyList AbcNote 101 | } 102 | 103 | -- | A (possibly) Graced and Decorated Note. 104 | type GraceableNote = 105 | { maybeGrace :: Maybe Grace 106 | , leftSlurs :: Int 107 | , decorations :: List String 108 | , abcNote :: AbcNote 109 | , rightSlurs :: Int 110 | } 111 | 112 | -- | A Chord. 113 | type AbcChord = 114 | { leftSlurs :: Int 115 | , decorations :: List String 116 | , notes :: NonEmptyList AbcNote 117 | , duration :: NoteDuration 118 | , rightSlurs :: Int 119 | } 120 | 121 | -- | A Chord Symbol definition. Note that in ABC, this is merely a free-format string 122 | -- | with recommendations in the spec of how it might be properly formatted. 123 | -- | We include an optional duration. This is ignored by the parser but can 124 | -- | act as a placeholder for applications such as players to calculate a duration. 125 | type SymbolDefinition = 126 | { name :: String 127 | , duration :: Maybe NoteDuration 128 | } 129 | 130 | -- | A tuplet signature: 131 | -- | put p notes into the time of q the next r notes. 132 | type TupletSignature = 133 | { p :: Int 134 | , q :: Int 135 | , r :: Int 136 | } 137 | 138 | -- | A Tuplet 139 | type AbcTuplet = 140 | { maybeGrace :: Maybe Grace 141 | , leftSlurs :: Int 142 | , signature :: TupletSignature 143 | , restsOrNotes :: NonEmptyList RestOrNote 144 | } 145 | 146 | -- | An Annotation placement. 147 | data AnnotationPlacement 148 | = AboveNextSymbol 149 | | BelowNextSymbol 150 | | LeftOfNextSymbol 151 | | RightOfNextSymbol 152 | | Discretional 153 | 154 | instance showAnnotationPlacement :: Show AnnotationPlacement where 155 | show AboveNextSymbol = "^" 156 | show BelowNextSymbol = "_" 157 | show LeftOfNextSymbol = "<" 158 | show RightOfNextSymbol = ">" 159 | show Discretional = "@" 160 | 161 | -- | either a Rest or a Note. 162 | type RestOrNote 163 | = Either AbcRest GraceableNote 164 | 165 | -- | The 'score' part of Music. 166 | data Music 167 | = Note GraceableNote 168 | | BrokenRhythmPair RestOrNote Broken RestOrNote 169 | | Rest AbcRest 170 | | Tuplet AbcTuplet 171 | | DecoratedSpace (List String) 172 | | Annotation AnnotationPlacement String 173 | | ChordSymbol SymbolDefinition 174 | | Chord AbcChord 175 | | Inline Header 176 | | Spacer Int 177 | | Ignore 178 | | Continuation String 179 | 180 | -- | A bar line Thickness. 181 | data Thickness 182 | = Thin 183 | | ThinThin 184 | | ThinThick 185 | | ThickThin 186 | | Invisible -- | e.e. an implied bar line at the start of a stave 187 | 188 | instance showThickness :: Show Thickness where 189 | show Thin = "|" 190 | show ThinThin = "||" 191 | show ThinThick = "|]" 192 | show ThickThin = "[|" 193 | show Invisible = "" 194 | 195 | derive instance eqThickness :: Eq Thickness 196 | 197 | -- | a Volta - a repeated section 198 | data Volta 199 | = Volta Int -- |1 or |2 etc 200 | | VoltaRange Int Int -- |1-3 etc 201 | 202 | derive instance genericVolta :: Generic Volta _ 203 | instance showVolta :: Show Volta where 204 | show (Volta v) = show v 205 | show (VoltaRange v1 v2) = (show v1) <> "-" <> (show v2) 206 | 207 | derive instance eqVolta :: Eq Volta 208 | 209 | {-| A Bar Line: 210 | * endRepeats - any repeat of the previous section indicated by colon(s) 211 | * thickness - the thickness of vertical lines in the bar 212 | * startRepeats - any repeat of the section to follow indicated by colon(s) 213 | * iteration - the section end may be an iteration defined by volta markings 214 | -} 215 | type BarLine = 216 | { endRepeats :: Int 217 | , thickness :: Thickness 218 | , startRepeats :: Int 219 | , iteration :: Maybe (NonEmptyList Volta) 220 | } 221 | 222 | -- | A Mode. 223 | data Mode 224 | = Major 225 | | Minor 226 | | Ionian 227 | | Dorian 228 | | Phrygian 229 | | Lydian 230 | | Mixolydian 231 | | Aeolian 232 | | Locrian 233 | 234 | instance showMode :: Show Mode where 235 | show Major = "Major" 236 | show Minor = "Minor" 237 | show Ionian = "Ionian" 238 | show Dorian = "Dorian" 239 | show Phrygian = "Phrygian" 240 | show Lydian = "Lydian" 241 | show Mixolydian = "Mixolydian" 242 | show Aeolian = "Aeolian" 243 | show Locrian = "Locrian" 244 | 245 | derive instance eqMode :: Eq Mode 246 | 247 | -- | An Accidental. 248 | data Accidental 249 | = Sharp 250 | | Flat 251 | | DoubleSharp 252 | | DoubleFlat 253 | | Natural 254 | | Implicit -- accidental determoined by context of the note 255 | 256 | {- as shown in the body of the tune but not in headers -} 257 | instance showAccidental :: Show Accidental where 258 | show Sharp = "^" 259 | show Flat = "_" 260 | show DoubleSharp = "^^" 261 | show DoubleFlat = "__" 262 | show Natural = "=" 263 | show Implicit = "" 264 | 265 | derive instance eqAccidental :: Eq Accidental 266 | derive instance ordAccidental :: Ord Accidental 267 | 268 | -- | A white note on the piano. 269 | data PitchClass 270 | = A 271 | | B 272 | | C 273 | | D 274 | | E 275 | | F 276 | | G 277 | 278 | instance showPitchClass :: Show PitchClass where 279 | show A = "A" 280 | show B = "B" 281 | show C = "C" 282 | show D = "D" 283 | show E = "E" 284 | show F = "F" 285 | show G = "G" 286 | 287 | derive instance eqPitchCLass :: Eq PitchClass 288 | derive instance ordPitchCLass :: Ord PitchClass 289 | 290 | instance enumPitchClass :: Enum PitchClass where 291 | succ C = Just D 292 | succ D = Just E 293 | succ E = Just F 294 | succ F = Just G 295 | succ G = Just A 296 | succ A = Just B 297 | succ B = Just C 298 | 299 | pred C = Just B 300 | pred D = Just C 301 | pred E = Just D 302 | pred F = Just E 303 | pred G = Just F 304 | pred A = Just G 305 | pred B = Just A 306 | 307 | -- | A Key Signature. 308 | type KeySignature = 309 | { pitchClass :: PitchClass 310 | , accidental :: Accidental -- Sharp, Flat or (explicitly) Natural 311 | , mode :: Mode 312 | } 313 | 314 | -- | A Key Signature with modifications (possibly empty) 315 | -- | This is used for non-diatonicrepeatS modes where intervals may be greater than two semitones 316 | -- | (for example as found in Klezmer). 317 | type ModifiedKeySignature = 318 | { keySignature :: KeySignature 319 | , modifications :: List Pitch 320 | , properties :: AmorphousProperties 321 | } 322 | 323 | -- | A Key Accidental is represented by a Pitch (A modification to a standard key for one pitch in the scale). 324 | -- | (we're not allowed to derive instances on record types unless we use newtype) 325 | data Pitch = Pitch 326 | { pitchClass :: PitchClass 327 | , accidental :: Accidental 328 | } 329 | 330 | derive instance genericPitchClass :: Generic PitchClass _ 331 | derive instance genericAccidental :: Generic Accidental _ 332 | 333 | derive instance genericPitch :: Generic Pitch _ 334 | 335 | instance eqPitch :: Eq Pitch where 336 | eq = genericEq 337 | 338 | instance ordPitch :: Ord Pitch where 339 | compare (Pitch r1) (Pitch r2) = 340 | let 341 | comp1 = compare r1.pitchClass r2.pitchClass 342 | in 343 | case comp1 of 344 | EQ -> 345 | compare r1.accidental r2.accidental 346 | _ -> 347 | comp1 348 | 349 | instance showPitch :: Show Pitch where 350 | show (Pitch p) = show p.accidental <> Str.toLower (show p.pitchClass) 351 | 352 | -- | A set of pitches within a key signature or scale 353 | type KeySet = 354 | List Pitch 355 | 356 | -- | A Time Signature - e.g. 3/4. 357 | type TimeSignature = 358 | { numerator :: Int 359 | , denominator :: Int 360 | } 361 | 362 | {-| A Tempo Signature - for example: 363 | * 1/4=120 364 | * 1/4 3/8 1/4 3/8=40 (up to 4 note lengths allowed) 365 | * "Allegro" 1/4=120 366 | * 3/8=50 "Slowly". 367 | -} 368 | type TempoSignature = 369 | { noteLengths :: NonEmptyList Rational 370 | , bpm :: Int 371 | , marking :: Maybe String 372 | } 373 | 374 | -- | A Note Duration - e.g. 1/4. 375 | -- newtype NoteDuration = NoteDuration Rational 376 | type NoteDuration = Rational 377 | 378 | -- | A broken rhythm operator - one or more < or >.-} 379 | data Broken 380 | = LeftArrow Int 381 | | RightArrow Int 382 | 383 | -- | voice description 384 | type VoiceDescription = 385 | { id :: String 386 | , properties :: AmorphousProperties 387 | } 388 | 389 | -- | An ABC Tune Header. 390 | data Header 391 | = Area String 392 | | Book String 393 | | Composer String 394 | | Discography String 395 | | FileUrl String 396 | | Group String 397 | | History String 398 | | Instruction String 399 | -- Directive 400 | | Key ModifiedKeySignature 401 | -- a standard key signature possibly modified with accidentals 402 | | UnitNoteLength NoteDuration 403 | | Meter (Maybe TimeSignature) 404 | | Macro String 405 | | Notes String 406 | | Origin String 407 | | Parts String 408 | | Tempo TempoSignature 409 | | Rhythm String 410 | | Remark String 411 | | Source String 412 | | SymbolLine String 413 | | Title String 414 | | UserDefined String 415 | | Voice VoiceDescription 416 | -- voice properties 417 | | WordsAfter String 418 | -- words after notes 419 | | WordsAligned String 420 | -- words aligned with notes 421 | | ReferenceNumber (Maybe Int) 422 | -- spec says number is optionally allowed to be blank but not recommended 423 | | Transcription String 424 | | FieldContinuation String 425 | | Comment String 426 | | UnsupportedHeader 427 | 428 | -- | we stringly-type any header properties that we don't particularly care about 429 | type AmorphousProperties = Map String String 430 | 431 | -- | The octave number of middle C in MIDI parlance. 432 | middlecOctave :: Int 433 | middlecOctave = 434 | 5 435 | -------------------------------------------------------------------------------- /src/Data/Abc/Accidentals.purs: -------------------------------------------------------------------------------- 1 | -- | Accidentals are a set of mappings from a PitchClass to an Accidental 2 | -- | They are useful, for example, when interpreting a bar of music where 3 | -- | the accidental nature of a note may depend on the existence of a previous 4 | -- | note of the same pitch within the bar. 5 | module Data.Abc.Accidentals 6 | ( Accidentals 7 | , empty 8 | , add 9 | , fromKeySet 10 | , lookup 11 | , member 12 | , fromKeySig 13 | , implicitInKeySet 14 | ) where 15 | 16 | import Prelude ((==), map) 17 | import Data.Abc (PitchClass, Accidental, Pitch(..), KeySet, KeySignature) 18 | import Data.Maybe (Maybe(..)) 19 | import Data.Map as Map 20 | import Data.Tuple (Tuple(..)) 21 | 22 | -- | A set of accidentals 23 | type Accidentals = 24 | Map.Map PitchClass Accidental 25 | 26 | -- | create an empty set of Key Accidentals 27 | empty :: Accidentals 28 | empty = 29 | Map.empty 30 | 31 | -- | add an accidental to the set 32 | add :: PitchClass -> Accidental -> Accidentals -> Accidentals 33 | add pc acc accs = 34 | Map.insert pc acc accs 35 | 36 | -- | build Accidentals from a KeySet 37 | fromKeySet :: KeySet -> Accidentals 38 | fromKeySet ks = 39 | let 40 | f kar = 41 | case kar of 42 | Pitch p -> 43 | Tuple p.pitchClass p.accidental 44 | tuples = map f ks 45 | in 46 | Map.fromFoldable tuples 47 | 48 | -- | lookup a pitch class and see of it exists in the Accidentals set 49 | lookup :: PitchClass -> Accidentals -> Maybe Accidental 50 | lookup = 51 | Map.lookup 52 | 53 | -- | lookup a KeyAccidental (represented as a Pitch) and see if it's a member of 54 | -- | the Accidentals set (i.e. the value of the Accidental matches for the supplied pitch) 55 | member :: Pitch -> Accidentals -> Boolean 56 | member (Pitch p) accs = 57 | let 58 | macc = 59 | lookup p.pitchClass accs 60 | in 61 | (Just p.accidental) == macc 62 | 63 | -- | extract the KeyAccidental Pitch from a KeySignature 64 | fromKeySig :: KeySignature -> Pitch 65 | fromKeySig ks = 66 | Pitch 67 | { pitchClass: ks.pitchClass 68 | , accidental: ks.accidental 69 | } 70 | 71 | -- | Return an accidental if it is implicitly there in the supplied KeySet 72 | -- | (which is obtained from a key signature) 73 | -- | attached to the pitch class of the note. In ABC, notes generally inherit 74 | -- | their (sharp, flat or natural) accidental nature from the key signature. 75 | implicitInKeySet :: PitchClass -> KeySet -> Maybe Accidental 76 | implicitInKeySet pc keyset = 77 | lookup pc (fromKeySet keyset) 78 | -------------------------------------------------------------------------------- /src/Data/Abc/Canonical.purs: -------------------------------------------------------------------------------- 1 | -- | A canonical representation of an ABC tune as a string. 2 | module Data.Abc.Canonical 3 | ( fromTune 4 | , fromEither 5 | , abcNote 6 | , abcChord 7 | , tupletSignature 8 | , bars 9 | , keySignatureAccidental 10 | ) where 11 | 12 | import Prelude (map, show, ($), (<>), (<<<), (+), (-), (<=), (>), (==), (||)) 13 | import Data.Abc 14 | import JS.BigInt (toString) as BigInt 15 | import Data.List (List, foldMap) 16 | import Data.List.NonEmpty (NonEmptyList) 17 | import Data.Maybe (Maybe(..), fromMaybe, maybe) 18 | import Data.Rational (Rational, numerator, denominator) 19 | import Data.Tuple (Tuple(..)) 20 | import Data.Map (size, toUnfoldable) 21 | import Data.Semigroup.Foldable (intercalateMap) 22 | import Data.String (trim, toLower, length, take) as Str 23 | import Data.String.CodeUnits (fromCharArray) 24 | import Data.String.Utils (repeat) 25 | import Data.Foldable (foldr, intercalate) 26 | import Data.Unfoldable (replicate) 27 | import Data.Either (Either(..)) 28 | 29 | -- | Module for converting an ABC Tune parse tree to a canonical ABC string 30 | 31 | keySignatureAccidental :: Accidental -> String 32 | keySignatureAccidental a = 33 | case a of 34 | Sharp -> 35 | "#" 36 | Flat -> 37 | "b" 38 | _ -> 39 | "" 40 | 41 | -- | Pretty-print a tuplet signature. 42 | tupletSignature :: TupletSignature -> String 43 | tupletSignature { p: 2, q: 3, r: 2 } = "(2" 44 | tupletSignature { p: 3, q: 2, r: 3 } = "(3" 45 | tupletSignature { p: 4, q: 3, r: 4 } = "(4" 46 | tupletSignature { p: p, q: q, r: r } = 47 | "(" 48 | <> (show p) 49 | <> ":" 50 | <> (show q) 51 | <> ":" 52 | <> (show r) 53 | 54 | tempo :: TempoSignature -> String 55 | tempo t = 56 | let 57 | text = 58 | fromMaybe "" (map (\s -> " " <> s) t.marking) 59 | in 60 | ratlist t.noteLengths 61 | <> "=" 62 | <> show t.bpm 63 | <> text 64 | 65 | showRatio :: Rational -> String 66 | showRatio r = 67 | (show $ numerator r) <> "/" <> (show $ denominator r) 68 | 69 | ratlist :: NonEmptyList Rational -> String 70 | ratlist rs = 71 | let 72 | f r acc = 73 | (showRatio r) <> " " <> acc 74 | in 75 | Str.trim $ foldr f "" rs 76 | 77 | meter :: Maybe TimeSignature -> String 78 | meter ms = 79 | case ms of 80 | Nothing -> 81 | "none" 82 | 83 | Just { numerator, denominator } -> 84 | show numerator <> "/" <> show denominator 85 | 86 | -- we optimise durations in tune bodies to the most compact form 87 | -- just use showRatio in headers 88 | duration :: Rational -> String 89 | duration r = 90 | case (BigInt.toString $ numerator r), (BigInt.toString $ denominator r) of 91 | "1", "1" -> "" 92 | "1" ,"2" -> "/" 93 | n, "1" -> n 94 | _, _ -> showRatio r 95 | 96 | key :: KeySignature -> String 97 | key k = 98 | show k.pitchClass <> (keySignatureAccidental k.accidental) <> show k.mode 99 | 100 | keyAccidentals :: List Pitch -> String 101 | keyAccidentals = 102 | concatenate <<< map (\ka -> " " <> (show ka)) 103 | 104 | -- amorphous properties of either the Key or Voice header 105 | amorphousProperties :: AmorphousProperties -> String 106 | amorphousProperties properties = 107 | if (size properties == 0) then "" 108 | else 109 | let 110 | kvs = toUnfoldable properties 111 | 112 | strs :: Array String 113 | strs = map (\(Tuple k v) -> k <> "=" <> v) kvs 114 | in 115 | " " <> intercalate " " strs 116 | 117 | octave :: Int -> String 118 | octave i = 119 | let 120 | octaveAboveMiddleC = 121 | middlecOctave + 1 122 | in 123 | if ((i == middlecOctave) || (i == octaveAboveMiddleC)) then 124 | "" 125 | else if (i > octaveAboveMiddleC) then 126 | -- catChars $ replicate (i - octaveAboveMiddleC) '\'' 127 | Str.take (i - octaveAboveMiddleC) "''''''''''" 128 | else 129 | Str.take (middlecOctave - i) ",,,,,,,,,," 130 | 131 | pitch :: Int -> PitchClass -> String 132 | pitch octaveNumber p = 133 | if (octaveNumber <= middlecOctave) then 134 | show p 135 | else 136 | Str.toLower (show p) 137 | 138 | -- | Pretty-print a note which may be prefaced by grace notes and/or decorations. 139 | graceableNote :: GraceableNote -> String 140 | graceableNote gn = 141 | (maybeGrace gn.maybeGrace) 142 | <> leftSlurs gn.leftSlurs 143 | <> decorate gn.decorations 144 | <> abcNote (gn.abcNote) 145 | <> rightSlurs gn.rightSlurs 146 | 147 | leftSlurs :: Int -> String 148 | leftSlurs n = 149 | fromCharArray $ replicate n '(' 150 | 151 | rightSlurs :: Int -> String 152 | rightSlurs n = 153 | fromCharArray $ replicate n ')' 154 | 155 | -- | pretty print an optional grace note 156 | maybeGrace :: Maybe Grace -> String 157 | maybeGrace mGrace = 158 | fromMaybe "" $ map grace mGrace 159 | 160 | grace :: Grace -> String 161 | grace g = 162 | "{" <> notes g.notes <> "}" 163 | 164 | -- | Pretty-print a note. 165 | abcNote :: AbcNote -> String 166 | abcNote a = 167 | let 168 | tie = 169 | case a.tied of 170 | true -> 171 | "-" 172 | _ -> 173 | "" 174 | in 175 | show a.accidental 176 | <> pitch a.octave a.pitchClass 177 | <> octave a.octave 178 | <> duration a.duration 179 | <> tie 180 | 181 | -- | Pretty-print a chord. 182 | abcChord :: AbcChord -> String 183 | abcChord c = 184 | leftSlurs c.leftSlurs 185 | <> decorate c.decorations 186 | <> "[" 187 | <> (notes c.notes) 188 | <> "]" 189 | <> duration c.duration 190 | <> rightSlurs c.rightSlurs 191 | 192 | notes :: NonEmptyList AbcNote -> String 193 | notes ns = 194 | let 195 | f a acc = 196 | (abcNote a) <> acc 197 | in 198 | foldr f "" ns 199 | 200 | -- generate a single free-standing rest or note (i.e. not part of a tuplet) 201 | singleRestOrNote :: RestOrNote -> String 202 | singleRestOrNote rn = 203 | restOrNote rn "" 204 | 205 | -- a rest or note whih may be part of a sequence if the accumulator is used 206 | restOrNote :: RestOrNote -> String -> String 207 | restOrNote rn acc = 208 | case rn of 209 | Left r -> 210 | (abcRest r) <> acc 211 | Right n -> 212 | (graceableNote n) <> acc 213 | 214 | restsOrNotes :: NonEmptyList RestOrNote -> String 215 | restsOrNotes rns = 216 | foldr restOrNote "" rns 217 | 218 | abcRest :: AbcRest -> String 219 | abcRest r = 220 | "z" <> (duration r.duration) 221 | 222 | decorate :: List String -> String 223 | decorate ds = 224 | foldMap decorate1 ds 225 | 226 | decorate1 :: String -> String 227 | decorate1 s = 228 | if (Str.length s == 1) then 229 | s 230 | else 231 | "!" <> s <> "! " 232 | 233 | bars :: List Bar -> String 234 | bars bs = 235 | let 236 | f b acc = 237 | (bar b) <> acc 238 | in 239 | foldr f "" bs 240 | 241 | bar :: Bar -> String 242 | bar b = 243 | let 244 | f m acc = 245 | (music m) <> acc 246 | in 247 | decorate b.decorations 248 | <> barLine b.startLine 249 | <> 250 | foldr f "" b.music 251 | 252 | barLine :: BarLine -> String 253 | barLine b = 254 | let 255 | lines = show b.thickness 256 | endColons = fromMaybe "" $ repeat b.endRepeats ":" 257 | startColons = fromMaybe "" $ repeat b.startRepeats ":" 258 | iteration = fromMaybe "" $ map voltas b.iteration 259 | in 260 | endColons <> lines <> startColons <> iteration 261 | 262 | 263 | voltas :: NonEmptyList Volta -> String 264 | voltas vs = 265 | intercalateMap "," show vs 266 | 267 | broken :: Broken -> String 268 | broken b = 269 | case b of 270 | LeftArrow i -> 271 | Str.take i "<<<<<<<<<<" 272 | 273 | RightArrow i -> 274 | Str.take i ">>>>>>>>>>" 275 | 276 | music :: Music -> String 277 | music m = 278 | case m of 279 | 280 | Note gn -> 281 | graceableNote gn 282 | 283 | BrokenRhythmPair g1 b g2 -> 284 | (singleRestOrNote g1) <> (broken b) <> (singleRestOrNote g2) 285 | 286 | Rest r -> 287 | abcRest r 288 | 289 | Tuplet t {- mGrace bracks tup rns -} -> 290 | (maybeGrace t.maybeGrace) 291 | <> leftSlurs t.leftSlurs 292 | <> tupletSignature t.signature 293 | <> restsOrNotes t.restsOrNotes 294 | 295 | DecoratedSpace decorations -> 296 | (decorate decorations) <> "y" 297 | 298 | Annotation placement s -> 299 | "\"" <> show placement <> s <> "\"" 300 | 301 | ChordSymbol symbol -> 302 | "\"" <> symbol.name <> "\"" 303 | 304 | Chord a -> 305 | abcChord a 306 | 307 | Inline h -> 308 | "[" <> header h <> "]" 309 | 310 | Spacer _ -> 311 | " " 312 | 313 | Ignore -> 314 | "" 315 | 316 | Continuation comment -> 317 | ("\\" <> comment <> "\r\n") 318 | 319 | header :: Header -> String 320 | header h = 321 | case h of 322 | Area s -> 323 | "A: " <> s 324 | 325 | Book s -> 326 | "B: " <> s 327 | 328 | Composer s -> 329 | "C: " <> s 330 | 331 | Discography s -> 332 | "D: " <> s 333 | 334 | FileUrl s -> 335 | "F: " <> s 336 | 337 | Group s -> 338 | "G: " <> s 339 | 340 | History s -> 341 | "H: " <> s 342 | 343 | Instruction s -> 344 | "I: " <> s 345 | 346 | Key mks -> 347 | "K: " <> (key mks.keySignature) <> (keyAccidentals mks.modifications) 348 | <> amorphousProperties mks.properties 349 | 350 | UnitNoteLength d -> 351 | "L: " <> (showRatio d) 352 | 353 | Meter m -> 354 | "M: " <> (meter m) 355 | 356 | Macro s -> 357 | "m: " <> s 358 | 359 | Notes s -> 360 | "N: " <> s 361 | 362 | Origin s -> 363 | "O: " <> s 364 | 365 | Parts s -> 366 | "P: " <> s 367 | 368 | Rhythm s -> 369 | "R: " <> s 370 | 371 | Remark s -> 372 | "r: " <> s 373 | 374 | Source s -> 375 | "S: " <> s 376 | 377 | Title s -> 378 | "T: " <> s 379 | 380 | Tempo t -> 381 | "Q: " <> (tempo t) 382 | 383 | UserDefined s -> 384 | "U: " <> s 385 | 386 | Voice voiceDescription -> 387 | "V: " <> voiceDescription.id 388 | <> amorphousProperties voiceDescription.properties 389 | 390 | WordsAfter s -> 391 | "W: " <> s 392 | 393 | WordsAligned s -> 394 | "w: " <> s 395 | 396 | ReferenceNumber mi -> 397 | "X: " <> (maybe "" show mi) 398 | 399 | Transcription s -> 400 | "Z: " <> s 401 | 402 | FieldContinuation s -> 403 | "+: " <> s 404 | 405 | Comment s -> 406 | "%" <> s 407 | 408 | _ -> 409 | "" 410 | 411 | tuneHeaders :: List Header -> String 412 | tuneHeaders hs = 413 | let 414 | f h acc = 415 | (header h) <> "\x0D\n" <> acc 416 | in 417 | foldr f "" hs 418 | 419 | bodyPart :: BodyPart -> String 420 | bodyPart bp = 421 | case bp of 422 | Score bs -> 423 | bars bs 424 | 425 | BodyInfo h -> 426 | header h 427 | 428 | tuneBody :: TuneBody -> String 429 | tuneBody b = 430 | -- import Data.Either (Either(..)) 431 | let 432 | f bp acc = 433 | (bodyPart bp) <> "\x0D\n" <> acc 434 | in 435 | foldr f "" b 436 | 437 | concatenate :: List String -> String 438 | concatenate = foldr (<>) "" 439 | 440 | -- Main Exported Functions 441 | 442 | -- | Translate an ABC Tune parse tree to a canonical ABC String. 443 | fromTune :: AbcTune -> String 444 | fromTune abcTune = 445 | tuneHeaders abcTune.headers <> tuneBody abcTune.body 446 | 447 | -- | Translate a parse Result containing an ABC Tune parse tree to a Result containing a canonical ABC String. 448 | fromEither :: Either String AbcTune -> Either String String 449 | fromEither r = 450 | map fromTune r 451 | -------------------------------------------------------------------------------- /src/Data/Abc/KeySignature.purs: -------------------------------------------------------------------------------- 1 | -- | ABC Key Signatures and their associated scales and details of signature. 2 | -- | The individual (sharp or flat) keys that comprise each key signature 3 | -- | across all the modes in western music. 4 | module Data.Abc.KeySignature 5 | ( getKeySig 6 | , getKeyProps 7 | , keySet 8 | , inKeySet 9 | , modifiedKeySet 10 | , getKeySet 11 | , notesInChromaticScale 12 | , diatonicScale 13 | , defaultKey 14 | , isCOrSharpKey 15 | , normaliseModalKey 16 | , transposeKeySignatureBy 17 | , pitchNumbers 18 | , pitchNumber 19 | ) where 20 | 21 | import Data.Abc (AbcTune, Accidental(..), AmorphousProperties, KeySet, KeySignature, Mode(..), ModifiedKeySignature, Pitch(..), PitchClass(..)) 22 | import Data.Abc.Optics (_headers, _properties, _ModifiedKeySignature) 23 | import Data.Array (index, elemIndex, head, drop, take, filter, toUnfoldable) 24 | import Data.Enum (succ, pred) 25 | import Data.Lens.Fold (firstOf) 26 | import Data.Lens.Traversal (traversed) 27 | import Data.List (List(..), (:), null, foldr) 28 | import Data.List (elem, filter) as L 29 | import Data.Map (Map, empty, fromFoldable, lookup) 30 | import Data.Maybe (Maybe(..), fromMaybe, fromJust) 31 | import Data.Tuple (Tuple(..)) 32 | import Partial.Unsafe (unsafePartial) 33 | import Prelude (class Eq, class Ord, class Show, map, mod, show, ($), (&&), (+), (/=), (<), (<>), (==), (||), (<<<)) 34 | 35 | -- Internal data structures 36 | -- a note on a piano keyboard. The virtue of this representation is that we 37 | -- don't (yet)commit to a particular (sharp or flat) representation 38 | data PianoKey 39 | = White PitchClass 40 | | Black PitchClass PitchClass 41 | 42 | derive instance eqPianoKey :: Eq PianoKey 43 | derive instance ordPianoKey :: Ord PianoKey 44 | 45 | instance showPianoKey :: Show PianoKey where 46 | show (White p) = "white: " <> (show p) 47 | show (Black p q) = "black: " <> (show p) <> " " <> (show q) 48 | 49 | -- API 50 | 51 | -- | Get the key signature (if any) from the tune. 52 | -- | For more flexibility, you should use the _ModifiedKeySignature optic. 53 | getKeySig :: AbcTune -> Maybe ModifiedKeySignature 54 | getKeySig tune = 55 | firstOf (_headers <<< traversed <<< _ModifiedKeySignature) tune 56 | 57 | -- | Get the key signature properties (if any) from the tune. 58 | getKeyProps :: AbcTune -> AmorphousProperties 59 | getKeyProps tune = 60 | case (firstOf (_headers <<< traversed <<< _ModifiedKeySignature <<< _properties) tune) of 61 | Just props -> props 62 | _ -> (empty :: AmorphousProperties) 63 | 64 | -- | The set of keys (pitches) that comprise the key signature. 65 | keySet :: KeySignature -> KeySet 66 | keySet ks = 67 | let 68 | -- the key signature in terms of a PianoKey 69 | pianoKeySignature = buildPianoKey 70 | ( Pitch 71 | { pitchClass: ks.pitchClass 72 | , accidental: ks.accidental 73 | } 74 | ) 75 | Tuple tonic blackKeys = blackKeySet pianoKeySignature ks.mode 76 | -- decide how we translate the black keys in the given context 77 | isFlatCtx = 78 | case tonic of 79 | White F -> true -- F Natural uses flat keys 80 | White _ -> false -- all other Natural key signatures use sharp (or no) keys 81 | _ -> true -- we'll ignore F# for the time being - all black note naturals use flat keys 82 | -- generate the basic keys 83 | basicKeySet = toUnfoldable $ map (pianoKeyToPitch isFlatCtx) blackKeys 84 | in 85 | -- special-case F# (which has an E#) 86 | if (isFSharp ks) then 87 | fSharpKeySet 88 | else 89 | -- special case Gb (which has a Cb) 90 | case tonic of 91 | Black F G -> 92 | -- need to mend this line with a modify 93 | (Pitch { pitchClass: C, accidental: Flat }) : basicKeySet 94 | _ -> 95 | basicKeySet 96 | 97 | -- | Is the pitch is in the KeySet? 98 | inKeySet :: Pitch -> KeySet -> Boolean 99 | inKeySet p ks = 100 | L.elem p ks 101 | 102 | -- | The set of keys (pitch classes with accidental) that comprise a modified key signature 103 | -- | (i.e. those signatures that don't represent classical western modes such as, 104 | -- | for example, Klezmer or Balkan music.) 105 | modifiedKeySet :: ModifiedKeySignature -> KeySet 106 | modifiedKeySet ksm = 107 | let 108 | kSet = keySet ksm.keySignature 109 | in 110 | if (null ksm.modifications) then 111 | kSet 112 | else 113 | foldr modifyKeySet kSet ksm.modifications 114 | 115 | -- | Get the set of key accidentals from the (possibly modified) key (if there is one in the tune). 116 | getKeySet :: AbcTune -> KeySet 117 | getKeySet t = 118 | case (getKeySig t) of 119 | Just ksig -> 120 | modifiedKeySet ksig 121 | Nothing -> 122 | Nil 123 | 124 | -- constants 125 | 126 | -- the intervals in a diatonic (major scale) are: [2, 2, 1, 2, 2, 2, 1] 127 | -- this represents the cumulative position of each note in such a scale 128 | -- (of seven notes) 129 | diatonicScaleOffsets :: Array Int 130 | diatonicScaleOffsets = [ 0, 2, 4, 5, 7, 9, 11 ] 131 | 132 | -- The notes of a chromatic scale (on a piano) starting at C 133 | -- This is sufficient to recognize all (major) key signatures except 134 | -- Gb/F# which require, respectively, Cb or E#, neither of which 135 | -- are representable like this and will have to be treated specially 136 | pianoOctave :: Array PianoKey 137 | pianoOctave = 138 | [ White C 139 | , Black C D 140 | , White D 141 | , Black D E 142 | , White E 143 | , White F 144 | , Black F G 145 | , White G 146 | , Black G A 147 | , White A 148 | , Black A B 149 | , White B 150 | ] 151 | 152 | -- special-case the F# Scale 153 | -- which we can't represent in our internal structure 154 | fSharpScale :: KeySet 155 | fSharpScale = 156 | Pitch { pitchClass: F, accidental: Sharp } 157 | : Pitch { pitchClass: G, accidental: Sharp } 158 | : Pitch { pitchClass: A, accidental: Sharp } 159 | : Pitch { pitchClass: B, accidental: Natural } 160 | : Pitch { pitchClass: C, accidental: Sharp } 161 | : Pitch { pitchClass: D, accidental: Sharp } 162 | : Pitch { pitchClass: E, accidental: Sharp } 163 | : Nil 164 | 165 | -- ditto for the F# key signature 166 | fSharpKeySet :: KeySet 167 | fSharpKeySet = 168 | L.filter (\(Pitch p) -> p.accidental == Sharp) fSharpScale 169 | 170 | -- F# needs to be special-cased 171 | isFSharp :: KeySignature -> Boolean 172 | isFSharp ks = 173 | ks.pitchClass == F && ks.accidental == Sharp && (ks.mode == Major || ks.mode == Ionian) 174 | 175 | -- Exported Functioms 176 | 177 | -- | the number of notes in a chromatic scale (12) 178 | notesInChromaticScale :: Int 179 | notesInChromaticScale = 180 | 12 181 | 182 | -- | The default key is C Major (with no accidental modifiers or other properties) 183 | defaultKey :: ModifiedKeySignature 184 | defaultKey = 185 | { keySignature: { pitchClass: C, accidental: Natural, mode: Major } 186 | , modifications: Nil 187 | , properties: empty 188 | } 189 | 190 | -- | The set of keys (pitches) that comprise the diatonic scale governed by 191 | -- | the key signature. 192 | diatonicScale :: KeySignature -> KeySet 193 | diatonicScale ks = 194 | let 195 | -- the key signature in terms of a PianoKey 196 | pianoKeySignature = buildPianoKey 197 | ( Pitch 198 | { pitchClass: ks.pitchClass 199 | , accidental: ks.accidental 200 | } 201 | ) 202 | Tuple tonic allKeys = pianoKeyScale pianoKeySignature ks.mode 203 | -- decide how we translate the black keys in the given context 204 | isFlatCtx = 205 | case tonic of 206 | White F -> true -- F Natural uses flat keys 207 | White _ -> false -- all other Natural key signatures use sharp (or no) keys 208 | _ -> true -- we'll ignore F# for the time being - all black note naturals use flat keys 209 | -- generate the basic keys 210 | basicKeySet = toUnfoldable $ map (pianoKeyToPitch isFlatCtx) allKeys 211 | in 212 | -- special-case F# (which has an E#) 213 | if (isFSharp ks) then 214 | fSharpScale 215 | else 216 | -- special case Gb (which has a Cb) 217 | case tonic of 218 | Black F G -> 219 | renameBNatural basicKeySet 220 | _ -> 221 | basicKeySet 222 | 223 | -- | Is the key signature a sharp key or else a simple C Major key? 224 | isCOrSharpKey :: KeySignature -> Boolean 225 | isCOrSharpKey ksig = 226 | let 227 | kset = 228 | keySet ksig 229 | 230 | isFlat :: Pitch -> Boolean 231 | isFlat (Pitch p) = 232 | p.accidental == Flat 233 | in 234 | -- the list is empty anyway or contains only flat keys 235 | null $ L.filter isFlat kset 236 | 237 | -- | normalise a modal key signature to its equivalent major key signature 238 | normaliseModalKey :: KeySignature -> KeySignature 239 | normaliseModalKey ks = 240 | let 241 | -- convert key sig to a piano key 242 | pianoKeySignature = buildPianoKey 243 | ( Pitch 244 | { pitchClass: ks.pitchClass 245 | , accidental: ks.accidental 246 | } 247 | ) 248 | -- retrieve the tonic of what is now a major scale 249 | Tuple tonic _ = pianoKeyScale pianoKeySignature ks.mode 250 | -- retain the flat context of the original key (if there is one) 251 | isFlatCtx = ks.accidental == Flat 252 | -- translate to a pitch in the new Major key 253 | (Pitch newKeyPitch) = pianoKeyToPitch isFlatCtx tonic 254 | in 255 | { pitchClass: newKeyPitch.pitchClass 256 | , accidental: newKeyPitch.accidental 257 | , mode: Major 258 | } 259 | 260 | -- | Transpose a key signature by a given distance. 261 | transposeKeySignatureBy :: Int -> ModifiedKeySignature -> ModifiedKeySignature 262 | transposeKeySignatureBy interval mks = 263 | let 264 | -- convert key sig to a piano key 265 | pianoKey = buildPianoKey 266 | ( Pitch 267 | { pitchClass: mks.keySignature.pitchClass 268 | , accidental: mks.keySignature.accidental 269 | } 270 | ) 271 | 272 | -- retain the sharp/flat/natural context 273 | isFlatCtx = mks.keySignature.accidental == Flat 274 | -- find the position in the octave of this key 275 | keyPos = fromMaybe 0 $ elemIndex pianoKey pianoOctave 276 | -- find its new position after moving 277 | -- be careful to use only values 0 <= n < 12 278 | newPos = boundedIndex (keyPos + interval) 279 | -- look up the new piano key 280 | newPianoKey = fromMaybe (White C) $ index pianoOctave newPos 281 | -- and convert back (via a pitch) 282 | Pitch pitch = pianoKeyToPitch isFlatCtx newPianoKey 283 | newks = 284 | { pitchClass: pitch.pitchClass 285 | , accidental: pitch.accidental 286 | , mode: mks.keySignature.mode 287 | } 288 | -- and also transpose any mods to the key signature 289 | modifications = 290 | map (transposeKeyAccidentalBy interval) mks.modifications 291 | in 292 | { keySignature: newks, modifications: modifications, properties: mks.properties } 293 | 294 | -- | a relationship between a Pitch and a note number 295 | -- | i.e. C is 0, C Sharp is 1 B is 11 etc. 296 | -- | Note that B# and B# go above the 12 notes in the scale 297 | -- | because they effectively jump octave 298 | pitchNumbers :: List (Tuple Pitch Int) 299 | pitchNumbers = 300 | ( Tuple (Pitch { pitchClass: C, accidental: Flat }) 11 301 | : Tuple (Pitch { pitchClass: C, accidental: Natural }) 0 302 | : Tuple (Pitch { pitchClass: C, accidental: Implicit }) 0 303 | : Tuple (Pitch { pitchClass: C, accidental: Sharp }) 1 304 | : Tuple (Pitch { pitchClass: C, accidental: DoubleSharp }) 2 305 | : Tuple (Pitch { pitchClass: D, accidental: DoubleFlat }) 0 306 | : Tuple (Pitch { pitchClass: D, accidental: Flat }) 1 307 | : Tuple (Pitch { pitchClass: D, accidental: Natural }) 2 308 | : Tuple (Pitch { pitchClass: D, accidental: Implicit }) 2 309 | : Tuple (Pitch { pitchClass: D, accidental: Sharp }) 3 310 | : Tuple (Pitch { pitchClass: D, accidental: DoubleSharp }) 4 311 | : Tuple (Pitch { pitchClass: E, accidental: DoubleFlat }) 2 312 | : Tuple (Pitch { pitchClass: E, accidental: Flat }) 3 313 | : Tuple (Pitch { pitchClass: E, accidental: Natural }) 4 314 | : Tuple (Pitch { pitchClass: E, accidental: Implicit }) 4 315 | : Tuple (Pitch { pitchClass: E, accidental: Sharp }) 5 316 | : Tuple (Pitch { pitchClass: E, accidental: DoubleSharp }) 6 317 | : Tuple (Pitch { pitchClass: F, accidental: Flat }) 4 318 | : Tuple (Pitch { pitchClass: F, accidental: Natural }) 5 319 | : Tuple (Pitch { pitchClass: F, accidental: Implicit }) 5 320 | : Tuple (Pitch { pitchClass: F, accidental: Sharp }) 6 321 | : Tuple (Pitch { pitchClass: F, accidental: DoubleSharp }) 7 322 | : Tuple (Pitch { pitchClass: G, accidental: DoubleFlat }) 5 323 | : Tuple (Pitch { pitchClass: G, accidental: Flat }) 6 324 | : Tuple (Pitch { pitchClass: G, accidental: Natural }) 7 325 | : Tuple (Pitch { pitchClass: G, accidental: Implicit }) 7 326 | : Tuple (Pitch { pitchClass: G, accidental: Sharp }) 8 327 | : Tuple (Pitch { pitchClass: G, accidental: DoubleSharp }) 9 328 | : Tuple (Pitch { pitchClass: A, accidental: DoubleFlat }) 7 329 | : Tuple (Pitch { pitchClass: A, accidental: Flat }) 8 330 | : Tuple (Pitch { pitchClass: A, accidental: Natural }) 9 331 | : Tuple (Pitch { pitchClass: A, accidental: Implicit }) 9 332 | : Tuple (Pitch { pitchClass: A, accidental: Sharp }) 10 333 | : Tuple (Pitch { pitchClass: A, accidental: DoubleSharp }) 11 334 | : Tuple (Pitch { pitchClass: B, accidental: DoubleFlat }) 9 335 | : Tuple (Pitch { pitchClass: B, accidental: Flat }) 10 336 | : Tuple (Pitch { pitchClass: B, accidental: Natural }) 11 337 | : Tuple (Pitch { pitchClass: B, accidental: Implicit }) 11 338 | : Tuple (Pitch { pitchClass: B, accidental: Sharp }) 12 339 | : Tuple (Pitch { pitchClass: B, accidental: DoubleSharp }) 13 340 | : Nil 341 | ) 342 | 343 | -- | the pitch number is the position of the pitch in the chromatic scale 344 | -- | starting at C Natural = 0 (i.e. C is 0, C Sharp is 1 B is 11 etc.) 345 | pitchNumber :: Pitch -> Int 346 | pitchNumber (Pitch p) = 347 | let 348 | target = 349 | case p.accidental of 350 | Implicit -> 351 | Pitch { pitchClass: p.pitchClass, accidental: Natural } 352 | _ -> 353 | Pitch p 354 | in 355 | fromMaybe 0 $ lookup target chromaticScaleMap 356 | 357 | -- IMPLEMENTATION 358 | 359 | -- transpose a pitch that defines a key signature modification be the required amount 360 | transposeKeyAccidentalBy :: Int -> Pitch -> Pitch 361 | transposeKeyAccidentalBy interval (Pitch p) = 362 | let 363 | -- convert the pitch to a piano key 364 | pianoKey = buildPianoKey (Pitch p) 365 | isFlatCtx = p.accidental == Flat 366 | -- find the position in the octave of this key 367 | keyPos = fromMaybe 0 $ elemIndex pianoKey pianoOctave 368 | -- find its new position after moving 369 | -- be careful to use only values 0 <= n < 12 370 | newPos = boundedIndex (keyPos + interval) 371 | newPianoKey = fromMaybe (White C) $ index pianoOctave newPos 372 | in 373 | pianoKeyToPitch isFlatCtx newPianoKey 374 | 375 | -- the set of black notes determined by the key signature 376 | -- of a diatonic scale (e.g. White C Major means C Major, 377 | -- Black D E Dorian means both C# Dorian or Db Dorian) # 378 | -- (assuming equal temperament) 379 | blackKeySet :: PianoKey -> Mode -> Tuple PianoKey (Array PianoKey) 380 | blackKeySet keySig mode = 381 | let 382 | Tuple tonic fullScale = pianoKeyScale keySig mode 383 | 384 | -- filter only the black notes 385 | isBlackKey :: PianoKey -> Boolean 386 | isBlackKey (White _) = false 387 | isBlackKey (Black _ _) = true 388 | in 389 | Tuple tonic $ filter isBlackKey fullScale 390 | 391 | -- | a complete diatonic scale in terms of PianoKeys governed by the 392 | -- | Piano Key and Mode that defines the key signature 393 | -- | coupled with the tonic for that scale 394 | pianoKeyScale :: PianoKey -> Mode -> Tuple PianoKey (Array PianoKey) 395 | pianoKeyScale keySig mode = 396 | let 397 | -- calculate a rotation from C Major taking into account both the 398 | -- key signature and the mode 399 | shift = (distanceFromC keySig + distanceFromMajor mode) `mod` notesInChromaticScale 400 | -- rotate the piano octave by this distance 401 | -- at this point we have a major scale with major key as the tonic (first note) 402 | scale = rotate shift pianoOctave 403 | -- establish the tonic 404 | tonic = fromMaybe (White C) $ head scale 405 | -- lookup each position in this new diatonic scale 406 | lookup key = fromMaybe (White C) $ index scale key 407 | -- and map each of the diatonic scale offsets to the key found at that position 408 | keys = map lookup diatonicScaleOffsets 409 | in 410 | Tuple tonic keys 411 | 412 | -- calculate the number of semitones between the C and the key 413 | distanceFromC :: PianoKey -> Int 414 | distanceFromC keySig = 415 | fromMaybe 0 $ elemIndex keySig pianoOctave 416 | 417 | -- the classical modes are just the major modes shifted a bit 418 | distanceFromMajor :: Mode -> Int 419 | distanceFromMajor mode = 420 | case mode of 421 | Dorian -> 10 422 | Phrygian -> 8 423 | Lydian -> 7 424 | Mixolydian -> 5 425 | Aeolian -> 3 426 | Minor -> 3 427 | Locrian -> 1 428 | Major -> 0 429 | Ionian -> 0 430 | 431 | -- rotate left an array by the specificed amount 432 | rotate :: ∀ a. Int -> Array a -> Array a 433 | rotate n xs = drop n xs <> take n xs 434 | 435 | -- Transform the PianoKey into a Pitch with black notes 436 | -- set to Flat or Sharp according to context 437 | pianoKeyToPitch :: Boolean -> PianoKey -> Pitch 438 | pianoKeyToPitch isFlatCtx pianoKey = 439 | let 440 | convertPianoKey :: Boolean -> PianoKey -> Pitch 441 | convertPianoKey _ (White p) = 442 | Pitch 443 | { pitchClass: p 444 | -- , accidental : Implicit 445 | , accidental: Natural 446 | } 447 | convertPianoKey flatCtx (Black p q) = 448 | if flatCtx then 449 | Pitch 450 | { pitchClass: q 451 | , accidental: Flat 452 | } 453 | else 454 | Pitch 455 | { pitchClass: p 456 | , accidental: Sharp 457 | } 458 | in 459 | convertPianoKey isFlatCtx pianoKey 460 | 461 | -- modify a key set by adding new accidental 462 | -- This is ussed in order to start with a simple key signature 463 | -- and end up with an extended set of keys by taking into account 464 | -- the modifications which add specific sharos or flats 465 | modifyKeySet :: Pitch -> KeySet -> KeySet 466 | modifyKeySet newP ks = 467 | case newP of 468 | -- ignore naturals in incomimg key for key signatures 469 | Pitch { pitchClass: _, accidental: Natural } -> 470 | ks 471 | Pitch { pitchClass: pitchClass, accidental: _ } -> 472 | newP : (L.filter (noMatchPC pitchClass) ks) 473 | where 474 | noMatchPC :: PitchClass -> Pitch -> Boolean 475 | noMatchPC pc (Pitch p) = 476 | pc /= p.pitchClass 477 | 478 | -- the key signature in terms of a PianoKey 479 | buildPianoKey :: Pitch -> PianoKey 480 | buildPianoKey (Pitch p) = 481 | case p.accidental of 482 | Flat -> Black (predecessor p.pitchClass) p.pitchClass 483 | Sharp -> Black p.pitchClass (successor p.pitchClass) 484 | _ -> White p.pitchClass 485 | 486 | -- find the successor to a PitchClass 487 | -- this is safe because all values have a defined successor (in a ring) 488 | successor :: PitchClass -> PitchClass 489 | successor pc = 490 | unsafePartial $ fromJust $ succ pc 491 | 492 | -- find the predecessor to a PitchClass 493 | -- again, this is safe because all values have a defined predecessor (in a ring) 494 | predecessor :: PitchClass -> PitchClass 495 | predecessor pc = 496 | unsafePartial $ fromJust $ pred pc 497 | 498 | -- take an arbitrary integer (positive or negative) and return a position 499 | -- within a single Piano keyboard in the rance 0 <= n < 12 500 | -- i.e. consider that it rotates uniformly in both directons 501 | boundedIndex :: Int -> Int 502 | boundedIndex i = 503 | let 504 | newPos = i `mod` notesInChromaticScale 505 | in 506 | if (newPos < 0) then 507 | notesInChromaticScale + newPos 508 | else 509 | newPos 510 | 511 | -- special case to rename B Natural as C Flat 512 | -- (only for use in correcting Db scales) 513 | renameBNatural :: KeySet -> KeySet 514 | renameBNatural = 515 | let 516 | f :: Pitch -> Pitch 517 | f (Pitch p) = 518 | if (p.pitchClass == B) && (p.accidental == Natural) then 519 | Pitch { pitchClass: C, accidental: Flat } 520 | else 521 | Pitch p 522 | in 523 | map f 524 | 525 | -- lookup for providing offsets from C in a chromatic scale 526 | chromaticScaleMap :: Map Pitch Int 527 | chromaticScaleMap = 528 | fromFoldable pitchNumbers 529 | -------------------------------------------------------------------------------- /src/Data/Abc/Meter.purs: -------------------------------------------------------------------------------- 1 | module Data.Abc.Meter 2 | ( getMeter 3 | , getDefaultedMeter 4 | , commonTime 5 | , cutTime 6 | , toRational 7 | ) where 8 | 9 | import Prelude (($), (<<<), join) 10 | import Data.Abc (AbcTune, TimeSignature) 11 | import Data.Abc.Optics (_headers, _Meter) 12 | import Data.Maybe (Maybe, fromMaybe) 13 | import Data.Lens.Fold (firstOf) 14 | import Data.Lens.Traversal (traversed) 15 | import Data.Rational (Rational, (%)) 16 | 17 | -- | Get the tune Meter where present 18 | -- | For more flexibility, you should use the _Meter optic. 19 | getMeter :: AbcTune -> Maybe TimeSignature 20 | getMeter tune = 21 | join $ (firstOf (_headers <<< traversed <<< _Meter) tune) 22 | 23 | -- | Get the meter defaulting to 4/4 24 | getDefaultedMeter :: AbcTune -> TimeSignature 25 | getDefaultedMeter tune = 26 | fromMaybe commonTime $ getMeter tune 27 | 28 | -- | common time - 4/4 29 | commonTime :: TimeSignature 30 | commonTime = 31 | { numerator: 4, denominator: 4} 32 | 33 | -- | cut time - 2/2 34 | cutTime :: TimeSignature 35 | cutTime = 36 | { numerator: 2, denominator: 2} 37 | 38 | -- | convert the time signature to a Rational 39 | toRational :: TimeSignature -> Rational 40 | toRational ts = 41 | ( ts.numerator % ts.denominator ) 42 | 43 | -------------------------------------------------------------------------------- /src/Data/Abc/Midi/Pitch.purs: -------------------------------------------------------------------------------- 1 | -- | Conversion of an ABC pitch to a MIDI pitch 2 | module Data.Abc.Midi.Pitch 3 | ( MidiPitch 4 | , toMidiPitch 5 | , midiPitchOffset 6 | ) 7 | 8 | where 9 | 10 | import Data.Abc (AbcNote, Accidental(..), ModifiedKeySignature, Pitch(..)) 11 | import Data.Abc.Accidentals as Accidentals 12 | import Data.Abc.KeySignature (modifiedKeySet, pitchNumber, notesInChromaticScale) 13 | import Data.Foldable (oneOf) 14 | import Data.List (List(..), (:)) 15 | import Data.Maybe (fromMaybe) 16 | import Prelude ((+), (*), ($)) 17 | 18 | -- | The pitch of a note expressed as a MIDI interval. 19 | type MidiPitch = 20 | Int 21 | 22 | -- | Convert an ABC note pitch to a MIDI pitch. 23 | -- | 24 | -- | AbcNote - the note in question 25 | -- | ModifiedKeySignature - the key signature (possibly modified by extra accidentals) 26 | -- | Accidentals - any notes in this bar which have previously been set explicitly to an accidental which are thus inherited by this note 27 | -- | MidiPitch - the resulting pitch of the MIDI note 28 | toMidiPitch :: ModifiedKeySignature -> Accidentals.Accidentals -> AbcNote -> MidiPitch 29 | toMidiPitch mks barAccidentals n = 30 | (n.octave * notesInChromaticScale) + midiPitchOffset mks barAccidentals n 31 | 32 | -- | convert an AbcNote (pich class and accidental) to a pitch offset in a chromatic scale 33 | midiPitchOffset :: ModifiedKeySignature -> Accidentals.Accidentals -> AbcNote -> Int 34 | midiPitchOffset mks barAccidentals n = 35 | let 36 | inBarAccidental = 37 | Accidentals.lookup n.pitchClass barAccidentals 38 | 39 | inKeyAccidental = 40 | -- accidentalImplicitInKey n.pitchClass mks 41 | Accidentals.implicitInKeySet n.pitchClass (modifiedKeySet mks) 42 | 43 | -- look first for an explicit note accidental, then for an explicit for the same note that occurred earlier in the bar and 44 | -- finally look for an implicit accidental attached to this key signature 45 | accidental = 46 | case n.accidental of 47 | Implicit -> 48 | fromMaybe Natural $ oneOf (inBarAccidental : inKeyAccidental : Nil) 49 | _ -> -- explict 50 | n.accidental 51 | 52 | pattern = 53 | Pitch { pitchClass: n.pitchClass, accidental: accidental } 54 | in 55 | pitchNumber pattern 56 | -------------------------------------------------------------------------------- /src/Data/Abc/Midi/RepeatSections.purs: -------------------------------------------------------------------------------- 1 | -- | Handle any repeated sections when interpreting an ABC tune. 2 | -- | Repeats are optional and can take the form: 3 | -- | 4 | -- | - '|: ABC :|' 5 | -- | - '|:: ABC :|' 6 | -- | - '|: ABC :: DEF :|' 7 | -- | - '|: ABC |1 de :|2 fg |' 8 | -- | - '|: ABC |1,3 def :|2,4 efg |' 9 | -- | 10 | -- | the very first repeat start marker is optional and often absent 11 | module Data.Abc.Midi.RepeatSections 12 | ( initialRepeatState 13 | , indexBar 14 | , finalBar 15 | ) where 16 | 17 | import Data.Abc (Volta) 18 | import Data.Abc.Repeats.Types (BarNo, RepeatState, Section) 19 | import Data.Abc.Repeats.Variant (addVariants, normaliseVoltas) 20 | import Data.Abc.Repeats.Section 21 | ( hasFirstEnding 22 | , isDeadSection 23 | , isUnrepeated 24 | , newSection 25 | , nullSection 26 | , setEndPos 27 | , setMissingRepeatCount 28 | , toOffsetZero 29 | ) 30 | import Data.List (List(..), (:)) 31 | import Data.List.NonEmpty (NonEmptyList) 32 | import Data.Maybe (Maybe(..)) 33 | import Data.Newtype (unwrap) 34 | import Prelude ((==), (>), (<=), (&&), ($), map, not) 35 | 36 | -- | support extensible records for different possible melody forms in the rest 37 | type IndexedBar rest = 38 | { number :: BarNo 39 | , endRepeats :: Int 40 | , startRepeats :: Int 41 | , iteration :: Maybe (NonEmptyList Volta) 42 | | rest 43 | } 44 | 45 | -- | initial repeats i.e. no repeats yet. intro is not used in MIDI production 46 | initialRepeatState :: RepeatState 47 | initialRepeatState = 48 | { current: nullSection, sections: Nil, intro: [] } 49 | 50 | -- | index a bar by identifying any repeat markings and saving the marking against 51 | -- | the bar number 52 | indexBar 53 | :: forall melody 54 | . IndexedBar melody 55 | -> RepeatState 56 | -> RepeatState 57 | indexBar bar r = 58 | case bar.iteration, bar.endRepeats, bar.startRepeats of 59 | -- |1 or |2 etc 60 | Just voltas, 61 | _, 62 | _ -> 63 | let 64 | vsList = map toOffsetZero $ normaliseVoltas voltas 65 | {- _ = spy "normalised volta numbers" vsList -} 66 | in 67 | r { current = addVariants vsList bar.number r.current } 68 | -- |: or :| or | 69 | Nothing, 70 | ends, 71 | starts -> 72 | if (ends > 0 && starts > 0) then 73 | endAndStartSection bar.number true starts r 74 | else if (ends > 0 && starts <= 0) then 75 | endSection bar.number true r 76 | else if (ends <= 0 && starts > 0) then 77 | startSection bar.number starts r 78 | else 79 | r 80 | 81 | {-| accumulate any residual current state from the final bar in the tune -} 82 | finalBar 83 | :: forall melody 84 | . IndexedBar melody 85 | -> RepeatState 86 | -> RepeatState 87 | finalBar bar r = 88 | let 89 | isRepeatEnd = bar.endRepeats > 0 90 | repeatState = endSection bar.number isRepeatEnd r 91 | in 92 | if not (isDeadSection r.current) then 93 | accumulateSection bar.number 0 repeatState 94 | else 95 | repeatState 96 | 97 | -- implementation 98 | 99 | -- accumulate the last section and start a new section -} 100 | startSection :: BarNo -> Int -> RepeatState -> RepeatState 101 | startSection pos repeatStartCount r = 102 | -- a start implies an end of the last section 103 | endAndStartSection pos false repeatStartCount r 104 | 105 | -- end the section. If there is a first repeat, keep it open, else accumulate it 106 | -- pos : the bar number marking the end of section 107 | -- isRepeatEnd : True if invoked with a known Repeat End marker in the bar line 108 | endSection :: BarNo -> Boolean -> RepeatState -> RepeatState 109 | endSection pos isRepeatEnd r = 110 | if (hasFirstEnding r.current) then 111 | let 112 | current = setEndPos pos r.current 113 | in 114 | r { current = current } 115 | else 116 | endAndStartSection pos isRepeatEnd 0 r 117 | 118 | -- end the current section, accumulate it and start a new section 119 | endAndStartSection :: BarNo -> Boolean -> Int -> RepeatState -> RepeatState 120 | endAndStartSection endPos isRepeatEnd repeatStartCount r = 121 | let 122 | -- cater for the situation where the ABC marks the first section of the tune as repeated solely by use 123 | -- of the End Repeat marker with no such explicit marker at the start of the section - it is implied as the tune start 124 | current :: Section 125 | current = 126 | if 127 | isRepeatEnd 128 | && (unwrap r.current).start == Just 0 129 | && (isUnrepeated r.current) then 130 | setMissingRepeatCount r.current 131 | else 132 | r.current 133 | -- now set the end position from the bar number position 134 | current' = setEndPos endPos current 135 | 136 | -- set the new current into the state 137 | endState :: RepeatState 138 | endState = r { current = current' } 139 | in 140 | accumulateSection endPos repeatStartCount endState 141 | 142 | -- accumulate the current section into the full score and re-initialise it 143 | accumulateSection :: BarNo -> Int -> RepeatState -> RepeatState 144 | accumulateSection pos repeatStartCount r = 145 | let 146 | newCurrent = newSection pos repeatStartCount 147 | in 148 | if not (isDeadSection r.current) then 149 | r { sections = r.current : r.sections, current = newCurrent } 150 | else 151 | r { current = newCurrent } 152 | 153 | -------------------------------------------------------------------------------- /src/Data/Abc/Midi/Types.purs: -------------------------------------------------------------------------------- 1 | module Data.Abc.Midi.Types 2 | ( MidiBar 3 | , MidiBars 4 | ) where 5 | 6 | import Data.Maybe (Maybe) 7 | import Data.List (List) 8 | import Data.List.NonEmpty (NonEmptyList) 9 | import Data.Abc (Volta) 10 | import Data.Midi as Midi 11 | 12 | -- | a bar of MIDI music 13 | type MidiBar = 14 | { number :: Int -- sequential from zero 15 | , endRepeats :: Int -- an end repeat (n >= 0) 16 | , startRepeats :: Int -- a start repeat (n >= 0) 17 | , iteration :: Maybe (NonEmptyList Volta) -- an iteration volta marker (|1 or |2 or |1-3 etc) 18 | , midiMessages :: List Midi.Message -- the notes in the bar or any tempo changes 19 | } 20 | 21 | type MidiBars = List MidiBar 22 | -------------------------------------------------------------------------------- /src/Data/Abc/Normaliser.purs: -------------------------------------------------------------------------------- 1 | module Data.Abc.Normaliser 2 | ( normalise 3 | , normaliseBrokenRhythm 4 | , normaliseChord 5 | , normaliseTuneBody 6 | ) where 7 | 8 | import Data.Abc (AbcTune, AbcChord, TuneBody, BodyPart(..), Bar, Broken(..), Music(..), RestOrNote) 9 | import Prelude 10 | 11 | import Data.Abc.Utils (dotFactor) 12 | import Data.Either (Either(..)) 13 | import Data.List (List(..), foldr, (:)) 14 | import Data.Rational (fromInt, toNumber, (%)) 15 | import Data.Tuple (Tuple(..)) 16 | 17 | -- | normalise the tune by flattening any broken rhythm pairs and regularising chord representations 18 | normalise :: AbcTune -> AbcTune 19 | normalise t = 20 | { headers: t.headers, body: (normaliseTuneBody t.body) } 21 | 22 | -- | as for normalise but just applied to the tune body 23 | normaliseTuneBody :: TuneBody -> TuneBody 24 | normaliseTuneBody = 25 | map normaliseBodyPart 26 | 27 | normaliseBodyPart :: BodyPart -> BodyPart 28 | normaliseBodyPart bp = 29 | case bp of 30 | Score ms -> 31 | Score (normaliseBarList ms) 32 | _ -> 33 | bp 34 | 35 | normaliseBarList :: List Bar -> List Bar 36 | normaliseBarList = 37 | map normaliseBar 38 | 39 | normaliseBar :: Bar -> Bar 40 | normaliseBar bar = 41 | let 42 | newMusic = 43 | foldr normaliseMusic Nil bar.music 44 | in 45 | bar { music = newMusic } 46 | 47 | normaliseMusic :: Music -> List Music -> List Music 48 | normaliseMusic next acc = 49 | case next of 50 | BrokenRhythmPair operand1 operator operand2 -> 51 | let 52 | (Tuple music1 music2) = normaliseBrokenRhythm operator operand1 operand2 53 | in 54 | music1 : (music2 : acc) 55 | 56 | Chord c -> 57 | Chord (normaliseChord c) : acc 58 | 59 | _ -> 60 | next : acc 61 | 62 | -- | Apply the specified broken rhythm to each note in the note pair (presented individually) 63 | -- | and return the broken note pair simply as a pair of normalised Music items held in a Tuple 64 | normaliseBrokenRhythm :: Broken -> RestOrNote -> RestOrNote -> (Tuple Music Music) 65 | normaliseBrokenRhythm broken rorNa rorNb = 66 | let 67 | factora = 68 | case broken of 69 | LeftArrow i -> 70 | (fromInt 1) - (dotFactor i) 71 | RightArrow i -> 72 | (fromInt 1) + (dotFactor i) 73 | factorb = 74 | case broken of 75 | LeftArrow i -> 76 | (fromInt 1) + (dotFactor i) 77 | RightArrow i -> 78 | (fromInt 1) - (dotFactor i) 79 | musica = 80 | case rorNa of 81 | Left r -> 82 | Rest r { duration = r.duration * factora} 83 | Right gn -> 84 | let 85 | newAbcNote = gn.abcNote { duration = gn.abcNote.duration * factora } 86 | in 87 | Note gn { abcNote = newAbcNote } 88 | musicb = 89 | case rorNb of 90 | Left r -> 91 | Rest r { duration = r.duration * factorb} 92 | Right gn -> 93 | let 94 | newAbcNote = gn.abcNote { duration = gn.abcNote.duration * factorb } 95 | in 96 | Note gn { abcNote = newAbcNote } 97 | in 98 | Tuple musica musicb 99 | 100 | -- | Normalise an ABC chord by placing the correct duration against each note 101 | -- | and setting the overall Chord length to Unit 102 | normaliseChord :: AbcChord -> AbcChord 103 | normaliseChord abcChord = 104 | case (toNumber abcChord.duration) of 105 | 1.0 -> abcChord 106 | _ -> 107 | let 108 | notes = map (\n -> n { duration = n.duration * abcChord.duration }) abcChord.notes 109 | decorations = abcChord.decorations 110 | leftSlurs = abcChord.leftSlurs 111 | rightSlurs = abcChord.rightSlurs 112 | in 113 | { leftSlurs, decorations, notes, duration: (1 % 1), rightSlurs } 114 | 115 | 116 | 117 | -------------------------------------------------------------------------------- /src/Data/Abc/Octave.purs: -------------------------------------------------------------------------------- 1 | -- | Conversion to a new octave. 2 | module Data.Abc.Octave 3 | ( move 4 | , up 5 | , down 6 | ) where 7 | 8 | import Prelude ((+), map, negate) 9 | import Data.List (List) 10 | import Data.List.NonEmpty (NonEmptyList) 11 | import Data.Either (Either(..)) 12 | import Data.Maybe (Maybe) 13 | import Data.Abc 14 | 15 | -- import Test.Unit.Assert as Assert 16 | -- Exposed API 17 | 18 | -- | if true, then move the tune up an octave, else down. 19 | move :: Boolean -> AbcTune -> AbcTune 20 | move isUp = 21 | if isUp then 22 | up 23 | else 24 | down 25 | 26 | -- | Move the tune up an octave. 27 | up :: AbcTune -> AbcTune 28 | up t = 29 | moveTune 1 t 30 | 31 | -- | Move the tune down octave. 32 | down :: AbcTune -> AbcTune 33 | down t = 34 | moveTune (-1) t 35 | 36 | -- Implementation 37 | moveTune :: Int -> AbcTune -> AbcTune 38 | moveTune i t = 39 | { headers: t.headers, body: (moveTuneBody i t.body) } 40 | 41 | moveTuneBody :: Int -> TuneBody -> TuneBody 42 | moveTuneBody i = 43 | map (moveBodyPart i) 44 | 45 | moveBodyPart :: Int -> BodyPart -> BodyPart 46 | moveBodyPart i bp = 47 | case bp of 48 | Score ms -> 49 | Score (moveBarList i ms) 50 | 51 | _ -> 52 | bp 53 | 54 | moveOctave :: Int -> Music -> Music 55 | moveOctave i m = 56 | case m of 57 | Note n -> 58 | Note (moveGraceableNoteBy i n) 59 | 60 | BrokenRhythmPair n1 b n2 -> 61 | BrokenRhythmPair (moveRestOrNoteBy i n1) b (moveRestOrNoteBy i n2) 62 | 63 | Tuplet tuplet -> 64 | let 65 | maybeGrace = moveMaybeGraceBy i tuplet.maybeGrace 66 | leftSlurs = tuplet.leftSlurs 67 | signature = tuplet.signature 68 | restsOrNotes = moveRestOrNoteList i tuplet.restsOrNotes 69 | in 70 | Tuplet { maybeGrace, leftSlurs, signature, restsOrNotes } 71 | 72 | Chord c -> 73 | Chord (moveChord i c) 74 | 75 | _ -> 76 | m 77 | 78 | moveGraceableNoteBy :: Int -> GraceableNote -> GraceableNote 79 | moveGraceableNoteBy i gn = 80 | let 81 | abcNote = moveNoteBy i gn.abcNote 82 | maybeGrace = moveMaybeGraceBy i gn.maybeGrace 83 | decorations = gn.decorations 84 | leftSlurs = gn.leftSlurs 85 | rightSlurs = gn.rightSlurs 86 | in 87 | { maybeGrace, leftSlurs, decorations, abcNote, rightSlurs } 88 | 89 | moveNoteBy :: Int -> AbcNote -> AbcNote 90 | moveNoteBy i note = 91 | note { octave = note.octave + i } 92 | 93 | moveMaybeGraceBy :: Int -> Maybe Grace -> Maybe Grace 94 | moveMaybeGraceBy i mGrace = 95 | map moveGraceBy mGrace 96 | where 97 | moveGraceBy :: Grace -> Grace 98 | moveGraceBy g = 99 | g { notes = moveNoteList i g.notes } 100 | 101 | moveBarList :: Int -> List Bar -> List Bar 102 | moveBarList i = 103 | map (moveBar i) 104 | 105 | moveBar :: Int -> Bar -> Bar 106 | moveBar i bar = 107 | let 108 | newMusic = 109 | map (moveOctave i) bar.music 110 | in 111 | bar { music = newMusic } 112 | 113 | moveNoteList :: Int -> NonEmptyList AbcNote -> NonEmptyList AbcNote 114 | moveNoteList i = 115 | map (moveNoteBy i) 116 | 117 | moveRestOrNoteBy :: Int -> RestOrNote -> RestOrNote 118 | moveRestOrNoteBy i rn = 119 | case rn of 120 | Left r -> Left r 121 | Right n -> Right (moveGraceableNoteBy i n) 122 | 123 | -- | tuples and broken operands may now contain either rests or notes 124 | moveRestOrNoteList :: Int -> NonEmptyList RestOrNote -> NonEmptyList RestOrNote 125 | moveRestOrNoteList i = 126 | map (moveRestOrNoteBy i) 127 | 128 | moveChord :: Int -> AbcChord -> AbcChord 129 | moveChord i c = 130 | c { notes = moveNoteList i c.notes } 131 | -------------------------------------------------------------------------------- /src/Data/Abc/Optics.purs: -------------------------------------------------------------------------------- 1 | -- | Optics for accessing the tune headers 2 | -- | 3 | -- | ABC allows for multiple headers of the same type to exist: 4 | -- | https://abcnotation.com/wiki/abc:standard:v2.1#file_header 5 | -- | It's not clear how you should discriminate between them if, for example, 6 | -- | you want to display the main tune header on a score. I use the convention 7 | -- | that the first header to be defined is the prominent one. 8 | -- | 9 | -- | It's also probably not necessary that optics are needed to retrieve components of 10 | -- | the tune body because it's almost always necessary to process this serially. 11 | -- | 12 | -- | Usage requires profunctor-optics. 13 | -- | 14 | -- | To retrieve the first title: 15 | -- | 16 | -- | firstOf (_headers <<< traversed <<< _Title) abcTune 17 | -- | 18 | -- | To retrieve all the titles into a list: 19 | -- | 20 | -- | toListOf (_headers <<< traversed <<< _Title) abcTune 21 | -- | 22 | -- | Or to get the tune mode: 23 | -- | 24 | -- | firstOf (_headers <<< traversed <<< _ModifiedKeySignature <<< _keySignature <<< _mode) abcTune 25 | -- | 26 | -- | Or to reset the title of a tune: 27 | -- | 28 | -- | set (_headers <<< traversed <<< _Title) "new title" abcTune 29 | -- | 30 | 31 | module Data.Abc.Optics where 32 | 33 | import Data.Abc 34 | import Data.Maybe (Maybe(..)) 35 | import Data.Lens.Prism (Prism', prism') 36 | import Data.Lens.Lens (Lens') 37 | import Data.Lens.Record (prop) 38 | import Type.Proxy (Proxy(..)) 39 | 40 | -- | the tune headers 41 | _headers :: forall a r. Lens' { headers :: a | r } a 42 | _headers = prop (Proxy :: Proxy "headers") 43 | 44 | -- | the tune body 45 | _body :: forall a r. Lens' { body :: a | r } a 46 | _body = prop (Proxy :: Proxy "body") 47 | 48 | -- | specific headers 49 | 50 | _Area :: Prism' Header String 51 | _Area = prism' Area case _ of 52 | Area a -> Just a 53 | _ -> Nothing 54 | 55 | _Book :: Prism' Header String 56 | _Book = prism' Book case _ of 57 | Book a -> Just a 58 | _ -> Nothing 59 | 60 | _Composer :: Prism' Header String 61 | _Composer = prism' Composer case _ of 62 | Composer a -> Just a 63 | _ -> Nothing 64 | 65 | _Discography :: Prism' Header String 66 | _Discography = prism' Discography case _ of 67 | Discography a -> Just a 68 | _ -> Nothing 69 | 70 | _FileUrl :: Prism' Header String 71 | _FileUrl = prism' FileUrl case _ of 72 | FileUrl a -> Just a 73 | _ -> Nothing 74 | 75 | _Group :: Prism' Header String 76 | _Group = prism' Group case _ of 77 | Group a -> Just a 78 | _ -> Nothing 79 | 80 | _History :: Prism' Header String 81 | _History = prism' History case _ of 82 | History a -> Just a 83 | _ -> Nothing 84 | 85 | _Instruction :: Prism' Header String 86 | _Instruction = prism' Instruction case _ of 87 | Instruction a -> Just a 88 | _ -> Nothing 89 | 90 | _ModifiedKeySignature :: Prism' Header ModifiedKeySignature 91 | _ModifiedKeySignature = prism' Key case _ of 92 | Key mks -> Just mks 93 | _ -> Nothing 94 | 95 | _UnitNoteLength :: Prism' Header NoteDuration 96 | _UnitNoteLength = prism' UnitNoteLength case _ of 97 | UnitNoteLength a -> Just a 98 | _ -> Nothing 99 | 100 | _Meter :: Prism' Header (Maybe TimeSignature) 101 | _Meter = prism' Meter case _ of 102 | Meter maybeTs -> Just maybeTs 103 | _ -> Nothing 104 | 105 | _Macro :: Prism' Header String 106 | _Macro = prism' Macro case _ of 107 | Macro a -> Just a 108 | _ -> Nothing 109 | 110 | _Notes :: Prism' Header String 111 | _Notes = prism' Notes case _ of 112 | Notes a -> Just a 113 | _ -> Nothing 114 | 115 | _Origin :: Prism' Header String 116 | _Origin = prism' Origin case _ of 117 | Origin a -> Just a 118 | _ -> Nothing 119 | 120 | _Parts :: Prism' Header String 121 | _Parts = prism' Parts case _ of 122 | Parts a -> Just a 123 | _ -> Nothing 124 | 125 | _Tempo :: Prism' Header TempoSignature 126 | _Tempo = prism' Tempo case _ of 127 | Tempo a -> Just a 128 | _ -> Nothing 129 | 130 | _Rhythm :: Prism' Header String 131 | _Rhythm = prism' Rhythm case _ of 132 | Rhythm a -> Just a 133 | _ -> Nothing 134 | 135 | _Remark :: Prism' Header String 136 | _Remark = prism' Remark case _ of 137 | Remark a -> Just a 138 | _ -> Nothing 139 | 140 | _Source :: Prism' Header String 141 | _Source = prism' Source case _ of 142 | Source a -> Just a 143 | _ -> Nothing 144 | 145 | _SymbolLine :: Prism' Header String 146 | _SymbolLine = prism' SymbolLine case _ of 147 | SymbolLine a -> Just a 148 | _ -> Nothing 149 | 150 | _Title :: Prism' Header String 151 | _Title = prism' Title case _ of 152 | Title a -> Just a 153 | _ -> Nothing 154 | 155 | _Voice :: Prism' Header VoiceDescription 156 | _Voice = prism' Voice case _ of 157 | Voice a -> Just a 158 | _ -> Nothing 159 | 160 | _WordsAfter :: Prism' Header String 161 | _WordsAfter = prism' WordsAfter case _ of 162 | WordsAfter a -> Just a 163 | _ -> Nothing 164 | 165 | _WordsAligned :: Prism' Header String 166 | _WordsAligned = prism' WordsAligned case _ of 167 | WordsAligned a -> Just a 168 | _ -> Nothing 169 | 170 | _ReferenceNumber :: Prism' Header (Maybe Int) 171 | _ReferenceNumber = prism' ReferenceNumber case _ of 172 | ReferenceNumber maybeRef -> Just maybeRef 173 | _ -> Nothing 174 | 175 | _Transcription :: Prism' Header String 176 | _Transcription = prism' Transcription case _ of 177 | Transcription a -> Just a 178 | _ -> Nothing 179 | 180 | _FieldContinuation :: Prism' Header String 181 | _FieldContinuation = prism' FieldContinuation case _ of 182 | FieldContinuation a -> Just a 183 | _ -> Nothing 184 | 185 | _Comment :: Prism' Header String 186 | _Comment = prism' Comment case _ of 187 | Comment a -> Just a 188 | _ -> Nothing 189 | 190 | -- | modified Key signature fields 191 | 192 | -- | the underlying key signature 193 | _keySignature :: forall a r. Lens' { keySignature :: a | r } a 194 | _keySignature = prop (Proxy :: Proxy "keySignature") 195 | 196 | -- | modifications to the key signature 197 | _keySignatureModifications :: forall a r. Lens' { modifications :: a | r } a 198 | _keySignatureModifications = prop (Proxy :: Proxy "modifications") 199 | 200 | -- | the pitch class e.g. A 201 | _pitchClass :: forall a r. Lens' { pitchClass :: a | r } a 202 | _pitchClass = prop (Proxy :: Proxy "pitchClass") 203 | 204 | -- the accidental e.g. Sharp 205 | _accidental :: forall a r. Lens' { accidental :: a | r } a 206 | _accidental = prop (Proxy :: Proxy "accidental") 207 | 208 | -- the mode of the key signature e.g. Major 209 | _mode :: forall a r. Lens' { mode :: a | r } a 210 | _mode = prop (Proxy :: Proxy "mode") 211 | 212 | -- | Tempo signature fields 213 | 214 | -- bpm (beats per minute) 215 | _bpm :: forall a r. Lens' { bpm :: a | r } a 216 | _bpm = prop (Proxy :: Proxy "bpm") 217 | 218 | -- the note lengths 219 | _noteLengths :: forall a r. Lens' { noteLengths :: a | r } a 220 | _noteLengths = prop (Proxy :: Proxy "noteLengths") 221 | 222 | _marking :: forall a r. Lens' { marking :: a | r } a 223 | _marking = prop (Proxy :: Proxy "marking") 224 | 225 | -- | Voice fields 226 | _id :: forall a r. Lens' { id :: a | r } a 227 | _id = prop (Proxy :: Proxy "id") 228 | 229 | -- | key signature or voice description properties 230 | _properties :: forall a r. Lens' { properties :: a | r } a 231 | _properties = prop (Proxy :: Proxy "properties") 232 | 233 | -------------------------------------------------------------------------------- /src/Data/Abc/Repeats/Section.purs: -------------------------------------------------------------------------------- 1 | -- | Utility functions to deal with Repeated Sections 2 | module Data.Abc.Repeats.Section 3 | ( hasFirstEnding 4 | , isDeadSection 5 | , isUnrepeated 6 | , newSection 7 | , nullSection 8 | , setEndPos 9 | , setMissingRepeatCount 10 | , toOffsetZero 11 | ) where 12 | 13 | import Data.Abc.Repeats.Types (BarNo, Label(..), Section(..)) 14 | import Data.Abc.Repeats.Variant (variantPositionOf) 15 | import Data.Map (empty) 16 | import Data.Maybe (Maybe(..), isJust) 17 | import Prelude ((==), (<=), (-)) 18 | 19 | -- | volta repeat markers are wrt offset 1 - reduce to 0 20 | toOffsetZero :: Int -> Int 21 | toOffsetZero i = 22 | if i <= 0 then 0 else i - 1 23 | 24 | -- start a new section 25 | newSection :: BarNo -> Int -> Section 26 | newSection pos repeatCount = 27 | Section 28 | { start: Just pos 29 | , variantPositions: empty 30 | , end: Just 0 31 | , repeatCount: repeatCount 32 | , label: OtherPart -- not used here 33 | } 34 | 35 | -- a 'null' section 36 | nullSection :: Section 37 | nullSection = 38 | newSection 0 0 39 | 40 | -- return true if the section is devoid of any useful content 41 | isDeadSection :: Section -> Boolean 42 | isDeadSection s = 43 | s == nullSection 44 | 45 | -- return true if the repeat count of a section is not set 46 | isUnrepeated :: Section -> Boolean 47 | isUnrepeated (Section s) = 48 | s.repeatCount == 0 49 | 50 | -- return true if the first (variant) ending is set 51 | hasFirstEnding :: Section -> Boolean 52 | hasFirstEnding s = 53 | isJust (variantPositionOf 0 s) 54 | 55 | -- set the repeatedCount status of a section if it is missing 56 | -- (in the wild we get |......|.....:| etc. with no start colon) 57 | setMissingRepeatCount :: Section -> Section 58 | setMissingRepeatCount (Section s) = 59 | Section s { repeatCount = 1 } 60 | 61 | -- set the end BarNo position of a section 62 | setEndPos :: BarNo -> Section -> Section 63 | setEndPos pos (Section s) = 64 | Section s { end = Just pos } 65 | 66 | -------------------------------------------------------------------------------- /src/Data/Abc/Repeats/Types.purs: -------------------------------------------------------------------------------- 1 | -- | Data types representing tune sections as defined by bar 2 | -- | number indexes and repeat indicators which are either 3 | -- | simple repeats or variant repeats (voltas) 4 | 5 | module Data.Abc.Repeats.Types 6 | ( BarNo 7 | , Label(..) 8 | , Section(..) 9 | , Sections 10 | , RepeatState 11 | , VariantPositions 12 | ) where 13 | 14 | import Prelude (class Eq, class Show) 15 | import Data.Generic.Rep 16 | import Data.Maybe (Maybe) 17 | import Data.List (List) 18 | import Data.Map (Map) 19 | import Data.Newtype (class Newtype) 20 | import Data.Eq.Generic (genericEq) 21 | import Data.Show.Generic (genericShow) 22 | 23 | data Label 24 | = LeadIn -- lead-in bars existing in the tune 25 | | Intro --- artificially generated Intro 26 | | APart 27 | | OtherPart 28 | 29 | instance showLabel :: Show Label where 30 | show LeadIn = "Lead-in" 31 | show Intro = "Intro" 32 | show APart = "A Part" 33 | show OtherPart = "Other Part" 34 | 35 | derive instance eqLabel :: Eq Label 36 | 37 | -- a bar number in the melody 38 | type BarNo = Int 39 | 40 | -- | a map of variant number (wrt offest zero - i.e. |1 becomes 0) 41 | -- | to the bar number where that variant is found 42 | type VariantPositions = Map Int BarNo 43 | 44 | -- | a section of the tune (possibly repeated) 45 | -- | with indices given by the bar number where the feature lives 46 | newtype Section = Section 47 | { start :: Maybe BarNo 48 | , variantPositions :: VariantPositions 49 | , end :: Maybe BarNo 50 | , repeatCount :: Int 51 | , label :: Label 52 | } 53 | 54 | derive instance newtypeSection :: Newtype Section _ 55 | derive instance genericSection :: Generic Section _ 56 | instance eqSection :: Eq Section where 57 | eq = genericEq 58 | 59 | instance showSection :: Show Section where 60 | show = genericShow 61 | 62 | -- | a set of sections 63 | type Sections = List Section 64 | 65 | -- | the current repeat state 66 | type RepeatState = 67 | { current :: Section 68 | , sections :: Sections 69 | , intro :: Array Int -- only used whenever we intend to support intros 70 | } -------------------------------------------------------------------------------- /src/Data/Abc/Repeats/Variant.purs: -------------------------------------------------------------------------------- 1 | -- | Variant Repeats 2 | -- | 3 | -- | support for the ABC volta construction: 4 | -- | ..|1 ..... :|2 ...:|3 .... 5 | -- | or ..|1,2,3.. :|4.... | etc 6 | -- | 7 | module Data.Abc.Repeats.Variant 8 | ( activeVariants 9 | , secondVariantPosition 10 | , addVariants 11 | , findEndingPosition 12 | , normaliseVoltas 13 | , variantPositionOf 14 | , variantIndexMax 15 | , variantCount 16 | ) where 17 | 18 | import Prelude (($), (>), (<>)) 19 | import Data.Abc (Volta(..)) 20 | import Data.Abc.Repeats.Types (BarNo, Section(..), VariantPositions) 21 | import Data.Foldable (foldr) 22 | import Data.List (List(..), (:), range) 23 | import Data.List.NonEmpty (NonEmptyList) 24 | import Data.Map (filter, insert, keys, lookup, size, toUnfoldable) 25 | import Data.Set (findMin, findMax) 26 | import Data.Tuple (Tuple) 27 | import Data.Maybe (Maybe(..), fromJust, fromMaybe) 28 | import Partial.Unsafe (unsafePartial) 29 | 30 | -- | the active variants returned as an array of tuples (variant no - bar no) 31 | activeVariants :: Section -> Array (Tuple Int BarNo) 32 | activeVariants (Section s) = 33 | toUnfoldable s.variantPositions 34 | 35 | -- | the variant bar number of the specified variant number 36 | variantPositionOf :: Int -> Section -> Maybe BarNo 37 | variantPositionOf n (Section s) = 38 | lookup n s.variantPositions 39 | 40 | -- | the bar number of the second variant 41 | secondVariantPosition :: Section -> Maybe BarNo 42 | secondVariantPosition s = 43 | variantPositionOf 1 s 44 | 45 | -- | add the list of variants having this bar number position to the existing variants 46 | addVariants :: List Int -> BarNo -> Section -> Section 47 | addVariants variants barNo (Section s) = 48 | let 49 | -- the update defintions sets each variant to be associated with the barNo 50 | variantPositions :: VariantPositions 51 | variantPositions = insertAllVariantIndices variants barNo s.variantPositions 52 | in 53 | Section s { variantPositions = variantPositions, repeatCount = 1 } 54 | 55 | -- | the number of variants in the ending 56 | variantCount :: Section -> Int 57 | variantCount (Section s) = 58 | size s.variantPositions 59 | 60 | -- | the maximum index we can use of the active variants 61 | variantIndexMax :: Section -> Int 62 | variantIndexMax (Section s) = 63 | let 64 | variantIndices = keys s.variantPositions 65 | in 66 | fromMaybe 0 $ findMax variantIndices 67 | 68 | -- set a bunch of variant positions with the same bar number position 69 | insertAllVariantIndices :: List Int -> BarNo -> VariantPositions -> VariantPositions 70 | insertAllVariantIndices variants barNo variantPositions = 71 | let 72 | f :: Int -> VariantPositions -> VariantPositions 73 | f v positions = 74 | insert v barNo positions 75 | in 76 | foldr f variantPositions variants 77 | 78 | -- | When supplied with: 79 | -- | the variant positions (map of index to BarNo) 80 | -- | the index of the current variant 81 | -- | the BarNo of the end of the entire section 82 | -- | then find the BarNo of the end of the variant 83 | -- | (This can either be the start of the next variant or the section end) 84 | findEndingPosition :: VariantPositions -> Int -> BarNo -> BarNo 85 | findEndingPosition variantPositions index end = 86 | -- find the position of the variant at this index 87 | case (lookup index variantPositions) of 88 | Nothing -> 89 | end 90 | Just thisPos -> 91 | let 92 | -- find all variants with bar positions greater than our position 93 | candidates = filter (_ > thisPos) variantPositions 94 | -- find the minimum key amongst these candidates 95 | mNext = findMin $ keys candidates 96 | in 97 | case mNext of 98 | Nothing -> 99 | -- nothing there - default to end 100 | end 101 | Just next -> 102 | -- look it up - it will never fail because we know the key exists 103 | unsafePartial $ fromJust $ lookup next candidates 104 | 105 | -- | Normalise a list of Voltas to a simple list of volta repeat numbers 106 | normaliseVoltas :: NonEmptyList Volta -> List Int 107 | normaliseVoltas vs = 108 | let 109 | f :: Volta -> List Int -> List Int 110 | f volta acc = 111 | case volta of 112 | Volta i -> 113 | i : acc 114 | VoltaRange start end -> 115 | (range start end) <> acc 116 | in 117 | foldr f Nil vs 118 | -------------------------------------------------------------------------------- /src/Data/Abc/Tempo.purs: -------------------------------------------------------------------------------- 1 | -- | Conversion functions for Tempo. 2 | module Data.Abc.Tempo 3 | ( MidiTick 4 | , AbcTempo 5 | , defaultTempo 6 | , defaultAbcTempo 7 | , getTempoSig 8 | , getAbcTempo 9 | , midiTempo 10 | , beatsPerSecond 11 | , getBpm 12 | , setBpm 13 | , playedNoteDuration 14 | , standardMidiTick 15 | , noteTicks 16 | , chordalNoteTicks 17 | ) where 18 | 19 | import Data.Abc 20 | 21 | import Data.Abc.Meter (getDefaultedMeter) 22 | import Data.Abc.Optics (_bpm, _headers, _Tempo) 23 | import Data.Abc.UnitNote (defaultUnitNoteLength, getUnitNoteLength) 24 | import Data.Foldable (foldl) 25 | import Data.Int (round) 26 | import Data.Lens.Fold (firstOf) 27 | import Data.Lens.Setter (set) 28 | import Data.Lens.Traversal (traversed) 29 | import Data.List ((:), List(..), filter, reverse) 30 | import Data.List.NonEmpty (singleton) 31 | import Data.Maybe (Maybe(..), fromMaybe) 32 | import Data.Rational (Rational, (%), fromInt, toNumber) 33 | import Prelude (($), (+), (/), (*), (<<<)) 34 | 35 | -- Exposed API 36 | 37 | -- | A MIDI tick - used to give a note duration. 38 | type MidiTick = 39 | Int 40 | 41 | -- | a standard beat is a quarter note 42 | -- | in tempo signatures such as 1/4=120 43 | standardBeatLength :: Rational 44 | standardBeatLength = (1 % 4) 45 | 46 | -- | ditto for a standard beat per minute (BPM) 47 | standardBPM :: Int 48 | standardBPM = 120 49 | 50 | -- | The tempo when the tune is being played. This is usually represented 51 | -- | as (for example) 1/4 = 120 - i.e. 120 querter notes per minute. 52 | -- | this is a consolidation of both the Tempo and the Unit Note length 53 | -- | which thus encapsulates everything you need to calculate the overall 54 | -- | tempo of the tune 55 | -- | 56 | -- | tempoNoteLength - the note length of a tempo definition 57 | -- | bpm - the beats per minute of a tempo Definition 58 | -- | unitNoteLength - the length of a 'unit note' in the ABC definition 59 | type AbcTempo = 60 | { tempoNoteLength :: Rational 61 | , bpm :: Int 62 | , unitNoteLength :: Rational 63 | } 64 | 65 | -- | The default Tempo - 1/4=120. 66 | defaultTempo :: TempoSignature 67 | defaultTempo = 68 | { noteLengths: singleton standardBeatLength 69 | , bpm: standardBPM 70 | , marking: Nothing 71 | } 72 | 73 | -- | default to 1/4=120 with eighth notes as the default note length 74 | -- | this works out that an eighth notes last for 1/4 second 75 | defaultAbcTempo :: AbcTempo 76 | defaultAbcTempo = 77 | { tempoNoteLength: standardBeatLength 78 | , bpm: standardBPM 79 | , unitNoteLength: 1 % 8 80 | } 81 | 82 | -- | Get the raw tempo signature from the tune 83 | -- | For more flexibility, you should use the _Tempo optic. 84 | getTempoSig :: AbcTune -> Maybe TempoSignature 85 | getTempoSig tune = 86 | firstOf (_headers <<< traversed <<< _Tempo) tune 87 | 88 | -- | Get the ABC tempo from the tune 89 | -- | This is usually more useful because it incorporates the unit note length 90 | getAbcTempo :: AbcTune -> AbcTempo 91 | getAbcTempo tune = 92 | let 93 | tempoSig = fromMaybe defaultTempo $ getTempoSig tune 94 | meterSig = getDefaultedMeter tune 95 | unitNoteLength = fromMaybe (defaultUnitNoteLength meterSig) $ getUnitNoteLength tune 96 | in 97 | { tempoNoteLength: foldl (+) (fromInt 0) tempoSig.noteLengths 98 | , bpm: tempoSig.bpm 99 | , unitNoteLength: unitNoteLength 100 | } 101 | 102 | {- 103 | midiTempo algorithm is: 104 | t.bpm beats occupy 1 minute or 60 * 10^6 μsec 105 | 1 bpm beat occupies 60 * 10^6/t.bpm μsec 106 | but we use a standard beat of 1 unit when writing a note, whereas the bpm measures a tempo note length of 107 | t.unitNoteLength/t.tempoNoteLength 108 | i.e. 109 | 1 whole note beat occupies 60 * 10^6/t.bpm * t.unl/t.tnl μsec 110 | -} 111 | 112 | -- | The MIDI tempo measured in microseconds per beat. 113 | -- | JMW!!! check 114 | midiTempo :: AbcTempo -> Int 115 | midiTempo t = 116 | let 117 | relativeNoteLength = 118 | t.unitNoteLength / t.tempoNoteLength 119 | in 120 | round ((60.0 * 1000000.0 * (toNumber relativeNoteLength)) / (toNumber $ fromInt t.bpm)) 121 | 122 | -- | calculate the number of beats per second given by an ABC tempo 123 | -- | to give a simple indication of the tempo of the overall melody 124 | -- | note that this is independent of the unit note length 125 | beatsPerSecond :: AbcTempo -> Rational 126 | beatsPerSecond t = 127 | (t.bpm % 60) * (t.tempoNoteLength / standardBeatLength) 128 | 129 | -- | Get the tempo of the tune in beats per minute from the tunes header 130 | -- | (if it exists) or the default of 120 if it does not. 131 | getBpm :: AbcTune -> Int 132 | getBpm tune = 133 | case (firstOf (_headers <<< traversed <<< _Tempo <<< _bpm) tune) of 134 | Just bpm -> bpm 135 | _ -> defaultTempo.bpm 136 | 137 | -- | Change the tempo of the tune by altering the beats per minute (bpm) 138 | -- | in the tune's tempo header (if it exists) or by altering a newly incorporated 139 | -- | default tempo if not. 140 | setBpm :: Int -> AbcTune -> AbcTune 141 | setBpm bpm tune = 142 | case (firstOf (_headers <<< traversed <<< _Tempo) tune) of 143 | Just _ -> 144 | set (_headers <<< traversed <<< _Tempo <<< _bpm) bpm tune 145 | _ -> 146 | let 147 | t = defaultTempo { bpm = bpm } 148 | newTempoHeader = (Tempo t) 149 | newHeaders = replaceTempoHeader newTempoHeader tune.headers 150 | in 151 | { headers: newHeaders, body: tune.body } 152 | 153 | -- Player support 154 | 155 | -- | calculate the note duration when it is played (in seconds) 156 | -- | from an ABC note duration and tempo 157 | playedNoteDuration :: AbcTempo -> Rational -> Number 158 | playedNoteDuration abcTempo noteLength = 159 | let 160 | bps = beatsPerSecond abcTempo 161 | beatLength = abcTempo.unitNoteLength / (1 % 4) 162 | in 163 | toNumber $ beatLength * noteLength / bps 164 | 165 | -- MIDI support 166 | 167 | -- | A standard MIDI tick - we use 1/4 note = 480 ticks. 168 | -- | this is known as 'ticks per quarter note' or 'parts per quarter' 169 | -- | in MIDI literature, 480 tends to be standard. 170 | standardMidiTick :: MidiTick 171 | standardMidiTick = 172 | 480 173 | 174 | -- | Assume a standard unit note length of 1/4 and a standard number of ticks per unit (1/4) note of 480. 175 | noteTicks :: Rational -> MidiTick 176 | noteTicks n = 177 | -- (standardMidiTick * (numerator n)) // (denominator n) 178 | round $ toNumber $ n * (fromInt standardMidiTick) 179 | 180 | -- | Find the MIDI duration of a note within a chord in standard ticks 181 | -- | (1/4 note == 480 ticks) 182 | chordalNoteTicks :: Rational -> Rational -> MidiTick 183 | chordalNoteTicks note chord = 184 | round $ toNumber $ note * chord * (fromInt standardMidiTick) 185 | 186 | -- implementation 187 | 188 | -- | replace a tempo header (if it exists) 189 | replaceTempoHeader :: Header -> TuneHeaders -> TuneHeaders 190 | replaceTempoHeader newTempoHeader hs = 191 | let 192 | f h = 193 | case h of 194 | Tempo _ -> 195 | false 196 | _ -> 197 | true 198 | 199 | newhs = 200 | filter f hs 201 | in 202 | placeHeaderPenultimately newTempoHeader newhs 203 | 204 | -- | the last ABC header should always be the key signature so we'll 205 | -- | choose to set the (altered) tempo header as next-to-last. 206 | placeHeaderPenultimately :: Header -> TuneHeaders -> TuneHeaders 207 | placeHeaderPenultimately h hs = 208 | case reverse hs of 209 | Nil -> 210 | (h : Nil) 211 | x : xs -> 212 | reverse (x : h : xs) 213 | 214 | -------------------------------------------------------------------------------- /src/Data/Abc/UnitNote.purs: -------------------------------------------------------------------------------- 1 | -- | The length of a unit note - see 3.1.7 L: - unit note length 2 | module Data.Abc.UnitNote 3 | ( defaultUnitNoteLength 4 | , getUnitNoteLength 5 | ) where 6 | 7 | import Prelude ((/), (<), (<<<)) 8 | import Data.Abc (AbcTune, TimeSignature, NoteDuration) 9 | import Data.Abc.Optics (_headers, _UnitNoteLength) 10 | import Data.Int (toNumber) 11 | import Data.Lens.Fold (firstOf) 12 | import Data.Lens.Traversal (traversed) 13 | import Data.Maybe (Maybe) 14 | import Data.Rational ((%)) 15 | 16 | -- | Get the unit note length 17 | -- | For more flexibility, you should use the _UnitNoteLength optic. 18 | getUnitNoteLength :: AbcTune -> Maybe NoteDuration 19 | getUnitNoteLength tune = 20 | firstOf (_headers <<< traversed <<< _UnitNoteLength) tune 21 | 22 | -- calculate the default unit note length from the Meter 23 | -- signature (which defaults to 4/4) 24 | defaultUnitNoteLength :: TimeSignature -> NoteDuration 25 | defaultUnitNoteLength sig = 26 | let 27 | computedMeter :: Number 28 | computedMeter = 29 | case sig of 30 | { numerator, denominator} -> (toNumber numerator) / (toNumber denominator) 31 | in 32 | if (computedMeter < 0.75) then 33 | (1 % 16) 34 | else 35 | (1 % 8) -------------------------------------------------------------------------------- /src/Data/Abc/Utils.purs: -------------------------------------------------------------------------------- 1 | -- | A Ragbag of convenience functions, many of which get Metadata from ABC 2 | module Data.Abc.Utils 3 | ( getTitle 4 | , dotFactor 5 | , chordDuration 6 | , tupletDuration 7 | , isEmptyStave 8 | , thumbnail 9 | , removeRepeatMarkers 10 | ) where 11 | 12 | import Data.Abc 13 | 14 | import Data.Abc.Optics (_headers, _Title) 15 | import Data.Either (Either(..)) 16 | import Data.Foldable (all, foldr) 17 | import Data.Lens.Fold (firstOf) 18 | import Data.Lens.Traversal (traversed) 19 | import Data.List (List(..), head, null, singleton, snoc, take) 20 | import Data.List.NonEmpty (head) as NEL 21 | import Data.Maybe (Maybe(..), maybe) 22 | import Data.Rational (Rational, (%), fromInt) 23 | import Data.String.Common (trim) 24 | import Prelude (map, ($), (||), (==), (*), (+), (<<<)) 25 | 26 | -- | Get the first Title (if any) from the tune. 27 | -- | For more flexibility, you should use the _Title optic. 28 | getTitle :: AbcTune -> Maybe String 29 | getTitle tune = 30 | map trim $ firstOf (_headers <<< traversed <<< _Title) tune 31 | 32 | -- | The amount by which you increase or decrease the duration of a (possibly multiply) dotted note. 33 | -- | For example A > B increases the duration of A and proportionally reduces that of B. 34 | -- | A << B decreases the duration of A and increases that of B by an even greater amount. This function 35 | -- | calculates the increase or decrease. The new duration will be given by: 36 | -- | 37 | -- | duration * (1 +/- dotfactor i) 38 | -- | 39 | -- | i is the number of 'dot' indicators (< or >) 40 | -- | 41 | dotFactor :: Int -> Rational 42 | dotFactor i = 43 | case i of 44 | 1 -> 45 | 1 % 2 46 | 47 | 2 -> 48 | 3 % 4 49 | 50 | 3 -> 51 | 7 % 8 52 | 53 | _ -> 54 | 0 % 1 55 | 56 | -- | check if a new stave's contents is effectively empty 57 | -- | (the list of bars is introduced by the Score BodyPart) 58 | isEmptyStave :: List Bar -> Boolean 59 | isEmptyStave bars = 60 | all isEmptyBar bars 61 | where 62 | isEmptyBar :: Bar -> Boolean 63 | isEmptyBar bar = 64 | let 65 | f music' = 66 | case music' of 67 | Spacer _ -> 68 | true 69 | Ignore -> 70 | true 71 | Continuation _ -> 72 | true 73 | _ -> 74 | false 75 | in 76 | all f bar.music || null bar.music 77 | 78 | 79 | 80 | -- | Get the duration of a chord. We consider notes in a chord to have the same 81 | -- | duration (as the first such note) and must also cater for the overall chord duration. 82 | chordDuration :: AbcChord -> NoteDuration 83 | chordDuration chord = 84 | (NEL.head chord.notes).duration * chord.duration 85 | 86 | restOrNoteDuration :: RestOrNote -> NoteDuration 87 | restOrNoteDuration = 88 | case _ of 89 | Left r -> 90 | r.duration 91 | Right gn -> 92 | gn.abcNote.duration 93 | 94 | -- | Get the overall duration of a tuplet 95 | tupletDuration :: AbcTuplet -> NoteDuration 96 | tupletDuration t = 97 | modifier * foldr adder (fromInt 0) t.restsOrNotes 98 | 99 | where 100 | adder :: RestOrNote -> NoteDuration -> NoteDuration 101 | adder rorn acc = restOrNoteDuration rorn + acc 102 | 103 | modifier = t.signature.q % t.signature.p 104 | 105 | -- filter the bars we need for the thumbnail and terminate properly with 106 | -- an empty bar. 107 | filterBars :: List Bar -> List Bar 108 | filterBars bars = 109 | let 110 | -- identify whether we have a lead-in bar 111 | count = 112 | case head bars of 113 | Nothing -> 114 | 0 115 | Just bar -> 116 | if (bar.startLine.thickness == Invisible) then 3 117 | else 2 118 | 119 | emptyBarLine :: BarLine 120 | emptyBarLine = 121 | { endRepeats: 0 122 | , thickness: Thin 123 | , startRepeats: 0 124 | , iteration: Nothing 125 | } 126 | 127 | emptyBar :: Bar 128 | emptyBar = 129 | { decorations: Nil 130 | , startLine: emptyBarLine 131 | , music: Nil 132 | } 133 | in 134 | snoc (take count bars) emptyBar 135 | 136 | -- | reduce an ABC tune to a 'thumbnail' of the first two full bars 137 | thumbnail :: AbcTune -> AbcTune 138 | thumbnail t = 139 | let 140 | f :: BodyPart -> List Bar 141 | f = case _ of 142 | Score bars -> bars 143 | _ -> Nil 144 | 145 | firstLine :: List Bar 146 | firstLine = maybe Nil f $ head t.body 147 | newBody = singleton (Score $ filterBars firstLine) 148 | in 149 | t { body = newBody } 150 | 151 | -- | remove repeat markers (used for thumbnails where we need to ignore them) 152 | removeRepeatMarkers :: AbcTune -> AbcTune 153 | removeRepeatMarkers abcTune = 154 | 155 | { headers: abcTune.headers 156 | , body: replaceBody abcTune.body 157 | } 158 | 159 | where 160 | 161 | removeRepeat :: Bar -> Bar 162 | removeRepeat bar = 163 | let 164 | newStartLine = bar.startLine { startRepeats = 0, endRepeats = 0 } 165 | in 166 | bar { startLine = newStartLine } 167 | 168 | replaceBars :: List Bar -> List Bar 169 | replaceBars = map removeRepeat 170 | 171 | replaceBodyPart :: BodyPart -> BodyPart 172 | replaceBodyPart bp = 173 | case bp of 174 | Score bars -> 175 | Score $ replaceBars bars 176 | _ -> 177 | bp 178 | 179 | replaceBody :: List BodyPart -> List BodyPart 180 | replaceBody = map replaceBodyPart 181 | 182 | 183 | -------------------------------------------------------------------------------- /src/Data/Abc/Voice.purs: -------------------------------------------------------------------------------- 1 | -- | Basic support for polyphonic ABC tunes. 2 | -- | 3 | -- | Where voice headers are present in the tune body, partition it 4 | -- | into seperate bodies, one for each voice. 5 | -- | 6 | -- | In ABC, voices can be introduced like this: 7 | -- | 8 | -- | V:1 9 | -- | abc ... 10 | -- | def ... 11 | -- | V:2 12 | -- | CDE ... 13 | -- | EFG .... 14 | -- | 15 | -- | or like this: 16 | -- | 17 | -- | [V:1] abc ... 18 | -- | [V:1] def ... 19 | -- | [V:2] CDE ... 20 | -- | [V:2] EFG 21 | -- | 22 | -- | which means that we either have a self-standing voice header before each group 23 | -- | of lines (which inherit this voice) or else we have an inline voice header defined 24 | -- | explictly against each line. 25 | -- | 26 | -- | Of course, there is nothing in the spec which prevents degenerate cases where 27 | -- | both forms are present. In this case, we'll assume inline headers take precedence 28 | -- | 29 | -- | The strategy is to fold over the tune structure in the State monad. State will be 30 | -- | changed each time we come across a free-standing Voice header in the tune body. 31 | -- | The current voice is this unless over-ridden by an inline voice. 32 | -- | The fold builds up a Map of Voices to partitioned ABC tune bodies 33 | module Data.Abc.Voice 34 | ( getVoiceLabels 35 | , getVoiceMap 36 | , partitionVoices 37 | , partitionTuneBody 38 | ) where 39 | 40 | import Control.Monad.State.Class (get, put, modify) 41 | import Control.Monad.State.Trans (StateT, evalStateT) 42 | import Data.Abc (AbcTune, Bar, BodyPart(..), Header(..), Music(..), TuneBody, TuneHeaders) 43 | import Data.Abc.Utils (isEmptyStave) 44 | import Data.Abc.Optics (_headers, _Voice, _Title) 45 | import Data.Array.NonEmpty (NonEmptyArray) 46 | import Data.Array.NonEmpty.Internal (NonEmptyArray(..)) as Unsafe 47 | import Data.Foldable (foldM) 48 | import Data.Identity (Identity) 49 | import Data.Lens.Fold (firstOf, lastOf) 50 | import Data.Lens.Traversal (traversed) 51 | import Data.Lens.Setter (over) 52 | import Data.List (List, (:), filter, head, singleton, snoc) 53 | import Data.Map (Map, empty, fromFoldable, lookup, insert, toUnfoldable) 54 | import Data.Maybe (Maybe(..)) 55 | import Data.Newtype (unwrap) 56 | import Data.Set (Set, empty, insert, toUnfoldable) as Set 57 | import Data.Tuple (Tuple(..), snd) 58 | import Prelude (class Eq, class Ord, ($), (==), (<<<), (<>), bind, join, map, not, pure) 59 | 60 | data VoiceLabel 61 | = VoiceLabel String 62 | | NoLabel 63 | 64 | derive instance eqVoiceLabel :: Eq VoiceLabel 65 | derive instance ordVoiceLabel :: Ord VoiceLabel 66 | 67 | type VoiceMap = Map VoiceLabel TuneBody 68 | 69 | type VoiceM = StateT VoiceLabel Identity 70 | 71 | type Labels = Set.Set String 72 | 73 | type LabelM = StateT Labels Identity 74 | 75 | -- | given a tune, find all the different voice names (labels) 76 | -- | no matter where they might be hiding 77 | getVoiceLabels :: AbcTune -> Array String 78 | getVoiceLabels tune = 79 | let 80 | initialLabels :: Set.Set String 81 | initialLabels = 82 | case (initialVoiceLabel tune) of 83 | NoLabel -> (Set.empty :: Labels) 84 | VoiceLabel label -> Set.insert label (Set.empty :: Labels) 85 | voiceLabels = 86 | runLabelM initialLabels (labelFold tune.body) 87 | in 88 | Set.toUnfoldable voiceLabels 89 | 90 | -- | get a map of voice name to tune (filtering the body for just that tune voice) 91 | -- | if there is no voice header, then the voice name is "unnamed" and attached to 92 | -- | the entire tune. 93 | -- | If voices are found, then the title of each partitioned voice tune is set to 94 | -- | 'Voice voice-name' 95 | getVoiceMap :: AbcTune -> Map String AbcTune 96 | getVoiceMap tune = 97 | fromFoldable $ map (retitleFromVoiceLabel tune) tuples 98 | 99 | where 100 | tuples :: Array (Tuple VoiceLabel TuneBody) 101 | tuples = toUnfoldable $ voiceMap tune 102 | 103 | -- | given a tune, partition it into multiple such tunes, one for each voice 104 | -- | with the title of each partitioned tune set to the voice label 105 | -- | where there are no voices, just return the singleton which contains 106 | -- | the original tune 107 | partitionVoices :: AbcTune -> NonEmptyArray AbcTune 108 | partitionVoices tune = 109 | map (snd <<< retitleFromVoiceLabel tune) tuples 110 | 111 | where 112 | tuples :: NonEmptyArray (Tuple VoiceLabel TuneBody) 113 | tuples = Unsafe.NonEmptyArray $ toUnfoldable $ voiceMap tune 114 | 115 | -- | given a tune, partition its body into multiple such bodies 116 | -- | with a separate body for each distinct voice 117 | -- | where there are no voices, just return the singleton which contains 118 | -- | the original tune body 119 | partitionTuneBody :: AbcTune -> NonEmptyArray TuneBody 120 | partitionTuneBody tune = 121 | map (\(Tuple _ v) -> v) $ Unsafe.NonEmptyArray $ toUnfoldable (voiceMap tune) 122 | 123 | -- produce a map of voice label to tune (filtered for that voice only) 124 | -- note that there must be at least one entry in the map because the common 125 | -- case is when there are no voices and there is one entry labelled 'unnnamed' 126 | -- and attached to the entire tune 127 | voiceMap :: AbcTune -> VoiceMap 128 | voiceMap tune = 129 | runVoiceM (initialVoiceLabel tune) (voiceFold tune.body) 130 | 131 | runVoiceM :: forall a. VoiceLabel -> VoiceM a -> a 132 | runVoiceM initialLabel v = 133 | unwrap $ evalStateT v initialLabel 134 | 135 | runLabelM :: forall a. Set.Set String -> LabelM a -> a 136 | runLabelM initialLabels v = 137 | unwrap $ evalStateT v initialLabels 138 | 139 | -- The heart of the algorithm 140 | -- Track voice labels for all score lines in the tune and separate 141 | -- parts of the tune with distinct voices into distinct tunes 142 | -- meanwhile ensuring any common constructs are shared by all tune partitions 143 | voiceFold :: TuneBody -> VoiceM VoiceMap 144 | voiceFold b = 145 | let 146 | foldf :: VoiceMap -> BodyPart -> VoiceM VoiceMap 147 | foldf vmap bp = do 148 | case bp of 149 | BodyInfo header -> 150 | case header of 151 | Voice voiceDescription -> do 152 | _ <- put (VoiceLabel voiceDescription.id) 153 | pure $ addAtLabel (VoiceLabel voiceDescription.id) bp vmap 154 | _ -> 155 | pure $ addToAll bp vmap 156 | Score bars -> do 157 | currentVoice <- get 158 | if (not $ isEmptyStave bars) then 159 | pure $ addAtLabel (scoreLabelOrDefault currentVoice bars) bp vmap 160 | else 161 | pure vmap 162 | in 163 | foldM foldf (empty :: VoiceMap) b 164 | 165 | -- as above but just retrieve the set of voice labels 166 | labelFold :: TuneBody -> LabelM Labels 167 | labelFold b = 168 | let 169 | foldf :: Labels -> BodyPart -> LabelM Labels 170 | foldf labels bp = do 171 | case bp of 172 | BodyInfo header -> 173 | case header of 174 | Voice voiceDescription -> do 175 | newLabels <- modify (Set.insert (voiceDescription.id)) 176 | pure newLabels 177 | _ -> 178 | pure labels 179 | Score bars -> do 180 | if (not $ isEmptyStave bars) then do 181 | case (inlineLabel bars) of 182 | Just (VoiceLabel label) -> do 183 | newLabels <- modify (Set.insert label) 184 | pure newLabels 185 | _ -> 186 | pure labels 187 | else 188 | pure labels 189 | in 190 | foldM foldf (Set.empty :: Labels) b 191 | 192 | -- append a body part at the specified map label 193 | addAtLabel :: VoiceLabel -> BodyPart -> VoiceMap -> VoiceMap 194 | addAtLabel label bp map = 195 | case (lookup label map) of 196 | Just body -> insert label (snoc body bp) map 197 | _ -> insert label (singleton bp) map 198 | 199 | -- append a body part to all labels in the map 200 | addToAll :: BodyPart -> VoiceMap -> VoiceMap 201 | addToAll bp vmap = 202 | map (\v -> (snoc v bp)) vmap 203 | 204 | -- find the inline voice label from a score line (if it exists) 205 | -- otherwise fall back to the default voice 206 | scoreLabelOrDefault :: VoiceLabel -> List Bar -> VoiceLabel 207 | scoreLabelOrDefault currentVoiceLabel bars = 208 | case (inlineLabel bars) of 209 | Just label -> label 210 | _ -> currentVoiceLabel 211 | 212 | -- if the line of music starts with an inLine voice header, return the voice 213 | -- label, otherwise Nothing 214 | inlineLabel :: List Bar -> Maybe VoiceLabel 215 | inlineLabel bars = 216 | let 217 | mFirstBarMusic = join $ map (head <<< _.music) $ head bars 218 | in 219 | case mFirstBarMusic of 220 | (Just (Inline header)) -> 221 | case header of 222 | (Voice description) -> Just (VoiceLabel description.id) 223 | _ -> Nothing 224 | _ -> Nothing 225 | 226 | -- get the voice label from the initial headers if it exists 227 | initialVoiceLabel :: AbcTune -> VoiceLabel 228 | initialVoiceLabel tune = 229 | case (lastOf (_headers <<< traversed <<< _Voice) tune) of 230 | Just description -> VoiceLabel description.id 231 | _ -> NoLabel 232 | 233 | -- map the keys to String and the values to AbcTune 234 | retitleFromVoiceLabel :: AbcTune -> Tuple VoiceLabel TuneBody -> Tuple String AbcTune 235 | retitleFromVoiceLabel tune (Tuple k body) = 236 | case k of 237 | VoiceLabel name -> 238 | Tuple name { headers: newHeaders, body } 239 | where 240 | newHeaders = retitle name tune.headers 241 | NoLabel -> 242 | Tuple "unnamed" { headers: tune.headers, body } 243 | 244 | where 245 | 246 | -- retitle the headers by replacing any original tune title 247 | -- with the voice name 248 | retitle :: String -> TuneHeaders -> TuneHeaders 249 | retitle voiceName headers = 250 | case (firstOf (traversed <<< _Title) headers) of 251 | Just _ -> 252 | over (traversed <<< _Title) (\t -> t <>" - voice " <> voiceName) filteredHeaders 253 | -- set (traversed <<< _Title) ("voice " <> voiceName) filteredHeaders 254 | 255 | where 256 | predicate :: Header -> Boolean 257 | predicate h = 258 | case h of 259 | -- remove any voice header for a different voice from the one we're handling 260 | -- i.e. only keep the voice header we're handling 261 | Voice voiceDescription -> voiceDescription.id == voiceName 262 | _ -> true 263 | filteredHeaders = filter predicate headers 264 | 265 | _ -> 266 | ReferenceNumber (Just 1) : Title ("voice " <> voiceName) : filteredRetitledHeaders 267 | 268 | where 269 | predicate :: Header -> Boolean 270 | predicate h = 271 | case h of 272 | -- remove the reference number 273 | ReferenceNumber _ -> false 274 | -- remove the old title 275 | Title _ -> false 276 | -- remove any voice header for a different voice from the one we're handling 277 | -- i.e. only keep the voice header we're handling 278 | Voice voiceDescription -> voiceDescription.id == voiceName 279 | _ -> true 280 | filteredRetitledHeaders = filter predicate headers 281 | 282 | 283 | 284 | -------------------------------------------------------------------------------- /test/Abc.purs: -------------------------------------------------------------------------------- 1 | module Test.Abc (abcSpec) where 2 | 3 | import Prelude 4 | 5 | import Effect.Aff (Aff) 6 | import Data.Either (Either(..)) 7 | import Data.List (length) 8 | import Data.Abc.Parser (parse, parseKeySignature) 9 | import Data.Abc.Canonical (fromTune) 10 | import Test.Spec (Spec, describe, it) 11 | import Test.Spec.Assertions (fail, shouldEqual) 12 | 13 | assertRoundTrip :: String -> Aff Unit 14 | assertRoundTrip s = 15 | assertCanonical s s 16 | 17 | assertCanonical :: String -> String -> Aff Unit 18 | assertCanonical s canonical = 19 | case (parse s) of 20 | Right tune -> 21 | canonical `shouldEqual` (fromTune tune) 22 | 23 | Left err -> 24 | fail ("parse failed: " <> (show err)) 25 | 26 | assertParses :: String -> Aff Unit 27 | assertParses s = 28 | case (parse s) of 29 | Right _res -> 30 | pure unit 31 | 32 | Left err -> 33 | fail ("parse failed: " <> (show err)) 34 | 35 | assertParseError :: String -> Aff Unit 36 | assertParseError s = 37 | case (parse s) of 38 | Right _res -> 39 | fail "parses when it shouldn't" 40 | 41 | Left _err -> 42 | pure unit 43 | 44 | assertKeySigParses :: String -> Aff Unit 45 | assertKeySigParses s = 46 | case (parseKeySignature s) of 47 | Right _res -> 48 | pure unit 49 | 50 | Left err -> 51 | fail ("parse failed: " <> (show err)) 52 | 53 | assertMusicLines :: String -> Int -> Aff Unit 54 | assertMusicLines s target = 55 | case (parse s) of 56 | Right tune -> 57 | target `shouldEqual` (length tune.body) 58 | 59 | Left err -> 60 | fail ("parse failed: " <> (show err)) 61 | 62 | abcSpec :: Spec Unit 63 | abcSpec = do 64 | headerSpec 65 | noteSpec 66 | barSpec 67 | slurSpec 68 | phrasingSpec 69 | structureSpec 70 | ambiguitySpec 71 | badInputSpec 72 | keySigSpec 73 | 74 | headerSpec :: Spec Unit 75 | headerSpec = 76 | describe "headers" do 77 | it "recognizes area" do 78 | assertRoundTrip "A: London\x0D\n| ABC |\x0D\n" 79 | it "recognizes book" do 80 | assertRoundTrip "B: Richie Robinson\x0D\n| ABC |\x0D\n" 81 | it "recognizes composer" do 82 | assertRoundTrip "C: Bys-Kalle\x0D\n| ABC |\x0D\n" 83 | it "recognizes discography" do 84 | assertRoundTrip "D: 2 Brudetstykke\x0D\n| ABC |\x0D\n" 85 | it "recognizes file URL" do 86 | assertRoundTrip "F: http\\\\tradtunedb.org.uk\x0D\n| ABC |\x0D\n" 87 | it "recognizes group" do 88 | assertRoundTrip "G: Swåp\x0D\n| ABC |\x0D\n" 89 | it "recognizes history" do 90 | assertRoundTrip "H: Learned from AnnbjØrg Lien\x0D\n| ABC |\x0D\n" 91 | it "recognizes instruction" do 92 | assertRoundTrip "I: abc-charset UTF-8\x0D\n| ABC |\x0D\n" 93 | it "recognizes key" do 94 | assertRoundTrip keyADorian 95 | it "recognizes key spaced" do 96 | assertCanonical "K: A Dorian\x0D\n| ABC |\x0D\n" keyADorian 97 | it "recognizes key with accidental" do 98 | assertRoundTrip "K: AMinor ^f\x0D\n| ABC |\x0D\n" 99 | it "recognizes key with unspaced accidental" do 100 | assertCanonical "K: EMinor^c\x0D\n| ABC |\x0D\n" keyWithAccidental 101 | it "recognizes simple key" do 102 | assertCanonical "K: C\x0D\n| ABC |\x0D\n" keyCMajor 103 | it "recognizes key with trailing space" do 104 | assertCanonical "K: CMajor \x0D\n| ABC |\x0D\n" keyCMajor 105 | it "recognizes key with properties" do 106 | assertRoundTrip "K: GMinor shift=GD\x0D\n| ABC |\x0D\n" 107 | it "recognizes note length" do 108 | assertRoundTrip "L: 1/8\x0D\n| ABC |\x0D\n" 109 | it "recognizes meter" do 110 | assertRoundTrip "M: 3/4\x0D\n| ABC |\x0D\n" 111 | it "no meter" do 112 | assertRoundTrip "M: none\x0D\n| ABC |\x0D\n" 113 | it "recognizes macro" do 114 | assertRoundTrip "m: ~g2 = {a}g{f}g\x0D\n| ABC |\x0D\n" 115 | it "recognizes notes" do 116 | assertRoundTrip "N: from recording made at Tideswell\x0D\n| ABC |\x0D\n" 117 | it "recognizes origin" do 118 | assertRoundTrip "O: Skåne\x0D\n| ABC |\x0D\n" 119 | it "recognizes parts" do 120 | assertRoundTrip "P: ((AB)3.(CD)3)2\x0D\n| ABC |\x0D\n" 121 | it "recognizes tempo" do 122 | assertRoundTrip standardTempo 123 | it "recognizes suffixed tempo" do 124 | assertRoundTrip suffixedTempo 125 | it "recognizes prefixed tempo" do 126 | assertCanonical "Q: \"lento\" 1/4=70\x0D\n| ABC |\x0D\n" suffixedTempo 127 | it "recognizes degenerate tempo" do 128 | assertCanonical "Q: 120\x0D\n| ABC |\x0D\n" standardTempo 129 | it "recognizes tempo trailing space" do 130 | assertCanonical "Q: 1/4=120 \x0D\n| ABC |\x0D\n" standardTempo 131 | it "recognizes multi-beat tempo" do 132 | assertRoundTrip "Q: 1/4 3/8 1/4 3/8=40\x0D\n| ABC |\x0D\n" 133 | it "recognizes remark" do 134 | assertRoundTrip "r: this is a remark\x0D\n| ABC |\x0D\n" 135 | it "recognizes rhythm" do 136 | assertRoundTrip "R: Polska\x0D\n| ABC |\x0D\n" 137 | it "recognizes source" do 138 | assertRoundTrip "S: Christine Dyer\x0D\n| ABC |\x0D\n" 139 | it "recognizes title" do 140 | assertRoundTrip "T: Engelska efter Albert Augustsson\x0D\n| ABC |\x0D\n" 141 | it "recognizes user-defined" do 142 | assertRoundTrip "U: some comment\x0D\n| ABC |\x0D\n" 143 | it "recognizes simple voice" do 144 | assertRoundTrip "V: T1\x0D\n| ABC |\x0D\n" 145 | it "recognizes voice" do 146 | assertRoundTrip "V: T1 clef=treble-8+8 name=\"Tenore I\" snm=\"T.I\"\x0D\n| ABC |\x0D\n" 147 | it "recognizes words after" do 148 | assertRoundTrip "W: doh re mi fa \x0D\n| ABC |\x0D\n" 149 | -- the words aligned header only appears inline 150 | it "recognizes words aligned" do 151 | assertRoundTrip "| ABC |\x0D\nw: doh re mi fa \x0D\n| ABC |\x0D\n" 152 | it "recognizes reference" do 153 | assertRoundTrip "X: 125\x0D\n| ABC |\x0D\n" 154 | it "recognizes degenerate reference with no number" do 155 | assertRoundTrip "X: \x0D\n| ABC |\x0D\n" 156 | it "recognizes transcriber" do 157 | assertRoundTrip "Z: John Watson\x0D\n| ABC |\x0D\n" 158 | it "recognizes field continuation" do 159 | assertRoundTrip "R: Polska\x0D\n+: in triplet time\x0D\n| ABC |\x0D\n" 160 | it "comment" do 161 | assertRoundTrip "%%TBL:{\"version\":\"beta\",\"type\":\"tune\",\"id\":\"10294\"}\x0D\n| ABC |\x0D\n" 162 | it "recognizes unsupported header" do 163 | assertParses "j: custom header\x0D\n| ABC |\x0D\n" 164 | it "recognizes bracket in header" do 165 | assertRoundTrip "r: this is a remark [part 1]\x0D\n| ABC |\x0D\n" 166 | it "recognizes comment in reference number" do 167 | assertParses "X: 125 % start of header\x0D\n| ABC |\x0D\n" 168 | it "recognizes comment in key" do 169 | assertParses "K: C % scale: C major\x0D\n| ABC |\x0D\n" 170 | 171 | noteSpec :: Spec Unit 172 | noteSpec = 173 | describe "note" do 174 | it "handles single duration" do 175 | assertRoundTrip "| A |\r\n" 176 | it "handles doubly implied half duration" do 177 | assertRoundTrip "| B/ |\r\n" 178 | it "handles implied half duration" do 179 | assertCanonical "| B/2 |\r\n" halfNoteCanonical 180 | it "handles explicit half duration" do 181 | assertCanonical "| B1/2 |\r\n" halfNoteCanonical 182 | it "handles quarter duration" do 183 | assertCanonical "| D// |\r\n" quarterNoteCanonical 184 | it "handles eighth duration" do 185 | assertCanonical "| D/// |\r\n" eighthNoteCanonical 186 | it "handles double duration" do 187 | assertRoundTrip "| a2 |\r\n" 188 | it "handles broken rhythm" do 189 | assertRoundTrip "| A>B C>>D a B |\x0D\n" "| A>B |\x0D\n" 192 | it "handles octave" do 193 | assertRoundTrip "| A,B,,C z2 d'e''f z/ |\x0D\n" 194 | it "handles tie" do 195 | assertRoundTrip "| A4- A2 |\x0D\n" 196 | -- relaxation of the spec for degenerate ties 197 | it "handles degenerate tie" do 198 | assertCanonical "| A4 -A2 |\x0D\n" "| A4-A2 |\x0D\n" 199 | it "handles complex tie" do 200 | assertRoundTrip "| fg-ga ab-bc|\x0D\n" 201 | it "handles triplet" do 202 | assertRoundTrip "| (3efg |\r\n" 203 | it "handles triplet long form" do 204 | assertCanonical "| (3:2:3efg |\r\n" "| (3efg |\r\n" 205 | it "handles triplet intermediate form" do 206 | assertCanonical "| (3:2efg |\r\n" "| (3efg |\r\n" 207 | it "handles spaced triplet" do 208 | assertCanonical "| (3 abc def |\x0D\n" "| (3abc def |\x0D\n" 209 | it "handles space between notes in triplet" do 210 | assertCanonical "| (3 a b c def |\x0D\n" "| (3abc def |\x0D\n" 211 | it "handles triplet with rest" do 212 | assertRoundTrip "| (3zfg |\r\n" 213 | it "handles grace note" do 214 | assertRoundTrip "| {d^f}GA |\x0D\n" 215 | it "accepts spaces between graces and note" do 216 | assertCanonical "| {d^f} GA |\x0D\n" "| {d^f}GA |\x0D\n" 217 | it "handles grace note in tuplet" do 218 | assertRoundTrip "| (3c{d}fg A |\x0D\n" 219 | it "handles grace note before tuplet" do 220 | assertRoundTrip "| {d}(3cfg A |\x0D\n" 221 | it "handles grace note in broken rhythm pair" do 222 | assertRoundTrip "| A>{f}B C>>{ef}D |\x0D\n" 223 | it "handles rest in broken rhythm pair" do 224 | assertRoundTrip "| A>z z>>D |\x0D\n" 225 | it "handles double sharp" do 226 | assertRoundTrip "| ^^C2 |\r\n" 227 | it "handles sharp" do 228 | assertRoundTrip "| ^C/ |\r\n" 229 | it "handles double flat" do 230 | assertRoundTrip "| __C |\r\n" 231 | it "handles flat" do 232 | assertRoundTrip "| _C3/2 |\r\n" 233 | it "handles natural" do 234 | assertRoundTrip "| =C3/2 |\r\n" 235 | it "handles chord symbol" do 236 | assertRoundTrip "| \"Em\" EG \"Am\" AC |\x0D\n" 237 | it "handles chords" do 238 | assertRoundTrip "| [de^f]g [cda]b |\x0D\n" 239 | it "handles chords with spaced notes" do 240 | assertCanonical "| [d e ^f ]g [c d a]b |\x0D\n" "| [de^f]g [cda]b |\x0D\n" 241 | it "handles chord duration" do 242 | assertRoundTrip "| [cda]4 |\x0D\n" 243 | 244 | barSpec :: Spec Unit 245 | barSpec = 246 | describe "bar lines" do 247 | it "handles no bars" do 248 | assertRoundTrip "A B C\r\n" 249 | it "handles no starting or terminating line" do 250 | assertRoundTrip "A B C | D E F\r\n" 251 | it "handles no terminating line" do 252 | assertRoundTrip "| A B C | D E F\r\n" 253 | it "handles no bars stave 2" do 254 | assertRoundTrip "| A B C |\r\n D E F\r\n" 255 | {-} 256 | it "from failing transposition test" do 257 | assertRoundTrip "| G3A B6 Ac |\r\n B2AG ^FGA^F D4\r\n" 258 | -} 259 | it "handles repeat" do 260 | assertRoundTrip "|: A :|\r\n" 261 | it "handles bracket line" do 262 | assertRoundTrip "[| A |]\r\n" 263 | it "handles double colon" do 264 | assertCanonical "||: A :: c :||\r\n" "||: A :|: c :||\r\n" 265 | it "handles alternate endings - simple" do 266 | assertRoundTrip "| A |1 B :|2 c||\r\n" 267 | it "handles alternate endings - list" do 268 | assertRoundTrip "| A |1,3 B :|2 c||\r\n" 269 | it "handles alternate endings - range" do 270 | assertRoundTrip "| A |1-3 B :|4 c||\r\n" 271 | it "handles alternate endings - combo" do 272 | assertRoundTrip "| A |1-3,5 B :|4 c||\r\n" 273 | it "handles repeat 0" do 274 | assertRoundTrip "|: ABCD EFGa |1 D4 C4 :|2 c8 |\x0D\n" 275 | it "handles repeat 1" do 276 | assertCanonical "|: ABCD EFGa |[1 D4 C4 :|[2 c8 |\x0D\n" repeat 277 | it "handles repeat 1a" do 278 | assertRoundTrip "|: ABCD EFGa [|1 D4 C4 :[|2 c8 |]\x0D\n" 279 | it "handles repeat 2" do 280 | assertRoundTrip "|: ABCD EFGa [|1 D4 C4 :[|2 c8 |]\x0D\n" 281 | it "handles repeat 3" do 282 | assertRoundTrip repeat3 283 | it "handles repeat 3a" do 284 | assertCanonical "|: ABCD EFGa :|: c8 |\x0D\n" repeat3 285 | it "handles repeat 3b" do 286 | assertRoundTrip "|: ABCD EFGa :||: c8 |\x0D\n" 287 | it "handles repeat 4" do 288 | assertRoundTrip "[|2 ABCD EFGa |]: c8 |\x0D\n" 289 | it "repeat 5" do 290 | assertRoundTrip "|: ABCD EFGa :|] c8 |\x0D\n" 291 | it "handles repeat 6" do 292 | assertRoundTrip "[|2 ABCD EFGa ||: c8 |\x0D\n" 293 | it "handles repeat 7" do 294 | assertRoundTrip "| ABCD EFGa :|| c8 |\x0D\n" 295 | it "handles degenerate repeat 1" do 296 | assertCanonical "[1 ABCD |\x0D\n" "|1 ABCD |\x0D\n" 297 | it "handles degenerate repeat 2" do 298 | assertCanonical "| [1 ABCD |\x0D\n" "| |1 ABCD |\x0D\n" 299 | 300 | slurSpec :: Spec Unit 301 | slurSpec = 302 | describe "slurs" do 303 | it "handles slur" do 304 | assertRoundTrip "| (de^f) (cda) |\x0D\n" 305 | it "handles broken rhythm slurred start" do 306 | assertRoundTrip "| A>(B C) |\x0D\n" 307 | it "handles broken rhythm slurred finish" do 308 | assertRoundTrip "| (B C)>A |\x0D\n" 309 | it "handles grace note with slur" do 310 | assertRoundTrip "| {d^f}(GA) |\x0D\n" 311 | it "handles chord with leading slur" do 312 | assertRoundTrip "| ([GB] d) |\x0D\n" 313 | it "handles chord with trailing slur" do 314 | assertRoundTrip "| (d [GB]) |\x0D\n" 315 | it "handles slurred tuplet" do 316 | assertRoundTrip "| ((3def) |\x0D\n" 317 | -- we throw away the slur if it mistakenly encompasses the operator 318 | it "handles degenerate slurred broken rhythm start" do 319 | assertCanonical "| A(>B C) |\x0D\n" "| A>B C) |\x0D\n" 320 | it "handles degenerate slurred broken rhythm finish" do 321 | assertCanonical "| (BC>)A |\x0D\n" "| (BC>A |\x0D\n" 322 | 323 | {- this test would fail. We don't allow slurs to span note sequences 324 | starting with a grace note. Instead, users should start the slur at 325 | the first full note 326 | test "degenerate slurred grace" do 327 | assertParses "| ({d^f}GA) |\x0D\n" 328 | -} 329 | 330 | phrasingSpec :: Spec Unit 331 | phrasingSpec = 332 | describe "phrasing" do 333 | it "handles articulation" do 334 | assertRoundTrip "(vA2 | !fz! Ld2).d.f .e.d.c.B A2(A2 | d2).d.f .e.d.c.B A2A2 |\x0D\n" 335 | it "handles annotation" do 336 | assertRoundTrip "| \"<(\" \">)\" EG |\x0D\n" 337 | it "handles decorated note" do 338 | assertRoundTrip "| !uppermordent! !trill! C |\x0D\n" 339 | it "handles decorated space" do 340 | assertRoundTrip "| ABc !coda! y |\x0D\n" 341 | it "handles decorated chord" do 342 | assertRoundTrip "| A B C | !uppermordent! [DE] |\r\n" 343 | it "handles decorated bar" do 344 | assertRoundTrip "| A B C | D E F !dacapo! |\r\n" 345 | 346 | structureSpec :: Spec Unit 347 | structureSpec = 348 | describe "structure" do 349 | it "handles ignore" do 350 | assertParses "| ABC# z2 @def z/ |\x0D\n" 351 | it "handles typeset space" do 352 | assertParses "| ABC yz2 defyz/ |\x0D\n" 353 | it "handles backtick" do 354 | assertParses "| A``B``C |\x0D\n" 355 | it "handles inline" do 356 | assertRoundTrip "| ABC z2 def z/ \x0D\nQ: 1/4=120\x0D\n| ABC z2 def z/ |\x0D\n" 357 | it "handles inline voice reference" do 358 | assertRoundTrip "[V: T1]| ABC |\x0D\n" 359 | it "handles inline bracket" do 360 | assertRoundTrip "| ABC def g3 | [L: 1/8] A3 A3 |\x0D\n" 361 | it "handles inline bracket 1" do 362 | assertRoundTrip "| ABC def g3 |[L: 1/8] A3 A3 |\x0D\n" 363 | it "handles new key" do 364 | assertRoundTrip "| ABc |\x0D\nK: F#Major\x0D\n| def |\x0D\n" 365 | it "handles new tempo" do 366 | assertRoundTrip "| ABc |\x0D\nM: 3/4\x0D\n| def |\x0D\n" 367 | it "handles new unit length" do 368 | assertRoundTrip "| ABc |\x0D\nL: 1/16\x0D\n| def |\x0D\n" 369 | it "handles new part" do 370 | assertRoundTrip "| ABc |\x0D\nP: B\x0D\n| def |\x0D\n" 371 | it "handles continuation" do 372 | let 373 | text = "| ABc |\\\x0D\n| def |\x0D\n" 374 | assertRoundTrip text 375 | -- we now coalesce the lines after a continuation 376 | assertMusicLines text 1 377 | it "handles continuation with comment" do 378 | let 379 | text = "| ABc |\\ ignored comment\x0D\n| def |\x0D\n" 380 | assertRoundTrip text 381 | -- we now coalesce the lines after a continuation 382 | assertMusicLines text 1 383 | it "handles empty bar" do 384 | assertRoundTrip "| ABc | | def |\x0D\n" 385 | it "handles inline key" do 386 | assertRoundTrip "| ABC def g3 | [K: AMajor] g3 a3 |\x0D\n" 387 | it "handles inline comment" do 388 | assertRoundTrip "| ABC z2 def z/ \x0D\n% this is a comment\x0D\n| ABC z2 def z/ |\x0D\n" 389 | it "handles outmoded line-break" do 390 | assertParses "| ABc | def |!\x0D\n| ABC|\x0D\n" 391 | it "handles workaround missing line feed line terminator" do 392 | assertParses "| ABc | def |\x0D| ABC|\x0D\n" 393 | 394 | -- | the purescript version handles parsing differently from the elm version 395 | -- | when two different productions have the same initial lexeme. 396 | -- | The purescript parser requires you to use 'try' to resolve the parse 397 | ambiguitySpec :: Spec Unit 398 | ambiguitySpec = 399 | describe "ambiguity" do 400 | it "handles ambiguous A" do 401 | assertRoundTrip "K: GMajor\r\nA\r\n" 402 | it "handles ambiguous a" do 403 | assertRoundTrip "K: GMajor\r\na\r\n" 404 | 405 | badInputSpec :: Spec Unit 406 | badInputSpec = 407 | describe "bad input" do 408 | it "handles bad chars 1" do 409 | assertParseError "| ABC z2 def z/ |\x0D\n| foo bar |\x0D\n" 410 | it "handles bad chars 2" do 411 | assertParseError "| foo bar |\x0D\n| ABC z2 def z/ |\x0D\n" 412 | it "handles bracket in inline header" do 413 | assertParseError "| ABC |\x0D\nr: this is a remark [part 1]\x0D\n" 414 | it "handles too few notes in short form triplet" do 415 | assertParseError "| ABC (3DE | GGG |\x0D\n" 416 | it "handles too few notes in long form triplet" do 417 | assertParseError "| ABC (3:2:3DE | GGG |\x0D\n" 418 | 419 | keySigSpec :: Spec Unit 420 | keySigSpec = 421 | describe "key signature parser" do 422 | it "recognizes G" do 423 | assertKeySigParses "G" 424 | it "recognizes C# Major" do 425 | assertKeySigParses "C# Major" 426 | it "recognizes G Mixolydian" do 427 | assertKeySigParses "G Mixolydian" 428 | it "recognizes A Locrian" do 429 | assertKeySigParses "A Locrian" 430 | it "recognizes Bb Minor" do 431 | assertKeySigParses "Bb Minor" 432 | 433 | -- these ABC samples are already in canonical format which should allow round-tripping to work 434 | -- because of the exact string matching algorithm 435 | 436 | keyWithAccidental = 437 | "K: EMinor ^c\x0D\n| ABC |\x0D\n" 438 | 439 | keyCMajor = 440 | "K: CMajor\x0D\n| ABC |\x0D\n" 441 | 442 | keyADorian = 443 | "K: ADorian\x0D\n| ABC |\x0D\n" 444 | 445 | halfNoteCanonical = 446 | "| B/ |\r\n" 447 | 448 | quarterNoteCanonical = 449 | "| D1/4 |\r\n" 450 | 451 | eighthNoteCanonical = 452 | "| D1/8 |\r\n" 453 | 454 | repeat = 455 | "|: ABCD EFGa ||1 D4 C4 :||2 c8 |\r\n" 456 | 457 | repeat3 = 458 | "|: ABCD EFGa :|: c8 |\x0D\n" 459 | 460 | standardTempo = 461 | "Q: 1/4=120\x0D\n| ABC |\x0D\n" 462 | 463 | suffixedTempo = 464 | "Q: 1/4=70 \"lento\"\x0D\n| ABC |\x0D\n" 465 | -------------------------------------------------------------------------------- /test/Accidentals.purs: -------------------------------------------------------------------------------- 1 | module Test.Accidentals (accidentalsSpec) where 2 | 3 | import Prelude (Unit, discard) 4 | import Data.Maybe (Maybe(..)) 5 | import Data.List (List(..)) 6 | import Data.Map (empty) 7 | import Data.Abc.KeySignature (modifiedKeySet) 8 | import Data.Abc (Accidental(..), PitchClass(..), KeySignature, Mode(..)) 9 | import Data.Abc.Accidentals as Accidentals 10 | import Test.Spec (Spec, describe, it) 11 | import Test.Spec.Assertions (shouldEqual) 12 | 13 | 14 | accidentalsSpec :: Spec Unit 15 | accidentalsSpec = 16 | describe "accidental lookups" do 17 | it "looks up f in G Major" do 18 | shouldEqual 19 | (Just Sharp) 20 | ( Accidentals.implicitInKeySet F 21 | (modifiedKeySet { keySignature: gMajor, modifications: Nil, properties: empty }) 22 | ) 23 | it "looks up f in G Major" do 24 | shouldEqual 25 | (Nothing) 26 | ( Accidentals.implicitInKeySet F 27 | (modifiedKeySet { keySignature: cMajor, modifications: Nil, properties: empty }) 28 | ) 29 | 30 | -- key signatures 31 | cMajor :: KeySignature 32 | cMajor = 33 | { pitchClass: C, accidental: Natural, mode: Major } 34 | 35 | gMajor :: KeySignature 36 | gMajor = 37 | { pitchClass: G, accidental: Natural, mode: Major } 38 | -------------------------------------------------------------------------------- /test/KeySignature.purs: -------------------------------------------------------------------------------- 1 | module Test.KeySignature (keySignatureSpec) where 2 | 3 | import Prelude (Unit, discard, negate, pure, show, unit, ($), (<>), (==)) 4 | import Effect.Aff (Aff) 5 | import Data.Either (Either(..)) 6 | import Data.Maybe (Maybe(..), fromMaybe) 7 | import Data.Map (empty) 8 | import Data.List (List(..), head, length, sort, (:)) 9 | import Data.Abc (AbcTune, PitchClass(..), KeySignature, ModifiedKeySignature, Accidental(..), Pitch(..), KeySet, Mode(..)) 10 | import Data.Abc.KeySignature 11 | import Data.Abc.Parser (parse) 12 | 13 | import Test.Spec (Spec, describe, it) 14 | import Test.Spec.Assertions (fail, shouldEqual) 15 | 16 | 17 | assertEquivalentKeys :: KeySet -> KeySet -> Aff Unit 18 | assertEquivalentKeys actual expected = 19 | if (length actual == length expected) then 20 | let 21 | as = sort actual 22 | es = sort expected 23 | in 24 | es `shouldEqual` as 25 | else 26 | fail $ "non-equivalent key lengths: " 27 | <> (show actual) 28 | <> " not equal to: " 29 | <> (show expected) 30 | 31 | assertOkKeySig :: String -> ModifiedKeySignature -> Aff Unit 32 | assertOkKeySig source target = 33 | case parse source of 34 | Right tune -> 35 | case (getKeySig tune) of 36 | Just keySig -> 37 | target.keySignature.pitchClass `shouldEqual` keySig.keySignature.pitchClass 38 | 39 | _ -> 40 | fail "no key signature" 41 | _ -> 42 | fail "parse error" 43 | 44 | assertNoHeader :: forall h. String -> (AbcTune -> Maybe h) -> Aff Unit 45 | assertNoHeader source getf = 46 | case parse source of 47 | Right tune -> 48 | let 49 | mtitle = 50 | getf tune 51 | in 52 | case mtitle of 53 | Just _ -> 54 | fail "no title expected" 55 | _ -> 56 | pure unit 57 | 58 | _ -> 59 | fail "parse error" 60 | 61 | keySignatureSpec :: Spec Unit 62 | keySignatureSpec = do 63 | headerSpec 64 | majorModeSpec 65 | minorModeSpec 66 | klezmerModeSpec 67 | otherModeSpec 68 | keySpec 69 | transposeSignatureSpec 70 | scaleSpec 71 | 72 | headerSpec :: Spec Unit 73 | headerSpec = 74 | describe "key signature header" do 75 | it "gets key header" do 76 | assertOkKeySig keyedTune fMajorM 77 | it "recognizes key header" do 78 | assertNoHeader unkeyedTune getKeySig 79 | 80 | majorModeSpec :: Spec Unit 81 | majorModeSpec = 82 | describe "major mode" do 83 | it "handles G Major" do 84 | assertEquivalentKeys 85 | (keySet { pitchClass: G, accidental: Natural, mode: Major }) 86 | (Pitch { pitchClass: F, accidental: Sharp } : Nil) 87 | it "handles Ab Major" do 88 | assertEquivalentKeys 89 | (keySet { pitchClass: A, accidental: Flat, mode: Major }) 90 | ( Pitch { pitchClass: B, accidental: Flat } 91 | : Pitch { pitchClass: E, accidental: Flat } 92 | : Pitch { pitchClass: A, accidental: Flat } 93 | : Pitch { pitchClass: D, accidental: Flat } 94 | : Nil 95 | ) 96 | it "handles A Major" do 97 | assertEquivalentKeys 98 | (keySet { pitchClass: A, accidental: Natural, mode: Major }) 99 | ( Pitch { pitchClass: C, accidental: Sharp } 100 | : Pitch { pitchClass: F, accidental: Sharp } 101 | : Pitch { pitchClass: G, accidental: Sharp } 102 | : Nil 103 | ) 104 | it "handles Bb Major" do 105 | assertEquivalentKeys 106 | (keySet { pitchClass: B, accidental: Flat, mode: Major }) 107 | ( Pitch { pitchClass: B, accidental: Flat } 108 | : Pitch { pitchClass: E, accidental: Flat } 109 | : Nil 110 | ) 111 | it "handles C Major" do 112 | assertEquivalentKeys 113 | (keySet { pitchClass: C, accidental: Natural, mode: Major }) 114 | (Nil) 115 | it "handles B Major" do 116 | assertEquivalentKeys 117 | (keySet { pitchClass: B, accidental: Natural, mode: Major }) 118 | ( Pitch { pitchClass: C, accidental: Sharp } 119 | : Pitch { pitchClass: F, accidental: Sharp } 120 | : Pitch { pitchClass: G, accidental: Sharp } 121 | : Pitch { pitchClass: D, accidental: Sharp } 122 | : Pitch { pitchClass: A, accidental: Sharp } 123 | : Nil 124 | ) 125 | it "handles Db Major" do 126 | assertEquivalentKeys 127 | (keySet { pitchClass: D, accidental: Flat, mode: Major }) 128 | ( Pitch { pitchClass: B, accidental: Flat } 129 | : Pitch { pitchClass: E, accidental: Flat } 130 | : Pitch { pitchClass: A, accidental: Flat } 131 | : Pitch { pitchClass: D, accidental: Flat } 132 | : Pitch { pitchClass: G, accidental: Flat } 133 | : Nil 134 | ) 135 | it "handles D Major" do 136 | assertEquivalentKeys 137 | (keySet { pitchClass: D, accidental: Natural, mode: Major }) 138 | ( Pitch { pitchClass: C, accidental: Sharp } 139 | : Pitch { pitchClass: F, accidental: Sharp } 140 | : Nil 141 | ) 142 | it "handles Eb Major" do 143 | assertEquivalentKeys 144 | (keySet { pitchClass: E, accidental: Flat, mode: Major }) 145 | ( Pitch { pitchClass: B, accidental: Flat } 146 | : Pitch { pitchClass: E, accidental: Flat } 147 | : Pitch { pitchClass: A, accidental: Flat } 148 | : Nil 149 | ) 150 | it "handles E Major" do 151 | assertEquivalentKeys 152 | (keySet { pitchClass: E, accidental: Natural, mode: Major }) 153 | ( Pitch { pitchClass: C, accidental: Sharp } 154 | : Pitch { pitchClass: F, accidental: Sharp } 155 | : Pitch { pitchClass: G, accidental: Sharp } 156 | : Pitch { pitchClass: D, accidental: Sharp } 157 | : Nil 158 | ) 159 | it "handles F Major" do 160 | assertEquivalentKeys 161 | (keySet { pitchClass: F, accidental: Natural, mode: Major }) 162 | (Pitch { pitchClass: B, accidental: Flat } : Nil) 163 | it "handles F# Major" do 164 | assertEquivalentKeys 165 | (keySet { pitchClass: F, accidental: Sharp, mode: Major }) 166 | ( Pitch { pitchClass: C, accidental: Sharp } 167 | : Pitch { pitchClass: F, accidental: Sharp } 168 | : Pitch { pitchClass: G, accidental: Sharp } 169 | : Pitch { pitchClass: D, accidental: Sharp } 170 | : Pitch { pitchClass: A, accidental: Sharp } 171 | : Pitch { pitchClass: E, accidental: Sharp } 172 | : Nil 173 | ) 174 | it "handles Gb Major" do 175 | assertEquivalentKeys 176 | (keySet { pitchClass: G, accidental: Flat, mode: Major }) 177 | ( Pitch { pitchClass: B, accidental: Flat } 178 | : Pitch { pitchClass: E, accidental: Flat } 179 | : Pitch { pitchClass: A, accidental: Flat } 180 | : Pitch { pitchClass: D, accidental: Flat } 181 | : Pitch { pitchClass: G, accidental: Flat } 182 | : Pitch { pitchClass: C, accidental: Flat } 183 | : Nil 184 | ) 185 | 186 | minorModeSpec :: Spec Unit 187 | minorModeSpec = 188 | describe "minor modes" do 189 | it "handles A Minor" do 190 | assertEquivalentKeys 191 | (keySet { pitchClass: A, accidental: Natural, mode: Minor }) 192 | (Nil) 193 | it "handles G Minor" do 194 | assertEquivalentKeys 195 | (keySet { pitchClass: G, accidental: Natural, mode: Minor }) 196 | ( Pitch { pitchClass: B, accidental: Flat } 197 | : Pitch { pitchClass: E, accidental: Flat } 198 | : Nil 199 | ) 200 | 201 | klezmerModeSpec :: Spec Unit 202 | klezmerModeSpec = 203 | describe "klezmer modes" do 204 | it "handles D Phrygian with sharpened f" do 205 | assertEquivalentKeys 206 | (modifiedKeySet dPhrygianSharpenedF) 207 | ( Pitch { pitchClass: B, accidental: Flat } 208 | : Pitch { pitchClass: E, accidental: Flat } 209 | : Pitch { pitchClass: F, accidental: Sharp } 210 | : Nil 211 | ) 212 | 213 | otherModeSpec :: Spec Unit 214 | otherModeSpec = 215 | describe "other modes" do 216 | it "handles C Dorian" do 217 | assertEquivalentKeys 218 | (keySet { pitchClass: C, accidental: Natural, mode: Dorian }) 219 | ( Pitch { pitchClass: B, accidental: Flat } 220 | : Pitch { pitchClass: E, accidental: Flat } 221 | : Nil 222 | ) 223 | it "handles D Dorian" do 224 | assertEquivalentKeys 225 | (keySet { pitchClass: D, accidental: Natural, mode: Dorian }) 226 | (Nil) 227 | it "handles C Phrygian" do 228 | assertEquivalentKeys 229 | (keySet { pitchClass: C, accidental: Natural, mode: Phrygian }) 230 | ( Pitch { pitchClass: B, accidental: Flat } 231 | : Pitch { pitchClass: E, accidental: Flat } 232 | : Pitch { pitchClass: A, accidental: Flat } 233 | : Pitch { pitchClass: D, accidental: Flat } 234 | : Nil 235 | ) 236 | it "handles E Phrygian" do 237 | assertEquivalentKeys 238 | (keySet { pitchClass: E, accidental: Natural, mode: Phrygian }) 239 | (Nil) 240 | it "handles C Lydian" do 241 | assertEquivalentKeys 242 | (keySet { pitchClass: C, accidental: Natural, mode: Lydian }) 243 | (Pitch { pitchClass: F, accidental: Sharp } : Nil) 244 | it "handles F Lydian" do 245 | assertEquivalentKeys 246 | (keySet { pitchClass: F, accidental: Natural, mode: Lydian }) 247 | (Nil) 248 | it "handles C Mixolydian" do 249 | assertEquivalentKeys 250 | (keySet { pitchClass: C, accidental: Natural, mode: Mixolydian }) 251 | (Pitch { pitchClass: B, accidental: Flat } : Nil) 252 | it "handles G Mixolydian" do 253 | assertEquivalentKeys 254 | (keySet { pitchClass: G, accidental: Natural, mode: Mixolydian }) 255 | (Nil) 256 | it "handles C Aeolian" do 257 | assertEquivalentKeys 258 | (keySet { pitchClass: C, accidental: Natural, mode: Aeolian }) 259 | ( Pitch { pitchClass: B, accidental: Flat } 260 | : Pitch { pitchClass: E, accidental: Flat } 261 | : Pitch { pitchClass: A, accidental: Flat } 262 | : Nil 263 | ) 264 | it "handles A Aeolian" do 265 | assertEquivalentKeys 266 | (keySet { pitchClass: A, accidental: Natural, mode: Aeolian }) 267 | (Nil) 268 | it "handles C Locrian" do 269 | assertEquivalentKeys 270 | (keySet { pitchClass: C, accidental: Natural, mode: Locrian }) 271 | ( Pitch { pitchClass: B, accidental: Flat } 272 | : Pitch { pitchClass: E, accidental: Flat } 273 | : Pitch { pitchClass: A, accidental: Flat } 274 | : Pitch { pitchClass: D, accidental: Flat } 275 | : Pitch { pitchClass: G, accidental: Flat } 276 | : Nil 277 | ) 278 | it "handles B Locrian" do 279 | assertEquivalentKeys 280 | (keySet { pitchClass: B, accidental: Natural, mode: Locrian }) 281 | (Nil) 282 | it "handles C Ionian" do 283 | assertEquivalentKeys 284 | (keySet { pitchClass: C, accidental: Natural, mode: Ionian }) 285 | (Nil) 286 | it "handles D mixolydian equivalent" do 287 | let 288 | newks = normaliseModalKey (mix D) 289 | G `shouldEqual` newks.pitchClass 290 | Natural `shouldEqual` newks.accidental 291 | Major `shouldEqual` newks.mode 292 | it "handles C mixolydian equivalent" do 293 | let 294 | newks = normaliseModalKey (mix C) 295 | F `shouldEqual` newks.pitchClass 296 | Natural `shouldEqual` newks.accidental 297 | Major `shouldEqual`newks.mode 298 | it "handles E dorian equivalent" do 299 | let 300 | newks = normaliseModalKey (dor E) 301 | D `shouldEqual` newks.pitchClass 302 | Natural `shouldEqual` newks.accidental 303 | Major `shouldEqual` newks.mode 304 | 305 | keySpec :: Spec Unit 306 | keySpec = 307 | describe "keys" do 308 | it "recognizes D is a sharp key" do 309 | true `shouldEqual` (isCOrSharpKey dMajor) 310 | it "recognizes C is an (honourary) sharp key" do 311 | true `shouldEqual` (isCOrSharpKey cMajor) 312 | it "recognizes F is not a sharp key" do 313 | false `shouldEqual` (isCOrSharpKey fMajor) 314 | it "recognizes Gm is not a sharp key" do 315 | false `shouldEqual` (isCOrSharpKey gMinor) 316 | 317 | transposeSignatureSpec :: Spec Unit 318 | transposeSignatureSpec = 319 | describe "transpose key signatures" do 320 | it "moves G major down 1 tone" do 321 | let 322 | newks = transposeKeySignatureBy (-2) gMajorM 323 | F `shouldEqual` newks.keySignature.pitchClass 324 | Natural `shouldEqual` newks.keySignature.accidental 325 | Major `shouldEqual` newks.keySignature.mode 326 | it "moves F major up 1 tone" do 327 | let 328 | newks = transposeKeySignatureBy 2 fMajorM 329 | G `shouldEqual` newks.keySignature.pitchClass 330 | Natural `shouldEqual` newks.keySignature.accidental 331 | Major `shouldEqual` newks.keySignature.mode 332 | it "moves C# major down 8 semitones" do 333 | let 334 | newks = transposeKeySignatureBy (-8) $ cSharpM Major 335 | F `shouldEqual` newks.keySignature.pitchClass 336 | Natural `shouldEqual` newks.keySignature.accidental 337 | Major `shouldEqual` newks.keySignature.mode 338 | it "moves C# minor down 8 semitones" do 339 | let 340 | newks = transposeKeySignatureBy (-8) $ cSharpM Minor 341 | F `shouldEqual` newks.keySignature.pitchClass 342 | Natural `shouldEqual` newks.keySignature.accidental 343 | Minor `shouldEqual` newks.keySignature.mode 344 | it "moves F major up 8 semitones" do 345 | let 346 | newks = transposeKeySignatureBy 8 fMajorM 347 | C `shouldEqual` newks.keySignature.pitchClass 348 | Sharp `shouldEqual` newks.keySignature.accidental 349 | Major `shouldEqual` newks.keySignature.mode 350 | it "moves D phrygian sharpened F up 1 tone" do 351 | let 352 | newks = transposeKeySignatureBy 2 dPhrygianSharpenedF 353 | modification = fromMaybe (Pitch { pitchClass: C, accidental: Natural }) 354 | $ head newks.modifications 355 | E `shouldEqual` newks.keySignature.pitchClass 356 | Natural `shouldEqual` newks.keySignature.accidental 357 | Phrygian `shouldEqual` newks.keySignature.mode 358 | (Pitch { pitchClass: G, accidental: Sharp }) `shouldEqual` modification 359 | it "moves E phrygian sharpened G down 1 tone" do 360 | let 361 | newks = transposeKeySignatureBy (-2) ePhrygianSharpenedG 362 | modification = fromMaybe (Pitch { pitchClass: C, accidental: Natural }) 363 | $ head newks.modifications 364 | D `shouldEqual` newks.keySignature.pitchClass 365 | Natural `shouldEqual` newks.keySignature.accidental 366 | Phrygian `shouldEqual` newks.keySignature.mode 367 | (Pitch { pitchClass: F, accidental: Sharp }) `shouldEqual` modification 368 | 369 | scaleSpec :: Spec Unit 370 | scaleSpec = 371 | describe "scales" do 372 | it "handles C Major" do 373 | assertEquivalentKeys 374 | (diatonicScale { pitchClass: C, accidental: Natural, mode: Major }) 375 | ( Pitch { pitchClass: C, accidental: Natural } 376 | : Pitch { pitchClass: D, accidental: Natural } 377 | : Pitch { pitchClass: E, accidental: Natural } 378 | : Pitch { pitchClass: F, accidental: Natural } 379 | : Pitch { pitchClass: G, accidental: Natural } 380 | : Pitch { pitchClass: A, accidental: Natural } 381 | : Pitch { pitchClass: B, accidental: Natural } 382 | : Nil 383 | ) 384 | it "handles G Major" do 385 | assertEquivalentKeys 386 | (diatonicScale { pitchClass: G, accidental: Natural, mode: Major }) 387 | ( Pitch { pitchClass: C, accidental: Natural } 388 | : Pitch { pitchClass: D, accidental: Natural } 389 | : Pitch { pitchClass: E, accidental: Natural } 390 | : Pitch { pitchClass: F, accidental: Sharp } 391 | : Pitch { pitchClass: G, accidental: Natural } 392 | : Pitch { pitchClass: A, accidental: Natural } 393 | : Pitch { pitchClass: B, accidental: Natural } 394 | : Nil 395 | ) 396 | it "handles E Minor" do 397 | assertEquivalentKeys 398 | (diatonicScale { pitchClass: E, accidental: Natural, mode: Minor }) 399 | ( Pitch { pitchClass: C, accidental: Natural } 400 | : Pitch { pitchClass: D, accidental: Natural } 401 | : Pitch { pitchClass: E, accidental: Natural } 402 | : Pitch { pitchClass: F, accidental: Sharp } 403 | : Pitch { pitchClass: G, accidental: Natural } 404 | : Pitch { pitchClass: A, accidental: Natural } 405 | : Pitch { pitchClass: B, accidental: Natural } 406 | : Nil 407 | ) 408 | it "handles B Minor" do 409 | assertEquivalentKeys 410 | (diatonicScale { pitchClass: B, accidental: Natural, mode: Minor }) 411 | ( Pitch { pitchClass: C, accidental: Sharp } 412 | : Pitch { pitchClass: D, accidental: Natural } 413 | : Pitch { pitchClass: E, accidental: Natural } 414 | : Pitch { pitchClass: F, accidental: Sharp } 415 | : Pitch { pitchClass: G, accidental: Natural } 416 | : Pitch { pitchClass: A, accidental: Natural } 417 | : Pitch { pitchClass: B, accidental: Natural } 418 | : Nil 419 | ) 420 | it "handles F# Major" do 421 | assertEquivalentKeys 422 | (diatonicScale { pitchClass: F, accidental: Sharp, mode: Major }) 423 | ( Pitch { pitchClass: C, accidental: Sharp } 424 | : Pitch { pitchClass: D, accidental: Sharp } 425 | : Pitch { pitchClass: E, accidental: Sharp } 426 | : Pitch { pitchClass: F, accidental: Sharp } 427 | : Pitch { pitchClass: G, accidental: Sharp } 428 | : Pitch { pitchClass: A, accidental: Sharp } 429 | : Pitch { pitchClass: B, accidental: Natural } 430 | : Nil 431 | ) 432 | it "handles Gb Major" do 433 | assertEquivalentKeys 434 | (diatonicScale { pitchClass: G, accidental: Flat, mode: Major }) 435 | ( Pitch { pitchClass: C, accidental: Flat } 436 | : Pitch { pitchClass: D, accidental: Flat } 437 | : Pitch { pitchClass: E, accidental: Flat } 438 | : Pitch { pitchClass: F, accidental: Natural } 439 | : Pitch { pitchClass: G, accidental: Flat } 440 | : Pitch { pitchClass: A, accidental: Flat } 441 | : Pitch { pitchClass: B, accidental: Flat } 442 | : Nil 443 | ) 444 | 445 | -- key signatures 446 | gMajor :: KeySignature 447 | gMajor = 448 | { pitchClass: G, accidental: Natural, mode: Major } 449 | 450 | gMajorM :: ModifiedKeySignature 451 | gMajorM = 452 | { keySignature: gMajor, modifications: Nil, properties: empty } 453 | 454 | gMinor :: KeySignature 455 | gMinor = 456 | { pitchClass: G, accidental: Natural, mode: Minor } 457 | 458 | cMajor :: KeySignature 459 | cMajor = 460 | { pitchClass: C, accidental: Natural, mode: Major } 461 | 462 | cSharp :: Mode -> KeySignature 463 | cSharp mode = 464 | { pitchClass: C, accidental: Sharp, mode: mode } 465 | 466 | cSharpM :: Mode -> ModifiedKeySignature 467 | cSharpM mode = 468 | { keySignature: cSharp mode, modifications: Nil, properties: empty } 469 | 470 | dMajor :: KeySignature 471 | dMajor = 472 | { pitchClass: D, accidental: Natural, mode: Major } 473 | 474 | mix :: PitchClass -> KeySignature 475 | mix pc = 476 | { pitchClass: pc, accidental: Natural, mode: Mixolydian } 477 | 478 | dor :: PitchClass -> KeySignature 479 | dor pc = 480 | { pitchClass: pc, accidental: Natural, mode: Dorian } 481 | 482 | fMajor :: KeySignature 483 | fMajor = 484 | { pitchClass: F, accidental: Natural, mode: Major } 485 | 486 | fMajorM :: ModifiedKeySignature 487 | fMajorM = 488 | { keySignature: fMajor, modifications: Nil, properties: empty } 489 | 490 | dPhrygianSharpenedF :: ModifiedKeySignature 491 | dPhrygianSharpenedF = 492 | { keySignature: { pitchClass: D, accidental: Natural, mode: Phrygian } 493 | , modifications: (Pitch { pitchClass: F, accidental: Sharp } : Nil) 494 | , properties: empty 495 | } 496 | 497 | ePhrygianSharpenedG :: ModifiedKeySignature 498 | ePhrygianSharpenedG = 499 | { keySignature: { pitchClass: E, accidental: Natural, mode: Phrygian } 500 | , modifications: (Pitch { pitchClass: G, accidental: Sharp } : Nil) 501 | , properties: empty 502 | } 503 | 504 | keyedTune :: String 505 | keyedTune = 506 | "K: FMajor\x0D\n| ABC |\x0D\n" 507 | 508 | unkeyedTune :: String 509 | unkeyedTune = 510 | "T: Gamal Reinlender\x0D\n| ABC |\x0D\n" 511 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Aff (launchAff_) 6 | import Test.Spec.Reporter (specReporter) 7 | import Test.Spec.Runner (runSpec) 8 | import Test.Spec (describe) 9 | import Test.Abc (abcSpec) 10 | import Test.Metadata (metadataSpec) 11 | import Test.Octave (octaveSpec) 12 | import Test.Optics (opticsSpec) 13 | import Test.Tempo (tempoSpec) 14 | import Test.Accidentals (accidentalsSpec) 15 | import Test.KeySignature (keySignatureSpec) 16 | import Test.Transposition (transpositionSpec) 17 | import Test.Midi (midiSpec) 18 | import Test.Voice (voiceSpec) 19 | import Test.UnitNote (unitNoteSpec) 20 | import Test.Normaliser (normaliserSpec) 21 | 22 | 23 | main :: Effect Unit 24 | main = launchAff_ $ runSpec [ specReporter] do 25 | describe "ABC parser" do 26 | abcSpec 27 | accidentalsSpec 28 | keySignatureSpec 29 | metadataSpec 30 | midiSpec 31 | octaveSpec 32 | opticsSpec 33 | tempoSpec 34 | transpositionSpec 35 | unitNoteSpec 36 | voiceSpec 37 | normaliserSpec 38 | -------------------------------------------------------------------------------- /test/Metadata.purs: -------------------------------------------------------------------------------- 1 | module Test.Metadata (metadataSpec) where 2 | 3 | -- | test both the Utils and Meter modules 4 | 5 | import Prelude (Unit, discard, pure, unit, ($), (<>), (<<<)) 6 | import Effect.Aff (Aff) 7 | import Data.Either (Either(..)) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Lens.Fold (toListOf) 10 | import Data.Lens.Traversal (traversed) 11 | import Data.List (List(..), head, length, (:)) 12 | import Data.Abc.Parser (parse) 13 | import Data.Abc ( TimeSignature, BodyPart(..), AbcTune) 14 | import Data.Abc.Utils 15 | import Data.Abc.Meter (getDefaultedMeter) 16 | import Data.Abc.Canonical (fromTune) 17 | import Data.Abc.Optics (_headers, _Title) 18 | 19 | import Test.Spec (Spec, describe, it) 20 | import Test.Spec.Assertions (fail, shouldEqual) 21 | 22 | assertOkTitle :: String -> String -> Aff Unit 23 | assertOkTitle source target = 24 | case parse source of 25 | Right tune -> 26 | case (getTitle tune) of 27 | Just title -> 28 | target `shouldEqual` title 29 | 30 | _ -> 31 | fail "no title" 32 | _ -> 33 | fail "parse error" 34 | 35 | assertAllTitles :: String -> List String -> Aff Unit 36 | assertAllTitles source target = 37 | case parse source of 38 | Right tune -> 39 | let 40 | titles = 41 | toListOf (_headers <<< traversed <<< _Title) tune 42 | in 43 | target `shouldEqual` titles 44 | _ -> 45 | fail "parse error" 46 | 47 | assertOkMeter :: String -> TimeSignature -> Aff Unit 48 | assertOkMeter source target = 49 | case parse source of 50 | Right tune -> 51 | let 52 | meter = 53 | getDefaultedMeter tune 54 | in 55 | target `shouldEqual` meter 56 | _ -> 57 | fail "parse error" 58 | 59 | {-} 60 | assertOkNoteLen :: String -> Rational -> Aff Unit 61 | assertOkNoteLen source target = 62 | case parse source of 63 | Right tune -> 64 | case (getUnitNoteLength tune) of 65 | Just rat -> 66 | target `shouldEqual` rat 67 | _ -> 68 | fail "no unit note length" 69 | _ -> 70 | fail "parse error" 71 | -} 72 | 73 | assertNoHeader :: forall h. String -> (AbcTune -> Maybe h) -> Aff Unit 74 | assertNoHeader source getf = 75 | case parse source of 76 | Right tune -> 77 | let 78 | mtitle = 79 | getf tune 80 | in 81 | case mtitle of 82 | Just _ -> 83 | fail "no title expected" 84 | _ -> 85 | pure unit 86 | 87 | _ -> 88 | fail "parse error" 89 | 90 | assertHeaderCount :: Int -> String -> Aff Unit 91 | assertHeaderCount expectedCount source = 92 | case parse source of 93 | Right tune -> 94 | expectedCount `shouldEqual` (length tune.headers) 95 | 96 | _ -> 97 | fail "parse error" 98 | 99 | assertEmptyScore :: Boolean -> String -> Aff Unit 100 | assertEmptyScore expected source = 101 | case parse source of 102 | Right tune -> 103 | case (head tune.body) of 104 | Just (Score bars) -> 105 | expected `shouldEqual` (isEmptyStave bars) 106 | _ -> 107 | fail "test has no Score BodyPart" 108 | _ -> 109 | fail "parse error" 110 | 111 | buildThumbnail :: String -> String 112 | buildThumbnail s = 113 | case parse s of 114 | Right tune -> 115 | fromTune $ thumbnail tune 116 | _ -> 117 | "parse error" 118 | 119 | buildThumbnailNoRepeats :: String -> String 120 | buildThumbnailNoRepeats s = 121 | case parse s of 122 | Right tune -> 123 | fromTune $ removeRepeatMarkers $ thumbnail tune 124 | _ -> 125 | "parse error" 126 | 127 | metadataSpec :: Spec Unit 128 | metadataSpec = do 129 | describe "metadata" do 130 | headerSpec 131 | scoreSpec 132 | thumbnailSpec 133 | 134 | headerSpec :: Spec Unit 135 | headerSpec = 136 | describe "headers" do 137 | it "gets title" do 138 | assertOkTitle titledTune "Gamal Reinlender" 139 | it "gets no title" do 140 | assertNoHeader keyedTune getTitle 141 | it "gets first of multiple titles" do 142 | assertOkTitle doublyTitledTune "Nancy Dawson" 143 | it "gets all titles" do 144 | assertAllTitles doublyTitledTune ("Nancy Dawson" : "Piss Upon the Grass" : Nil) 145 | it "gets multiple headers" do 146 | assertHeaderCount 8 manyHeaders 147 | it "gets meter" do 148 | assertOkMeter manyHeaders { numerator: 4, denominator: 4} 149 | 150 | scoreSpec :: Spec Unit 151 | scoreSpec = 152 | describe "score" do 153 | it "recognizes empty score" do 154 | assertEmptyScore true emptyScore 155 | it "recognizes a non empty score" do 156 | assertEmptyScore false keyedTune 157 | 158 | thumbnailSpec :: Spec Unit 159 | thumbnailSpec = 160 | describe "thumbnail" do 161 | it "copes with lead-in bar" do 162 | augustssonThumbnail `shouldEqual` (buildThumbnail augustsson) 163 | it "copes without lead-in bar" do 164 | fastanThumbnail `shouldEqual` (buildThumbnail fastan) 165 | it "removes the repeat markers" do 166 | augustssonThumbnailNoRepeats `shouldEqual` (buildThumbnailNoRepeats augustsson) 167 | 168 | -- headers in sample ABC tunes 169 | keyedTune :: String 170 | keyedTune = 171 | "K: FMajor\x0D\n| ABC |\x0D\n" 172 | 173 | titledTune :: String 174 | titledTune = 175 | "T: Gamal Reinlender\x0D\n| ABC |\x0D\n" 176 | 177 | doublyTitledTune :: String 178 | doublyTitledTune = 179 | "T: Nancy Dawson\x0D\nT: Piss Upon the Grass\x0D\n| ABC |\x0D\n" 180 | 181 | manyHeaders :: String 182 | manyHeaders = 183 | "X: 1\r\nT: Skänklåt efter Brittas Hans\r\nR: Skänklåt\r\nZ: Brian O'Connor, 11/7/2016\r\nL: 1/16\r\nO: Bjorsa\r\nM: 4/4\r\nK:Gmaj\r\n| ABC |\r\n" 184 | 185 | emptyScore :: String 186 | emptyScore = 187 | "| @ # | \\r\n| |\r\n" 188 | 189 | augustssonHeaders :: String 190 | augustssonHeaders = 191 | "X: 1\r\n" 192 | <> "T: Engelska efter Albert Augustsson\r\n" 193 | <> "N: From the playing of Albert Augustsson, Bohuslän county.\r\n" 194 | <> "M: 4/4\r\n" 195 | <> "R: Engelska\r\n" 196 | <> "S: Orust\r\n" 197 | <> "Z: John Watson 24/01/2015\r\n" 198 | <> "L: 1/8\r\n" 199 | <> "K: AMajor\r\n" 200 | 201 | augustsson :: String 202 | augustsson = 203 | augustssonHeaders 204 | <> "A>c|: e2f2 efed | c2a2 e3d | cedc BdcB | Aced cBAc |\r\n" 205 | <> "e2f2 efed | c2a2 e3d | cedc BdcB | A4 A>AA>B :|\r\n" 206 | <> "|: e2e2 e2de | f2ed B3c | d3c d2cd | e3d cdBc |\r\n" 207 | <> "A2a2 a2gf | e2f2 e3d | cedc BdcB |1 A4 A>AA>B :|2 [A4E4] [A4E4] |\r\n" 208 | 209 | augustssonThumbnail :: String 210 | augustssonThumbnail = 211 | augustssonHeaders 212 | <> "A>c|: e2f2 efed | c2a2 e3d |\r\n" 213 | 214 | augustssonThumbnailNoRepeats :: String 215 | augustssonThumbnailNoRepeats = 216 | augustssonHeaders 217 | <> "A>c| e2f2 efed | c2a2 e3d |\r\n" 218 | 219 | fastanHeaders :: String 220 | fastanHeaders = 221 | "T: Fastan\r\n" 222 | <> "R: Polska\r\n" 223 | <> "M: 3/4\r\n" 224 | <> "K: FMajor\r\n" 225 | <> "L: 1/16\r\n" 226 | 227 | fastan :: String 228 | fastan = 229 | fastanHeaders 230 | <> "| (3A4F4G4 A2B2 | (3:2:4c2d2B4c4 A2F2 | (3F4E4D4 B,2D2 | EA3 A8- |\r\n" 231 | <> "| (3A4F4G4 A2B2 | (3:2:4c2d2B4c4 A2F2 | (3F4E4D4 G2A2 | AF3 F8- |\r\n" 232 | <> "| (3:2:5F4B4cBA2 B2d2 | ge3 c4 A4- | (3:2:5A4B4cBA2 B2d2 | de3 c8- |\r\n" 233 | <> "| (3:2:5F4B4cBA2 B2d2 | (3:2:4g2a2f4g4 e4- | (3:c4B4A4 F2G2 | ef3 F8 |\r\n" 234 | 235 | fastanThumbnail :: String 236 | fastanThumbnail = 237 | fastanHeaders 238 | <> "| (3A4F4G4 A2B2 | (3:2:4c2d2B4c4 A2F2 |\r\n" 239 | -------------------------------------------------------------------------------- /test/Midi.purs: -------------------------------------------------------------------------------- 1 | module Test.Midi (midiSpec) where 2 | 3 | import Effect.Aff (Aff) 4 | import Data.Abc (AbcNote, Accidental(..), Mode(..), ModifiedKeySignature, PitchClass(..)) 5 | import Data.Abc.Midi (MidiPitch, toMidiRecording, toMidiRecordingAtBpm, toMidiPitch) 6 | import Data.Abc.Parser (parse) 7 | import Data.Abc.Repeats.Types (VariantPositions) 8 | import Data.Abc.Repeats.Variant (findEndingPosition) 9 | import Data.Abc.Tempo (standardMidiTick) 10 | import Data.Either (Either(..)) 11 | import Data.Int (round) 12 | import Data.List (List(..), head, (:)) 13 | import Data.Map (empty, fromFoldable) 14 | import Data.Maybe (fromMaybe) 15 | import Data.Midi as Midi 16 | import Data.Rational (Rational, fromInt, toNumber, (%)) 17 | import Data.Tuple (Tuple(..)) 18 | import Prelude (Unit, discard, show, (<>), (*), (<<<)) 19 | import Test.Utils (buildKeySig) 20 | import Test.Spec (Spec, describe, it) 21 | import Test.Spec.Assertions (fail, shouldEqual) 22 | 23 | 24 | assertMidi :: String -> Midi.Track -> Aff Unit 25 | assertMidi s midiTrack = 26 | case (parse s) of 27 | Right tune -> 28 | let 29 | Midi.Recording midiRecording = toMidiRecording tune 30 | track0 = fromMaybe (Midi.Track Nil) (head midiRecording.tracks) 31 | in 32 | midiTrack `shouldEqual` track0 33 | 34 | Left err -> 35 | fail ("parse failed: " <> (show err)) 36 | 37 | assertMidiAtBpm :: String -> Int -> Midi.Track -> Aff Unit 38 | assertMidiAtBpm s bpm midiTrack = 39 | case (parse s) of 40 | Right tune -> 41 | let 42 | Midi.Recording midiRecording = toMidiRecordingAtBpm tune bpm 43 | track0 = fromMaybe (Midi.Track Nil) (head midiRecording.tracks) 44 | in 45 | midiTrack `shouldEqual` track0 46 | 47 | Left err -> 48 | fail ("parse failed: " <> (show err)) 49 | 50 | -- | assert the MIDI Pitch of an ABCNote in the context of G Major 51 | -- | but with no accidentals occurring in the nominal bar where the note lives 52 | assertMidiPitch :: AbcNote -> MidiPitch -> Aff Unit 53 | assertMidiPitch abcNote target = 54 | pitch `shouldEqual` target 55 | 56 | where 57 | pitch = 58 | toMidiPitch gMajor empty abcNote 59 | 60 | midiSpec :: Spec Unit 61 | midiSpec = do 62 | transformationSpec 63 | repeatSpec 64 | variantSpec 65 | graceSpec 66 | atTempoSpec 67 | pitchSpec 68 | 69 | transformationSpec :: Spec Unit 70 | transformationSpec = 71 | describe "MIDI transformation" do 72 | it "handles notes" do 73 | assertMidi "| CDE |\r\n" 74 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 75 | it "handles tied notes" do 76 | assertMidi "| CD-D |\r\n" 77 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 2))) 78 | it "handles doubly tied notes" do 79 | assertMidi "| CD-D-D |\r\n" 80 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 3))) 81 | it "handles a tie across bars" do 82 | assertMidi "| CD- | D |\r\n" 83 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 2))) 84 | it "handles long notes" do 85 | assertMidi "| C2D2E2 |\r\n" 86 | (Midi.Track (standardTempo <> noteC (fromInt 2) <> noteD (fromInt 2) <> noteE (fromInt 2))) 87 | it "handles a rest" do 88 | assertMidi "| CDZ |\r\n" 89 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> rest (fromInt 1))) 90 | it "handles a long rest" do 91 | assertMidi "| CDZ2 |\r\n" 92 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> rest (fromInt 2))) 93 | it "handles bars" do 94 | assertMidi "| C | D | E | F |\r\n" 95 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) <> noteF (fromInt 1))) 96 | it "handles lines" do 97 | assertMidi "| CD |\r\n| E |\r\n" 98 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 99 | it "handles tuplets" do 100 | assertMidi "| (3CDE |\r\n" 101 | (Midi.Track (standardTempo <> noteC (2 % 3) <> noteD (2 % 3) <> noteE (2 % 3))) 102 | it "handles a tuplet with rest" do 103 | assertMidi "| (3zDE |\r\n" 104 | (Midi.Track (standardTempo <> rest (2 % 3) <> noteD (2 % 3) <> noteE (2 % 3))) 105 | it "handles broken rhythm >" do 106 | assertMidi "| C>D |\r\n" 107 | (Midi.Track (standardTempo <> noteC (3 % 2) <> noteD (1 % 2))) 108 | it "handles broken rhythm <" do 109 | assertMidi "| C noteC (1 % 2) <> noteD (3 % 2))) 111 | it "handles broken rhythm >>" do 112 | assertMidi "| C>>D |\r\n" 113 | (Midi.Track (standardTempo <> noteC (7 % 4) <> noteD (1 % 4))) 114 | it "handles broken rhythm <<" do 115 | assertMidi "| C< noteC (1 % 4) <> noteD (7 % 4))) 117 | it "handles chords" do 118 | assertMidi "| [CEG] |\r\n" 119 | (Midi.Track (standardTempo <> chordC (fromInt 1))) 120 | it "handles along chord" do 121 | assertMidi "| [CEG]2 |\r\n" 122 | (Midi.Track (standardTempo <> chordC (fromInt 2))) 123 | it "handles an equivalent long chord" do 124 | assertMidi "| [C2E2G2] |\r\n" 125 | (Midi.Track (standardTempo <> chordC (fromInt 2))) 126 | it "handles a doubly fractional chord" do 127 | assertMidi "| [C/E/G/]1/3 |\r\n" 128 | (Midi.Track (standardTempo <> chordC (1 % 6))) 129 | it "handles a tie into chord" do -- we don't support ties into chords - it's ambiguous 130 | assertMidi "| C-[CEG] |\r\n" 131 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> chordC (fromInt 1))) 132 | it "respects a tempo header" do 133 | assertMidi "Q: 1/4=180\r\n| CDE |\r\n" 134 | (Midi.Track (tempo (2 % 3) <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 135 | it "respects a unit note length header" do 136 | assertMidi "L: 1/16\r\n| CDE |\r\n" 137 | (Midi.Track (tempo (1 % 2) <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 138 | it "respects a key signature header" do 139 | assertMidi "K: D\r\n| CDE |\r\n" 140 | (Midi.Track (standardTempo <> noteCs (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 141 | it "acknowledges accidental impact" do -- an accidental influences the pitch of notes later in the bar 142 | assertMidi "| ^CDEC |\r\n" 143 | (Midi.Track (standardTempo <> noteCs (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) <> noteCs (fromInt 1))) 144 | it "hadles a change of tempo" do 145 | assertMidi "| CD |\r\nQ: 1/4=180\r\n| E |\r\n" 146 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> tempo (2 % 3) <> noteE (fromInt 1))) 147 | it "handles a change of tempo inline " do 148 | assertMidi "| CD | [Q: 1/4=180] | E |\r\n" 149 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> tempo (2 % 3) <> noteE (fromInt 1))) 150 | it "respects a change unit note length" do 151 | assertMidi "| CD |\r\nL: 1/16\r\n| E |\r\n" 152 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> tempo (1 % 2) <> noteE (fromInt 1))) 153 | it "respects a change unit note length inline" do 154 | assertMidi "| CD | [L: 1/16] | E |\r\n" 155 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> tempo (1 % 2) <> noteE (fromInt 1))) 156 | it "respects a key change" do 157 | assertMidi "| CDE |\r\nK: D\r\n| C |\r\n" 158 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) <> noteCs (fromInt 1))) 159 | it "respects a key change inline" do 160 | assertMidi "| CDE | [K: D] | C |\r\n" 161 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) <> noteCs (fromInt 1))) 162 | 163 | repeatSpec :: Spec Unit 164 | repeatSpec = 165 | describe "repeats" do 166 | it "handles a simple repeat" do 167 | assertMidi "|: CDE :|\r\n" 168 | ( Midi.Track 169 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 170 | <> noteC (fromInt 1) 171 | <> noteD (fromInt 1) 172 | <> noteE (fromInt 1) 173 | ) 174 | ) 175 | it "handles a lead-in then repeat" do 176 | assertMidi "FC |: CDE :|\r\n" 177 | ( Midi.Track 178 | ( standardTempo <> noteF (fromInt 1) <> noteC (fromInt 1) 179 | <> noteC (fromInt 1) 180 | <> noteD (fromInt 1) 181 | <> noteE (fromInt 1) 182 | <> noteC (fromInt 1) 183 | <> noteD (fromInt 1) 184 | <> noteE (fromInt 1) 185 | ) 186 | ) 187 | it "handles a pair of repeats" do 188 | assertMidi "|: CDE :|: DEF :|\r\n" 189 | ( Midi.Track 190 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 191 | <> noteC (fromInt 1) 192 | <> noteD (fromInt 1) 193 | <> noteE (fromInt 1) 194 | <> noteD (fromInt 1) 195 | <> noteE (fromInt 1) 196 | <> noteF (fromInt 1) 197 | <> noteD (fromInt 1) 198 | <> noteE (fromInt 1) 199 | <> noteF (fromInt 1) 200 | ) 201 | ) 202 | it "handles a simple repeat implicit start" do 203 | assertMidi "| CDE :|\r\n" 204 | ( Midi.Track 205 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 206 | <> standardTempo 207 | <> noteC (fromInt 1) 208 | <> noteD (fromInt 1) 209 | <> noteE (fromInt 1) 210 | ) 211 | ) 212 | it "handles a simple repeat then unrepeated" do 213 | assertMidi "|: CDE :| F |\r\n" 214 | ( Midi.Track 215 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 216 | <> noteC (fromInt 1) 217 | <> noteD (fromInt 1) 218 | <> noteE (fromInt 1) 219 | <> noteF (fromInt 1) 220 | ) 221 | ) 222 | it "handles unrepeated then simple repeat" do 223 | assertMidi "| F |: CDE :|\r\n" 224 | ( Midi.Track 225 | ( standardTempo <> noteF (fromInt 1) 226 | <> noteC (fromInt 1) 227 | <> noteD (fromInt 1) 228 | <> noteE (fromInt 1) 229 | <> noteC (fromInt 1) 230 | <> noteD (fromInt 1) 231 | <> noteE (fromInt 1) 232 | ) 233 | ) 234 | it "handles alternate endings" do 235 | assertMidi "|: CD |1 E :|2 F |\r\n" 236 | ( Midi.Track 237 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 238 | <> noteC (fromInt 1) 239 | <> noteD (fromInt 1) 240 | <> noteF (fromInt 1) 241 | ) 242 | ) 243 | it "handles alternate endings then repeat" do 244 | assertMidi "|: CD |1 E :|2 F |: CDE :|\r\n" 245 | ( Midi.Track 246 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 247 | <> noteC (fromInt 1) 248 | <> noteD (fromInt 1) 249 | <> noteF (fromInt 1) 250 | <> noteC (fromInt 1) 251 | <> noteD (fromInt 1) 252 | <> noteE (fromInt 1) 253 | <> noteC (fromInt 1) 254 | <> noteD (fromInt 1) 255 | <> noteE (fromInt 1) 256 | ) 257 | ) 258 | it "handles an alternate endings list" do 259 | assertMidi "|: CD |1,3 E :|2 F |\r\n" 260 | ( Midi.Track 261 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 262 | <> noteC (fromInt 1) 263 | <> noteD (fromInt 1) 264 | <> noteF (fromInt 1) 265 | <> noteC (fromInt 1) 266 | <> noteD (fromInt 1) 267 | <> noteE (fromInt 1) 268 | ) 269 | ) 270 | it "handles an alternate endings range" do 271 | assertMidi "|: CD |1-3 E :|4 F |\r\n" 272 | ( Midi.Track 273 | ( standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1) 274 | <> noteC (fromInt 1) 275 | <> noteD (fromInt 1) 276 | <> noteE (fromInt 1) 277 | <> noteC (fromInt 1) 278 | <> noteD (fromInt 1) 279 | <> noteE (fromInt 1) 280 | <> noteC (fromInt 1) 281 | <> noteD (fromInt 1) 282 | <> noteF (fromInt 1) 283 | ) 284 | ) 285 | 286 | -- different types of variants (voltas) in repeated sections 287 | variantSpec :: Spec Unit 288 | variantSpec = 289 | describe "next position" do 290 | it "handles sample1 at 1,2,3 and 4" do 291 | 8 `shouldEqual` (findEndingPosition variant1 1 end) 292 | 8 `shouldEqual` (findEndingPosition variant1 2 end) 293 | 8 `shouldEqual` (findEndingPosition variant1 3 end) 294 | end `shouldEqual` (findEndingPosition variant1 4 end) 295 | it "handles sample2 at 1,2,3 and 4" do 296 | 8 `shouldEqual` (findEndingPosition variant2 1 end) 297 | end `shouldEqual` (findEndingPosition variant2 2 end) 298 | 8 `shouldEqual` (findEndingPosition variant2 3 end) 299 | end `shouldEqual` (findEndingPosition variant2 4 end) 300 | it "handle sample3 at 1,2,3 and 4" do 301 | 4 `shouldEqual` (findEndingPosition variant3 1 end) 302 | 6 `shouldEqual` (findEndingPosition variant3 2 end) 303 | 8 `shouldEqual` (findEndingPosition variant3 3 end) 304 | end `shouldEqual` (findEndingPosition variant3 4 end) 305 | 306 | -- each grace note 'steals' 10% of the note it graces 307 | graceSpec :: Spec Unit 308 | graceSpec = 309 | describe "grace notes" do 310 | it "handles single grace" do 311 | assertMidi "| {D}CDE |\r\n" 312 | (Midi.Track (standardTempo <> noteD (1 % 10) <> noteC (9 % 10) <> noteD (fromInt 1) <> noteE (fromInt 1))) 313 | it "handles double grace" do 314 | assertMidi "| {ED}CDE |\r\n" 315 | (Midi.Track (standardTempo <> noteE (1 % 10) <> noteD (1 % 10) <> noteC (8 % 10) <> noteD (fromInt 1) <> noteE (fromInt 1))) 316 | it "handles graces immediately after ties are ignored" do 317 | assertMidi "| C-{D}CDE |\r\n" 318 | (Midi.Track (standardTempo <> noteC (fromInt 2) <> noteD (fromInt 1) <> noteE (fromInt 1))) 319 | it "handles graces before ties are accumulated" do 320 | assertMidi "| {D}C-CDE |\r\n" 321 | (Midi.Track (standardTempo <> noteD (1 % 10) <> noteC (19 % 10) <> noteD (fromInt 1) <> noteE (fromInt 1))) 322 | it "handles graces inside tuplets" do 323 | assertMidi "| (3C{E}DE |\r\n" 324 | (Midi.Track (standardTempo <> noteC (2 % 3) <> noteE (2 % 30) <> noteD (18 % 30) <> noteE (2 % 3))) 325 | it "handles graces immediately preceding tuplets" do 326 | assertMidi "| {E}(3CDE |\r\n" 327 | (Midi.Track (standardTempo <> noteE (2 % 30) <> noteC (18 % 30) <> noteD (2 % 3) <> noteE (2 % 3))) 328 | 329 | assertMidi "| C>{E}D |\r\n" 330 | (Midi.Track (standardTempo <> noteC (3 % 2) <> noteE (1 % 20) <> noteD (9 % 20))) 331 | 332 | atTempoSpec :: Spec Unit 333 | atTempoSpec = 334 | describe "set tempo externally" do 335 | it "handles an identical tempo" do 336 | assertMidiAtBpm "| CDE |\r\n" 120 337 | (Midi.Track (standardTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 338 | it "handles half tempo" do 339 | assertMidiAtBpm "| CDE |\r\n" 60 340 | (Midi.Track (halfTempo <> noteC (fromInt 1) <> noteD (fromInt 1) <> noteE (fromInt 1))) 341 | 342 | pitchSpec :: Spec Unit 343 | pitchSpec = 344 | describe "convert a note's pitch class to a MIDI pitch (in context)" do 345 | it "converts B natural to MIDI" do 346 | assertMidiPitch b 47 347 | it "converts B# to MIDI" do 348 | assertMidiPitch bSharp 48 349 | it "converts B## to MIDI" do 350 | assertMidiPitch bDoubleSharp 49 351 | it "converts C natural to MIDI" do 352 | assertMidiPitch c 48 353 | 354 | -- | the number of MIDI ticks that equates to 1/4=120 355 | standardTicks :: Int 356 | standardTicks = 250000 357 | 358 | -- these functions are helpers to build a MIDI target track 359 | standardTempo :: List Midi.Message 360 | standardTempo = 361 | Midi.Message 0 (Midi.Tempo standardTicks) 362 | : Nil 363 | 364 | -- half the standard tempo - a MIDI tick is twice as long 365 | halfTempo :: List Midi.Message 366 | halfTempo = 367 | Midi.Message 0 (Midi.Tempo (standardTicks * 2)) 368 | : Nil 369 | 370 | tempo :: Rational -> List Midi.Message 371 | tempo r = 372 | let 373 | tmpo = (round <<< toNumber) (r * fromInt standardTicks) 374 | in 375 | Midi.Message 0 (Midi.Tempo tmpo) 376 | : Nil 377 | 378 | rest :: Rational -> List Midi.Message 379 | rest abcDuration = 380 | Midi.Message (midiTicks abcDuration) (Midi.NoteOn 0 0 80) 381 | : Nil 382 | 383 | noteC :: Rational -> List Midi.Message 384 | noteC abcDuration = 385 | Midi.Message 0 (Midi.NoteOn 0 60 80) 386 | : Midi.Message (midiTicks abcDuration) (Midi.NoteOff 0 60 80) 387 | : Nil 388 | 389 | noteCs :: Rational -> List Midi.Message 390 | noteCs abcDuration = 391 | Midi.Message 0 (Midi.NoteOn 0 61 80) 392 | : Midi.Message (midiTicks abcDuration) (Midi.NoteOff 0 61 80) 393 | : Nil 394 | 395 | noteD :: Rational -> List Midi.Message 396 | noteD abcDuration = 397 | Midi.Message 0 (Midi.NoteOn 0 62 80) 398 | : Midi.Message (midiTicks abcDuration) (Midi.NoteOff 0 62 80) 399 | : Nil 400 | 401 | noteE :: Rational -> List Midi.Message 402 | noteE abcDuration = 403 | Midi.Message 0 (Midi.NoteOn 0 64 80) 404 | : Midi.Message (midiTicks abcDuration) (Midi.NoteOff 0 64 80) 405 | : Nil 406 | 407 | noteF :: Rational -> List Midi.Message 408 | noteF abcDuration = 409 | Midi.Message 0 (Midi.NoteOn 0 65 80) 410 | : Midi.Message (midiTicks abcDuration) (Midi.NoteOff 0 65 80) 411 | : Nil 412 | 413 | chordC :: Rational -> List Midi.Message 414 | chordC abcDuration = 415 | Midi.Message 0 (Midi.NoteOn 0 60 80) 416 | : Midi.Message 0 (Midi.NoteOn 0 64 80) 417 | : Midi.Message 0 (Midi.NoteOn 0 67 80) 418 | : Midi.Message (midiTicks abcDuration) (Midi.NoteOff 0 60 80) 419 | : Midi.Message 0 (Midi.NoteOff 0 64 80) 420 | : Midi.Message 0 (Midi.NoteOff 0 67 80) 421 | : Nil 422 | 423 | b :: AbcNote 424 | b = 425 | { pitchClass: B, accidental: Implicit, octave: 3, duration: fromInt 1, tied: false } 426 | 427 | bSharp :: AbcNote 428 | bSharp = 429 | { pitchClass: B, accidental: Sharp, octave: 3, duration: fromInt 1, tied: false } 430 | 431 | bDoubleSharp :: AbcNote 432 | bDoubleSharp = 433 | { pitchClass: B, accidental: DoubleSharp, octave: 3, duration: fromInt 1, tied: false } 434 | 435 | c :: AbcNote 436 | c = 437 | { pitchClass: C, accidental: Implicit, octave: 4, duration: fromInt 1, tied: false } 438 | 439 | gMajor :: ModifiedKeySignature 440 | gMajor = 441 | buildKeySig G Natural Major 442 | 443 | -- |1,2,3 ...:|4.....| 444 | variant1 :: VariantPositions 445 | variant1 = 446 | fromFoldable [ Tuple 1 5, Tuple 2 5, Tuple 3 5, Tuple 4 8 ] 447 | 448 | -- |1,3....:|2,4.....| 449 | variant2 :: VariantPositions 450 | variant2 = 451 | fromFoldable [ Tuple 1 5, Tuple 3 5, Tuple 2 8, Tuple 4 8 ] 452 | 453 | -- |1....:|2....:|3....:|4.....| 454 | variant3 :: VariantPositions 455 | variant3 = 456 | fromFoldable [ Tuple 1 2, Tuple 2 4, Tuple 3 6, Tuple 4 8 ] 457 | 458 | -- the end of a section with variants 459 | end :: Int 460 | end = 10 461 | 462 | midiTicks :: Rational -> Int 463 | midiTicks r = 464 | (round <<< toNumber) (fromInt standardMidiTick * r) 465 | -------------------------------------------------------------------------------- /test/Normaliser.purs: -------------------------------------------------------------------------------- 1 | module Test.Normaliser (normaliserSpec) where 2 | 3 | import Prelude 4 | import Effect.Aff (Aff) 5 | import Data.Either (Either(..)) 6 | import Data.Abc.Parser (parse) 7 | import Data.Abc.Canonical (fromTune) 8 | import Data.Abc.Normaliser (normalise) 9 | import Test.Spec (Spec, describe, it) 10 | import Test.Spec.Assertions (fail, shouldEqual) 11 | 12 | assertNormalised :: String -> String -> Aff Unit 13 | assertNormalised s normalised = 14 | case (parse s) of 15 | Right tune -> 16 | normalised `shouldEqual` (fromTune $ normalise tune) 17 | 18 | Left err -> 19 | fail ("parse failed: " <> (show err)) 20 | 21 | normaliserSpec :: Spec Unit 22 | normaliserSpec = 23 | describe "normalisation" do 24 | it "normalisation leaves other music items intact " do 25 | assertNormalised "| ABC4 (3CDE z2 |\x0D\n" "| ABC4 (3CDE z2 |\x0D\n" 26 | it "normalises a chord" do 27 | assertNormalised "| [AB]4 [F2E2]2 |\x0D\n" "| [A4B4] [F4E4] |\x0D\n" 28 | it "normalises a broken rhythm between two notes" do 29 | assertNormalised "| A4>B4 C2z4 C2E4 z2>B4 C4<B Cb' |\x0D\n" 75 | 76 | phrase2Med = 77 | "| A,,B,, CDE [f'g'] |\x0D\n| a''>b'' |\x0D\n" 78 | 79 | phrase2High = 80 | "| A,B, cde [f''g''] |\x0D\n| a'''>b''' |\x0D\n" 81 | -------------------------------------------------------------------------------- /test/Optics.purs: -------------------------------------------------------------------------------- 1 | module Test.Optics (opticsSpec) where 2 | 3 | import Data.Abc 4 | import Data.Abc.Optics 5 | 6 | import Data.Abc.Parser (parse) 7 | import Data.Either (hush) 8 | import Data.Lens.Fold (firstOf, toListOf) 9 | import Data.Lens.Setter (set) 10 | import Data.Lens.Traversal (traversed) 11 | import Data.List (List(..), (:)) 12 | import Data.Maybe (Maybe(..), fromJust) 13 | import Data.Rational ((%)) 14 | import Partial.Unsafe (unsafePartial) 15 | import Prelude (($), (<>), (<<<), Unit, discard) 16 | import Test.Spec (Spec, describe, it) 17 | import Test.Spec.Assertions (shouldEqual) 18 | 19 | opticsSpec :: Spec Unit 20 | opticsSpec = 21 | describe "optics" do 22 | it "fetches the title" do 23 | let 24 | title :: Maybe String 25 | title = firstOf (_headers <<< traversed <<< _Title) (getTune borddajnsijn) 26 | title `shouldEqual` (Just "Borddajnsijn") 27 | it "fetches all titles" do 28 | let 29 | titles :: List String 30 | titles = toListOf (_headers <<< traversed <<< _Title) (getTune borddajnsijn) 31 | titles `shouldEqual` ("Borddajnsijn" : "Second title" : Nil) 32 | it "fetches unit note length" do 33 | let 34 | duration :: Maybe NoteDuration 35 | duration = firstOf (_headers <<< traversed <<< _UnitNoteLength) (getTune borddajnsijn) 36 | duration `shouldEqual` (Just (1 % 8)) 37 | it "fetches the mode" do 38 | let 39 | mode :: Maybe Mode 40 | mode = firstOf 41 | (_headers <<< traversed <<< _ModifiedKeySignature <<< _keySignature <<< _mode) 42 | (getTune borddajnsijn) 43 | mode `shouldEqual` (Just Major) 44 | it "fetches the key pitch class" do 45 | let 46 | pitchClass :: Maybe PitchClass 47 | pitchClass = firstOf 48 | (_headers <<< traversed <<< _ModifiedKeySignature <<< _keySignature <<< _pitchClass) 49 | (getTune borddajnsijn) 50 | pitchClass `shouldEqual` (Just G) 51 | it "fetches the tempo bpm" do 52 | let 53 | bpm :: Maybe Int 54 | bpm = firstOf 55 | (_headers <<< traversed <<< _Tempo <<< _bpm) 56 | (getTune borddajnsijn) 57 | bpm `shouldEqual` (Just 150) 58 | it "fetches the voice id" do 59 | let 60 | id :: Maybe String 61 | id = firstOf 62 | (_headers <<< traversed <<< _Voice <<< _id) 63 | (getTune borddajnsijn) 64 | id `shouldEqual` (Just "1") 65 | it "sets the title" do 66 | let 67 | newTune = set (_headers <<< traversed <<< _Title) "new title" (getTune borddajnsijn) 68 | 69 | title :: Maybe String 70 | title = firstOf (_headers <<< traversed <<< _Title) newTune 71 | title `shouldEqual` (Just "new title") 72 | 73 | getTune :: String -> AbcTune 74 | getTune s = 75 | -- (unsafePartial <<< fromJust <<< hush <<< parse) 76 | unsafePartial $ fromJust $ hush $ parse s 77 | 78 | borddajnsijn :: String 79 | borddajnsijn = 80 | "X: 1\r\n" 81 | <> "T: Borddajnsijn\r\n" 82 | <> "T: Second title\r\n" 83 | <> "R: polka\r\n" 84 | <> "L: 1/8\r\n" 85 | <> "Q: 1/4=150\r\n" 86 | <> "K: GMajor\r\n" 87 | <> "V: 1\r\n" 88 | <> "|: d2 d2 | d3 B | dc AF | GA Bc | d2 g2 | d3 B | dc AF | G2 z2 :|\r\n" 89 | <> "|: DF AF | DG Bd | dc AF | GB d2 | DF AF | DG Bd | dc AF | G2 z2 :|\r\n" 90 | <> "\r\n" 91 | <> "\r\n" -------------------------------------------------------------------------------- /test/Tempo.purs: -------------------------------------------------------------------------------- 1 | module Test.Tempo (tempoSpec) where 2 | 3 | import Prelude (Unit, discard, ($)) 4 | 5 | import Data.Abc.Tempo (getBpm, setBpm, midiTempo, defaultAbcTempo, beatsPerSecond) 6 | import Test.Utils 7 | import Data.Rational (fromInt, (%)) 8 | 9 | import Test.Spec (Spec, describe, it) 10 | import Test.Spec.Assertions (shouldEqual) 11 | 12 | 13 | tempoSpec :: Spec Unit 14 | tempoSpec = do 15 | describe "tempo" do 16 | it "gets the tempo from header" do 17 | assertIntFuncMatches 18 | fullHeaderHigh 19 | getBpm 20 | 132 21 | it "gets the default tempo when there's no header" do 22 | assertIntFuncMatches 23 | noHeader 24 | getBpm 25 | 120 26 | it "alters tempo of existing header" do 27 | assertMoveMatches 28 | fullHeaderMed 29 | (setBpm 132) 30 | fullHeaderHigh 31 | it "provides a new tempo from default of no headers" do 32 | assertMoveMatches 33 | noHeader 34 | (setBpm 144) 35 | justTempoHeader 36 | it "provides a new tempo from default of only Key header" do 37 | assertMoveMatches 38 | onlyKeyHeader 39 | (setBpm 84) 40 | justTempoAndKeyHeader 41 | -- | standard tempo is 1/4 = 120 (120 quarter notes/min) 42 | -- | i.e. 2 quarter notes/sec (each quarter note takes 1/2 sec) 43 | -- | but default ABC tempo uses eighth notes 44 | -- | so these last for 1/4 sec = 250000 μsec 45 | it "provides a MIDI tempo for default ABC tempo" do 46 | 250000 `shouldEqual` (midiTempo defaultAbcTempo) 47 | it "provides a default bps" do 48 | (fromInt 2) `shouldEqual` (beatsPerSecond defaultAbcTempo) 49 | it "calculates a faster bps" do 50 | (fromInt 3) `shouldEqual` (beatsPerSecond $ defaultAbcTempo { bpm = 180 }) 51 | -- | bps should be unaffected by unit note length 52 | it "provides an accurate bps irrespective of a shorter notelen" do 53 | (fromInt 2) `shouldEqual` (beatsPerSecond $ defaultAbcTempo { unitNoteLength = 1 % 16 }) 54 | 55 | fullHeaderMed = 56 | "X: 1\x0D\nT: a title\x0D\nQ: 1/4=120\x0D\nM: 3/4\x0D\nK: CMajor\x0D\n| A,B, (3CDE [FG] |\x0D\n" 57 | 58 | fullHeaderHigh = 59 | "X: 1\x0D\nT: a title\x0D\nQ: 1/4=132\x0D\nM: 3/4\x0D\nK: CMajor\x0D\n| A,B, (3CDE [FG] |\x0D\n" 60 | 61 | noHeader = 62 | "| A,B, (3CDE [FG] |\x0D\n" 63 | 64 | justTempoHeader = 65 | "Q: 1/4=144\x0D\n| A,B, (3CDE [FG] |\x0D\n" 66 | 67 | onlyKeyHeader = 68 | "K: CMajor\x0D\n| A,B, (3CDE [FG] |\x0D\n" 69 | 70 | justTempoAndKeyHeader = 71 | "Q: 1/4=84\x0D\nK: CMajor\x0D\n| A,B, (3CDE [FG] |\x0D\n" 72 | -------------------------------------------------------------------------------- /test/Transposition.purs: -------------------------------------------------------------------------------- 1 | module Test.Transposition (transpositionSpec) where 2 | 3 | import Effect.Aff (Aff) 4 | import Data.Abc.Parser (parse) 5 | import Data.Abc.Canonical (abcNote, fromTune) 6 | import Data.Abc.Transposition 7 | import Data.Abc (AbcNote, Accidental(..), Pitch(..), PitchClass(..), Mode(..), ModifiedKeySignature) 8 | import Data.Either (Either(..)) 9 | import Data.List (List(..)) 10 | import Data.Map (empty) 11 | import Data.Rational (fromInt) 12 | import Prelude (Unit, discard, map, negate) 13 | import Test.Spec (Spec, describe, it) 14 | import Test.Spec.Assertions (fail, shouldEqual) 15 | import Test.Utils (buildKeySig) 16 | 17 | 18 | assertTranspositionMatches :: String -> Pitch -> String -> Aff Unit 19 | assertTranspositionMatches s targetp target = 20 | case parse s of 21 | Right tune -> 22 | target `shouldEqual` (fromTune (transposeTo targetp tune)) 23 | Left _ -> 24 | fail "unexpected parse error" 25 | 26 | transpositionSpec :: Spec Unit 27 | transpositionSpec = do 28 | describe "transposition" do 29 | keySpec 30 | noteSpec 31 | phraseSpec 32 | tuneSpec 33 | keyChangeSpec 34 | 35 | keySpec :: Spec Unit 36 | keySpec = do 37 | describe "keys" do 38 | it "moves C to G#" do 39 | shouldEqual 40 | (Right 8) 41 | (keyDistance gSharpMajor cMajor) 42 | it "moves G# to Bb" do 43 | shouldEqual 44 | (Right 2) 45 | (keyDistance bFlat gSharpMajor) 46 | it "moves Bb to G#" do 47 | shouldEqual 48 | (Right (-2)) 49 | (keyDistance gSharpMajor bFlat) 50 | it "moves Bm to Am" do 51 | shouldEqual 52 | (Left "incompatible modes") 53 | (keyDistance bFlatDorian cMajor) 54 | 55 | -- | Transposition within the contexts of given keys 56 | -- | This is another example of where I find PureScript awkward 57 | -- | no derived instances are available for AbcNote because it's defined 58 | -- | as simply as possible as a record. However we can 'show' an AbcNote 59 | -- | because it's there in Canonical. So we compare the stringified versions. 60 | noteSpec :: Spec Unit 61 | noteSpec = do 62 | describe "notes" do 63 | it "handles F in FMaj to GMaj" do 64 | shouldEqual 65 | (map abcNote (Right g)) 66 | (map abcNote (transposeNote gMajor fMajor f)) 67 | it " handles FNat in GMaj to FMaj" do 68 | shouldEqual 69 | (map abcNote (Right eb)) 70 | (map abcNote (transposeNote fMajor gMajor fnat)) 71 | it "handles C# in AMaj to GMaj" do 72 | shouldEqual 73 | (map abcNote (Right b)) 74 | (map abcNote (transposeNote gMajor aMajor cs)) 75 | it "handles C# in GMaj to AMaj" do 76 | shouldEqual 77 | (map abcNote (Right ds)) 78 | (map abcNote (transposeNote aMajor gMajor cs)) 79 | it "handles G# in Amin to FMin" do 80 | shouldEqual 81 | (map abcNote (Right enat)) 82 | (map abcNote (transposeNote fMinor aMinor gs)) 83 | it "handles B in DMaj to CMaj" do 84 | shouldEqual 85 | (map abcNote (Right a)) 86 | (map abcNote (transposeNote cMajor dMajor b)) 87 | it "handles C in BMin to EMin" do 88 | shouldEqual 89 | (map abcNote (Right f)) 90 | (map abcNote (transposeNote eMinor bMinor c)) 91 | 92 | phraseSpec :: Spec Unit 93 | phraseSpec = do 94 | describe "phrases" do 95 | it "moves C phrase to D phrase" do 96 | assertTranspositionMatches 97 | cPhrase 98 | -- dMajor 99 | (Pitch { pitchClass: D, accidental: Natural }) 100 | dPhrase 101 | it "moves D phrase to C phrase" do 102 | assertTranspositionMatches 103 | dPhrase 104 | -- cMajor 105 | (Pitch { pitchClass: C, accidental: Natural }) 106 | cPhrase 107 | it "moves C phrase to F phrase" do 108 | assertTranspositionMatches 109 | cPhrase 110 | -- fMajor 111 | (Pitch { pitchClass: F, accidental: Natural }) 112 | fPhrase 113 | it "moves Gm phrase to Dm phrase" do 114 | assertTranspositionMatches 115 | gmPhrase 116 | -- dMinor 117 | (Pitch { pitchClass: D, accidental: Natural }) 118 | dmPhrase 119 | it "moves Gm phrase with in-bar accidental" do 120 | assertTranspositionMatches 121 | gmPhraseLocal 122 | -- dMinor 123 | (Pitch { pitchClass: D, accidental: Natural }) 124 | dmPhrase 125 | it "moves Dm phrase to Gm phrase" do 126 | assertTranspositionMatches 127 | dmPhrase 128 | -- gMinor 129 | (Pitch { pitchClass: G, accidental: Natural }) 130 | gmPhraseLocal 131 | it "moves Bm phrase to Em phrase" do 132 | assertTranspositionMatches 133 | bmPhrase 134 | -- eMinor 135 | (Pitch { pitchClass: E, accidental: Natural }) 136 | emPhrase 137 | it "moves Am phrase to Fm phrase" do 138 | assertTranspositionMatches 139 | amPhrase 140 | -- fMinor 141 | (Pitch { pitchClass: F, accidental: Natural }) 142 | fmPhrase 143 | it "moves Am phrase to F#m phrase" do 144 | assertTranspositionMatches 145 | amPhrase0 146 | -- fSharpMinor 147 | (Pitch { pitchClass: F, accidental: Sharp }) 148 | fsharpmPhrase0 149 | it "respects the identity transposition" do 150 | assertTranspositionMatches 151 | dmPhrase 152 | -- dMinor 153 | (Pitch { pitchClass: D, accidental: Natural }) 154 | dmPhrase 155 | it "moves Cm phrase to Am phrase" do 156 | assertTranspositionMatches 157 | cmPhrase1 158 | -- aMinor 159 | (Pitch { pitchClass: A, accidental: Natural }) 160 | amPhrase1High 161 | 162 | -- | test that headers are ordered properly 163 | tuneSpec :: Spec Unit 164 | tuneSpec = do 165 | describe"tunes" do 166 | it "moves Bm tune to Am tune" do 167 | assertTranspositionMatches 168 | tuneBm 169 | -- aMinor 170 | (Pitch { pitchClass: A, accidental: Natural }) 171 | tuneAm 172 | 173 | keyChangeSpec :: Spec Unit 174 | keyChangeSpec = do 175 | describe"key changes" do 176 | it "changes key Bm to Am" do 177 | assertTranspositionMatches 178 | keyChangeBm 179 | -- aMinor 180 | (Pitch { pitchClass: A, accidental: Natural }) 181 | keyChangeAm 182 | it "changes key Am to Bm" do 183 | assertTranspositionMatches 184 | keyChangeAm 185 | -- bMinor 186 | (Pitch { pitchClass: B, accidental: Natural }) 187 | keyChangeBm 188 | it "changes key Bm to Em" do 189 | assertTranspositionMatches 190 | keyChangeBm 191 | -- eMinor 192 | (Pitch { pitchClass: E, accidental: Natural }) 193 | keyChangeEmHigh 194 | it "changes key Em to Bm" do 195 | assertTranspositionMatches 196 | keyChangeEm 197 | -- bMinor 198 | (Pitch { pitchClass: B, accidental: Natural }) 199 | keyChangeBm 200 | it "changes key Bm to C#m" do 201 | assertTranspositionMatches 202 | keyChangeBm 203 | -- cSharpMinor 204 | (Pitch { pitchClass: C, accidental: Sharp }) 205 | keyChangeCSharpmHigh 206 | it "changes key C#m to Bm" do 207 | assertTranspositionMatches 208 | keyChangeCSharpm 209 | -- bMinor 210 | (Pitch { pitchClass: B, accidental: Natural }) 211 | keyChangeBm 212 | it "changes key Bm to Am inline" do 213 | assertTranspositionMatches 214 | keyChangeBmInline 215 | -- aMinor 216 | (Pitch { pitchClass: A, accidental: Natural }) 217 | keyChangeAmInline 218 | 219 | -- note C Sharp and D Sharp are in octave 5 all the other notes are in octave 4 220 | cs :: AbcNote 221 | cs = 222 | { pitchClass: C, accidental: Sharp, octave: 5, duration: fromInt 1, tied: false } 223 | 224 | ds :: AbcNote 225 | ds = 226 | { pitchClass: D, accidental: Sharp, octave: 5, duration: fromInt 1, tied: false } 227 | 228 | eb :: AbcNote 229 | eb = 230 | { pitchClass: E, accidental: Flat, octave: 4, duration: fromInt 1, tied: false } 231 | 232 | enat :: AbcNote 233 | enat = 234 | { pitchClass: E, accidental: Natural, octave: 4, duration: fromInt 1, tied: false } 235 | 236 | b :: AbcNote 237 | b = 238 | { pitchClass: B, accidental: Implicit, octave: 4, duration: fromInt 1, tied: false } 239 | 240 | c :: AbcNote 241 | c = 242 | { pitchClass: C, accidental: Implicit, octave: 4, duration: fromInt 1, tied: false } 243 | 244 | bnat :: AbcNote 245 | bnat = 246 | { pitchClass: B, accidental: Natural, octave: 4, duration: fromInt 1, tied: false } 247 | 248 | f :: AbcNote 249 | f = 250 | { pitchClass: F, accidental: Implicit, octave: 4, duration: fromInt 1, tied: false } 251 | 252 | fnat :: AbcNote 253 | fnat = 254 | { pitchClass: F, accidental: Natural, octave: 4, duration: fromInt 1, tied: false } 255 | 256 | g :: AbcNote 257 | g = 258 | { pitchClass: G, accidental: Implicit, octave: 4, duration: fromInt 1, tied: false } 259 | 260 | gs :: AbcNote 261 | gs = 262 | { pitchClass: G, accidental: Sharp, octave: 4, duration: fromInt 1, tied: false } 263 | 264 | a :: AbcNote 265 | a = 266 | { pitchClass: A, accidental: Implicit, octave: 4, duration: fromInt 1, tied: false } 267 | 268 | fMajor :: ModifiedKeySignature 269 | fMajor = 270 | buildKeySig F Natural Major 271 | 272 | fMinor :: ModifiedKeySignature 273 | fMinor = 274 | buildKeySig F Natural Minor 275 | 276 | fSharpMinor :: ModifiedKeySignature 277 | fSharpMinor = 278 | buildKeySig F Sharp Minor 279 | 280 | gMajor :: ModifiedKeySignature 281 | gMajor = 282 | buildKeySig G Natural Major 283 | 284 | gMinor :: ModifiedKeySignature 285 | gMinor = 286 | buildKeySig G Natural Minor 287 | 288 | aMajor :: ModifiedKeySignature 289 | aMajor = 290 | buildKeySig A Natural Major 291 | 292 | aMinor :: ModifiedKeySignature 293 | aMinor = 294 | buildKeySig A Natural Minor 295 | 296 | bMinor :: ModifiedKeySignature 297 | bMinor = 298 | buildKeySig B Natural Minor 299 | 300 | gSharpMajor :: ModifiedKeySignature 301 | gSharpMajor = 302 | buildKeySig G Sharp Major 303 | 304 | cMajor :: ModifiedKeySignature 305 | cMajor = 306 | buildKeySig C Natural Major 307 | 308 | cSharpMinor :: ModifiedKeySignature 309 | cSharpMinor = 310 | buildKeySig C Sharp Minor 311 | 312 | dMajor :: ModifiedKeySignature 313 | dMajor = 314 | buildKeySig D Natural Major 315 | 316 | dMinor :: ModifiedKeySignature 317 | dMinor = 318 | buildKeySig D Natural Minor 319 | 320 | eMinor :: ModifiedKeySignature 321 | eMinor = 322 | buildKeySig E Natural Minor 323 | 324 | bFlatDorian :: ModifiedKeySignature 325 | bFlatDorian = 326 | { keySignature: { pitchClass: B, accidental: Flat, mode: Dorian } 327 | , modifications: Nil 328 | , properties: empty 329 | } 330 | 331 | bFlat :: ModifiedKeySignature 332 | bFlat = 333 | buildKeySig B Flat Major 334 | 335 | cPhrase = 336 | "K: CMajor\x0D\n| AB (3zde [fg] |\x0D\n" 337 | 338 | dPhrase = 339 | "K: DMajor\x0D\n| Bc (3zef [ga] |\x0D\n" 340 | 341 | fPhrase = 342 | "K: FMajor\x0D\n| de (3zga [bc'] |\x0D\n" 343 | 344 | gmPhrase = 345 | "K: GMinor\x0D\n| G3A B6 Ac |\x0D\n B2AG ^FGA^F D4\x0D\n" 346 | 347 | gmPhraseLocal = 348 | "K: GMinor\x0D\n| G3A B6 Ac |\x0D\n B2AG ^FGAF D4\x0D\n" 349 | 350 | -- second F implicitly sharpened 351 | 352 | dmPhrase = 353 | "K: DMinor\x0D\n| D3E F6 EG |\x0D\n F2ED ^CDEC A,4\x0D\n" 354 | 355 | bmPhrase = 356 | "K: BMinor\x0D\n| B4 A4 B4 | c2d2 e2dc {b}(3c2d2e2 |\x0D\n" 357 | 358 | emPhrase = 359 | "K: EMinor\x0D\n| e4 d4 e4 | f2g2 a2gf {e'}(3f2g2a2 |\x0D\n" 360 | 361 | amPhrase0 = 362 | "K: AMinor\x0D\n| edcB A2E2 C2E2 | A^GAB cBcd e4 |\x0D\n" 363 | 364 | fsharpmPhrase0 = 365 | "K: F#Minor\x0D\n| cBAG F2C2 A,2C2 | F=F^FG AGAB c4 |\x0D\n" 366 | 367 | amPhrase1High = 368 | "K: AMinor\x0D\n| c'2ba ^gabg e4 |\x0D\n" 369 | 370 | amPhrase1 = 371 | "K: AMinor\x0D\n| c2BA ^GABG E4 |\x0D\n" 372 | 373 | cmPhrase1 = 374 | "K: CMinor\x0D\n| e2dc =BcdB G4 |\x0D\n" 375 | 376 | fmPhrase1 = 377 | "K: FMinor\x0D\n| A2GF =EFGE C4 |\x0D\n" 378 | 379 | amPhrase = 380 | "K: AMinor\x0D\n| e2ef g2gf e2ed | c2ce d2dB c4 |\x0D\n" 381 | 382 | fmPhrase = 383 | "K: FMinor\x0D\n| c2c^c e2ec =c2cB | A2Ac B2BG A4 |\x0D\n" 384 | 385 | keyChangeBm = 386 | "K: BMinor\x0D\n| B4 A4 B4 | d2f2 e2dc c2d2 |\x0D\nK: F#Minor\x0D\n| f4 e4 f4 | g2a2 b2ag g2a2 |\x0D\n" 387 | 388 | keyChangeAm = 389 | "K: AMinor\x0D\n| A4 G4 A4 | c2e2 d2cB B2c2 |\x0D\nK: EMinor\x0D\n| e4 d4 e4 | f2g2 a2gf f2g2 |\x0D\n" 390 | 391 | keyChangeEm = 392 | "K: EMinor\x0D\n| E4 D4 E4 | G2B2 A2GF F2G2 |\x0D\nK: BMinor\x0D\n| B4 A4 B4 | c2d2 e2dc c2d2 |\x0D\n" 393 | 394 | keyChangeEmHigh = 395 | "K: EMinor\x0D\n| e4 d4 e4 | g2b2 a2gf f2g2 |\x0D\nK: BMinor\x0D\n| b4 a4 b4 | c'2d'2 e'2d'c' c'2d'2 |\x0D\n" 396 | 397 | keyChangeCSharpm = 398 | "K: C#Minor\x0D\n| C4 B,4 C4 | E2G2 F2ED D2E2 |\x0D\nK: G#Minor\x0D\n| G4 F4 G4 | A2B2 c2BA A2B2 |\x0D\n" 399 | 400 | keyChangeCSharpmHigh = 401 | "K: C#Minor\x0D\n| c4 B4 c4 | e2g2 f2ed d2e2 |\x0D\nK: G#Minor\x0D\n| g4 f4 g4 | a2b2 c'2ba a2b2 |\x0D\n" 402 | 403 | keyChangeBmInline = 404 | "K: BMinor\x0D\n| B4 A4 B4 | d2f2 e2dc c2d2 | [K: F#Minor] f4 e4 f4 | g2a2 b2ag g2a2 |\x0D\n" 405 | 406 | keyChangeAmInline = 407 | "K: AMinor\x0D\n| A4 G4 A4 | c2e2 d2cB B2c2 | [K: EMinor] e4 d4 e4 | f2g2 a2gf f2g2 |\x0D\n" 408 | 409 | tuneBm = 410 | "X: 1\r\nT: title\r\nM: 3/4\r\nK: BMinor\r\n| d e f |\r\n" 411 | 412 | tuneAm = 413 | "X: 1\r\nT: title\r\nM: 3/4\r\nK: AMinor\r\n| c d e |\r\n" 414 | -------------------------------------------------------------------------------- /test/UnitNote.purs: -------------------------------------------------------------------------------- 1 | module Test.UnitNote (unitNoteSpec) where 2 | 3 | import Prelude (Unit, discard) 4 | 5 | import Effect.Aff (Aff) 6 | import Data.Abc.UnitNote (defaultUnitNoteLength, getUnitNoteLength) 7 | import Data.Abc.Parser (parse) 8 | import Data.Either (Either(..)) 9 | import Data.Maybe (Maybe(..)) 10 | import Data.Rational (Rational, (%)) 11 | 12 | import Test.Spec (Spec, describe, it) 13 | import Test.Spec.Assertions (fail, shouldEqual) 14 | 15 | assertOkNoteLen :: String -> Rational -> Aff Unit 16 | assertOkNoteLen source target = 17 | case parse source of 18 | Right tune -> 19 | case (getUnitNoteLength tune) of 20 | Just rat -> 21 | target `shouldEqual` rat 22 | _ -> 23 | fail "no unit note length" 24 | _ -> 25 | fail "parse error" 26 | 27 | unitNoteSpec :: Spec Unit 28 | unitNoteSpec = do 29 | describe "unit note" do 30 | it "gets UnitNoteLen" do 31 | assertOkNoteLen manyHeaders (1 % 16) 32 | it " computes a 4/4 unit note" do 33 | shouldEqual 34 | (1 % 8) 35 | (defaultUnitNoteLength { numerator: 4, denominator: 4 }) 36 | it "computes a 2/4 unit note" do 37 | shouldEqual 38 | (1 % 16) 39 | (defaultUnitNoteLength { numerator: 2, denominator: 4}) 40 | it "finds a default unit note when no meter is present" do 41 | -- 4/4 is the default 42 | shouldEqual 43 | (1 % 8) 44 | (defaultUnitNoteLength { numerator: 4, denominator: 4 }) 45 | 46 | 47 | manyHeaders :: String 48 | manyHeaders = 49 | "X: 1\r\nT: Skänklåt efter Brittas Hans\r\nR: Skänklåt\r\nZ: Brian O'Connor, 11/7/2016\r\nL: 1/16\r\nO: Bjorsa\r\nM: 4/4\r\nK:Gmaj\r\n| ABC |\r\n" 50 | -------------------------------------------------------------------------------- /test/Utils.purs: -------------------------------------------------------------------------------- 1 | module Test.Utils where 2 | 3 | import Prelude (Unit, ($), map) 4 | import Effect.Aff (Aff) 5 | import Data.Either (Either(..)) 6 | import Data.Abc.Parser (parse) 7 | import Data.Abc (Accidental, AbcTune, Mode, ModifiedKeySignature, PitchClass) 8 | import Data.Abc.Canonical (fromTune) 9 | import Data.List (List(..)) 10 | import Data.Map (empty) 11 | 12 | import Test.Spec.Assertions (fail, shouldEqual) 13 | 14 | {- assert the moved parsed input equals the target -} 15 | assertMoveMatches :: String -> (AbcTune -> AbcTune) -> String -> Aff Unit 16 | assertMoveMatches s move target = 17 | let 18 | movedResult = 19 | map move $ parse s 20 | -- mapError (\x -> "parse error: " ++ toString x) (parse s) 21 | in 22 | case movedResult of 23 | Right res -> 24 | target `shouldEqual` (fromTune res) 25 | 26 | Left _errs -> 27 | fail "unexpected error" 28 | 29 | {- assert the value of some Int producing function on a parsed tune -} 30 | assertIntFuncMatches :: String -> (AbcTune -> Int) -> Int -> Aff Unit 31 | assertIntFuncMatches s f target = 32 | let 33 | result = 34 | map f $ parse s 35 | -- mapError (\x -> "parse error: " ++ toString x) (parse s) 36 | in 37 | case result of 38 | Right res -> 39 | target `shouldEqual` res 40 | 41 | Left _errs -> 42 | fail "unexpected error" 43 | 44 | 45 | buildKeySig :: PitchClass -> Accidental -> Mode -> ModifiedKeySignature 46 | buildKeySig pc acc mode = 47 | { keySignature: { pitchClass: pc, accidental: acc, mode: mode } 48 | , modifications: Nil 49 | , properties: empty 50 | } 51 | -------------------------------------------------------------------------------- /test/Voice.purs: -------------------------------------------------------------------------------- 1 | module Test.Voice (voiceSpec) where 2 | 3 | import Prelude 4 | 5 | import Effect.Aff (Aff) 6 | import Data.Abc (AbcTune) 7 | import Data.Abc.Canonical (fromTune) 8 | import Data.Abc.Utils (getTitle) 9 | import Data.Abc.Parser (parse) 10 | import Data.Abc.Voice (getVoiceLabels, getVoiceMap, partitionTuneBody, partitionVoices) 11 | import Data.Array.NonEmpty (index, length) 12 | import Data.Array.NonEmpty.Internal (NonEmptyArray(..)) 13 | import Data.Map (keys, size, values) 14 | import Data.Maybe (Maybe(..), fromMaybe) 15 | import Data.List (List(..)) 16 | import Data.List (fromFoldable, length) as List 17 | import Data.Either (Either(..)) 18 | import Data.Set (Set) 19 | import Data.Set (fromFoldable) as Set 20 | import Data.Unfoldable (replicate) 21 | import Test.Spec (Spec, describe, it) 22 | import Test.Spec.Assertions (fail, shouldEqual) 23 | 24 | assertVoiceCount :: String -> Int -> Aff Unit 25 | assertVoiceCount s target = 26 | case (parse s) of 27 | Right tune -> 28 | target `shouldEqual` (length (partitionTuneBody tune)) 29 | 30 | Left err -> 31 | fail ("parse failed: " <> (show err)) 32 | 33 | -- | assert that a canonical tune is equal to the partitioned tune 34 | -- | in the array of voice-partitioned tunes at the stated index 35 | assertVoice :: String -> String -> Int -> Aff Unit 36 | assertVoice s canonical ix = 37 | case (parse s) of 38 | Right tune -> 39 | let 40 | partitionedBody = partitionTuneBody tune 41 | indexedBody = fromMaybe Nil $ index partitionedBody ix 42 | indexedVoice = { headers: tune.headers, body: indexedBody } 43 | in 44 | canonical `shouldEqual` (fromTune indexedVoice) 45 | 46 | Left err -> 47 | fail ("parse failed: " <> (show err)) 48 | 49 | -- | ditto but use partitionVoices instead of partitionTuneBody 50 | assertVoice' :: String -> String -> Int -> Aff Unit 51 | assertVoice' s canonical ix = 52 | case (parse s) of 53 | Right tune -> 54 | let 55 | partitionedVoices :: NonEmptyArray AbcTune 56 | partitionedVoices = partitionVoices tune 57 | 58 | indexedVoice :: Maybe AbcTune 59 | indexedVoice = index partitionedVoices ix 60 | in 61 | (Just canonical) `shouldEqual` (map fromTune indexedVoice) 62 | 63 | Left err -> 64 | fail ("parse failed: " <> (show err)) 65 | 66 | -- assert the set of voice names found in the tune after asking for just the labels 67 | assertVoiceLabels :: String -> Array String -> Aff Unit 68 | assertVoiceLabels s target = 69 | case (parse s) of 70 | Right tune -> 71 | target `shouldEqual` (getVoiceLabels tune) 72 | 73 | Left err -> 74 | fail ("parse failed: " <> (show err)) 75 | 76 | -- ditto after asking for the entire voice map 77 | assertVoiceMapLabels :: String -> Set String -> Aff Unit 78 | assertVoiceMapLabels s target = 79 | case (parse s) of 80 | Right tune -> 81 | let 82 | voiceMap = getVoiceMap tune 83 | in 84 | target `shouldEqual` (keys voiceMap) 85 | 86 | Left err -> 87 | fail ("parse failed: " <> (show err)) 88 | 89 | -- check that the partitioned voice has a title representing the voice name 90 | -- when using getVoiceMap 91 | assertVoiceTitles :: String -> List (Maybe String) -> Aff Unit 92 | assertVoiceTitles s target = 93 | case (parse s) of 94 | Right tune -> 95 | let 96 | voiceMap = getVoiceMap tune 97 | titles = map getTitle (values voiceMap) 98 | in 99 | target `shouldEqual` titles 100 | 101 | Left err -> 102 | fail ("parse failed: " <> (show err)) 103 | 104 | -- check that the partitioned voice has a title representing the voice name 105 | -- when using partitionVoices 106 | assertPartitionedVoiceTitles :: String -> NonEmptyArray (Maybe String) -> Aff Unit 107 | assertPartitionedVoiceTitles s target = 108 | case (parse s) of 109 | Right tune -> 110 | let 111 | voices = partitionVoices tune 112 | titles = map getTitle voices 113 | in 114 | target `shouldEqual` titles 115 | 116 | Left err -> 117 | fail ("parse failed: " <> (show err)) 118 | 119 | assertRetitlingPreservesHeaders :: String -> Aff Unit 120 | assertRetitlingPreservesHeaders s = 121 | case (parse s) of 122 | Right tune -> 123 | let 124 | tuneHeaderLength = List.length (tune.headers) 125 | voiceMap = getVoiceMap tune 126 | voiceHeaderLengths = map (List.length <<< _.headers) (values voiceMap) 127 | in 128 | (replicate (size voiceMap) tuneHeaderLength) `shouldEqual` voiceHeaderLengths 129 | 130 | Left err -> 131 | fail ("parse failed: " <> (show err)) 132 | 133 | voiceSpec :: Spec Unit 134 | voiceSpec = do 135 | describe "voice" do 136 | it "handles no voices" do 137 | assertVoiceCount noVoice 1 138 | it "handles one voice" do 139 | assertVoiceCount oneVoice 1 140 | it "handles two voices" do 141 | assertVoiceCount twoVoices 2 142 | it "handles four voices" do 143 | assertVoiceCount fourVoices 4 144 | it "handles two voices inline" do 145 | assertVoiceCount twoVoicesInline 2 146 | it "handles three voices" do 147 | assertVoiceCount threeVoices 3 148 | it "finds first voice of two" do 149 | assertVoice twoVoices firstVoiceOfTwo 0 150 | it "finds first voice of two inline" do 151 | assertVoice twoVoicesInline firstVoiceOfTwoInline 0 152 | it "finds second voice of two" do 153 | assertVoice' twoVoices secondVoiceOfTwo 1 154 | it "finds second voice of two inline" do 155 | assertVoice' twoVoicesInline secondVoiceOfTwoInline 1 156 | it "finds fourth voice of four" do 157 | assertVoice' fourVoices fourthVoiceOfFour 3 158 | it "handles three voices with empty stave" do 159 | assertVoiceCount (threeVoices <> "\x0D\n") 3 160 | it "handles labels - no voice" do 161 | assertVoiceLabels noVoice [] 162 | it "finds labels - one voice" do 163 | assertVoiceLabels oneVoice [ "T1" ] 164 | it "finds labels - two voice inline" do 165 | assertVoiceLabels twoVoicesInline [ "T1", "T2" ] 166 | it "finds labels - four voices" do 167 | assertVoiceLabels fourVoices [ "1", "2", "3", "4" ] 168 | it "finds labels from voice map - four voices" do 169 | assertVoiceMapLabels fourVoices (Set.fromFoldable [ "1", "2", "3", "4" ]) 170 | it "retitles the voice header via getVoiceMap - two voices" do 171 | assertVoiceTitles twoVoicesTitled (List.fromFoldable [ Just "Two Voices - voice T1", Just "Two Voices - voice T2" ]) 172 | it "retitles the voice header via getVoiceMap - three voices" do 173 | assertVoiceTitles threeVoices (List.fromFoldable 174 | [ Just "Three Voices - voice T1" 175 | , Just "Three Voices - voice T2" 176 | , Just "Three Voices - voice T3" ]) 177 | it "retitles preserves other headers" do 178 | assertRetitlingPreservesHeaders threeVoices 179 | it "retitles the voice header via partitionVoices - two voices" do 180 | assertPartitionedVoiceTitles twoVoicesTitled 181 | (NonEmptyArray [ Just "Two Voices - voice T1", Just "Two Voices - voice T2" ]) 182 | 183 | noVoice :: String 184 | noVoice = 185 | "K: CMajor\x0D\n| AB (3zde [fg] |\x0D\n| CD EF FG |\x0D\n| AB EF FG |\x0D\n" 186 | 187 | oneVoice :: String 188 | oneVoice = 189 | "X: 1\x0D\nT: One Voice\x0D\n" <> 190 | "K: CMajor\x0D\n[V:T1]| AB (3zde [fg] |\x0D\n[V:T1]| CD EF FG |\x0D\n[V:T1]| AB EF FG |\x0D\n" 191 | 192 | twoVoicesInline :: String 193 | twoVoicesInline = 194 | "K: CMajor\x0D\n[V:T1]| AB (3zde [fg] |\x0D\n[V:T2]| CD EF FG |\x0D\n" <> 195 | "[V:T1]| AB EF FG |\x0D\n[V:T2]| AB (3zde [fg] |\x0D\n" 196 | 197 | twoVoices :: String 198 | twoVoices = 199 | "K: CMajor\x0D\nV:T1\r\n| AB (3zde [fg] |\x0D\n| AB EF FG |\x0D\nV:T2\r\n" <> 200 | "| CD EF FG |\x0D\n| AB (3zde [fg] |\x0D\n" 201 | 202 | twoVoicesTitled :: String 203 | twoVoicesTitled = 204 | "T: Two Voices\r\nK: CMajor\x0D\nV:T1\r\n| AB (3zde [fg] |\x0D\n| AB EF FG |\x0D\nV:T2\r\n" <> 205 | "| CD EF FG |\x0D\n| AB (3zde [fg] |\x0D\n" 206 | 207 | threeVoices :: String 208 | threeVoices = 209 | "X: 1\x0D\nT: Three Voices\x0D\n" 210 | <> "K: CMajor\x0D\n[V:T1]| AB (3zde [fg] |\x0D\n[V:T2]| CD EF FG |\x0D\n" 211 | <> 212 | "[V:T1]| AB EF FG |\x0D\n[V:T3]| AB (3zde [fg] |\x0D\n" 213 | 214 | -- the first voice of the twoVoices 215 | firstVoiceOfTwo :: String 216 | firstVoiceOfTwo = 217 | "K: CMajor\x0D\nV: T1\r\n| AB (3zde [fg] |\r\n| AB EF FG |\x0D\n" 218 | 219 | -- the first voice of the twoVoices (inline representation) 220 | firstVoiceOfTwoInline :: String 221 | firstVoiceOfTwoInline = 222 | "K: CMajor\x0D\n[V: T1]| AB (3zde [fg] |\x0D\n[V: T1]| AB EF FG |\x0D\n" 223 | 224 | -- the second voice of the twoVoices 225 | secondVoiceOfTwo :: String 226 | secondVoiceOfTwo = 227 | "X: 1\r\nT: voice T2\r\nK: CMajor\x0D\nV: T2\r\n| CD EF FG |\x0D\n| AB (3zde [fg] |\x0D\n" 228 | 229 | -- the second voice of the twoVoices (inline representation) 230 | secondVoiceOfTwoInline :: String 231 | secondVoiceOfTwoInline = 232 | "X: 1\r\nT: voice T2\r\nK: CMajor\x0D\n[V: T2]| CD EF FG |\x0D\n[V: T2]| AB (3zde [fg] |\x0D\n" 233 | 234 | -- Modified four Voice example (from abcnotation.com) 235 | -- added the foo=bar property for a voice header to prepare for v2.2 236 | -- we use 4/4 meter instead of C, CMajor instead of C and spaces after 237 | -- header colons to make it easier to test against the canonical form 238 | fourVoices :: String 239 | fourVoices = 240 | "X: 1\r\n" 241 | <> "T: Grand Staff With Four Voices\r\n" 242 | <> "M: 4/4\r\n" 243 | <> "L: 1/2\r\n" 244 | <> "K: CMajor\r\n" 245 | <> "V: 1 clef=treble foo=bar\r\n" 246 | <> "c/e/d/c/|c/B/B/c/|c2|]\r\n" 247 | <> "V: 2 clef=treble\r\n" 248 | <> "EF|ED|E2|]\r\n" 249 | <> "V: 3 clef=bass\r\n" 250 | <> "G,A,|G,G,|G,2|]\r\n" 251 | <> "V: 4 clef=bass\r\n" 252 | <> "C,F,|G,G,,|C,2|]\r\n" 253 | 254 | {- This is the actual example and seems awkward and uses 255 | a variety of volatile features which will be regularized 256 | to some extent in release 2.2 257 | fourVoices :: String 258 | fourVoices = 259 | "X:1\r\n" <> 260 | "T:Grand Staff With Four Voices\r\n" <> 261 | "M:C\r\n" <> 262 | "L:1/2\r\n" <> 263 | "K:\r\n" <> 264 | "%%staves {1 2 3 4}\r\n" <> 265 | "K:C\r\n" <> 266 | "V:1 [K:clef=treble]\r\n" <> 267 | "c/e/d/c/|c/B/B/c/|c2|]\r\n" <> 268 | "V:2 [K:clef=treble]\r\n" <> 269 | "EF|ED|E2|]\r\n" <> 270 | "V:3 [K:clef=bass]\r\n" <> 271 | "G,A,|G,G,|G,2|]\r\n" <> 272 | "V:4 [K:clef=bass]\r\n" <> 273 | "C,F,|G,G,,|C,2|]\r\n" 274 | -} 275 | 276 | fourthVoiceOfFour :: String 277 | fourthVoiceOfFour = 278 | "X: 1\r\n" 279 | <> "T: Grand Staff With Four Voices - voice 4\r\n" 280 | <> "M: 4/4\r\n" 281 | <> "L: 1/2\r\n" 282 | <> "K: CMajor\r\n" 283 | <> "V: 4 clef=bass\r\n" 284 | <> "C,F,|G,G,,|C,2|]\r\n" 285 | --------------------------------------------------------------------------------