AlgoRhythm (empty) → 0.1.0.0
raw patch · 44 files changed
+3665/−0 lines, 44 filesdep +AlgoRhythmdep +Euterpeadep +HCodecssetup-changed
Dependencies added: AlgoRhythm, Euterpea, HCodecs, HUnit, QuickCheck, base, bytestring, containers, data-default, derive, directory, kmeans, lilypond, midi, mtl, prettify, random, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers
Files
- AlgoRhythm.cabal +118/−0
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- app/Main.hs +237/−0
- src/Dynamics.hs +128/−0
- src/Export.hs +7/−0
- src/Export/MIDI.hs +106/−0
- src/Export/MIDIConfig.hs +23/−0
- src/Export/Score.hs +117/−0
- src/Generate.hs +15/−0
- src/Generate/Applications/ChaosPitches.hs +56/−0
- src/Generate/Applications/Diatonic.hs +340/−0
- src/Generate/Applications/GenConfig.hs +22/−0
- src/Generate/Chaos.hs +101/−0
- src/Generate/Generate.hs +179/−0
- src/Generate/QuickCheck.hs +45/−0
- src/Grammar.hs +21/−0
- src/Grammar/Harmony.hs +71/−0
- src/Grammar/Integration.hs +25/−0
- src/Grammar/Melody.hs +179/−0
- src/Grammar/Tabla.hs +89/−0
- src/Grammar/TonalHarmony.hs +58/−0
- src/Grammar/Types.hs +167/−0
- src/Grammar/UUHarmony.hs +47/−0
- src/Grammar/Utilities.hs +80/−0
- src/Grammar/VoiceLeading.hs +41/−0
- src/Music.hs +13/−0
- src/Music/Constants.hs +129/−0
- src/Music/Operators.hs +48/−0
- src/Music/Transformations.hs +153/−0
- src/Music/Types.hs +242/−0
- src/Music/Utilities.hs +36/−0
- src/Utils/Peano.hs +48/−0
- src/Utils/Vec.hs +54/−0
- test/GenSetup.hs +55/−0
- test/Spec.hs +19/−0
- test/TChaos.hs +37/−0
- test/TGenerate.hs +49/−0
- test/TGrammar.hs +33/−0
- test/TMidi.hs +182/−0
- test/TMusic.hs +129/−0
- test/TScore.hs +74/−0
- test/TVec.hs +57/−0
+ AlgoRhythm.cabal view
@@ -0,0 +1,118 @@+name: AlgoRhythm+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: Orestis Melkonian <melkon.or@gmail.com>+stability: experimental+homepage: http://github.com/omelkonian/AlgoRhythm/+bug-reports: http://github.com/omelkonian/AlgoRhythm/issues+synopsis: Algorithmic music composition+description:+ A library consisting of several mini-DSLs for representing, manipulating and+ automatically generating music.+category: Algorithmic Music Composition,+ Automatic Music Generation,+ Generative Music Grammars,+ Chaos Music+author: Orestis Melkonian, Joris ten Tusscher, Cas van der Rest+extra-source-files:+ README.md+ LICENSE++source-repository head+ type: git+ location: git://github.com/omelkonian/AlgoRhythm.git++library+ exposed-modules:+ Music+ Music.Types+ Music.Constants+ Music.Transformations+ Music.Operators+ Music.Utilities+ Export+ Export.MIDI+ Export.MIDIConfig+ Export.Score+ Generate+ Generate.Generate+ Generate.Chaos+ Generate.QuickCheck+ Generate.Applications.Diatonic+ Generate.Applications.GenConfig+ Generate.Applications.ChaosPitches+ Grammar+ Grammar.Types+ Grammar.Utilities+ Grammar.Harmony+ Grammar.UUHarmony+ Grammar.TonalHarmony+ Grammar.VoiceLeading+ Grammar.Melody+ Grammar.Integration+ Grammar.Tabla+ Utils.Vec+ Utils.Peano+ Dynamics+ build-depends:+ base >=4.7 && <5,+ midi ==0.2.*,+ template-haskell ==2.11.1.*,+ Euterpea ==2.0.*,+ HCodecs ==0.5.*,+ lilypond ==1.9.*,+ data-default ==0.7.*,+ prettify -any,+ text -any,+ QuickCheck -any,+ mtl -any,+ derive -any,+ containers -any,+ transformers -any,+ random -any,+ kmeans -any+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall++executable music-exe+ main-is: Main.hs+ build-depends:+ base >=4.7 && <5,+ AlgoRhythm -any+ default-language: Haskell2010+ hs-source-dirs: app++test-suite music-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-depends:+ base >=4.7 && <5,+ AlgoRhythm -any,+ test-framework -any,+ test-framework-hunit -any,+ test-framework-quickcheck2 -any,+ HUnit -any,+ QuickCheck -any,+ derive -any,+ directory -any,+ lilypond -any,+ bytestring -any,+ HCodecs -any,+ Euterpea -any,+ random -any,+ transformers -any+ default-language: Haskell2010+ hs-source-dirs: test+ other-modules:+ GenSetup+ TMusic+ TScore+ TMidi+ TVec+ TGrammar+ TGenerate+ TChaos
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018 Orestis Melkonian, Joris ten Tusscher, Cas van der Rest++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+1. `stack setup`+2. `stack build`+3. `stack exec music-exe` or `stack test`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE PostfixOperators #-}++module Main where++import Dynamics+import Export+import Grammar+import Music+import qualified Generate as Gen++import Control.Monad++main :: IO ()+main = do+ let ?harmonyConfig = HarmonyConfig+ { basePc = C+ , baseOct = Oct4+ , baseScale = japanese+ , chords = equally allChords+ }+ let ?midiConfig = defaultMIDIConfig+ let t = 4 * wn+ harmonicStructure <- runGrammar uuHarmony t ?harmonyConfig+ background <- voiceLead harmonicStructure++ let melodyConfig = Gen.GenConfig+ { Gen.key = C+ , Gen.baseScale = japanese+ , Gen.chords = harmonicStructure+ , Gen.phraseDistribution = [(1, Gen.High), (1, Gen.Medium), (2, Gen.Low)]+ , Gen.octaveDistribution = [(1, 3), (3, 4), (2, 5)]+ }+ foreground <- Gen.runGenerator () (Gen.diatonicMelody melodyConfig)++ playDev 4 $ 2 ## dyn (toMusicCore background :=: toMusicCore foreground)++-- | Chaos blues. Generates a short music composition using the Chaos function+-- represented in Figure 1 of Chaos Melody Theory by Elaine Walker+-- (http://www.ziaspace.com/elaine/chaos/ChaosMelodyTheory.pdf)+chaosBlues :: Bool -> IO ()+chaosBlues addDyn = do+ m <- Gen.genChaosMusic+ let m' = if addDyn then dyn m else toMusicCore m+ let ?midiConfig = defaultMIDIConfig+ writeToMidiFile "out.midi" m'+ playDev 0 m'++simpleMelody :: IO ()+simpleMelody = do+ m <- Gen.runGenerator () $ replicateM 4 Gen.melodyInC+ let ?midiConfig = MIDIConfig (4%4) [AcousticGrandPiano]+ writeToMidiFile "simpleMelody.midi" (line m)++randomMelody :: IO ()+randomMelody = do+ m <- Gen.runGenerator () Gen.randomMelody+ let ?midiConfig = MIDIConfig (4%4) [AcousticGrandPiano]+ writeToMidiFile "random.midi" m++-- Jazz example using the primitive generation DSL.+jazz :: IO ()+jazz = do+ let ?midiConfig = MIDIConfig (4%4) [AltoSax, AcousticGrandPiano]+ let t = 12 * wn++ -- Harmony.+ let ?harmonyConfig = HarmonyConfig+ { basePc = D+ , baseOct = Oct4+ , baseScale = dorian+ , chords = equally [maj, mi, maj7, m7, dim, d7, m7b5]+ }+ harmonicStructure <- runGrammar uuHarmony t ?harmonyConfig+ background <- voiceLead harmonicStructure++ let melodyConfig = Gen.GenConfig+ { Gen.key = D+ , Gen.baseScale = dorian+ , Gen.chords = harmonicStructure+ , Gen.phraseDistribution = [(4, Gen.High), (7, Gen.Medium), (2, Gen.Low)]+ , Gen.octaveDistribution = [(2, 3), (7, 4), (4, 5)]+ }+ foreground <- Gen.runGenerator () (Gen.diatonicMelody melodyConfig)++ writeToMidiFile "jazz1.midi" (foreground :=: toMusicCore background)++-- A piece with fast banjo playing.+fastBanjo :: IO ()+fastBanjo = do+ let ?midiConfig = MIDIConfig (6%4) [Banjo, ElectricGuitarMuted]+ let t = 32 * wn++ -- Harmony.+ let ?harmonyConfig = HarmonyConfig+ { basePc = C+ , baseOct = Oct4+ , baseScale = ionian+ , chords = equally [maj, mi, dim]+ }+ harmonicStructure <- runGrammar uuHarmony t ?harmonyConfig+ background <- voiceLead harmonicStructure++ let melodyConfig = Gen.GenConfig+ { Gen.key = C+ , Gen.baseScale = ionian+ , Gen.chords = harmonicStructure+ , Gen.phraseDistribution = [(1, Gen.High), (0, Gen.Medium), (0, Gen.Low)]+ , Gen.octaveDistribution = [(3, 3), (5, 4), (2, 5)]+ }+ foreground <- Gen.runGenerator () (Gen.diatonicMelody melodyConfig)++ writeToMidiFile "out.midi" (((Rest $ 4 * wn) :+: foreground) :=: toMusicCore background)++rockOrganBlues :: IO ()+rockOrganBlues = do+ let ?midiConfig = MIDIConfig (6%4) [RockOrgan, AcousticGrandPiano]+ let ?harmonyConfig = HarmonyConfig+ { basePc = C+ , baseOct = Oct4+ , baseScale = ionian+ , chords = equally [maj, mi, dim]+ }+ let harmonicStructure = foldr1 (:+:) $+ map (Note hn . (=| d7))+ [E, E, E, E, E, E, E, E, A, A, A, A, E, E, E, E, B, B, A, A, E, E, B, B]+ let background = flip (<#) 3 <$> harmonicStructure+ let melodyConfig = Gen.GenConfig+ { Gen.key = E+ , Gen.baseScale = blues+ , Gen.chords = 2##harmonicStructure+ , Gen.phraseDistribution = [(5, Gen.High), (5, Gen.Medium), (1, Gen.Low)]+ , Gen.octaveDistribution = [(3, 3), (5, 4), (2, 5)]+ }+ foreground <- Gen.runGenerator () (Gen.diatonicMelody melodyConfig)+ foreground' <- Gen.runGenerator () (Gen.diatonicMelody melodyConfig)+ writeToMidiFile "out.midi" ((foreground :+: foreground') :=: toMusicCore (4##background))++-- Hypnotic passage.+hypnotic :: Melody+hypnotic = 2%5 *~ cascades :+: (cascades ><)+ where+ cascades = rep id (%> sn) 2 cascade+ cascade = rep (~> M3) (%> en) 5 run+ run = rep (~> P4) (%> tn) 5 (D#3 <| tn)+ rep :: (Melody -> Melody) -> (Melody -> Melody) -> Int -> Melody -> Melody+ rep _ _ 0 _ = (0~~)+ rep f g n m = m :=: g (rep f g (n - 1) (f m))++writeHypnotic :: IO ()+writeHypnotic = writeToMidiFile "hypnotic.mid" hypnotic+ where ?midiConfig = MIDIConfig 1 [RhodesPiano]++-- Byzantine dance for Harpsichord.+byzantineDance :: IO ()+byzantineDance = do+ let ?harmonyConfig = HarmonyConfig+ { basePc = Fs+ , baseOct = Oct4+ , baseScale = byzantine+ , chords = equally allChords+ }+ let ?melodyConfig = defMelodyConfig+ { scales = equally allScales+ , octaves = [(1, Oct3), (20, Oct4), (15, Oct5), (1, Oct6)]+ }+ let ?midiConfig = MIDIConfig (7%4) [Harpsichord]+ (back, fore) <- integrate (8 * wn)++ writeToMidiFile "byzantine-h.mid" back+ writeToMidiFile "byzantine-m.mid" fore+ playDev 4 $ back :=: fore++-- Sonata in E Minor.+sonata :: IO ()+sonata = do+ let ?harmonyConfig = HarmonyConfig+ { basePc = E+ , baseOct = Oct4+ , baseScale = minor+ , chords = equally [mi, maj, dim]+ }+ let ?melodyConfig = defMelodyConfig+ { scales = equally [ionian, harmonicMinor]+ , octaves = [(5, Oct4), (20, Oct5), (10, Oct6)]+ }+ let ?midiConfig = MIDIConfig (7%10) [AcousticGrandPiano, Flute]+ (back, fore) <- integrate (12 * wn)++ writeToMidiFile "sonata-h.mid" back+ writeToMidiFile "sonata-m.mid" fore+ playDev 4 $ back :=: fore++-- Romanian Elegy for Piano & Cello.+romanianElegy :: IO ()+romanianElegy = do+ let ?harmonyConfig = HarmonyConfig+ { basePc = C+ , baseOct = Oct4+ , baseScale = romanian+ , chords = equally [mi, maj, aug, dim, m7, m7b5]+ }+ let ?melodyConfig = defMelodyConfig+ { scales = equally allScales+ , octaves = [(20, Oct3), (15, Oct4), (10, Oct5)]+ }+ let ?midiConfig = MIDIConfig 1 [Harpsichord]+ (back, fore) <- integrate (12 * wn)++ writeToMidiFile "romanian-h.mid" back+ writeToMidiFile "romanian-m.mid" fore+ playDev 4 $ back :=: fore++-- Oriental Algebras for Metalophone, Sitar & Tablas.+orientalAlgebras :: IO ()+orientalAlgebras = do+ let ?harmonyConfig = HarmonyConfig+ { basePc = A+ , baseOct = Oct3+ , baseScale = arabian+ , chords = equally allChords+ }+ let ?melodyConfig = defMelodyConfig+ { scales = equally allScales+ , octaves = [(20, Oct4), (15, Oct5), (5, Oct6)]+ , colorWeight = 0+ , approachWeight = 10+ }+ let ?midiConfig = MIDIConfig (6%5) [Harpsichord , Sitar]+ (back, fore) <- integrate (12 * wn)+ let ?tablaBeat = en+ rhythm <- dyn <$> runGrammar tabla (12 * wn) ()++ writeToMidiFile "oriental-h.mid" back+ writeToMidiFile "oriental-m.mid" fore+ writeToMidiFile "oriental-r.mid" rhythm+ playDev 4 $ back :=: fore
+ src/Dynamics.hs view
@@ -0,0 +1,128 @@+module Dynamics ( addDynamics+ , dyn+ , sinTimeDynamics+ , sinPitchDynamics+ , expPitchDynamics+ , DynamicsMap) where++import Data.KMeans (kmeansGen)+import Data.List (find)+import Data.Maybe (fromJust)+import Music++type AbsStartTime = Rational+type PitchIntValue = Int+type ClusterMusicA = (FullPitch, (AbsStartTime, PitchIntValue))+type MusicCluster = Music ClusterMusicA+type Cluster = [ClusterMusicA]++-- | Gets the time of the note within its cluster as a Double in the range+-- [0,1] (where 0 represents that the note is at the start of the cluster,+-- and 1 that it's at the end of the cluster) and the pitch of the note+-- within the cluster (where 0 represents the lowest note in the cluster and+-- 1 the highest note in the cluster) and returns another Double in the range+-- [0,1] that represents how loud the note should be played, where 0 is as+-- soft as possible (but not silent!) and 1 is as loud as possible.+type DynamicsMap = Double -- ^ Time location of note in cluster, in range [0,1].+ -> Double -- ^ Pitch location in cluster, in range [0,1].+ -> Double -- ^ Volume of the note, in range [0,1].++-- | Returns a dynamic between 25% and 75% volume, based on one full sine+-- oscillation+sinTimeDynamics :: DynamicsMap+sinTimeDynamics x _ = 0.25 + (0.25 * sin (2 * pi * x))++-- | Returns a dynamic between 0% and 100% volume, based on one full sine+-- oscillation. Note that this sounds ridiculous+sinPitchDynamics :: DynamicsMap+sinPitchDynamics x _ = 0.25 + (0.25 * sin (2 * pi * x))++-- | Returns a dynamic between 0% and 100% volume, based on the exponential+-- quantile function and the relative pitch height of the note in the cluster.+expPitchDynamics :: DynamicsMap+expPitchDynamics _ y = max 0.45 (min 0.8 (-log (1 - y)))++-- | Adds `Dynamic` to all notes in the given `Music` using `expPitchDynamics`.+dyn :: (ToMusicCore a) => Music a -> MusicCore+dyn m = addDynamics m expPitchDynamics++-- | Adds `Dynamic` to all notes in the given `Music` using the given `DynamicsMap`+addDynamics :: (ToMusicCore a) => Music a -> DynamicsMap -> MusicCore+addDynamics m' dynMap = do+ let m = toMusicCore m'+ let mCluster = coreToCluster m+ let clusters = cluster mCluster+ -- Generate dynamics for notes per cluster, and then concatenate the clusters.+ let dynamics = concatMap (addDynamicsToCluster dynMap) clusters+ addDynamicsToMCore mCluster dynamics++addDynamicsToMCore :: MusicCluster -> Cluster -> MusicCore+addDynamicsToMCore m c =+ fmap add m+ where add (_,info) =+ -- Find the element in c with matching absolute start time and pitch int value,+ -- and get the FullPitch (that contains the dynamic) from that element and put+ -- it in the note.+ fst $ fromJust $ find ((info==) . snd) c++bounds :: [ClusterMusicA] -> ((Double, Double),(Double, Double))+bounds m = ( (fromRational (minimum (map (fst . snd) m)), fromIntegral (minimum (map (snd . snd) m)))+ , (fromRational (maximum (map (fst . snd) m)), fromIntegral (maximum (map (snd . snd) m)))+ )++addDynamicsToCluster :: DynamicsMap -> Cluster -> Cluster+addDynamicsToCluster _ [] = []+addDynamicsToCluster f c = do+ let ((minTime,minNote),(maxTime,maxNote)) = bounds c+ -- Returns a value in [0,1] that indicates how far the Note is in the cluster.+ let tProg t = ((fromRational t) - minTime) / (maxTime - minTime)+ -- Returns a value in [0,1] that indicates how high the Note is in the cluster.+ let pProg n = ((fromIntegral n) - minNote) / (maxNote - minNote)+ let pToDyn ((p',attrs),(t,p)) = do+ let dynDouble = f (tProg t) (pProg p)+ if dynDouble < 0 || dynDouble > 1 then+ error "Result from DynamicsMap is not in range [0,1]."+ else do+ let maxDynNum = fromIntegral (fromEnum (maxBound :: Dynamic)) :: Double+ let dynNum = round (maxDynNum * dynDouble)+ let d = Dynamic (toEnum dynNum :: Dynamic)+ ((p',d:attrs),(t,p))+ map pToDyn c++-- | Clusters a MusicCluster. The number of clusters is equal to half+cluster :: MusicCluster -> [Cluster]+cluster m = kmeansGen gen k (notes m)+ where gen :: ClusterMusicA -> [Double]+ gen (_,(x,y)) = [fromRational x, fromIntegral y]+ -- The number of clusters is equal to the duration of the music divided+ -- by 4 (we assume that 4 beats go into a measure.)+ k = max 1 (round ((fromRational (duration m) :: Double) / 4))++-- | Assings 2d coordinates to all music Notes (not Rests), where the x is the+-- absolute start time of the Note and the y is the Pitch of the Note+-- represented as a number (in other words, a very abstract representation of+-- the notes on actual sheet music). Also removes PitchAttributes, because+-- they aren't needed here.+coreToCluster :: MusicCore -> MusicCluster+coreToCluster = calcClusterInfo . fmap (\p -> (p,(0,0)) )++-- | Adds absolute times to Notes.+calcClusterInfo :: MusicCluster -> MusicCluster+calcClusterInfo (m1@(Rest l) :+: m2) = m1 :+: fmap (addTime l) (calcClusterInfo m2)+calcClusterInfo (m1@(Note l _) :+: m2) = calcClusterInfo m1 :+: fmap (addTime l) (calcClusterInfo m2)+calcClusterInfo (m1 :=: m2) = calcClusterInfo m1 :=: calcClusterInfo m2+calcClusterInfo (m1 :+: m2) =+ calcClusterInfo m1 :+: fmap (addTime (duration m1)) (calcClusterInfo m2)+calcClusterInfo r@(Rest _) = r+calcClusterInfo (Note l (p,(x,_))) = Note l (p,(x, fromEnum p))++-- | Calculates the duration of a piece of Music.+duration :: Music a -> Duration+duration (m1 :+: m2) = (+) (duration m1) (duration m2)+duration (m1 :=: m2) = max (duration m1) (duration m2)+duration (Note l _) = l+duration (Rest l) = l++-- | Adds an amount of time to the AbsStartTime field of a ClusterMusicA Note.+addTime :: Duration -> ClusterMusicA -> ClusterMusicA+addTime t (p,(x,y)) = (p,(x+t,y))
+ src/Export.hs view
@@ -0,0 +1,7 @@+module Export+ ( module Export.MIDI+ , module Export.Score+ ) where++import Export.MIDI+import Export.Score
+ src/Export/MIDI.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE ImplicitParams #-}+-- | Can be used to export `Music` to a Midi file, or to play it in real time.+module Export.MIDI (+ module Export.MIDIConfig+ , writeToMidiFile+ , play+ , playDev+ , musicToE+) where++import Codec.Midi+import Control.Arrow ((>>>))+import Data.Ratio ((%))+import Export.MIDIConfig+import qualified Euterpea as E+import Music++-- | Write `Music` to MIDI file.+writeToMidiFile :: (ToMusicCore a, ?midiConfig :: MIDIConfig)+ => FilePath -> Music a -> IO ()+writeToMidiFile path = toMusicCore >>> musicToMidi >>> E.exportMidiFile path++-- | Plays `Music` to the given MIDI output device (using Euterpea under the+-- hood).+playDev :: (ToMusicCore a, ?midiConfig :: MIDIConfig)+ => Int -> Music a -> IO ()+playDev devId = toMusicCore >>> musicToE >>> E.playDev devId++-- | Plays `Music` to the standard MIDI output device.+play :: (ToMusicCore a, ?midiConfig :: MIDIConfig)+ => Music a -> IO ()+play = toMusicCore >>> musicToE >>> E.play++-- | Converts `MusicCore` to `Codec.Midi.Midi`. Note that this is done using+-- Euterpea's `toMidi` function, which does not return a Euterpea defined+-- Midi type, but rather a Midi type from the `HCodecs` library.+musicToMidi :: (?midiConfig :: MIDIConfig) => MusicCore -> Midi+musicToMidi m = E.toMidi $ E.perform $ musicToE m++-- | Converts `MusicCore` to Euterpea `E.Music1` using a `MIDIConfig`.+musicToE :: (?midiConfig :: MIDIConfig) => MusicCore -> E.Music1+musicToE ms =+ E.chord1 [ foldr E.Modify (musicToE' m) modifiers+ | (inst, m) <- zip (cycle $ instruments ?midiConfig) (voices ms)+ , let modifiers = [E.Tempo $ tempo ?midiConfig, E.Instrument inst]+ ]++-- | Converts `MusicCore` to Euterpea Music1+musicToE' :: MusicCore -> E.Music1+musicToE' (m :+: m') = musicToE' m E.:+: musicToE' m'+musicToE' (m :=: m') = musicToE' m E.:=: musicToE' m'+musicToE' (Rest dur) = E.rest dur+musicToE' (Note dur (p, attrs)) = noteToE dur (p, attrs)++-- | Converts MusicCore Note to a Euterpea Music1 Note.+noteToE :: Duration -> FullPitch -> E.Music1+noteToE dur (p, attrs) = do+ -- Initially create a note with pitch and duration, but no extra attributes.+ let noteE = E.note dur (pitchToE p, [])+ -- Add the attributes one by one.+ foldr (flip addAttrToE) noteE attrs++-- | Converts `Pitch` to a Euterpea Pitch.+pitchToE :: Pitch -> E.Pitch+pitchToE (pc, oct) = (pitchClassToE pc, fromEnum oct)++-- | Converts `PitchClass` to a Euterpea PitchClass.+pitchClassToE :: PitchClass -> E.PitchClass+pitchClassToE p = case p of+ C -> E.C+ Cs -> E.Cs+ D -> E.D+ Ds -> E.Ds+ E -> E.E+ F -> E.F+ Fs -> E.Fs+ G -> E.G+ Gs -> E.Gs+ A -> E.A+ As -> E.As+ B -> E.B++addAttrToE :: E.Music1 -> PitchAttribute -> E.Music1+addAttrToE n a = E.Modify (E.Phrase [attrToE a]) n++-- | Converts a PitchAttribute to its Euterpea representation.+attrToE :: PitchAttribute -> E.PhraseAttribute+attrToE (Dynamic d) = E.Dyn $ dynamicsToE d+attrToE (Articulation a) = E.Art $ articulationToE a++-- | Converts Dynamics to Euterpea Dynamic.+dynamicsToE :: Dynamic -> E.Dynamic+dynamicsToE d = E.StdLoudness dE+ where -- There are 11 Dynamics in the Music DSL and only 9 in the Euterpea+ -- DSL. Hence the code below. The magic 8 represents the maximum+ -- fromEnum value one can get from an E.Dynamic value. However, Euterpea+ -- has not derived Bounded for E.Dynamic, so maxBound::E.Dynamic+ -- couldn't be used here.+ dE = toEnum (min 8 (max 0 ((fromEnum d) - 1)))++-- | Converts Articulation to Euterpea Articulation.+articulationToE :: Articulation -> E.Articulation+articulationToE Staccato = E.Staccato (1%4)+articulationToE Staccatissimo = E.Staccato (1%8)+articulationToE Marcato = E.Marcato+articulationToE Tenuto = E.Tenuto
+ src/Export/MIDIConfig.hs view
@@ -0,0 +1,23 @@+-- | Can be used by `Export.MIDI` to specify instruments, tempo and other+-- global music configurations in the exported MIDI file.+module Export.MIDIConfig (+ E.InstrumentName (..)+ , MIDIConfig (..)+ , defaultMIDIConfig+) where++import qualified Euterpea as E++-- | The tempo of the music (1 would be a standard tempo.)+type Tempo = Rational+-- | Stores metadata that will be added to the Midi file on export.+data MIDIConfig = MIDIConfig { tempo :: Tempo+ , instruments :: [E.InstrumentName]+ }++-- | Standard `MIDIConfig` with a `Tempo` of 1 and an `AcousticGrandPiano` as+-- instrument.+defaultMIDIConfig :: MIDIConfig+defaultMIDIConfig = MIDIConfig { tempo = 1+ , instruments = [E.AcousticGrandPiano]+ }
+ src/Export/Score.hs view
@@ -0,0 +1,117 @@+module Export.Score (writeToLilypondFile, splitDurations, musicToLilypond) where++import Control.Arrow ((>>>))+import Data.Maybe+import qualified Data.Music.Lilypond as Ly+import qualified Data.Music.Lilypond.Dynamics as LyD+import Music+import Text.Pretty+import Data.Text (replace, pack, unpack)+import Data.Ratio++-- | Write 'Music' to Lilypond file.+writeToLilypondFile :: (ToMusicCore a) => FilePath -> Music a -> IO ()+writeToLilypondFile path = musicToLilypondString >>> writeFile path+ where musicToLilypondString =+ toMusicCore >>> musicToLilypond >>> pretty >>> runPrinter >>> cleanup+ cleanup =+ unpack . replace (pack "|") (pack "\\staccatissimo") . pack+++-- | Convert `MusicCore` to `Data.Music.Lilypond.Music`.+musicToLilypond :: MusicCore -> Ly.Music+musicToLilypond (m :+: m') =+ Ly.sequential (musicToLilypond m) (musicToLilypond m')+musicToLilypond (m :=: m') =+ Ly.simultaneous (musicToLilypond m) (musicToLilypond m')+musicToLilypond (Note d m) = tiedNoteSequence (splitDurations d) m+musicToLilypond (Rest d) = Ly.Rest (Just $ toDuration d) []++tiedNoteSequence :: [Duration] -> FullPitch -> Ly.Music+tiedNoteSequence ds m = Ly.Sequential $ map (toNote [Ly.Tie]) (init ds) ++ [toNote [] (last ds)]+ where toNote pm d = Ly.Note (Ly.NotePitch (toLilypondPitch m) Nothing)+ (Just $ toDuration d) (pm ++ getPostModifiers m)++-- | Splits a duration into powers of two+splitDurations :: Duration -> [Duration]+splitDurations d =+ case isPowerOf2 d of+ True -> [d]+ False -> splitDurations (d - 1%denominator d) ++ [(1%denominator d)]++-- | Convert a 'FullPitch' to it's corresponding+-- 'Data.Music.Lilypond.Pitch'+toLilypondPitch :: FullPitch -> Ly.Pitch+toLilypondPitch ((p, oc), _) =+ Ly.Pitch { Ly.getPitch = (toName p, getAccidental p, fromEnum $ oc + 1) }++-- | Convert a 'Rational' to it's corresponding+-- 'Data.Music.Lilypond.Duration'+toDuration :: Rational -> Ly.Duration+toDuration ratio = Ly.Duration { Ly.getDuration = ratio }++-- | Convert the 'PitchAttribute' list of a 'FullPitch' to+-- list of 'Data.Music.Lilypond.PostEvent' representing+-- the same dynamics and articulation+getPostModifiers :: FullPitch -> [Ly.PostEvent]+getPostModifiers (_, xs) = map attrToPost xs++-- | Convert 'PitchClass' it's corresponding 'Data.Music.Lilypond.PitchName'+toName :: PitchClass -> Ly.PitchName+toName pc = findMatch pc nameMap+ where nameMap =+ [ ([C, Cs], Ly.C)+ , ([D, Ds], Ly.D)+ , ([E], Ly.E)+ , ([F, Fs], Ly.F)+ , ([G, Gs], Ly.G)+ , ([A, As], Ly.A)+ , ([B], Ly.B)+ ]++-- | Get the 'Data.Music.Lilypond.Accidental' for a 'PitchClass'+getAccidental :: PitchClass -> Ly.Accidental+getAccidental pc = findMatch pc accMap+ where accMap =+ [ ([C, D, E, F, G, A, B], 0)+ , ([Cs, Ds, Fs, Gs, As], 1)+ ]++-- | Convert a 'PitchAttribute' to it's corresponding+-- 'Data.Music.Lilypond.PostEvent'+attrToPost :: PitchAttribute -> Ly.PostEvent+attrToPost (Dynamic d) = Ly.Dynamics Ly.Default (toLilyPondDynamics d)+attrToPost (Articulation a) = Ly.Articulation Ly.Default (toLilyPondArticulation a)++toLilyPondArticulation :: Articulation -> Ly.Articulation+toLilyPondArticulation a = fromJust $ lookup a m+ where m = [+ (Staccato, Ly.Staccato),+ (Staccatissimo, Ly.Staccatissimo),+ (Marcato, Ly.Marcato),+ (Tenuto, Ly.Tenuto)+ ]++toLilyPondDynamics :: Dynamic -> LyD.Dynamics+toLilyPondDynamics d = fromJust $ lookup d m+ where m = [+ (PPPPP, LyD.PPPPP),+ (PPPP, LyD.PPPP),+ (PPP, LyD.PPP),+ (PP, LyD.PP),+ (P, LyD.P),+ (MP, LyD.MP),+ (MF, LyD.MF),+ (F_, LyD.F),+ (FF, LyD.FF),+ (FFF, LyD.FFF),+ (FFFF, LyD.FFFF)+ ]++-- | Find a match in a structure which maps list of keys to elements+findMatch :: Eq a => a -> [([a], b)] -> b+findMatch el = snd . head . filter (elem el. fst)++-- | Checks if a note is 2 to some power+isPowerOf2 :: Duration -> Bool+isPowerOf2 x = elem x [1%1,1%2,1%4,1%8,1%16,1%32]
+ src/Generate.hs view
@@ -0,0 +1,15 @@+module Generate+ ( module Generate.Generate,+ module Generate.QuickCheck,+ module Generate.Chaos,+ module Generate.Applications.Diatonic,+ module Generate.Applications.GenConfig,+ module Generate.Applications.ChaosPitches+ ) where++import Generate.Generate+import Generate.QuickCheck+import Generate.Chaos+import Generate.Applications.Diatonic+import Generate.Applications.GenConfig+import Generate.Applications.ChaosPitches
+ src/Generate/Applications/ChaosPitches.hs view
@@ -0,0 +1,56 @@+{-# language GADTs #-}++-- | An example implementation of a `Generate.Chaos` that generates music with+-- chaotic octave and pitch selection.+module Generate.Applications.ChaosPitches (+ genChaosMusic+ , chaos1+ , bSolo+ , chaos1Selector) where++import Music+import Utils.Vec+import Generate.Generate+import Control.Monad.State hiding (state)+import Generate.Chaos++-- | Generates `Music` with chaos function f x = 1 - 1.9521 * x^2 in range [-1,1]+-- with initial x = 1.2.+genChaosMusic :: IO (Music Pitch)+genChaosMusic = do+ let mapping = defaultMapping {pcSel=chaos1Selector, octSel=chaos1Selector }+ runChaosGenerator chaos1 mapping bSolo++-- | ChaosState with chaos function f x = 1 - 1.9521 * x^2 in range [-1,1]+-- with initial x = 1.2.+chaos1 :: ChaosState D1+chaos1 = do+ let startX = 1.2+ buildChaos (startX :. Nil) (f :. Nil)+ where f :: (Vec D1 Double -> Double)+ f (x:.Nil) = max (-1) (min 1 (1 - 1.9521 * x**2))++-- | `MusicGenerator` that uses `chaos1` to generate some blues music.+bSolo :: MusicGenerator (ChaosState D1) Melody+bSolo = do+ addConstraint pitchClass (`elem` (E +| blues :: [PitchClass]))+ run1 <- local $ do+ octave >! (`elem` [4,5])+ duration >! (`elem` [1%32, 1%16])+ line <$> 12 .#. genNote+ run2 <- local $ do+ octave >! (`elem` [2,3,4])+ duration >! (`elem` [1%8, 1%16])+ pitchClass >! (`elem` [E, Fs, Gs, B, Cs])+ line <$> 6 .#. genNote+ return $ run1 :=: run2++-- | The selector that maps the chaos function from `chaos1` to an element in a.+chaos1Selector :: Selector (ChaosState n) a+chaos1Selector s as = do+ ([d], s') <- runStateT genNextIteration s+ let dNormalised = (d+1) / 2+ let maxI = fromIntegral (length as - 1)+ let index = round (dNormalised * maxI)+ let a = as !! index+ return (snd a, s')
+ src/Generate/Applications/Diatonic.hs view
@@ -0,0 +1,340 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PostfixOperators #-}++module Generate.Applications.Diatonic where++ import Generate.Generate+ import Generate.QuickCheck+ import Music+ import Data.List+ import Data.Maybe+ import qualified Control.Arrow as Arrow+ import Control.Monad+ import Control.Monad.State+ import Grammar.Utilities+ import Test.QuickCheck+ import Generate.Applications.GenConfig+++ -- | Sample weights for note durations during a cerain density+ densityToDurations :: Density -> [(Weight, Duration)]+ -- High density phrases+ densityToDurations High =+ [ (0.05, 1%32)+ , (0.15, 1%16)+ , (0.55, 1%8)+ , (0.30, 1%4)+ , (0.05, 1%2)+ ]+ -- Medium density phrases+ densityToDurations Medium =+ [ (0.02, 1%16)+ , (0.05, 1%8)+ , (0.55, 1%4)+ , (0.30, 1%2)+ , (0.05, 1%1)+ ]+ -- Low density phrases+ densityToDurations Low =+ [ (0.10, 1%8)+ , (0.40, 1%4)+ , (0.40, 1%2)+ , (0.10, 1%1)+ ]++ -- | Weights table containing the relative 'importance' of all+ -- possible intervals+ relativeWeights :: [(Weight, Interval)]+ relativeWeights = [ (10.0, P1)+ , (0.50, Mi2)+ , (2.50, M2)+ , (8.00, Mi3)+ , (8.00, M3)+ , (5.00, P4)+ , (1.00, A4)+ , (9.00, P5)+ , (1.00, Mi6)+ , (4.00, M6)+ , (4.00, Mi7)+ , (4.00, M7)+ , (10.0, P8)+ , (1.00, Mi9)+ , (2.50, M9)+ , (8.00, A9)+ , (8.00, M10)+ , (5.00, P11)+ , (1.00, A11)+ , (9.00, P12)+ , (1.00, Mi13)+ , (4.00, M13)+ , (4.00, Mi14)+ , (4.00, M14)+ , (10.0, P15)+ ]++ -- | Get the relative note 'importance' from a certain scale using+ -- the global weights table+ intervalWeights :: PitchClass -> [Interval]+ -> [(Weight, PitchClass)]+ intervalWeights key scale =+ map (\(a, b) -> (a, key =| b)) $+ filter (\(a, b) -> b `elem` scale) relativeWeights++ -- Convert a SemiChord to a list representing the relative+ -- importance of each note in the key the chord is played in.+ semiChordWeights :: PitchClass -> SemiChord+ -> [(Weight, PitchClass)]+ semiChordWeights key chord =+ map (+ (\(a, b) -> (a, key =| b)) .+ (\pc ->+ relativeWeights!!(+ ((12 ++ -- Find relative weights in the given key+ -- for the pitchclasses in the provided chord+ ((fromEnum ([C .. B]!!(fromEnum pc))) -+ (fromEnum ([C .. B]!!(fromEnum key)))))+ `mod` 12)+ )+ )) chord++ -- Merge two weight lists by taking the union, and adding the weights+ -- for all elements that are common to both lists.+ mergeWeights :: (Eq a) => [(Weight, a)] -> [(Weight, a)] -> [(Weight, a)]+ mergeWeights xs ys =+ let xs' = normalize xs+ in let ys' = normalize ys+ in normalize $+ -- xs / ys+ (filter+ ((not . (flip elem) (stripList ys)) . snd) xs'+ ) +++ -- ys / xs+ (filter+ ((not . (flip elem) (stripList xs)) . snd) ys'+ ) +++ -- ys /\ ys, with weights summed+ zipWith (\(x1, x2) (y1, _) -> ((x1 + y1) / 2, x2))+ (filter ((flip elem) intersection . snd) xs')+ (filter ((flip elem) intersection . snd) ys')+ where -- Normalize a distribution such that all weights sum to 1+ normalize xs =+ let k = (sum . map fst) xs+ in map (\(x, v) -> (x / k, v)) xs+ -- Calculate the set of intersecting elements.+ intersection = intersect (stripList xs) (stripList ys)++ -- | Constraint that requires all generated notes to be in a certain scale+ inScale :: PitchClass -> [Interval]+ -> Constraint PitchClass+ inScale key scale = (flip elem) (key +| scale :: [PitchClass])++ -- | Note selector that generates a distribution based on the last+ -- note that was generated+ beamSelector :: (Eq a, Enum a) => Double+ -> Accessor st s a+ -> Selector a a+ beamSelector k _ s xs = do+ (el, _) <- quickCheckSelector s (getDistributions s k xs)+ return (el, el)++ -- Retrieve weights relative to a certain value for all possible+ -- values of a certain aspect+ getDistributions :: (Eq a, Enum a) => a+ -> Double+ -> [(Weight, a)]+ -> [(Weight, a)]+ getDistributions el k xs =+ case idx of+ -- Check if the given element is in fact+ -- an element of the given list+ (Just _) -> (map (\(w, v) -> (getWeight v w, v)) xs)+ (Nothing) -> xs+ where idx = (elemIndex el (stripList xs))+ -- A the weight for an element is related to the distance+ -- between that element and the previously generated element+ -- by a negative exponential distribution+ getWeight el' ow | el == el' = ow * 0.5+ getWeight el' ow | otherwise =+ ow * k^^(0 - abs((fromJust idx) -+ (fromJust (elemIndex el' (stripList xs )))))+ -- TODO include trends in distribution++ -- Strip a weighted list to it's elements+ stripList :: [(Weight, a)] -> [a]+ stripList = map snd++ -- Generate a sequence of values for a certain aspect using the+ -- 'beamed selector'.+ -- n denotes the number of values to be generated, options denotes the list+ -- of options from which the beamed selector should choose, and k is the width+ -- of the beam, where the probability distribution is roughly denoted by+ -- (k^distance between center of beam and value)+ genAspect :: (Eq a, Enum a) => Accessor GenState a a+ -> a+ -> Int+ -> Double+ -> [(Weight, a)]+ -> MusicGenerator () [a]+ genAspect accessor initial n k options = do+ lift $ runGenerator initial $+ do accessor >+ options+ accessor >? (beamSelector k accessor)+ replicateM n (accessor??)++ -- | Generate a diatonic phrase. Strictly speaking, the generated+ -- melodies don't have to be diatonic, as any possible scale can be+ -- given to function as the generator's basis+ diatonicPhrase :: Duration -> Density+ -> PitchClass+ -> [Interval]+ -> SemiChord+ -> [(Int, Octave)]+ -> MusicGenerator () MusicCore+ diatonicPhrase dur density key scale chord octD = do+ durations <- boundedRhythm dur density+ octaves <- genAspect octave 4+ (length durations) 2.0+ (map (Arrow.first fromIntegral) octD)++ pitches <- genAspect pitchClass key+ (length durations) 1.3+ (mergeWeights+ (intervalWeights key scale)+ (semiChordWeights key chord))+ let fullPitches = ((flip (<:) $ []) <$> (zipWith (#) pitches octaves))+ return $ line+ (zipWith (<|) fullPitches durations)++ -- | Generate a diatonic melody over a given chord progression. This is done by+ -- generating separate phrases that are linked together with a rest in+ -- between. The phraseses are aware of the chord they are over, so that they+ -- will use notes from the current chord with a higher probability.+ diatonicMelody :: GenConfig -> MusicGenerator () MusicCore+ diatonicMelody config =+ let timeline = chordalTimeline (chords config)+ in f timeline 0+ where f [] pos = return $ Rest 0+ f tl pos =+ do density <- lift (fromDistribution (phraseDistribution config))+ len <- lift $ phraseLength density+ pause <- lift pauseLength+ phrase <- diatonicPhrase+ len density+ (key config)+ (baseScale config)+ (fst $ head tl)+ (octaveDistribution config)+ r <- f (remainder tl (pos + len + pause)) (pos + len + pause)+ return $ phrase :+: (Rest pause) :+: r+ where remainder [] _ = []+ remainder [x] _ = []+ remainder (x:y:xs) p | p < snd y = (y:xs)+ | otherwise = remainder (y:xs) p++ melodyInC :: MusicGenerator () MusicCore+ melodyInC = do+ pitchClass >! (inScale C major)+ options <- (pitchClass?+)+ rhythm <- boundedRhythm (1 * wn) High+ -- set options and generate pitches+ pitchClass >+ map+ (\(w, v) ->+ if v `elem` (G =| d7 :: [PitchClass])+ then (4 * w, v) else (w, v)) options+ pitches <- (length rhythm) .#. (pitchClass??)+ -- put everything together into a piece of music+ let fullPitches = (flip (<:) $ []) <$> (zipWith (#) pitches (repeat 4))+ let gmaj7 = (toMusicCore . chord .+ map (Note (1 * wn) . (flip (#)) 3)) (G =| d7)+ return $ gmaj7 :=: line (zipWith (<|) fullPitches rhythm)++ randomMelody :: MusicGenerator () MusicCore+ randomMelody = do+ pitches <- 20 .#. (pitchClass??)+ durations <- 20 .#. (duration??)+ octaves <- 20 .#. (octave??)+ return (line $ zipWith (<|)+ ((flip (<:) $ []) <$> zipWith (#) pitches octaves)+ durations)++ -- | Generate a (random) length for a phrase. A higher density will result in+ -- phrases with more notes allowed, in order to enforce that the average+ -- high density phrase will take roughly the same amount of time as the+ -- average low density phrase.+ phraseLength :: Density -> IO Duration+ phraseLength density = do+ aux <- generate $ oneof+ (map (elements . (\x -> [x]))+ [2..maxLen]+ )+ return $ aux * qn+ where maxLen =+ case density of+ Low -> 8+ Medium -> 16+ High -> 32++ -- | Choose a random rest length+ pauseLength :: IO Duration+ pauseLength = do+ aux <- generate $ oneof+ (map (elements . (\x -> [x]))+ [1..8]+ )+ return $ aux * en++ -- | Generate an element from a distribution+ fromDistribution :: [(Int, a)] -> IO a+ fromDistribution dist = do+ sample <- generate $ frequency+ (map (\(x, y) -> (x, elements [y])) dist)+ return sample++ -- | Convert a sequential piece of music to a timeline, containing pairs of+ -- all musical elements in the piece with the point in time they occur on+ chordalTimeline :: Music SemiChord -> [(SemiChord, Duration)]+ chordalTimeline chords = getTimeline (toListM chords) 0++ -- | Convert a list of musical elements and durations to a list+ -- of all elements and the absolute point in time they occur on.+ getTimeline :: [(Maybe a, Duration)] -> Duration -> [(a, Duration)]+ getTimeline [] _ = []+ getTimeline ((x, y):xs) p =+ case x of+ Nothing -> getTimeline xs (p + y)+ (Just v) -> (v, p):getTimeline xs (p + y)++ -- | Trim a generated rhythm sequence to a certain length.+ trimToLength :: Duration -> [Duration] -> [Duration]+ trimToLength d [] = []+ trimToLength d (x:xs) | d - x <= 0 = [d]+ trimToLength d (x:xs) | otherwise = x:(trimToLength (d - x) xs)++ -- | Generate a rythm piece with a maximum length.+ boundedRhythm :: Duration -> Density -> MusicGenerator () [Duration]+ boundedRhythm bound density = do+ dur <- (duration??)+ rhythm <- genAspect duration+ dur (round (bound / qn)) 2.0 (densityToDurations density)+ return $ trimToLength bound rhythm++ -- | Concatenates the result of a list of monadic computations that+ -- all yield a list themselves+ concatM :: (Monad m) => [m [a]] -> m [a]+ concatM [] = return []+ concatM (x:xs) = do+ v <- x+ vs <- concatM xs+ return (v ++ vs)+ {-+ TODO: Chord generation+ TODO: pitch attributes+ TODO: time-awareness+ be instantiated to a concrete piece of music+ -}
+ src/Generate/Applications/GenConfig.hs view
@@ -0,0 +1,22 @@+-- | Used by the Diatonic generator to steer the generation process+module Generate.Applications.GenConfig (+ GenConfig (..)+ , Density (..)+ , defaultGenConfig+) where++import Music+++-- | Denotes the global note density in a piece of music+data Density = High | Medium | Low++data GenConfig = GenConfig { key :: PitchClass+ , baseScale :: [Interval]+ , chords :: Music SemiChord+ , phraseDistribution :: [(Int, Density)]+ , octaveDistribution :: [(Int, Octave)]+ }++defaultGenConfig :: GenConfig+defaultGenConfig = undefined
+ src/Generate/Chaos.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}++-- | A `MusicGenerator` that uses Chaos functions.++module Generate.Chaos where++import Music+import Utils.Vec+import Generate.Generate+import Export+import Control.Monad.State hiding (state)++-- | Selectors for all `Generate.Generate.GenState` elements.+data Mapping n = Mapping { pcSel :: Selector (ChaosState n) PitchClass+ , octSel :: Selector (ChaosState n) Octave+ , durSel :: Selector (ChaosState n) Duration+ , itvSel :: Selector (ChaosState n) Interval+ , dynSel :: Selector (ChaosState n) Dynamic+ , artSel :: Selector (ChaosState n) Articulation+ }++-- | Default `Mapping` that just grabs the first element from the list of+-- possible values.+defaultMapping :: Mapping n+defaultMapping = Mapping { pcSel = defaultChaosSelector+ , octSel = defaultChaosSelector+ , durSel = defaultChaosSelector+ , itvSel = defaultChaosSelector+ , dynSel = defaultChaosSelector+ , artSel = defaultChaosSelector+ }++-- | Default Chaos selector, (just grabs the first element from the list).+defaultChaosSelector :: Selector (ChaosState n) a+defaultChaosSelector s as = do+ return (snd (head as), s)++-- | Generates an `Entry` based on a `ChaosState` and `Selector`.+chaosEntry :: (Enum a, Bounded a) => ChaosState n -> Selector (ChaosState n) a -> Entry (ChaosState n) a+chaosEntry _ sel = Entry { values = zip (repeat 1) [minBound ..]+ , constraints = []+ , selector = sel+ }++-- | Builds a `GenState` with a `ChaosState` based on a `ChaosState` and `Mapping`+chaosState :: ChaosState n -> Mapping n -> GenState (ChaosState n)+chaosState st m = GenState { state = st+ , pc = chaosEntry st (pcSel m)+ , oct = chaosEntry st (octSel m)+ , dur = Entry { values =+ zip (repeat 1) [1%1,1%2,1%4,1%8,1%16]+ , constraints = []+ , selector = (durSel m)+ }+ , itv = chaosEntry st (itvSel m)+ , dyn = chaosEntry st (dynSel m)+ , art = chaosEntry st (artSel m)+ }++-- | Runs a generator on the chaos state.+runChaosGenerator :: ChaosState n -> Mapping n -> MusicGenerator (ChaosState n) a -> IO a+runChaosGenerator s m g = runGenerator' (chaosState s m) g++-- | Cleans the `MusicGenerator`+cleanChaos :: ChaosState n -> Mapping n -> MusicGenerator (ChaosState n) a -> MusicGenerator (ChaosState n) a+cleanChaos s m = modified (const $ chaosState s m)++-- | Generates music and plays it using Midi on device 0.+playChaosGen :: ToMusicCore a => ChaosState n -> Mapping n -> MusicGenerator (ChaosState n) (Music a) -> IO ()+playChaosGen s m gen = do+ music <- runChaosGenerator s m gen+ let ?midiConfig = defaultMIDIConfig+ playDev 0 music++-- | Builds a ChaosState from two Vectors of the same length. This constraint+-- is imposed since the number of variables should be equal to the number+-- of update functions.+buildChaos :: Vec n Double -- ^ Initial variable values+ -> Vec n (Vec n Double -> Double) -- ^ Functions that calculate next variable values+ -> ChaosState n+buildChaos vs fs = ChaosState { variables=vs , updateFunctions=fs}++-- | The default `ChaosState` that is used for Chaotic generation.+data ChaosState n =+ ChaosState { variables :: Vec n Double+ , updateFunctions :: Vec n (Vec n Double -> Double)+ }++-- | The `ChaosState wrapped in a `StateT` monad.`+type ChaosGenerator n = StateT (ChaosState n) IO++-- | Calculates the next iteration of values for the `ChaosState`.+genNextIteration :: ChaosGenerator n [Double]+genNextIteration = do+ s <- get+ let vs = variables s+ let fs = updateFunctions s+ let newVs = fmap (\f -> f vs) fs+ put (s { variables = newVs })+ return $ list newVs
+ src/Generate/Generate.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Generate.Generate where++import Control.Monad.State hiding (state)+import Music++type Weight = Double+type Selector s a = s -> [(Weight, a)] -> IO (a, s)++data Accessor st s a = Accessor+ { getValue :: st s -> Entry s a+ , setValue :: Entry s a -> st s -> st s+ }++-- | State to be kept during generation+type Constraint a = a -> Bool++data Entry s a = Entry { values :: [(Weight, a)]+ , constraints :: [Constraint a]+ , selector :: Selector s a+ }++data GenState s = GenState { state :: s+ , pc :: Entry s PitchClass+ , oct :: Entry s Octave+ , dur :: Entry s Duration+ , itv :: Entry s Interval+ , dyn :: Entry s Dynamic+ , art :: Entry s Articulation+ }++pitchClass :: Accessor GenState s PitchClass+pitchClass = Accessor { getValue = pc , setValue = \e st -> st { pc = e } }++octave :: Accessor GenState s Octave+octave = Accessor { getValue = oct, setValue = \e st -> st { oct = e } }++duration :: Accessor GenState s Duration+duration = Accessor { getValue = dur, setValue = \e st -> st { dur = e } }++interval :: Accessor GenState s Interval+interval = Accessor { getValue = itv, setValue = \e st -> st { itv = e } }++dynamic :: Accessor GenState s Dynamic+dynamic = Accessor { getValue = dyn, setValue = \e st -> st { dyn = e } }++articulation :: Accessor GenState s Articulation+articulation = Accessor { getValue = art, setValue = \e st -> st { art = e } }++-- | A 'Music' generator is simply state monad wrapped around IO.+type MusicGenerator s a = GenericMusicGenerator GenState s a++type GenericMusicGenerator st s a = StateT (st s) IO a++getEntry :: Accessor st s a -> GenericMusicGenerator st s (Entry s a)+getEntry accessor = do+ st <- get+ return $ getValue accessor st++(?@) :: Accessor st s a -> GenericMusicGenerator st s (Entry s a)+(?@) = getEntry++putEntry :: Accessor st s a -> Entry s a -> GenericMusicGenerator st s ()+putEntry accessor entry = modify $ setValue accessor entry++(>@) :: Accessor st s a -> Entry s a -> GenericMusicGenerator st s ()+(>@) = putEntry++putSelector :: Accessor st s a -> Selector s a -> GenericMusicGenerator st s ()+putSelector accessor sel = do+ entry <- getEntry accessor+ putEntry accessor (entry { selector = sel })++(>?) :: Accessor st s a -> Selector s a -> GenericMusicGenerator st s ()+(>?) = putSelector++putOptions :: Accessor st s a -> [(Weight, a)] -> GenericMusicGenerator st s ()+putOptions accessor options = do+ entry <- getEntry accessor+ putEntry accessor (entry { values = options })++getOptions :: Accessor st s a -> GenericMusicGenerator st s [(Weight, a)]+getOptions accessor = do+ entry <- getEntry accessor+ return (values entry)++(>+) :: Accessor st s a -> [(Weight, a)] -> GenericMusicGenerator st s ()+(>+) = putOptions++(?+) :: Accessor st s a -> GenericMusicGenerator st s [(Weight, a)]+(?+) = getOptions++setState :: s -> MusicGenerator s ()+setState state' = modify (\st -> st { state = state' })++(.#.) :: (Applicative m) => Int -> m a -> m [a]+(.#.) = replicateM+++(>$) :: s -> MusicGenerator s ()+(>$) = setState++select :: Accessor GenState s a -> MusicGenerator s a+select = gselect state setState++gselect :: (st s -> s)+ -> (s -> GenericMusicGenerator st s ())+ -> Accessor st s a+ -> GenericMusicGenerator st s a+gselect stateGet stateSet accessor = do+ e <- getEntry accessor+ genstate <- get+ let st = stateGet genstate+ let e' = constrain e+ let sel = selector e+ (value, st') <- lift (sel st e')+ stateSet st'+ return value++constrain :: Entry s a -> [(Weight, a)]+constrain e = filter (\(_, x) -> all ($ x) (constraints e)) $ values e++addConstraint :: Accessor st s a -> Constraint a -> GenericMusicGenerator st s ()+addConstraint accessor c = do+ e <- getEntry accessor+ putEntry accessor Entry { values = values e+ , constraints = c:constraints e+ , selector = selector e+ }++(>!) :: Accessor st s a -> Constraint a -> GenericMusicGenerator st s ()+(>!) = addConstraint++(??) :: Accessor GenState s a -> MusicGenerator s a+(??) = select++class Generatable st a where+ rand :: GenericMusicGenerator st s a++ randN :: Int -> GenericMusicGenerator st s [a]+ randN n = replicateM n rand++instance Generatable GenState PitchClass where+ rand = (pitchClass??)+instance Generatable GenState Octave where+ rand = (octave??)+instance Generatable GenState Duration where+ rand = (duration??)++instance Generatable GenState Pitch where+ rand = (,) <$> rand <*> rand++-- | Generate a note within the currently applied constraints.+genNote :: MusicGenerator s Melody+genNote = (<|) <$> rand <*> rand++genChord :: Int -> MusicGenerator s Melody+genChord n =+ chord <$> (map <$> (Note <$> rand)+ <*> (zip <$> randN n <*> randN n))++-- | Runs a generator on the provided state+runGenerator' :: st s -> GenericMusicGenerator st s a -> IO a+runGenerator' st gen = fst <$> runStateT gen st++modified :: (st s -> st s)+ -> GenericMusicGenerator st s a+ -> GenericMusicGenerator st s a+modified f gen = get >>= \st -> lift $ runGenerator' (f st) gen++local :: GenericMusicGenerator st s a -> GenericMusicGenerator st s a+local = modified id
+ src/Generate/QuickCheck.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE ImplicitParams #-}+module Generate.QuickCheck where++import Music+import Generate.Generate+import Test.QuickCheck.Gen+import Export++quickCheckSelector :: Selector s a+quickCheckSelector s as =+ let conv (x, a) = ((round . (*) 100) x, elements [a]) in+ generate $ frequency (map conv as) >>= \a -> return (a,s)++quickCheckEntry :: (Enum a, Bounded a) => s -> Entry s a+quickCheckEntry _ = Entry { values = zip (repeat 1) [minBound ..]+ , constraints = []+ , selector = quickCheckSelector+ }++quickCheckState :: s -> GenState s+quickCheckState st = GenState { state = st+ , pc = quickCheckEntry st+ , oct = quickCheckEntry st+ , dur = Entry { values =+ zip (repeat 1) [1%1,1%2,1%4,1%8,1%16,1%32]+ , constraints = []+ , selector = quickCheckSelector+ }+ , itv = quickCheckEntry st+ , dyn = quickCheckEntry st+ , art = quickCheckEntry st+ }++-- | Runs a generator on the quickCheck state.+runGenerator :: s -> MusicGenerator s a -> IO a+runGenerator = runGenerator' . quickCheckState++clean :: s -> MusicGenerator s a -> MusicGenerator s a+clean s = modified (const $ quickCheckState s)++playGen :: ToMusicCore a => s -> MusicGenerator s (Music a) -> IO ()+playGen s music = do+ m <- runGenerator s music+ let ?midiConfig = defaultMIDIConfig+ playDev 4 m
+ src/Grammar.hs view
@@ -0,0 +1,21 @@+module Grammar+ ( module Grammar.Types+ , module Grammar.Utilities+ , module Grammar.Harmony+ , module Grammar.UUHarmony+ , module Grammar.TonalHarmony+ , module Grammar.VoiceLeading+ , module Grammar.Melody+ , module Grammar.Integration+ , module Grammar.Tabla+ ) where++import Grammar.Types+import Grammar.Utilities+import Grammar.Harmony+import Grammar.UUHarmony+import Grammar.TonalHarmony+import Grammar.VoiceLeading+import Grammar.Melody+import Grammar.Integration+import Grammar.Tabla
+ src/Grammar/Harmony.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Grammar.Harmony+ ( HarmonyConfig (..), defHarmonyConfig+ , harmony, interpret+ , Degree (..), Modulation (..)+ ) where++import Grammar.Types+import Grammar.Utilities+import Music++-- | Terminal symbol that represents scale degrees.+data Degree = I | II | III | IV | V | VI | VII+ deriving (Eq, Show, Enum, Bounded)++-- | Auxiliary wrapper for modulating keys.+newtype Modulation = Modulation Interval deriving (Eq, Show)++-- | Custom grammar for harmonic structure.+harmony :: Grammar Modulation Degree+harmony = I |:+ [ -- Turn-arounds+ (I, 8, (> wn)) :-> \t -> Let (I:%:t/2) (\x -> x :-: x)+ , (I, 2, (> wn)) :-> \t -> I:%:t/2 :-: I:%:t/2+ , (I, 6, (> hn) /\ (<= wn)) :-> \t -> II:%:t/4 :-: V:%:t/4 :-: I:%:t/2+ , (I, 2, (> hn) /\ (<= wn)) :-> \t -> V:%:t/2 :-: I:%:t/2+ , (I, 2) -|| (<= wn)+ -- Modulations+ , (V, 5, (> hn)) :-> \t -> Modulation P5 $: I:%:t+ , V -| 3+ -- Tritone substitution+ , (V, 1, (> hn)) :-> \t -> Let (V:%:t/2) (\x -> (Modulation A4 |$: x) :-: x)+ ]++-- | Expands modulations and intreprets degrees to chords.+instance Expand HarmonyConfig Degree Modulation SemiChord where+ expand conf (m :-: m') = (:-:) <$> expand conf m <*> expand conf m'+ expand conf (Aux _ (Modulation itv) t) =+ expand (conf {basePc = basePc conf ~~> itv}) t+ expand conf (a :%: t) = do+ ch <- conf `interpret` a+ return $ ch :%: t+ expand _ _ = error "Expand: let-expressions exist"++-- | Interpret a degree as a 'SemiChord' on a given harmonic context.+interpret :: HarmonyConfig -> Degree -> IO SemiChord+interpret config degree = choose options+ where tonic = basePc config +| baseScale config :: SemiScale+ tone = tonic !! fromEnum degree+ options = [ (w, ch)+ | (w, chordType) <- chords config+ , let ch = tone =| chordType+ , all (`elem` tonic) ch+ ]++-- | Configuration for harmony.+data HarmonyConfig = HarmonyConfig+ { basePc :: PitchClass+ , baseOct :: Octave+ , baseScale :: AbstractScale+ , chords :: [(Weight, AbstractChord)]+ }++defHarmonyConfig :: HarmonyConfig+defHarmonyConfig = HarmonyConfig+ { basePc = def+ , baseOct = def+ , baseScale = major+ , chords = equally allChords+ }
+ src/Grammar/Integration.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ImplicitParams #-}+module Grammar.Integration+ ( integrate+ ) where++import Control.Monad (when)++import Dynamics+import Grammar.Harmony+import Grammar.Melody+import Grammar.TonalHarmony+import Grammar.Types+import Grammar.VoiceLeading+import Music++integrate :: (?melodyConfig :: MelodyConfig, ?harmonyConfig :: HarmonyConfig)+ => Duration -> IO (MusicCore, MusicCore)+integrate t = do+ when (t < 4 * wn) $+ fail "integrate: requested duration should be at least 4 bars of music"+ harmonicStructure <- runGrammar tonalHarmony t ?harmonyConfig+ melodicStructure <- runGrammar melody t ()+ background <- voiceLead harmonicStructure+ foreground <- mkSolo harmonicStructure melodicStructure+ return (dyn $ toMusicCore background, dyn $ toMusicCore foreground)
+ src/Grammar/Melody.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE PostfixOperators #-}+module Grammar.Melody+ ( MelodyConfig (..), defMelodyConfig+ , melody, mkSolo+ ) where++import Control.Arrow (first)++import Grammar.Types+import Grammar.Utilities+import Music++-- | Melodic (non)-terminal symbols.+data NT = MQ -- Meta-rhythm+ | Q -- Rhythm non-terminal+ | MN -- Meta-note+ | N -- Note non-terminal+ | HT -- any of [CT, L, AT]+ | CT -- chord tone+ | L -- color tone+ | AT -- approach tone+ | ST -- scale tone+ | R -- rest+ deriving (Eq, Show)++-- | Grammar for melodic lines based on the paper:+-- "A Grammatical Approach to Automatic Improvisation" by Robert M. Keller.+melody :: Grammar () NT+melody = MQ |:+ [ -- Rhythm { expand MQ(*) to multiple Q(wn), Q(hn) and Q(qn) }+ (MQ, 1, (== 0)) |-> R:%:0+ , (MQ, 1, (== qn)) |-> Q:%:qn+ , (MQ, 1, (== hn)) |-> Q:%:hn+ , (MQ, 1, (== (hn^.))) |-> Q:%:hn :-: Q:%:qn+ , (MQ, 25, (> (hn^.))) :-> \t -> Q:%:hn :-: MQ:%:(t - hn)+ , (MQ, 75, (> wn)) :-> \t -> Q:%:wn :-: MQ:%:(t - wn)++ -- Melody { expand Qs to notes }+ , (Q, 52, (== wn)) |-> Q:%:hn :-: MN:%:qn :-: MN:%:qn+ , (Q, 47, (== wn)) |-> MN:%:qn :-: Q:%:hn :-: MN:%:qn+ , (Q, 1, (== wn)) |-> MN:%:en :-: N:%:qn :-: N:%:qn :-: N:%:qn :-: MN:%:en++ , (Q, 60, (== hn)) |-> MN:%:qn :-: MN:%:qn+ , (Q, 16, (== hn)) |-> HT:%:(qn^.) :-: N:%:en+ , (Q, 12, (== hn)) |-> MN:%:en :-: N:%:qn :-: MN:%:en+ , (Q, 6, (== hn)) |-> N:%:hn+ , (Q, 6, (== hn)) |-> HT:%:(qn^^^) :-: HT:%:(qn^^^) :-: HT:%:(qn^^^)++ , (Q, 1, (== qn)) |-> CT:%:qn++ , (MN, 1, (== wn)) |-> MN:%:qn :-: MN:%:qn :-: MN:%:qn :-: MN:%:qn++ , (MN, 72, (== qn)) |-> MN:%:en :-: MN:%:en+ , (MN, 22, (== qn)) |-> N:%:qn+ , (MN, 5, (== qn)) |-> HT:%:(en^^^) :-: HT:%:(en^^^) :-: HT:%:(en^^^)+ , (MN, 1, (== qn)) |-> HT:%:(en^^^) :-: HT:%:(en^^^) :-: AT:%:(en^^^)++ , (MN, 99, (== en)) |-> N:%:en+ , (MN, 1, (== en)) |-> HT:%:sn :-: AT:%:sn++ , (N, 1, (== hn)) |-> CT:%:hn++ , (N, 50, (== qn)) |-> CT:%:qn+ , (N, 50, (== qn)) |-> ST:%:qn+ , (N, 45, (== qn)) |-> R:%:qn+ , (N, 20, (== qn)) |-> L:%:qn+ , (N, 1, (== qn)) |-> AT:%:qn++ , (N, 40, (== en)) |-> CT:%:en+ , (N, 40, (== en)) |-> ST:%:en+ , (N, 20, (== en)) |-> L:%:en+ , (N, 20, (== en)) |-> R:%:en+ , (N, 1, (== en)) |-> AT:%:en+ ]++-- | Produce a concrete improvisation out of a melodic structure.+mkSolo :: (?melodyConfig :: MelodyConfig) => Music SemiChord -> Music NT -> IO Melody+mkSolo chs nts =+ fromListM <$> go Nothing [] (synchronize (toList chs) (toList nts))+ where+ go :: Maybe Pitch -> [Duration] -> ListMusic (SemiChord, NT) -> IO (ListMusicM Pitch)+ go _ _ [] = return []+ go prevP approach (((ch, nt), t):rest) =+ case nt of+ HT -> do+ nt' <- choose [(5, CT), (3, AT), (2, L)]+ go prevP approach (((ch, nt'), t):rest)+ AT -> if null rest then return [] else go prevP (approach ++ [t]) rest+ _ -> do m <- interpretNT prevP approach ch nt t+ (++) <$> pure m <*> go (fst $ last m) [] rest++ interpretNT :: Maybe Pitch -- ^ previous pitch+ -> [Duration] -- ^ approach tones+ -> SemiChord -- ^ harmonic context+ -> NT -- ^ current tone characteristic+ -> Duration -- ^ current duration+ -> IO (ListMusicM Pitch)+ interpretNT prevP approach ch nt t =+ case nt of+ R -> return $ (,) Nothing <$> (t : approach)+ CT -> mkPitch prevP approach t ch+ ST ->+ let scales' = [(w, sc) | (w, sc) <- scales ?melodyConfig, all (`elem` sc) (toIntervals ch)]+ in if null scales'+ then interpretNT prevP approach ch CT t+ else do sc <- choose scales'+ mkPitch prevP approach t (head ch +| sc)+ L -> let colors = colorTones ch+ in if null colors+ then interpretNT prevP approach ch CT t+ else mkPitch prevP approach t colors+ _ -> error $ "intrepret: incomplete grammar rewrite " ++ show nt ++ " <| " ++ show t++ mkPitch :: Maybe Pitch -> [Duration] -> Duration -> [PitchClass] -> IO (ListMusicM Pitch)+ mkPitch prevP approach t pcs =+ -- do pc <- choose $ equally pcs+ -- oct <- choose (octaves ?melodyConfig)+ -- approachPitch approach prevP t (pc#oct)+ let ps = [(pc#oct, w) | pc <- pcs, (w, oct) <- normally $ octaves ?melodyConfig]+ setWeight (p', w') =+ -- w'+ -- w' - fromIntegral (pitchDistanceM prevP p')+ -- w' * 1.0 / fromIntegral (pitchDistanceM prevP p')+ w' * (1.0 - (fromIntegral (pitchDistanceM prevP p') / 12.0))+ in (fst <$> chooseWith setWeight ps) >>= approachPitch approach prevP t+++ approachPitch :: [Duration] -> Maybe Pitch -> Duration -> Pitch -> IO (ListMusicM Pitch)+ approachPitch approach prevP t p = reverse <$> oneOf [move dir | dir <- directions]+ where+ move dir = first Just <$> zip (iterate (`dir` Mi2) p) (t : approach)+ directions = case prevP of+ Just p' -> if p' > p then [(<~)] else [(~>)]+ Nothing -> [(~>), (<~)]++ -- | Synchronize the harmonic background with the melodic foreground.+ synchronize :: ListMusic SemiChord -> ListMusic NT -> ListMusic (SemiChord, NT)+ synchronize [] _ = []+ synchronize _ [] = []+ synchronize ((ch, t):back) front =+ let (ps', front') = takeTime front t+ in [((ch, p'), t') | (p', t') <- ps' ] ++ synchronize back front'++ takeTime :: ListMusic NT -> Duration -> (ListMusic NT, ListMusic NT)+ takeTime ntz d+ | d <= 0 = ([], ntz)+ | otherwise = case ntz of+ [] -> ([], [])+ (nt@(_, d'):ntz') ->+ let (ntz'', rest) = takeTime ntz' (d - d')+ in (nt:ntz'', rest)++ -- | Extracts the color tones of a chord.+ colorTones :: SemiChord -> [PitchClass]+ colorTones (p:ps) = filter (\p' -> distancePc p p' `elem` colorIntervals) ps+ where colorIntervals = [M3, Mi3, Mi7, M7, Mi9, M9, M13, Mi13]+ colorTones [] = []++ toIntervals :: SemiChord -> AbstractChord+ toIntervals ch = P1 : (uncurry distancePc <$> zip ch (tail ch))++-- | Configuration for melody.+data MelodyConfig = MelodyConfig+ { scales :: [(Weight, AbstractScale)]+ , octaves :: [(Weight, Octave)]+ , chordWeight :: Weight+ , approachWeight :: Weight+ , colorWeight :: Weight+ }++defMelodyConfig :: MelodyConfig+defMelodyConfig = MelodyConfig+ { scales = equally allScales+ , octaves = equally allOctaves+ , chordWeight = 10+ , approachWeight = 5+ , colorWeight = 3+ }
+ src/Grammar/Tabla.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ImplicitParams #-}+module Grammar.Tabla+ ( tabla+ ) where++import Grammar.Types+import Grammar.Utilities+import Music++-- | Raw MIDI representation.+newtype MidiNumber = MidiNumber Int+instance ToMusicCore MidiNumber where+ toMusicCore = toMusicCore . fmap (\(MidiNumber n) -> toEnum (n - 12) :: Pitch)++-- | Tabla music.+data TablaNote =+ -- terminals+ Tr | Kt | Dhee | Tee | Dha | Ta | Ti | Ge | Ke | Na | Ra | Noop+ -- non-terminals+ | Start | S | XI | XD | XJ | XA | XB | XG | XH | XC | XE| XF+ | TA7 | TC2 | TE1 | TF1 | TF4 | TD1 | TB2 | TE4 | TC1 | TB3 | TA8 | TA3 | TB1 | TA1+ deriving (Eq, Show)++instance ToMusicCore TablaNote where+ toMusicCore = toMusicCore . fromListM . concatMap percussionMap . toList+ where percussionMap :: (TablaNote, Duration) -> [(Maybe MidiNumber, Duration)]+ percussionMap (tableNote, t) =+ (\n -> (n, t)) <$> (if null xs then [Nothing] else Just <$> xs)+ where xs = MidiNumber <$> case tableNote of+ Tr -> [38, 39]+ Kt -> [45, 40]+ Dhee -> [50] -- dhin+ Tee -> [38] -- ti+ Dha -> [46]+ Ta -> [40]+ Ti -> [38]+ Ge -> [44] -- ga+ Ke -> [45] -- ka+ Na -> [52] -- tin+ Ra -> [39]+ Noop -> []+ _ -> error "Incomplete grammar rewrite"++(|-->) :: (?tablaBeat :: Duration) => a -> [a] -> Rule meta a+x |--> xs = (x, 1, always) |-> foldl1 (:-:) (map (:%: ?tablaBeat) xs)++-- | Grammar for tabla improvisation based on the paper:+-- "Modelling Improvisatory and Compositional Processes" by Bernard Bel.+tabla :: (?tablaBeat :: Duration) => Grammar () TablaNote+tabla = Start |:+ [ (Start, 1, always) :-> \t ->+ foldr1 (:-:) $ replicate (t // (16 * ?tablaBeat)) $ S:%:def+ , S |--> [TE1, XI]+ , XI |--> [TA7, XD]+ , XD |--> [TA8]+ , XI |--> [TF1, XJ]+ , XJ |--> [TC2, XA]+ , XA |--> [TA1, XB]+ , XB |--> [TB3, XD]+ , XI |--> [TF1, XG]+ , XG |--> [TB2, XA]+ , S |--> [TA1, XH]+ , XH |--> [TF4, XB]+ , XH |--> [TA3, XC]+ , XC |--> [TE4, XD]+ , XC |--> [TA3, XE]+ , XE |--> [TA1, XD]+ , XE |--> [TC1, XD]+ , XC |--> [TB1, XB]+ , S |--> [TB1, XF]+ , XF |--> [TA1, XJ]+ , XF |--> [TD1, XG]++ , TA7 |--> [Kt, Dha, Tr, Kt, Dha, Ge, Na]+ , TC2 |--> [Tr, Kt]+ , TE1 |--> [Tr]+ , TF1 |--> [Kt]+ , TF4 |--> [Ti, Dha, Tr, Kt]+ , TD1 |--> [Noop]+ , TB2 |--> [Dha, Ti]+ , TE4 |--> [Ti, Noop, Dha, Ti]+ , TC1 |--> [Ge]+ , TB3 |--> [Dha, Tr, Kt]+ , TA8 |--> [Dha, Ti, Dha, Ge, Dhee, Na, Ge, Na]+ , TA3 |--> [Tr, Kt, Dha]+ , TB1 |--> [Ti]+ , TA1 |--> [Dha]+ ]
+ src/Grammar/TonalHarmony.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Grammar.TonalHarmony+ ( tonalHarmony+ ) where++import qualified Grammar.Harmony as H+import Grammar.Types+import Music++data Degree =+ -- terminals+ I | II | III | IV | V | VI | VII+ -- non-terminals+ | Piece | TR | DR | SR | TS | DS | SS+ deriving (Eq, Show, Enum, Bounded)++(|~>) :: Head [a] -> (a -> Body meta a) -> [Rule meta a]+(xs, w, activ) |~> k = [(x, w, activ) :-> k x | x <- xs]++-- | Grammar for tonal harmony, based on the paper:+-- "Towards a Generative Syntax of Tonal Harmony" by Martin Rohrmeier.+tonalHarmony :: Grammar H.Modulation Degree+tonalHarmony = Piece |:+ [ -- Phrase level+ (Piece, 1, always) :-> \t ->+ foldr1 (:-:) $ replicate (t // (4 * wn)) $ TR:%:(4 * wn)++ -- Functional level: Expansion+ , (TR, 1, (> wn)) :-> \t -> TR:%:t/2 :-: DR:%:t/2+ , (TR, 1, always) :-> \t -> DR:%:t/2 :-: TS:%:t/2+ , (DR, 1, always) :-> \t -> SR:%:t/2 :-: DS:%:t/2+ ] +++ (([TR, SR, DR], 1, (> wn)) |~> \x t -> x:%:t/2 :-: x:%:t/2) +++ [+ (TR, 1, always) :-> (TS :%:)+ , (DR, 1, always) :-> (DS :%:)+ , (SR, 1, always) :-> (SS :%:)++ -- Functional level: Modulation+ , (DS, 1, (>= qn)) :-> \t -> H.Modulation P5 $: DS:%:t+ , (SS, 1, (>= qn)) :-> \t -> H.Modulation P4 $: SS:%:t++ -- Scale-degree level: Secondary dominants+ ] +++ (([TS, DS, SS], 1, (>= hn)) |~> \x t -> (H.Modulation P5 $: x:%:t/2) :-: x:%:t/2) +++ [ -- Scale-degree level: Functional-Scale interface+ (TS, 1, (>= wn)) :-> \t -> I:%:t/2 :-: IV:%:t/4 :-: I:%:t/4+ , (TS, 1, always) :-> (I :%:)+ , (SS, 1, always) :-> (IV :%:)+ , (DS, 1, always) :-> (V :%:)+ , (DS, 1, always) :-> (VI :%:)+ ]++-- | Expands modulations and intreprets degrees to chords.+instance Expand H.HarmonyConfig Degree H.Modulation SemiChord where+ expand conf = expand conf . fmap ((toEnum :: Int -> H.Degree) . fromEnum)
+ src/Grammar/Types.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+module Grammar.Types+ ( Weight+ , Grammar (..), Rule (..), Head, Activation, Body+ , Term (..), Expand (..), Grammarly+ , runGrammar, always, (/\), (\/)+ , (|:), (-|), (-||), ($:), (|$:), (|->)+ ) where++import System.Random+import Text.Show.Functions ()++import Generate (Weight)+import Music++{- Operators' precedence. -}+infix 6 :%:+infix 5 $:+infix 5 |$:+infixr 4 :-:+infix 3 :->+infix 3 |->++{- Grammar datatypes. -}+data Grammar meta a = Grammar { initial :: a, rules :: [Rule meta a] }+infix 2 |:+(|:) :: a -> [Rule meta a] -> Grammar meta a+initA |: rs = Grammar initA rs++data Rule meta a = Head a :-> Body meta a+type Head a = (a, Weight, Activation)+type Activation = Duration -> Bool+type Body meta a = Duration -> Term meta a+-- type Terminal a = (a, Duration)++data Term meta a = -- primitive+ a :%: Duration+ -- sequence+ | Term meta a :-: Term meta a+ -- auxiliary modifications+ | Aux Bool meta (Term meta a)+ -- let (enables repetition)+ | Let (Term meta a) (Term meta a -> Term meta a)++deriving instance (Show a, Show meta) => Show (Term meta a)++instance (Eq a, Eq meta) => Eq (Term meta a) where+ (a :%: d) == (a' :%: d') = a == a' && d == d'+ (x :-: y) == (x' :-: y') = x == x' && y == y'+ (Aux b meta t) == (Aux b' meta' t') = b == b' && meta == meta' && t == t'+ (Let t _) == (Let t' _) = t == t'+ _ == _ = False++instance Functor (Term meta) where+ fmap f m = case m of+ a :%: t -> f a :%: t+ m1 :-: m2 -> (f <$> m1) :-: (f <$> m2)+ Aux frozen meta m1 -> Aux frozen meta (f <$> m1)+ _ -> error "fmap: let-expressions exist"++type Grammarly input a meta b =+ (Show a, Show meta, Eq a, Eq meta, Expand input a meta b)++-- | Any metadata-carrying grammar term must be expanded to a stripped-down+-- grammar term with no metadata (i.e. `Term a ()`), possibly producing terms of+-- a different type `b`.+class Expand input a meta b | input a meta -> b where+ -- | Expand meta-information.+ expand :: input -> Term meta a -> IO (Term () b)++-- | Convert to music (after expansion).+toMusic :: (Expand input a meta b) => input -> Term meta a -> IO (Music b)+toMusic input term = do+ expanded <- expand input (unlet term)+ go expanded+ where go (a :%: t) = return $ Note t a+ go (t :-: t') = (:+:) <$> toMusic () t <*> toMusic () t'+ go _ = error "toMusic: lets/aux after expansion"++ unlet (Let x k) = unlet (k x)+ unlet (t :-: t') = unlet t :-: unlet t'+ unlet (Aux b meta t) = Aux b meta (unlet t)+ unlet t = t++-- | A term with no auxiliary wrappers can be trivially expanded.+instance Expand input a () a where+ expand = const return++-- | Run a grammar with the given initial symbol.+runGrammar :: Grammarly input a meta b+ => Grammar meta a -> Duration -> input -> IO (Music b)+runGrammar grammar initT input = do+ rewritten <- fixpoint (go grammar) (initial grammar :%: initT)+ toMusic input rewritten+ where+ -- | Run one term of grammar rewriting.+ go :: (Eq meta, Eq a) => Grammar meta a -> Term meta a -> IO (Term meta a)+ -- go _ (Var x) = return $ Var x+ go gram (Let x k) = do+ x' <- go gram x+ return $ Let x' k+ go gram (t :-: t') =+ (:-:) <$> go gram t <*> go gram t'+ go _ a@(Aux True _ _) =+ return a+ go gram (Aux False meta term) =+ Aux False meta <$> go gram term+ go (Grammar _ rs) (a :%: t) = do+ let rs' = filter (\((a', _, activ) :-> _) -> a' == a && activ t) rs+ (_ :-> rewrite) <- pickRule a rs'+ return $ rewrite t++{- Grammar-specific operators. -}++-- | Rule which always activates.+always :: Activation+always = const True++-- | Conjunction of activation functions.+(/\) :: Activation -> Activation -> Activation+(f /\ g) x = f x && g x++-- | Disjunction of activation functions.+(\/) :: Activation -> Activation -> Activation+(f \/ g) x = f x || g x++-- | Rule with duration-independent body.+(|->) :: Head a -> Term meta a -> Rule meta a+a |-> b = a :-> const b++-- | Identity rule.+(-|) :: a -> Weight -> Rule meta a+a -| w = (a, w, always) :-> \t -> a :%: t++-- | Identity rule with activation function.+(-||) :: (a, Weight) -> Activation -> Rule meta a+(a, w) -|| f = (a, w, f) :-> \t -> a :%: t++-- | Operators for auxiliary terms.+($:), (|$:) :: meta -> Term meta a -> Term meta a+($:) = Aux False -- auxiliary symbol that allows internal rewriting+(|$:) = Aux True -- frozen auxiliary symbol++{- Helpers. -}++-- | Randomly pick a rule to rewrite given terminal.+pickRule :: a -> [Rule meta a] -> IO (Rule meta a)+pickRule a [] = return $ a -| 1+pickRule _ rs = do+ let totalWeight = sum ((\((_, w, _) :-> _) -> w) <$> rs)+ index <- getStdRandom $ randomR (0, totalWeight)+ return $ pick' index rs+ where pick' :: Double -> [Rule meta a] -> Rule meta a+ pick' n (r@((_, w, _) :-> _):rest) =+ if n <= w then r else pick' (n-w) rest+ pick' _ _ = error "pick: empty list"++-- | Converge to fixpoint with given initial value.+fixpoint :: Eq a => (a -> IO a) -> a -> IO a+fixpoint k l = do+ l' <- k l+ if l == l' then return l else fixpoint k l'
+ src/Grammar/UUHarmony.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Grammar.UUHarmony+ ( uuHarmony+ ) where++import qualified Grammar.Harmony as H+import Grammar.Types+import Music++data Degree =+ -- terminals+ I | II | III | IV | V | VI | VII+ -- non-terminals+ | Piece | Phrase | Tonic | Dominant | SubDominant+ deriving (Eq, Show, Enum, Bounded)++-- | Simplified version of 'TonalHarmony', based on the paper:+-- "Functional Generation of Harmony and Melody"+-- by José Pedro Magalhaes & Hendrik Vincent Koops.+uuHarmony :: Grammar H.Modulation Degree+uuHarmony = Piece |:+ [ (Piece, 1, always) :-> \t -> foldr1 (:-:) $ replicate (t // (4 * wn)) $ Phrase:%:(4 * wn)++ , (Phrase, 1, always) :-> \t -> Tonic:%:t/2 :-: Dominant:%:t/4 :-: Tonic:%:t/2+ , (Phrase, 1, always) :-> \t -> Dominant:%:t/2 :-: Tonic:%:t/2++ , (Phrase, 1, always) :-> \t -> H.Modulation P5 $: Phrase:%:t++ , (Tonic, 1, (> wn)) :-> \t -> Let (Tonic:%:t/2) (\x -> x :-: x)+ , (Tonic, 1, (<= wn)) :-> (I :%:)++ , (Dominant, 3, (>= wn)) :-> \t -> SubDominant:%:t/2 :-: Dominant:%:t/2+ , (Dominant, 1, (<= wn)) :-> (V :%:)+ , (Dominant, 1, (<= wn)) :-> (VII :%:)+ , (Dominant, 1, (<= wn)) :-> \t -> II:%:t/2 :-: V:%:t/2++ , (SubDominant, 3, (> hn)) :-> \t -> Let (SubDominant:%:t/2) (\x -> x :-: x)+ , (SubDominant, 1, (<= hn)) :-> (II :%:)+ , (SubDominant, 1, (<= hn)) :-> (IV :%:)+ , (SubDominant, 1, (<= wn)) :-> \t -> III:%:t/2 :-: IV:%:t/2+ ]++-- | Expands modulations and intreprets degrees to chords.+instance Expand H.HarmonyConfig Degree H.Modulation SemiChord where+ expand conf = expand conf . fmap ((toEnum :: Int -> H.Degree) . fromEnum)
+ src/Grammar/Utilities.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE PostfixOperators #-}+module Grammar.Utilities where++import Control.Arrow (first)+import Music+import System.Random++-- Random helper functions.+(<|>) :: a -> a -> IO a+x <|> y = oneOf [x, y]++(<||>) :: IO a -> IO a -> IO a+x' <||> y' = do+ x <- x'+ y <- y'+ x <|> y++oneOf :: [a] -> IO a+oneOf = choose . fmap (\a -> (1, a))++chooseWith :: (a -> Double) -> [a] -> IO a+chooseWith f = choose . fmap (\a -> (f a, a))++choose :: [(Double, a)] -> IO a+choose items = do+ let totalWeight = sum $ fst <$> items+ index <- getStdRandom $ randomR (0, totalWeight)+ return $ pick index items++pick :: Double -> [(Double, a)] -> a+pick n ((w, a):es) =+ if n <= w || null es+ then a+ else pick (n-w) es+pick _ _ = error "pick: empty list"++equally :: [a] -> [(Double, a)]+equally = zip (repeat 1.0)++normally :: [(Double, a)] -> [(Double, a)]+normally xs = first (/ sum (map fst xs)) <$> xs++-- Convertion from/to lists.+type ListMusic a = [(a, Duration)]++toList :: Music a -> ListMusic a+toList (m :+: m') = toList m ++ toList m'+toList(Note d a) = [(a, d)]+toList (_ :=: _) = error "toList: non-sequential music"+toList (Rest _) = error "toList: rest exists"++fromList :: ListMusic a -> Music a+fromList = line . fmap (uncurry (<|))++type ListMusicM a = [(Maybe a, Duration)]++toListM :: Music a -> ListMusicM a+toListM (m :+: m') = toListM m ++ toListM m'+toListM (_ :=: _) = error "toListM: non-sequential music"+toListM (Note d a) = [(Just a, d)]+toListM (Rest d) = [(Nothing, d)]++fromListM :: ListMusicM a -> Music a+fromListM = line . fmap f+ where f (Just a, t) = a <| t+ f (Nothing, t) = (t~~)++-- Music distances+chordDistance :: Chord -> Chord -> Int+chordDistance c c' = sum $ uncurry pitchDistance <$> zip c c'++pitchDistance :: Pitch -> Pitch -> Int+pitchDistance p p' = abs $ fromEnum p - fromEnum p'++pitchDistanceM :: Maybe Pitch -> Pitch -> Int+pitchDistanceM Nothing = const 1+pitchDistanceM (Just p) = pitchDistance p++distancePc :: PitchClass -> PitchClass -> Interval+distancePc pc pc' = toEnum $ abs $ fromEnum pc - fromEnum pc'
+ src/Grammar/VoiceLeading.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImplicitParams #-}+module Grammar.VoiceLeading (voiceLead) where++import Grammar.Utilities+import Grammar.Harmony+import Music++-- | Produce concrete chords out of a harmonic structure.+voiceLead :: (?harmonyConfig :: HarmonyConfig) => Music SemiChord -> IO (Music Chord)+voiceLead m' = do+ vl <- foldl f (pure [(initC, t)]) ms+ return $ fromList vl+ where+ initC = toBaseChord c+ ((c, t) : ms) = toList m'+ f :: IO [(Chord, Duration)] -> (SemiChord, Duration) -> IO [(Chord, Duration)]+ f cs' (sc, d) = do+ cs <- cs'+ c' <- smoothTransition initC (fst $ last cs) sc+ return $ cs ++ [(c', d)]++-- | Get a basic voicing of a chord in a given octave.+toBaseChord :: (?harmonyConfig :: HarmonyConfig) => SemiChord -> Chord+toBaseChord = fmap (\pc -> (pc, baseOct ?harmonyConfig))++-- | Get all inversions of +-1 octave.+allInversions :: (?harmonyConfig :: HarmonyConfig) => SemiChord -> [Chord]+allInversions c =+ let initC = toBaseChord c+ n = length c+ invs ch = take n $ iterate invert ch+ in invs (initC ~> P8) ++ invs initC ++ invs (initC <~ P8)++-- | Smooth voice-leading from one chord to another (i.e. minimal pitch distance).+smoothTransition :: (?harmonyConfig :: HarmonyConfig) => Chord -> Chord -> SemiChord -> IO Chord+smoothTransition initC prevC curC =+ chooseWith setWeight (allInversions curC)+ where+ -- | Set probability weight based on (inverse) pitch distance.+ setWeight :: Chord -> Double+ setWeight c = 1.0 / fromIntegral (2 * chordDistance initC c + chordDistance prevC c)
+ src/Music.hs view
@@ -0,0 +1,13 @@+module Music+ ( module Music.Constants+ , module Music.Operators+ , module Music.Transformations+ , module Music.Types+ , module Music.Utilities+ ) where++import Music.Constants+import Music.Operators+import Music.Transformations+import Music.Types+import Music.Utilities
+ src/Music/Constants.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE PostfixOperators #-}+module Music.Constants where++import Data.List (insert)++import Music.Types+import Music.Utilities++-- Roman numbers.+i, ii, iii, iv, v, vi, vii :: Int+[i, ii, iii, iv, v, vi, vii] = [1..7]++-- 'PitchClass' synonyms.+cb, db, eb, fb, gb, bb :: PitchClass+cb = B ; db = Cs ; eb = Ds; fb = E; gb = Fs; bb = As++-- Octaves+allOctaves :: [Octave]+allOctaves = enumFrom Oct0++---------------------------------- Durations -----------------------------------++-- Basic.+wn, hn, qn, en, sn, tn :: Duration+wn = 1 ; hn = 1%2 ; qn = 1%4 ; en = 1%8 ; sn = 1%16 ; tn = 1%32++-- Triplets.+(^^^), tripl :: Duration -> Duration+(^^^) d = 2*d / 3+tripl = (^^^)++-- Dotted.+(^.), dot :: Duration -> Duration+(^.) d = d + d/2+dot = (^.)++------------------------------------ Chords ------------------------------------+allChords =+ [ maj, mi, dim, aug, majb5, mis5, sus4, sus4s5, d7sus4, maj6, m6, maj7, m7+ , d7, dim7, m7b5, mmaj7, maj9, m9, d9, d7b5, d7s5, d7b9, d7s9+ , d7b5b9, d7b5s9, d7s5b9, d7s5s9+ ] :: [AbstractChord]++-- Triads+maj = [P1, M3, P5]+mi = [P1, Mi3, P5]+dim = [P1, Mi3, A4]+aug = [P1, M3, Mi6]+majb5 = [P1, M3, A4]+mis5 = [P1, Mi3, Mi6]+-- sus+sus4 = [P1, P4, P5]+sus4s5 = [P1, P4, Mi6]+d7sus4 = [P1, P4, P5, Mi7]+-- 6ths+maj6 = [P1, M3, P5, M6]+m6 = [P1, Mi3, P5, M6]+-- 7ths+maj7 = [P1, M3, P5, M7]+m7 = [P1, Mi3, P5, Mi7]+d7 = [P1, M3, P5, Mi7]+dim7 = [P1, Mi3, A4, M6]+m7b5 = [P1, Mi3, A4, Mi7]+mmaj7 = [P1, Mi3, P5, M7]+-- 9ths+maj9 = [P1, M3, P5, M7, M9]+m9 = [P1, Mi3, P5, Mi7, M9]+d9 = [P1, M3, P5, Mi7, M9]+-- Altered Dominants+d7b5 = [P1, M3, A4, Mi7]+d7s5 = [P1, M3, Mi6, Mi7]+d7b9 = [P1, M3, P5, Mi7, Mi9]+d7s9 = [P1, M3, P5, Mi7, A9]+d7b5b9 = [P1, M3, A4, Mi7, Mi9]+d7b5s9 = [P1, M3, A4, Mi7, A9]+d7s5b9 = [P1, M3, Mi6, Mi7, Mi9]+d7s5s9 = [P1, M3, Mi6, Mi7, A9]++------------------------------------ Scales ------------------------------------+allScales =+ [ major, pentatonicMajor, ionian, dorian, phrygian, lydian, mixolydian, aeolian+ , locrian, minor, harmonicMinor, melodicMinor, pentatonicMinor, blues+ , bebopDominant, bebopDorian, bebopMajor, bebopMelodicMinor, bebopHarmonicMinor+ , altered, wholeTone, halfDiminished, flamenco, persian, romanian, arabian+ , japanese, hungarian, jewish, byzantine, oriental, raga+ ] :: [AbstractScale]++-- Major scales.+major = [P1, M2, M3, P4, P5, M6, M7]+pentatonicMajor = [P1, M2, M3, P5, M6]+ionian = mode i major+dorian = mode ii major+phrygian = mode iii major+lydian = mode iv major+mixolydian = mode v major+aeolian = mode vi major+locrian = mode vii major++-- Minor scales.+minor = [P1, M2, Mi3, P4, P5, Mi6, Mi7]+harmonicMinor = [P1, M2, Mi3, P4, P5, Mi6, M7]+melodicMinor = [P1, M2, Mi3, P4, P5, M6, M7]+pentatonicMinor = [P1, Mi3, P4, P5, Mi7]+blues = [P1, Mi3, P4, A4, P5, Mi7]++-- Bebop scales.+bebopDominant = insert M7 mixolydian+bebopDorian = mode v bebopDominant+bebopMajor = insert Mi6 major+bebopMelodicMinor = insert Mi6 melodicMinor+bebopHarmonicMinor = mode vi bebopMelodicMinor++-- Exotic scales.+persian = [P1, Mi2, M3, P4, P5, Mi6, M7]+flamenco = persian+romanian = [P1, M2, Mi3, A4, P5, M6, Mi7]+arabian = [P1, M2, Mi3, P4, A4, Mi6, M7]+japanese = [P1, M2, P4, A4, Mi6, M6, M7]+hungarian = [P1, M2, Mi3, A4, P5, Mi6, M7]+jewish = [P1, Mi2, M3, P4, P5, Mi6, Mi7]+byzantine = [P1, Mi2, M3, P4, P5, Mi6, M7]+oriental = [P1, Mi2, M3, P4, A4, M6, Mi7]+raga = [P1, Mi2, Mi3, P4, P5, Mi6, Mi7]++-- Other scales.+altered = [P1, Mi2, Mi3, M3, A4, Mi6, Mi7]+wholeTone = [P1, M2, M3, A4, Mi6, Mi7]+halfDiminished = mode vi melodicMinor
+ src/Music/Operators.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PostfixOperators #-}+module Music.Operators+ ( (#), (<#)+ , (<|), (<||), (%>)+ , (=|), (+|)+ , (<:)+ , (~~)+ ) where++import Music.Types+import Music.Utilities++-- | Operator precedence.+infix 9 #, ~~+infix 8 <:+infix 7 <|+infix 6 =|, +|+infixl 5 <#, <||, %>++-- Constructors.+(~~) :: Duration -> Music a+(~~) = Rest++(#) :: PitchClass -> Octave -> Pitch+pc # n = (pc, n)++(<#) :: [PitchClass] -> Octave -> [Pitch]+pcs <# n = (# n) <$> pcs++(<:) :: Pitch -> [PitchAttribute] -> FullPitch+p <: attrs = (p, attrs)++(<|) :: a -> Duration -> Music a+(<|) = flip Note++(<||) :: [Pitch] -> Duration -> [Music Pitch]+(<||) sc d = (<| d) <$> sc++(%>) :: Music a -> Duration -> Music a+m %> d = (d~~) :+: m++-- Instantiating chords/scales.+(=|), (+|) :: (Abstract rep a inst) => a -> rep -> inst+(=|) = instantiate+(+|) = instantiate
+ src/Music/Transformations.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Music.Transformations+ ( Transposable (..)+ , Invertible (..)+ , Retrogradable (..)+ , Repeatable (..)+ , Scalable (..)+ , musicToList, listToMusic+ , normalize+ ) where++import Control.Arrow (first)+import Data.Maybe (catMaybes)++import Music.Types++-- | Operator precedence.+infixl 5 ~>, <~, ~~>, <~~+infix 3 *~+infix 2 ##++-- | Anything that can be transposed with an 'Interval'.+class Transposable a where+ trans, trans_, snart, snart_ :: Interval -> a -> a+ (~>), (<~), (~~>), (<~~) :: a -> Interval -> a+ (~>) = flip trans ; (<~) = flip snart ; (~~>) = flip trans_ ; (<~~) = flip snart_++instance {-# OVERLAPPABLE #-} BoundEnum a => Transposable a where+ trans = moveN . fromEnum+ snart = moveN . negate . fromEnum+ trans_ = moveN_ . fromEnum+ snart_ = moveN_ . negate . fromEnum++instance {-# OVERLAPS #-} Transposable a => Transposable (Music a) where+ trans = fmap . trans+ snart = fmap . snart+ trans_ = fmap . trans_+ snart_ = fmap . snart_++instance {-# OVERLAPS #-} Transposable a => Transposable [a] where+ trans = fmap . trans+ snart = fmap . snart+ trans_ = fmap . trans_+ snart_ = fmap . snart_++instance {-# OVERLAPS #-} Transposable FullPitch where+ trans i = first (moveN $ fromEnum i)+ snart i = first (moveN $ -(fromEnum i))+ trans_ i = first (moveN_ $ fromEnum i)+ snart_ i = first (moveN_ $ -(fromEnum i))++instance {-# OVERLAPS #-} (Enum a, BoundEnum a) => Num a where+ i + i' = moveN (fromEnum i') i+ i - i' = moveN (- (fromEnum i')) i+ i * i' = moveN (fromEnum i * (fromEnum i' - 1)) i+ abs = safeToEnum . abs . fromEnum+ signum = safeToEnum . signum . fromEnum+ fromInteger = safeToEnum . fromInteger++-- Anything that can be inverted.+class Invertible f a where+ invert :: f a -> f a++ invertN :: Int -> f a -> f a+ invertN n xs = iterate invert xs !! (n - 1)++instance Invertible [] a => Invertible [] (Maybe a) where+ invert ms = go ms (invert $ catMaybes ms)+ where go (x:xs) (y:ys) = case x of Just _ -> Just y : go xs ys+ Nothing -> Nothing : go xs ys+ go _ _ = []++instance Invertible [] a => Invertible [] (a, b) where+ invert = uncurry zip . first invert . unzip++instance (Show a, Invertible [] a) => Invertible Music a where+ invert = listToMusic . invert . musicToList++instance Invertible [] Interval where+ invert (P1:xs) =+ P1 : scanl1 (+) (zipWith (curry distance) xs (tail xs ++ [P1]))+ where distance (i, i') | i' > i = i' - i+ | otherwise = 12 - i+ invert _ = error "inverting malformed interval description"++instance Invertible [] AbsPitch where+ invert = fmap negate++instance {-# OVERLAPS #-} Invertible [] Pitch where+ invert [] = []+ invert ps = pitch <$> aps'+ where aps' = (+ pivot) <$> inverted+ inverted = invert distances+ distances = (\ap -> ap - pivot) <$> aps+ aps = absPitch <$> ps+ pivot = head aps++-- Anything that can be mirrored.+class Retrogradable f a where+ (><) :: f a -> f a++instance Retrogradable [] a where+ (><) = reverse++instance Retrogradable Music a where+ (><) = normalize . retro+ where retro (m :+: m') = (m'><) :+: (m><)+ retro (m :=: m') = (m><) :=: (m'><)+ retro m = m++-- | Anything that can be scaled up/down.+class Scalable a where+ (*~) :: Rational -> a -> a++instance Scalable Duration where+ (*~) n d = d / n++instance Scalable a => Scalable [a] where+ (*~) n xs = (n *~) <$> xs++instance Scalable (Music a) where+ (*~) n m = (n *~) <$$> m++-- | Anything that can be repeated a number of times.+class Repeatable a where+ (##) :: Int -> a -> a++instance Repeatable (Music a) where+ n ## m | n == 1 = m+ | otherwise = m :+: ((n-1) ## m)++-- | Normalize nested application of sequential composition.+normalize :: Music a -> Music a+normalize (m :+: m') = listToMusic $ musicToList m ++ musicToList m'+normalize (m :=: m') = normalize m :=: normalize m'+normalize m = m++-- | Conversion to/from 'List'.+musicToList :: Music a -> [(Maybe a, Duration)]+musicToList (m :+: m') = musicToList m ++ musicToList m'+musicToList (m :=: _) = musicToList m+musicToList (Note d a) = [(Just a, d)]+musicToList (Rest d) = [(Nothing, d)]++listToMusic :: [(Maybe a, Duration)] -> Music a+listToMusic = line . map (uncurry $ \m d ->+ case m of Nothing -> Rest d+ Just a -> Note d a)
+ src/Music/Types.hs view
@@ -0,0 +1,242 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+module Music.Types+ ( -- * Types+ Music (..)+ , Duration+ , FullPitch+ , Pitch+ , PitchClass (..)+ , Octave (..)+ , PitchAttribute (..)+ , Dynamic (..)+ , Interval (..)+ , Articulation (..)+ , MusicCore, AbsPitch+ , Melody, Rhythm, Harmony+ , Chord, SemiChord, AbstractChord+ , Scale, SemiScale, AbstractScale+ -- * Classes+ , ToMusicCore (..)+ , BoundEnum (..)+ -- * Shorthands+ , (<$$>), (<$$$>)+ , (%), (//), Default(..)+ , line, chord, scale, parallel, voices+ , notes, flatten, harmonyToMelody+ , absPitch, pitch+ ) where++import Data.Default (Default (..))+import Data.Monoid ((<>))+import GHC.Generics (Generic)+import Data.Ratio ((%), numerator, denominator)++-- | Operator precedence.+infixr 4 :+:, :=:, <$$>++(//) :: Rational -> Rational -> Int+r1 // r2 = let r = r1 / r2 in fromInteger $ quot (numerator r) (denominator r)++---------------------------------- TYPES ---------------------------------------+data Music a = Music a :+: Music a+ | Music a :=: Music a+ | Note Duration a+ | Rest Duration+ deriving (Eq, Show, Generic)++type Duration = Rational++type FullPitch = (Pitch, [PitchAttribute])++type Pitch = (PitchClass, Octave)++type AbsPitch = Int++data PitchClass = C | Cs | D | Ds | E | F | Fs | G | Gs | A | As | B+ deriving (Eq, Show, Generic, Enum, Bounded, Ord)++data Octave = Oct0 | Oct1 | Oct2 | Oct3 | Oct4 | Oct5 | Oct6+ deriving (Eq, Show, Generic, Enum, Bounded, Ord)++data PitchAttribute = Dynamic Dynamic+ | Articulation Articulation+ deriving (Eq, Show, Generic)++data Dynamic = PPPPP | PPPP | PPP | PP | P | MP | MF | F_ | FF | FFF | FFFF+ deriving (Eq, Show, Generic, Enum, Bounded, Ord)++data Articulation = Staccato | Staccatissimo | Marcato | Tenuto+ deriving (Eq, Show, Generic, Enum, Bounded)++data Interval = P1 | Mi2 | M2 | Mi3 | M3 | P4 | A4+ | P5 | Mi6 | M6 | Mi7 | M7 | P8+ | Mi9 | M9 | A9 | M10 | P11 | A11+ | P12 | Mi13 | M13 | Mi14 | M14 | P15+ deriving (Eq, Show, Generic, Enum, Bounded, Ord)++type Chord = [Pitch]+type Scale = [Pitch]+type SemiChord = [PitchClass]+type SemiScale = [PitchClass]+type AbstractChord = [Interval]+type AbstractScale = [Interval]++-- Common types of 'Music'.+type Melody = Music Pitch+type Rhythm = Music ()+type Harmony = Music Chord++-------------------------------- INSTANCES -------------------------------------+instance Functor Music where+ fmap f (m :+: m') = (f <$> m) :+: (f <$> m')+ fmap f (m :=: m') = (f <$> m) :=: (f <$> m')+ fmap f (Note d x) = Note d (f x)+ fmap _ (Rest d) = Rest d++-- For mapping over durations.+(<$$>) :: (Duration -> Duration) -> Music a -> Music a+f <$$> (m :+: m') = (f <$$> m) :+: (f <$$> m')+f <$$> (m :=: m') = (f <$$> m) :=: (f <$$> m')+f <$$> (Note d x) = Note (f d) x+f <$$> (Rest d) = Rest (f d)++-- For mapping primitive musical elements (i.e. 'Note' and 'Rest').+(<$$$>) :: (Music a -> Music b) -> Music a -> Music b+f <$$$> (m :+: m') = (f <$$$> m) :+: (f <$$$> m')+f <$$$> (m :=: m') = (f <$$$> m) :=: (f <$$$> m')+f <$$$> m = f m++instance Foldable Music where+ foldMap f (m :+: m') = foldMap f m <> foldMap f m'+ foldMap f (m :=: _) = foldMap f m+ foldMap f (Note _ a) = f a+ foldMap _ _ = mempty++instance Enum FullPitch where+ fromEnum ((pc,oct),_) = fromEnum oct * mOct + fromEnum pc+ toEnum i = ((toEnum (i `mod` mOct), toEnum (i `div` mOct)),[])+mOct :: Int+mOct = fromEnum (maxBound :: Octave)++-- | Core 'Music' datatype.+type MusicCore = Music FullPitch++-- | To allow playback, exporting to MIDI and rendering scores, all user-defined+-- abstractions must be convertible to 'MusicCore'.+class ToMusicCore a where+ toMusicCore :: Music a -> MusicCore++-- | 'FullPitch' is defined as the core music type,+-- so this instance doesn't change anything.+instance ToMusicCore FullPitch where+ toMusicCore = id++instance ToMusicCore Pitch where+ toMusicCore = fmap (\p -> (p, def))++instance ToMusicCore AbsPitch where+ toMusicCore = toMusicCore . fmap (\i -> (toEnum i :: Pitch, def :: [PitchAttribute]))++instance ToMusicCore Duration where+ toMusicCore = toMusicCore . fmap (const (def :: Pitch))++instance ToMusicCore PitchClass where+ toMusicCore = fmap (\pc -> ((pc, def), def))++instance ToMusicCore a => ToMusicCore [a] where+ toMusicCore (m :+: m') = toMusicCore m :+: toMusicCore m'+ toMusicCore (m :=: m') = toMusicCore m :=: toMusicCore m'+ toMusicCore (Note d ps) = toMusicCore $ chord $ Note d <$> ps+ toMusicCore (Rest d) = Rest d++-- Default values.+instance Default PitchClass where+ def = C+instance Default Octave where+ def = Oct4+instance {-# OVERLAPS #-} Default Duration where+ def = 1++-- Bounded enumeration of 'Music' datatypes.+instance Enum Pitch where+ toEnum n = (safeToEnum pc, safeToEnum oct)+ where (oct, pc) = n `divMod` 12++ fromEnum (pc, oct) = 12 * fromEnum oct + fromEnum pc++class (Eq a, Enum a, Bounded a) => BoundEnum a where+ -- | Safely convert from 'Int', respecting bounds.+ safeToEnum :: Int -> a+ safeToEnum = toEnum . min top . max bottom+ where top = fromEnum (maxBound :: a)+ bottom = fromEnum (minBound :: a)++ -- | Get next value or min/max if out-of-bounds.+ next :: a -> a+ next = safeToEnum . (+ 1) . fromEnum++ -- | Get previous value or min/max if out-of-bounds.+ prev :: a -> a+ prev = safeToEnum . subtract 1 . fromEnum++ -- | Move n-times forward.+ moveN :: Int -> a -> a+ moveN n a | n < 0 = iterate prev a !! abs n+ | otherwise = iterate next a !! n++ -- | Variant of 'prev' that cycles forth to the maximum.+ prev_ :: Eq a => a -> a+ prev_ a | a == minBound = maxBound+ | otherwise = prev a++ -- | Variant of 'next' that cycles back to the minimum.+ next_ :: Eq a => a -> a+ next_ a | a == maxBound = minBound+ | otherwise = next a++ -- | Cycle n-times forward.+ moveN_ :: Eq a => Int -> a -> a+ moveN_ n a | n < 0 = iterate prev_ a !! abs n+ | otherwise = iterate next_ a !! n++instance (Eq a, Enum a, Bounded a) => BoundEnum a where++-- Useful shorthands.+line, chord, scale, parallel :: [Music a] -> Music a+line = foldr1 (:+:)+chord = foldr1 (:=:)+scale = line+parallel = chord++-- TODO handle deeper nesting+voices :: Music a -> [Music a]+voices (m :=: m') = m : voices m'+voices m = [m]++notes :: Music a -> [a]+notes (m :+: m') = notes m ++ notes m'+notes (m :=: m') = notes m ++ notes m'+notes (Note _ m) = [m]+notes (Rest _) = []++flatten :: Music (Music a) -> Music a+flatten (m :+: m') = flatten m :+: flatten m'+flatten (m :=: m') = flatten m :=: flatten m'+flatten (Note _ m) = m+flatten (Rest d) = Rest d++harmonyToMelody :: Harmony -> Melody+harmonyToMelody (m :+: m') = harmonyToMelody m :+: harmonyToMelody m'+harmonyToMelody (m :=: m') = harmonyToMelody m :=: harmonyToMelody m'+harmonyToMelody (Note d xs) = chord (Note d <$> xs)+harmonyToMelody (Rest d) = Rest d++absPitch :: Pitch -> AbsPitch+absPitch = fromEnum+pitch :: AbsPitch -> Pitch+pitch = toEnum
+ src/Music/Utilities.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Music.Utilities+ ( Abstract (..)+ , mode+ , line, chord+ ) where++import Music.Transformations+import Music.Types++-- | Represents abstractions of certain music elements.+-- e.g. Abstract AbstractChord Pitch Chord+class Abstract rep -- type of the abstract representation+ a -- value needed to instantiate a `rep`+ inst -- instantiated type+ where+ instantiate :: a -> rep -> inst++-- | Covers both 'Chord' and 'Scale'.+instance Abstract [Interval] Pitch [Pitch] where+ instantiate p rep = [p ~> i | i <- rep]++instance Abstract [Interval] PitchClass [PitchClass] where+ instantiate p rep = [p ~~> if i - P8 > P1 then i - P8 else i | i <- rep]++instance Abstract Interval PitchClass PitchClass where+ instantiate p rep = p ~> rep++instance (Functor f, Abstract rep a inst) => Abstract rep (f a) (f inst) where+ instantiate ma rep = (`instantiate` rep) <$> ma++-- Aliases.+mode :: Int -> AbstractChord -> AbstractChord+mode = invertN
+ src/Utils/Peano.hs view
@@ -0,0 +1,48 @@+{-# language GADTs #-}+{-# language DataKinds #-}++{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++-- | Can be used to encode natural numbers as types.++module Utils.Peano (+ Nat (..)+ , SNat (..)+ , derivePeanoAliases+ , toInt+ , toNat+) where++import Language.Haskell.TH++-- | Singleton definition for `Nat`+data SNat n where+ SZ :: SNat Z+ SS :: SNat n -> SNat (S n)++-- | Typelevel Peano numbers.+data Nat = Z -- ^ Zero+ | S Nat -- ^ Successor+instance Show Nat where+ show = ("D"++) . show . toInt++-- | Derives type aliases D0, D1, ..., DX, where Da is equivalent to the decimal+-- number a, written as a Peano number.+derivePeanoAliases :: Integer -- ^ X, the maximum decimal type alias.+ -> Q [Dec]+derivePeanoAliases nr = do+ let tAliasNames = map (mkName . ("D"++) . show) [0..nr]+ let ts = zip tAliasNames (tAliases nr)+ mapM (\(n,t) -> tySynD n [] (return t)) ts+ where tAliases n = reverse (foldr nextIter [ConT (mkName "Z")] [0..n])+ nextIter _ b = (AppT (ConT (mkName "S")) (head b)) : b++-- | Converts a `Nat` to its `Int` representation.+toInt :: Nat -> Int+toInt Z = 0+toInt (S x) = 1 + (toInt x)++-- | Converts an `Int` to its `Nat` representation.+toNat :: Int -> Nat+toNat 0 = Z+toNat n = S (toNat (n-1))
+ src/Utils/Vec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+-- Suppress all unused TH-generated type aliases.+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++-- | Vector with its length encoded in the type.++module Utils.Vec (+ module Utils.Vec+ , module Utils.Peano+) where++import Prelude hiding (pred)+import Utils.Peano+import Data.Monoid ((<>))++-- | Vector with length encoded in its type using `Nat`.+data Vec n a where+ Nil :: Vec Z a + (:.) :: a -> Vec n a -> Vec (S n) a+infixr 4 :.++instance Eq a => Eq (Vec n a) where+ Nil == Nil = True+ (x :. xs) == (y :. ys) = x == y && xs == ys++instance Functor (Vec n) where+ fmap _ Nil = Nil+ fmap f (x:.xs) = f x :. fmap f xs++instance Foldable (Vec n) where+ foldMap _ Nil = mempty+ foldMap f (x:.xs) = f x <> foldMap f xs++instance Show a => Show (Vec n a) where+ show = show . list++-- | Converts a list to a `Vec`.+list :: Vec n a -> [a]+list = foldr (:) []++-- | Converts a `Vec` to a list.+vec :: SNat n -> [a] -> Vec n a+vec SZ [] = Nil+vec (SS n) (x:xs) = x :. (vec n xs)+vec _ _ = error "Given SNat is different than the length of the given list."++-- Derives type aliases D0, D1, ..., D100, where Da is equivalent to the+-- integer a, written as a `Nat`. This enables the user to write+-- Vec D3 Int`, instead of `Vec ('S ('S ('S 'Z))) Int`.+$(derivePeanoAliases 100)
+ test/GenSetup.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+module GenSetup+ ( genScale+ , genChord+ , genMelody+ , genNote+ , genPitch+ , genDur+ , generate+ ) where++import Data.DeriveTH+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen++import Music++-- | Automatically derive 'Arbitrary' instances.+derive makeArbitrary ''PitchClass+derive makeArbitrary ''Octave+derive makeArbitrary ''Music+derive makeArbitrary ''Interval++-- | Simple generators.+genScale :: Gen AbstractScale+genScale = elements+ [ major, pentatonicMajor, ionian, dorian, phrygian, lydian, mixolydian, aeolian+ , locrian, minor, harmonicMinor, melodicMinor, pentatonicMinor, blues+ , bebopDominant, bebopDorian, bebopMajor, bebopMelodicMinor, bebopHarmonicMinor+ , altered, wholeTone, halfDiminished, flamenco+ ]++genChord :: Gen AbstractChord+genChord = elements+ [ maj, mi, dim, aug, sus4, d7sus4, maj6, m6, maj7, m7, d7, dim7, m7b5+ , maj9, m9, d9, d7b5, d7s5, d7b9, d7s9, d7b5b9, d7b5s9, d7s5b9, d7s5s9+ ]++genMelody :: Gen Melody+genMelody = line <$> listOf1 genNote++genNote :: Gen Melody+genNote = (<|) <$> genPitch <*> genDur++genPitch :: Gen Pitch+genPitch = (,) <$> arbitrary <*> arbitrary++genDur :: Gen Duration+genDur = elements [1%16,1%8,1%4,1%2]
+ test/Spec.hs view
@@ -0,0 +1,19 @@+import Test.Framework (defaultMain)++import TGrammar (grammarTests)+import TMidi (midiTests)+import TMusic (musicTests)+import TScore (scoreTests)+import TVec (vecTests)+import TGenerate (genTests)+import TChaos (chaosTests)++main :: IO ()+main = defaultMain [ musicTests+ , scoreTests+ , midiTests+ , vecTests+ , grammarTests+ , genTests+ , chaosTests+ ]
+ test/TChaos.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE GADTs #-}++module TChaos where++import Control.Monad.Trans.State+import qualified Generate as Gen+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit hiding (Test)+import Utils.Vec++-- | Tests if the Chaos function correctly updates every iteration.+chaosTests :: Test+chaosTests = testGroup "Chaos"+ [ testCase "chaos1" $ do+ let mapping = Gen.defaultMapping {Gen.pcSel=Gen.chaos1Selector, Gen.octSel=Gen.chaos1Selector}+ (_, genState) <- runStateT Gen.bSolo (Gen.chaosState Gen.chaos1 mapping)+ let chaosState = Gen.state genState+ let ds = Gen.variables chaosState+ case Gen.updateFunctions chaosState of+ (f :. Nil) -> do+ let expectedVs = [ -1.0+ , -0.9521+ , -0.7695677377609997+ , -0.15610097331134187+ , 0.9524321761768165+ , -0.7708027147284231+ , -0.15981449614634702+ , 0.9501420518882291+ , -0.7622971584238392+ , -0.1343593712063227+ ]+ let actualVs = reverse+ $ snd+ $ foldr (\_ (d',vs) -> (f d' :. Nil, f d' : vs)) (ds, []) [(1 :: Int)..10]+ actualVs @?= expectedVs+ ]
+ test/TGenerate.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TemplateHaskell #-}++module TGenerate where++import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import System.IO.Unsafe (unsafePerformIO)+import Test.HUnit++import Generate hiding (melodyInC)+import Generate.QuickCheck+import Music+import Data.Ratio+import qualified Data.Music.Lilypond as Ly++import Control.Monad++ioFromGen = runGenerator (quickCheckState ())++genTests = testGroup "Generate"+ [ testCase "genNote yields a single note" $+ let res = ioFromGen (genNote)+ in (countNotes $ unsafePerformIO res) == 1 @? "unexpected note count",+ testCase "replicate generators yields correct number of results" $+ let res = ioFromGen (replicateM 10 genNote)+ in (countNotes (line $ unsafePerformIO res) == 10) @? "unexpected note count",+ testCase "pitchClass constraint" $+ let res = ioFromGen melodyInC+ in (all (inC . fst) $ unsafePerformIO res) @? "found notes not in the key of C"+ ]++instance Monoid Int where+ mappend = (+)+ mempty = 0++countNotes :: Melody -> Int+countNotes = foldMap (const 1)++melodyInC :: MusicGenerator (GenState ()) Melody+melodyInC = do+ addConstraint pitchClass inC+ notes <- replicateM 20 genNote+ return $ line notes++inC :: PitchClass -> Bool+inC pc = elem pc [C, D, E, F, G, A, B]++inG :: PitchClass -> Bool+inG pc = elem pc [G, A, B, C, D, E, Fs, G]
+ test/TGrammar.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module TGrammar where++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++import Grammar+import Music++data LK = L | K deriving (Eq, Show)++data Flip = Flip deriving (Eq, Show)++lkGrammar :: Grammar Flip LK+lkGrammar = L |:+ [ (L, 1, (== wn)) :-> \t -> Let (K:%:t/4 :-: L:%:t/4) (\x -> x :-: x)+ , (L, 1, (== qn)) :-> \t -> Flip |$: (L:%:t/2 :-: K:%:t/2)+ ]++instance Expand () LK Flip LK where+ expand () (m :-: m') = (:-:) <$> expand () m <*> expand () m'+ expand () (Aux _ Flip (m :-: m')) = (:-:) <$> expand () m' <*> expand () m+ expand () (Aux _ _ m) = expand () m+ expand () (x :%: d) = return $ x :%: d+ expand _ _ = error "Expand: let-expressions exist"++grammarTests :: Test+grammarTests = testGroup "Grammar"+ [ testCase "LK-grammar" $ do+ fin <- runGrammar lkGrammar wn ()+ fin @?= ((K<|qn :+: (K<|en :+: L<|en)) :+: (K<|qn :+: (K<|en :+: L<|en)))+ ]
+ test/TMidi.hs view
@@ -0,0 +1,182 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TMidi where++import Codec.Midi (importFile)+import Control.Applicative ((<|>))+import qualified Data.ByteString as B+import Data.Char (toUpper)+import Data.List (find, intersect, sort)+import qualified Euterpea as E+import Euterpea.IO.MIDI (fromMidi)+import System.Directory (doesFileExist, removeFile)+import System.IO.Unsafe (unsafePerformIO)+import System.Random (newStdGen, randomRs)+import Test.Framework (Test, buildTestBracketed,+ testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=), Assertion)+import Text.Printf (printf)++import Export+import Grammar hiding ((<|>))+import Music++-- | Generates a random filename `f` with the .midi extension, runs the given+-- test `t` using that filename, and immediately removes the file stored at+-- location `f` after the test finished. The reason that we have to generate+-- random file names and cannot use the same one all the time is that tests+-- can be exectued concurrently.+testAndCleanup :: (String -> Test) -> Test+testAndCleanup t = buildTestBracketed $ do+ g <- newStdGen+ let f = take 8 (randomRs ('a','z') g) ++ ".midi"+ let test = t f+ let cleanup = removeFile f+ return (test, cleanup)++midiTests :: Test+midiTests = testGroup "MIDI export"+ [ testAndCleanup $ \f -> testCase "Successfully write to file" $ do+ let res = unsafePerformIO $ do+ let ?harmonyConfig = defHarmonyConfig+ let ?melodyConfig = defMelodyConfig+ let ?midiConfig = defaultMIDIConfig+ (back, fore) <- integrate (16 * wn)+ writeToMidiFile f (back :=: fore)+ doesFileExist f+ res @?= True++ -- Check if the header is correct (HCodecs (which is used by Euterpea))+ -- doesn't check MIDI headers properly.+ , testAndCleanup $ \f -> testCase "Correct Midi header" $ do+ {- See: https://www.csie.ntu.edu.tw/~r92092/ref/midi/++ 4D546864 = "MThd", which represents the start of a MIDI header chunk.+ 00000006 = length of the actual header chunk. This is always 6 bytes.+ 000100000060 = The six byte long header chunk. Can be subdivided in:+ 0001 = MIDI file format. Should be 0,1 or 2. 1 means that there+ is only 1 track and that everything is played concurrently.+ 0000 = The number of track chunks. Should be 0 obviously, since+ our music only consists of a rest.+ 0060 = Speed. hex 0060 = bin 0-000000001100000. Here, the most+ significant bit says that the unit of speed is ticks per+ quarternote. The last 15 bits are the number of ticks,+ so 96 in decimal.++ -}+ let midiHex = "4D546864-00000006-000100000060"+ let m = Rest 0 :: Music Chord+ let byteString = unsafePerformIO $ do+ let ?midiConfig = defaultMIDIConfig+ writeToMidiFile f m+ B.readFile f+ let hex = concatMap (printf "%02x") (B.unpack byteString)+ let upperHex = map toUpper hex+ upperHex @?= filter ('-'/=) midiHex++ , testCase "Sequential music to Euterpea" $ do+ let ?midiConfig = MIDIConfig (1%2) [AcousticGrandPiano]+ let m = toMusicCore $ C#4<|qn :+: Cs#3<|hn+ let mE = musicToE m+ let mEExpected = E.Modify (E.Tempo (1 % 2)) (+ E.Modify (E.Instrument AcousticGrandPiano) (+ E.Prim (E.Note (1 % 4) ((E.C,4),[]))+ E.:+:+ E.Prim (E.Note (1 % 2) ((E.Cs,3),[]))+ )+ )+ mE @?= mEExpected++ , testCase "Parallel music to Euterpea" $ do+ let ?midiConfig = MIDIConfig (1%4) [Piccolo]+ let m = toMusicCore $ G#1<|qn :=: Ds#6<|hn+ let mE = musicToE m+ let mEExpected = E.Modify (E.Tempo (1 % 4)) (E.Modify (E.Instrument Piccolo) (+ E.Prim (E.Note (1 % 4) ((E.G,1),[]))+ ))+ E.:=:+ E.Modify (E.Tempo (1 % 4)) (E.Modify (E.Instrument Piccolo) (+ E.Prim (E.Note (1 % 2) ((E.Ds,6),[]))+ ))+ mE @?= mEExpected++ , testAndCleanup $ \f -> testCase "Sequential music to Midi and back" $ do+ let ?midiConfig = defaultMIDIConfig+ let m = toMusicCore $ C#4<|qn :+: Cs#3<|hn+ let mE1 = musicToE m+ unsafePerformIO $ do+ writeToMidiFile f m+ mE2 <- importFile f >>= \(Right m') -> return (fromMidi m')+ return $ compareMusic1s (preprocess mE1) (preprocess (preprocess mE2))++ , testAndCleanup $ \f -> testCase "Parallel music to Midi and back" $ do+ let ?midiConfig = MIDIConfig 1 [AcousticGrandPiano, Banjo]+ let m = toMusicCore $ G#1<|qn :=: Ds#6<|hn+ let mE1 = musicToE m+ unsafePerformIO $ do+ writeToMidiFile f m+ mE2 <- importFile f >>= \(Right m) -> return (fromMidi m)+ return $ compareMusic1s (preprocess mE1) (preprocess (preprocess mE2))+ ]++-- | Rewrites the Music1 that was read from a MIDI file, preprocesses it,+-- permutes it, e.g. a :=: b is the same as b :=: a, and checks if there is at+-- least 1 permutation that is exactly equal to the original Music1.+compareMusic1s :: E.Music1 -> E.Music1 -> Assertion+compareMusic1s mOriginal mRead = do+ let mOriginalMs = commonModifiers [] mOriginal+ let mOriginal' = stripModifiers mOriginalMs mOriginal+ let mReadMs = commonModifiers [] mRead+ let mRead' = stripModifiers mReadMs mRead+ -- remove e.g. empty rests in iteration 1, rewrite in iteration 2.+ let mReadPreprocessed = preprocess $ preprocess mRead'+ let mReadPerms = perms mReadPreprocessed+ let (Just p) = find (mOriginal'==) mReadPerms <|> Just (head mReadPerms)+ (p, sort mReadMs) @?= (mOriginal', sort mOriginalMs)++commonModifiers :: [E.Control] -> E.Music1 -> [E.Control]+commonModifiers cs (E.Modify c m) = commonModifiers (c:cs) m+commonModifiers cs (a E.:=: b) = commonModifiers cs a `intersect` commonModifiers cs b+commonModifiers cs (a E.:+: b) = commonModifiers cs a `intersect` commonModifiers cs b+commonModifiers cs _ = cs++stripModifiers :: [E.Control] -> E.Music1 -> E.Music1+stripModifiers cs (E.Modify c m) | elem c cs = stripModifiers cs m+stripModifiers cs (E.Modify c m) | otherwise = E.Modify c (stripModifiers cs m)+stripModifiers cs (a E.:=: b) = stripModifiers cs a E.:=: stripModifiers cs b+stripModifiers cs (a E.:+: b) = stripModifiers cs a E.:+: stripModifiers cs b+stripModifiers _ x = x++perms :: E.Music1 -> [E.Music1]+perms (m1 E.:=: m2) = concatMap (\(m1',m2') -> [m1' E.:=: m2', m2' E.:=: m1']) (perms' m1 m2)+perms (m1 E.:+: m2) = concatMap (\(m1',m2') -> [m1' E.:+: m2']) (perms' m1 m2)+perms (E.Modify x (E.Modify y m)) = concatMap ops (perms m)+ where ops m' = [E.Modify x (E.Modify y m'), E.Modify y (E.Modify x m')]+perms (E.Modify x m) = map (E.Modify x) (perms m)+perms prim = [prim]++perms' :: E.Music1 -> E.Music1 -> [(E.Music1, E.Music1)]+perms' m1 m2 = [(m1',m2') | m1'<-perms m1, m2' <-perms m2]++-- | The data read from file is slightly differently formatted (rests with+-- duration 0 and some other stuff, so the preprocess function is called+-- on the Music1 that was generated by reading from a midi file, before+-- the Music1 can be compared to the original Music1.)+preprocess :: E.Music1 -> E.Music1+preprocess (E.Modify x m) = E.Modify x (preprocess m)+preprocess (n@(E.Prim (E.Note l1 _)) E.:=: (E.Prim (E.Rest l2) E.:+: m))+ | l1 == l2 = (preprocess n) E.:+: (preprocess m)+ | otherwise = (preprocess n) E.:=: (E.Prim (E.Rest l2) E.:+: (preprocess m))+preprocess (r@(E.Prim (E.Rest l)) E.:+: m) = if l == 0 then preprocess m else (r E.:+: (preprocess m))+preprocess (m E.:+: r@(E.Prim (E.Rest l))) = if l == 0 then preprocess m else ((preprocess m) E.:+: r)+preprocess (r@(E.Prim (E.Rest l)) E.:=: m) = if l == 0 then preprocess m else (r E.:=: (preprocess m))+preprocess (m E.:=: r@(E.Prim (E.Rest l))) = if l == 0 then preprocess m else ((preprocess m) E.:+: r)+preprocess (m1 E.:+: m2) = preprocess m1 E.:+: preprocess m2+preprocess (m1 E.:=: m2) = preprocess m1 E.:=: preprocess m2+preprocess (E.Prim (E.Rest l)) = E.Prim (E.Rest l)+preprocess (E.Prim (E.Note l (x, xs))) = E.Prim (E.Note l (x, filter notVol xs))+ where notVol (E.Volume _) = False+ notVol _ = True
+ test/TMusic.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+module TMusic where++import Control.Arrow ((>>>))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@?=))+import Test.QuickCheck ((==>))++import GenSetup+import Music++musicTests :: Test+musicTests = testGroup "Music"+ [ testGroup "Instances"+ [ testCase "Functor" $+ const (D#5) <$> line [C#4<|qn, D#2<|wn] @?= line [D#5<|qn, D#5<|wn]+ , testCase "Foldable" $+ let f a = [a]+ in foldMap f (line [C#4<|qn, D#2<|wn]) @?= [C#4, D#2]+ ]+ , testGroup "Transpose"+ [ testCase "a pitch class" $+ C ~> M3 @?= E+ , testCase "a pitch" $+ C#4 ~> M7 @?= B#4+ , testCase "a note" $+ C#4 <|hn ~> M3 @?= E#4<|hn+ , testCase "a chord" $+ let a = chord $ C#4=|maj <|| def+ a' = chord $ C#5=|maj <|| def+ in a ~> P8 @?= a'+ , testCase "a sequence of chords" $+ let a = chord $ C#4=|maj7 <|| 1%8+ a' = chord $ Cs#4=|maj7 <|| 1%8+ b = chord $ Ds#4=|aug <|| def+ b' = chord $ E#4=|aug <|| def+ in line [a, b, a] ~> Mi2 @?= line [a', b', a']+ , testCase "a scale" $+ let a = scale $ C#4+|minor <|| def+ a' = scale $ B#4+|minor <|| def+ in a ~> M7 @?= a'+ , testCase "a sequence of scales" $+ let a = line $ C#4+|blues <|| 1%8+ a' = line $ Cs#4+|blues <|| 1%8+ b = line $ Ds#4+|harmonicMinor <|| def+ b' = line $ E#4+|harmonicMinor <|| def+ in line [a, b, a] ~> Mi2 @?= line [a', b', a']+ , testProperty "identityUp" $ \(p :: Pitch) (d :: Duration) ->+ p<|d ~> P1 == p<|d+ , testProperty "identityDown" $ \(p :: Pitch) (d :: Duration) ->+ p<|d <~ P1 == p<|d+ , testProperty "commutativeUp" $+ \(p :: Pitch) (m :: Interval) (n :: Interval) (d :: Duration) ->+ ((~> m) >>> (~> n)) (p<|d) == ((~> n) >>> (~> m)) (p<|d)+ , testProperty "commutativeDown" $+ \(p :: Pitch) (m :: Interval) (n :: Interval) (d :: Duration) ->+ ((<~ m) >>> (<~ n)) (p<|d) == ((<~ n) >>> (<~ m)) (p<|d)+ , testProperty "erasure" $+ \(p :: Pitch) (m :: Interval) (d :: Duration) ->+ fromEnum p + fromEnum m <= fromEnum (maxBound :: Pitch) ==>+ ((~> m) >>> (<~ m)) (p<|d) == (p<|d)+ ]+ , testGroup "Invert"+ [ testCase "absolute pitches" $+ invert ([0, 10, -20] :: [AbsPitch]) @?= [0, -10, 20]+ , testCase "a melody" $+ let melody = line [C#4<|hn, E#2<|wn, C#3<|en]+ melody' = line [C#4<|hn, Gs#5<|wn, C#5<|en]+ in invert melody @?= melody'+ , testCase "a chord" $+ invert maj7 @?= [P1, Mi3, P5, Mi6]+ , testProperty "a diminished chord" $ \n -> n > 0 ==>+ invertN n dim7 == dim7+ , testCase "a scale" $+ mode vi ionian @?= minor+ , testProperty "scale orbit" $ do+ sc <- genScale+ return $ or [invertN n sc == sc | n <- [5..9]]+ , testProperty "chord orbit" $ do+ ch <- genChord+ return $ length ch < 5 ==> or [invertN n ch == ch | n <- [4, 5]]+ ]+ , testGroup "Retro"+ [ testCase "a melody" $+ (line [C#4<|hn, (wn~~), Gs#4<|en] ><) @?=+ line [Gs#4<|en, (wn~~), C#4<|hn]+ , testCase "a chord" $+ (chord (C#4=|maj <||wn) ><) @?= chord (C#4=|maj <||wn)+ , testCase "a scale" $+ (scale (C#4+|major <||sn) ><) @?=+ line (reverse [C, D, E, F, G, A, B]<#4<||sn)+ ]+ , testGroup "Repeat"+ [ testCase "a single note" $+ let note = C#4<|wn+ in 4 ## note @?= note :+: note :+: note :+: note+ , testCase "a piece of music" $+ let piece = line $ chord <$> [c, c', c']+ c = Cs#4=|maj7 <|| def+ c' = db#3=|m7b5 <|| def+ in 3 ## piece @?= piece :+: piece :+: piece+ ]+ , testGroup "Scaling time"+ [ testCase "to smaller single duration" $+ 2 *~ hn @?= qn+ , testCase "to bigger single duration" $+ 1%2 *~ sn @?= en+ , testCase "a melody" $+ 1%4 *~ C#4<|en :+: C#3<|sn @?= C#4<|hn :+: C#3<|qn+ , testCase "a chord" $+ 4 *~ chord (C#4=|maj <||wn) @?= chord (C#4=|maj <||qn)+ , testCase "a scale" $+ 1%4 *~ scale (eb#2+|bebopDorian <||qn) @?= scale (eb#2=|bebopDorian <||wn)+ ]+ , testGroup "Other"+ [ testCase "toList" $+ musicToList (C#4<|hn :+: (wn~~) :+: C#5<|qn) @?=+ [(Just $ C#4, hn), (Nothing, wn), (Just $ C#5, qn)]+ , testCase "fromList" $+ listToMusic [(Just $ C#4, hn), (Nothing, wn), (Just $ C#5, qn)] @?=+ (C#4<|hn :+: (wn~~) :+: C#5<|qn)+ , testCase "normalize" $+ let m = (wn~~) :: Melody+ in normalize ((m :+: m) :+: m) @?= m :+: m :+: m+ ]+ ]
+ test/TScore.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ScopedTypeVariables #-}+module TScore where++import qualified Data.Music.Lilypond as Ly+import Data.Ratio+import System.Directory (doesFileExist, removeFile)+import System.IO.Unsafe (unsafePerformIO)+import System.Random (newStdGen, randomRs)+import Test.Framework (Test, buildTestBracketed,+ testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++import Export+import Grammar+import Music+++testAndCleanup :: (String -> Test) -> Test+testAndCleanup t = buildTestBracketed $ do+ g <- newStdGen+ let f = take 8 (randomRs ('a','z') g) ++ ".ly"+ let test' = t f+ let cleanup = removeFile f+ return (test', cleanup)++scoreTests :: Test+scoreTests = testGroup "Score"+ [ testAndCleanup $ \t -> testCase "successfully write to file" $ do+ let res = do let ?harmonyConfig = defHarmonyConfig+ let ?melodyConfig = defMelodyConfig+ let ?tablaBeat = sn+ m <- runGrammar tabla wn ()+ -- (back, fore) <- integrate (4 * wn)+ _ <- writeToLilypondFile t m+ doesFileExist t+ unsafePerformIO res @?= True,+ testCase "Split a note duration into powers of 2" $+ splitDurations (11 % 16) @?= [1%2, 1%8, 1%16],+ testCase "Correctly tie notes while generating score" $+ musicToLilypond ((C#4 <: []) <| (11%16)) @?=+ Ly.Sequential+ [+ Ly.Note (+ Ly.NotePitch+ Ly.Pitch {Ly.getPitch = (Ly.C,0,5)}+ Nothing)+ (Just+ Ly.Duration+ {Ly.getDuration = 1 % 2}+ )+ [Ly.Tie],+ Ly.Note (+ Ly.NotePitch+ Ly.Pitch {Ly.getPitch = (Ly.C,0,5)}+ Nothing)+ (Just+ Ly.Duration+ {Ly.getDuration = 1 % 8}+ )+ [Ly.Tie],+ Ly.Note (+ Ly.NotePitch+ Ly.Pitch+ {Ly.getPitch = (Ly.C,0,5)}+ Nothing)+ (Just+ Ly.Duration+ {Ly.getDuration = 1 % 16}+ )+ []+ ]+ ]
+ test/TVec.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# language DataKinds #-}+module TVec where++import Utils.Vec+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++len :: Vec n a -> Integer+len v = foldr (\_ -> (1+)) 0 v++addElem :: a -> Vec n a -> Vec (S n) a+addElem a v = a :. v++sameElems :: Eq a => Vec n a -> [a] -> Bool+sameElems Nil [] = True+sameElems (y:.ys) (x:xs) = x == y && sameElems ys xs+sameElems _ _ = False++-- Since it's pretty much impossible to generate arbitrary Vecs that have+-- their length encoded in their type, only some hardcoded Vecs are tested.+vecTests :: Test+vecTests = testGroup "Vec"+ [ testCase "0-elem vec length" $+ len v0 @?= 0+ , testCase "0-elem vec list length" $+ length (list v0) @?= 0+ , testCase "0-elem vec list same elems" $+ sameElems v0 [] @?= True+ , testCase "0-elem vec addElem" $+ (addElem 1 v0) @?= v1++ , testCase "1-elem vec length" $+ len v1 @?= 1+ , testCase "1-elem vec list length" $+ length (list v1) @?= 1+ , testCase "1-elem vec list same elems" $+ sameElems v1 [1] @?= True+ , testCase "1-elem vec addElem" $+ addElem 2 v1 @?= v2++ , testCase "2-elem vec length" $+ len v2 @?= 2+ , testCase "2-elem vec list length" $+ length (list v2) @?= 2+ , testCase "2-elem vec list same elems" $+ sameElems v2 [2,1] @?= True+ , testCase "2-elem vec addElem" $+ addElem 3 v2 @?= v3+ ]+ where v0 = Nil :: Vec D0 Int+ v1 = 1 :. Nil+ v2 = 2 :. 1 :. Nil+ v3 = 3 :. 2 :. 1 :. Nil