diff --git a/AlgoRhythm.cabal b/AlgoRhythm.cabal new file mode 100644 --- /dev/null +++ b/AlgoRhythm.cabal @@ -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 +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +1. `stack setup` +2. `stack build` +3. `stack exec music-exe` or `stack test` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/src/Dynamics.hs b/src/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/Dynamics.hs @@ -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)) diff --git a/src/Export.hs b/src/Export.hs new file mode 100644 --- /dev/null +++ b/src/Export.hs @@ -0,0 +1,7 @@ +module Export + ( module Export.MIDI + , module Export.Score + ) where + +import Export.MIDI +import Export.Score diff --git a/src/Export/MIDI.hs b/src/Export/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/Export/MIDI.hs @@ -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 diff --git a/src/Export/MIDIConfig.hs b/src/Export/MIDIConfig.hs new file mode 100644 --- /dev/null +++ b/src/Export/MIDIConfig.hs @@ -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] + } diff --git a/src/Export/Score.hs b/src/Export/Score.hs new file mode 100644 --- /dev/null +++ b/src/Export/Score.hs @@ -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] diff --git a/src/Generate.hs b/src/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Generate.hs @@ -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 diff --git a/src/Generate/Applications/ChaosPitches.hs b/src/Generate/Applications/ChaosPitches.hs new file mode 100644 --- /dev/null +++ b/src/Generate/Applications/ChaosPitches.hs @@ -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') diff --git a/src/Generate/Applications/Diatonic.hs b/src/Generate/Applications/Diatonic.hs new file mode 100644 --- /dev/null +++ b/src/Generate/Applications/Diatonic.hs @@ -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 + -} diff --git a/src/Generate/Applications/GenConfig.hs b/src/Generate/Applications/GenConfig.hs new file mode 100644 --- /dev/null +++ b/src/Generate/Applications/GenConfig.hs @@ -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 diff --git a/src/Generate/Chaos.hs b/src/Generate/Chaos.hs new file mode 100644 --- /dev/null +++ b/src/Generate/Chaos.hs @@ -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 diff --git a/src/Generate/Generate.hs b/src/Generate/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Generate/Generate.hs @@ -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 diff --git a/src/Generate/QuickCheck.hs b/src/Generate/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Generate/QuickCheck.hs @@ -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 diff --git a/src/Grammar.hs b/src/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Grammar.hs @@ -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 diff --git a/src/Grammar/Harmony.hs b/src/Grammar/Harmony.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/Harmony.hs @@ -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 + } diff --git a/src/Grammar/Integration.hs b/src/Grammar/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/Integration.hs @@ -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) diff --git a/src/Grammar/Melody.hs b/src/Grammar/Melody.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/Melody.hs @@ -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 + } diff --git a/src/Grammar/Tabla.hs b/src/Grammar/Tabla.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/Tabla.hs @@ -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] + ] diff --git a/src/Grammar/TonalHarmony.hs b/src/Grammar/TonalHarmony.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/TonalHarmony.hs @@ -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) diff --git a/src/Grammar/Types.hs b/src/Grammar/Types.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/Types.hs @@ -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' diff --git a/src/Grammar/UUHarmony.hs b/src/Grammar/UUHarmony.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/UUHarmony.hs @@ -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) diff --git a/src/Grammar/Utilities.hs b/src/Grammar/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/Utilities.hs @@ -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' diff --git a/src/Grammar/VoiceLeading.hs b/src/Grammar/VoiceLeading.hs new file mode 100644 --- /dev/null +++ b/src/Grammar/VoiceLeading.hs @@ -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) diff --git a/src/Music.hs b/src/Music.hs new file mode 100644 --- /dev/null +++ b/src/Music.hs @@ -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 diff --git a/src/Music/Constants.hs b/src/Music/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Music/Constants.hs @@ -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 diff --git a/src/Music/Operators.hs b/src/Music/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Music/Operators.hs @@ -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 diff --git a/src/Music/Transformations.hs b/src/Music/Transformations.hs new file mode 100644 --- /dev/null +++ b/src/Music/Transformations.hs @@ -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) diff --git a/src/Music/Types.hs b/src/Music/Types.hs new file mode 100644 --- /dev/null +++ b/src/Music/Types.hs @@ -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 diff --git a/src/Music/Utilities.hs b/src/Music/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Music/Utilities.hs @@ -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 diff --git a/src/Utils/Peano.hs b/src/Utils/Peano.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Peano.hs @@ -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)) diff --git a/src/Utils/Vec.hs b/src/Utils/Vec.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vec.hs @@ -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) diff --git a/test/GenSetup.hs b/test/GenSetup.hs new file mode 100644 --- /dev/null +++ b/test/GenSetup.hs @@ -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] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/TChaos.hs b/test/TChaos.hs new file mode 100644 --- /dev/null +++ b/test/TChaos.hs @@ -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 + ] diff --git a/test/TGenerate.hs b/test/TGenerate.hs new file mode 100644 --- /dev/null +++ b/test/TGenerate.hs @@ -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] diff --git a/test/TGrammar.hs b/test/TGrammar.hs new file mode 100644 --- /dev/null +++ b/test/TGrammar.hs @@ -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))) + ] diff --git a/test/TMidi.hs b/test/TMidi.hs new file mode 100644 --- /dev/null +++ b/test/TMidi.hs @@ -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 diff --git a/test/TMusic.hs b/test/TMusic.hs new file mode 100644 --- /dev/null +++ b/test/TMusic.hs @@ -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 + ] + ] diff --git a/test/TScore.hs b/test/TScore.hs new file mode 100644 --- /dev/null +++ b/test/TScore.hs @@ -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} + ) + [] + ] + ] diff --git a/test/TVec.hs b/test/TVec.hs new file mode 100644 --- /dev/null +++ b/test/TVec.hs @@ -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