packages feed

fadno (empty) → 1.1.0

raw patch · 10 files changed

+1611/−0 lines, 10 filesdep +Decimaldep +HUnitdep +basesetup-changed

Dependencies added: Decimal, HUnit, base, comonad, containers, data-default, deepseq, event-list, fadno, fadno-braids, fadno-xml, hspec, hspec-contrib, lens, midi, mtl, process, safe, split, text, unordered-containers, vector, xml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Stuart Popejoy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fadno.cabal view
@@ -0,0 +1,65 @@+name:                fadno+category:            Music+synopsis:            Minimal library for music generation and notation+version:             1.1.0+homepage:            http://github.com/slpopejoy/fadno+description:         Provides the Note type and HasNote class with polymorphic pitch and duration representations,+                     metering, barring and time signature utilities, plus midi and MusicXML support.+license:             BSD3+license-file:        LICENSE+author:              Stuart Popejoy+maintainer:          spopejoy@panix.com+build-type:          Simple+cabal-version:       >=1.10+source-repository head+  type:     git+  location: https://github.com/slpopejoy/fadno.git++library+  exposed-modules:+                  Fadno.Meter+                  Fadno.Midi+                  Fadno.Notation+                  Fadno.Note+                  Fadno.Util+                  Fadno.Xml+++  -- other-modules:+  -- other-extensions:+  build-depends:       Decimal == 0.4.*+                     , HUnit == 1.5.*+                     , base == 4.9.*+                     , containers == 0.5.*+                     , comonad == 5.*+                     , data-default == 0.7.*+                     , deepseq == 1.4.*+                     , event-list == 0.1.*+                     , fadno-braids == 0.1.*+                     , fadno-xml == 1.1.*+                     , lens == 4.15.*+                     , midi == 0.2.*+                     , mtl == 2.2.*+                     , process == 1.4.*+                     , safe == 0.3.*+                     , split == 0.2.*+                     , text == 1.2.*+                     , unordered-containers == 0.2.*+                     , vector == 0.12.*+                     , xml == 1.3.*+  hs-source-dirs: src+  default-language:    Haskell2010++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  hs-source-dirs: tests+  default-language:    Haskell2010+  build-depends:+                base+              , containers+              , HUnit+              , fadno+              , lens+              , hspec+              , hspec-contrib
+ src/Fadno/Meter.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+module Fadno.Meter where++import Fadno.Notation+import Fadno.Note+import Control.Lens hiding (Empty,pre)+import Data.Foldable+import Test.HUnit+import Data.Ratio+import GHC.Real+import Data.Maybe+import Data.List (sort,sortBy,nub)+import Data.Function+import Control.Arrow+import qualified Data.Map.Strict as M+import Safe+import Fadno.Util++type HasRatioNotes t n p = (Traversable t, HasNote n p Rational)++--+-- REBAR+--++-- | use 'rebar' with multiple input "bars".+rebars :: (HasRatioNotes b n p, HasRatioNotes c m p,Monoid p,Eq p,+           Monoid (c m), Monoid (b n),HasTimeSignature (c m),+           Snoc (c m) (c m) m m,HasTie m,Show (c m)) =>+          TimeSignature -> [b n] -> [c m]+rebars ts = rebar ts . mconcat++-- | Given a time signature and a "bar" (Traversable "b" of HasNotes "n"),+-- make new "bars" (Traversable "c" of HasNotes "m"),+-- partitioning notes, applying ties as needed,+-- and decorating with the time signature.+rebar :: (HasRatioNotes b n p, HasRatioNotes c m p,Monoid p,Eq p,Monoid (c m),+          HasTimeSignature (c m),Snoc (c m) (c m) m m,HasTie m,Show (c m)) =>+         TimeSignature -> b n -> [c m]+rebar ts = reverse . fixup . foldl' go [mempty] . fmap fromNote where+    tslen = tsToRatio ts+    go [] _ = error "impossible"+    go bss@(b:bs) n | barlen == tslen = go (mempty:bss) n+                    | newBarLen <= tslen = (b |> n):bs+                    | otherwise = {- trace1' "otherwise" (remaining, ndur) $ -} go ((b |> pre):bs) post+        where barlen = sumDurs b+              ndur = view noteDur n+              newBarLen = barlen + ndur+              remaining = newBarLen - tslen+              post = tieMay TStop . set noteDur remaining $ n+              pre = tieMay TStart . set noteDur (ndur - remaining) $ n+    -- fixup: set head and tail timesigs+    fixup [] = []+    fixup bs = over _head fixLast . joinLast . over _last (timeSignature ?~ ts) $ bs+    fixLast b | barlen == tslen = b+              | otherwise = case tsFromRatio' ts barlen of+                              Just t -> b & timeSignature ?~ t+                              Nothing -> b+              where barlen = sumDurs b+    -- joinLast: apply heuristic that an additional bar less than 1/2 the ts length+    -- should be merged with the prior bar.+    joinLast aas@(a:b:as) | sumDurs a + sumDurs b < tslen * (3%2) =+                              (b `mappend` a):as -- leave notes tied. why not.+                          | otherwise = aas+    joinLast a = a++++-- | 'rebar' using 'Bar' and 'Note\'' for output.+rebar' :: (HasRatioNotes b n p,Monoid p,Eq p,Show p) =>+          TimeSignature -> b n -> [Bar (Note' p Rational)]+rebar' = rebar++-- | 'rebars' using 'Bar' and 'Note\'' for output.+rebars' :: (HasRatioNotes b n p,Monoid (b n),Monoid p,Eq p,Show p) =>+           TimeSignature -> [b n] -> [Bar (Note' p Rational)]+rebars' = rebars++-- | Set tie if not a rest+tieMay :: (Eq a, Monoid a, HasNote s a d, HasTie s) => Tie -> s -> s+tieMay end v | isRest v = v+             | otherwise = over tie setTie v+             where setTie o@(Just old) | old == end = o+                                       | otherwise = Just TBoth+                   setTie Nothing = Just end++++--+-- TIE RULES+--++-- | Representable duration denominators.+--+-- For standard base-2 durs, 2 and 4 are spurious as they reduce to 1,+-- thus 1 plus the "dot values" 3,7.+--+-- For non-standard (quintuples etc), we admit 2 and 4 as well, for e.g. 2%5,+-- a "half-note" under a quarter-quintuple. Anything greater+-- exceeding the understanding limit: 8%17 can certainly be represented as+-- a half-note, but it makes little sense to the reader.+validDenoms :: [Integer]+validDenoms = [1,2,3,4,7]++-- | Max representable duration.+maxDur :: Rational+maxDur = 2++-- | Test for representational duration per 'validDenoms' and 'maxDur'.+validDur :: Rational -> Bool+validDur r = r == maxDur ||+             (r < maxDur && numerator r `elem` validDenoms)++-- | Tie rules that work across any denominators, such that+-- 5%8 -> [1%2,1%8], 9%16 -> [1%2,1%16],  11%16 -> [1%2,3%16],+-- 13%16 -> [3%2,1%16], 9%4 -> [2,1%4].+splitDur :: Rational -> [Rational]+splitDur r | r < 0 = error "splitDur: negative duration"+           | r == 0 = []+           | validDur r = [r]+           -- NB: subtraction doesn't preserve denom (17:%20 - 3%5 -> 1%4, not 5%20)+           | otherwise = split:splitDur (r - split)+           where split = findSplit r++-- | Find split by 1) finding largest power-of-2 fraction under value or+-- 2) finding longest power-of-two denominator split, up to 8.+findSplit :: Rational -> Rational+findSplit r = case filter validDur candidates of+                [] -> splitOnValid+                (v:_) -> v+    where+      n = numerator r+      d = denominator r+      pow2s = [x | p <- [(1 :: Integer)..], x<-[2^p]]+      denomPow2s = reverse $ takeWhile (\v -> v < d && d `rem` v == 0) pow2s+      candidates = filter (<r) $ map (\cd -> (n * cd `div` d) :% (d `div` cd)) denomPow2s+      splitOnValid = case filter (<= min r maxDur) $ map (:%d) $ reverse $+                     takeWhile (<min n 8) pow2s of+                       [] -> r+                       (v:_) -> v++-- | Apply rules in 'splitDur' and tie affected notes.+tieRules :: (HasRatioNotes b n p, HasTie n, Monoid p, Eq p, Show n,+             HasRatioNotes c m p, HasTie m, Monoid (c m),+             Snoc (c m) (c m) m m) => b n -> c m+tieRules = foldl' apply mempty where+    apply r n = case splitDur (view noteDur n) of+                       [] -> error $ "tieRules: empty result from splitDur for " ++ show n+                       [_] -> r |> set tie (view tie n) (fromNote n)+                       ds -> foldl (|>) r . fixLast . fixFirst . map mkTied $ ds+                           where mkTied d = tieMay TBoth (set noteDur d (fromNote n))+                                 forOrgTie t = case view tie n of+                                                 Nothing -> t+                                                 (Just a) | a == t -> t+                                                          | otherwise -> TBoth+                                 fixFirst = over (_head.tie) (fmap (const (forOrgTie TStart)))+                                 fixLast = over (_last.tie) (fmap (const (forOrgTie TStop)))++++-- | Monomorphic-result 'tieRules+tieRules' :: (HasRatioNotes b n p, HasTie n, Monoid p, Eq p, Show n) =>+             b n -> Bar (Note' p Rational)+tieRules' = tieRules+++--+-- SELECT TIMESIG+--++-- | Weights and pulse values for pre-configured TSs.+data TsConfig = TsConfig {+      _tSig :: TimeSignature+    , _tWeight :: Rational+    , _tPulse :: Rational+    } deriving (Eq,Show)+makeLenses ''TsConfig++selectTimeSig :: HasRatioNotes t n p => [t n] -> Maybe TimeSignature+selectTimeSig phrases = fmap fst $ headMay $ selectTimeSigs phrases++-- | Combine scores from phrases.+selectTimeSigs :: HasRatioNotes t n p => [t n] -> [(TimeSignature,Rational)]+selectTimeSigs = mergeScores . preferDivisableHeads . map selectTsConfigs where+    mergeScores = sortBy (flip compare `on` snd) .+                  M.toList . foldl1 (M.unionWith (+)) .+                  map (M.fromListWith max . map (_tSig &&& _tWeight))+++-- | nutty heuristic that overweights a TS for a uniform duration divisor+preferDivisableHeads :: [[TsConfig]] -> [[TsConfig]]+preferDivisableHeads [] = []+preferDivisableHeads [a] = [a]+preferDivisableHeads phraseTss =+    case sequence (map headMay phraseTss) of+      Nothing -> phraseTss+      Just heads | length (nub heads) == 1 -> phraseTss+                 | otherwise -> case nub $ (zipWith commonDivHeur <*> tail) (map tsConfigToDur heads) of+                      [] -> phraseTss+                      [a] -> maybe phraseTss ((:phraseTss).return) $ tsConfigFromDur 100 a+                      _ -> phraseTss++-- | main heuristic is finding the common divisible duration,+-- with requirement that it must be greater than 1/4 the difference between the durations.+-- Hopefully avoids crappy tiny TSs like 2/8.+commonDivHeur :: Rational -> Rational -> Rational+commonDivHeur d1 d2 | d1 == d2 = d1+                | c / (abs (d1 - d2)) > (1%4) = min d1 d2+                | otherwise = c+                where c = d1 / fromIntegral (numerator (d1/d2))+++tsConfigToDur :: TsConfig -> Rational+tsConfigToDur = tsToRatio . _tSig++++-- | Attempt to construct a TS config from duration+tsConfigFromDur :: Rational -> Rational -> Maybe TsConfig+tsConfigFromDur weight = fmap (\t -> TsConfig t weight (minMedianDur (_tsUnit t))) . tsFromRatio++-- | Pre-configured timesigs.+tsConfigs :: [TsConfig]+tsConfigs = [TsConfig (4/:Q4) 9 (1%4)+            ,TsConfig (3/:Q4) 8 (1%4)+            ,TsConfig (6/:Q8) 8 (3%8)+            ,TsConfig (12/:Q8) 7 (3%8)+            ,TsConfig (2/:Q4) 6 (1%4)+             ,TsConfig (5/:Q4) 5 (5%4)+             ,TsConfig (5/:Q8) 5 (5%8)+             ,TsConfig (7/:Q4) 5 (7%4)+            ,TsConfig (7/:Q8) 5 (7%8)+             ,TsConfig (9/:Q8) 5 (3%8)+            ]+++-- | Given a median note duration, minima for acceptable quanta.+minMedianDur :: Quanta -> Rational+minMedianDur q = fromMaybe (1%32) . lookup q $+                                   [(Q8,1%32),(Q4,1%16),(Q2,1%4)]++-- | Given a phrase, select configs+selectTsConfigs :: HasRatioNotes t n p => t n -> [TsConfig]+selectTsConfigs phrase | null phrase = []+                       | otherwise = sortBy (flip compare `on` _tWeight) $+                                     mapMaybe (evalTsConfig phrase)+                                     -- append custom-length TS as lowest-weight choice+                                     (maybe tsConfigs (:tsConfigs) (tsConfigFromDur 4 (sumDurs phrase)))++-- | Filter and score time signatures per heuristics.+evalTsConfig :: HasRatioNotes t n p => t n -> TsConfig -> Maybe TsConfig+evalTsConfig phrase c@(TsConfig ts@(TimeSignature _n q) _ pulse)+    | medianDur < minMedianDur q = Nothing -- density filter+    | phraseDur < tsDur = Nothing -- min duration filter+    | tsDur >= 2 = Nothing -- too long TS+    | phraseDur == tsDur = Just $ over tWeight (* (9%4)) c -- exact length match bonus,+    | otherwise = Just $ over tWeight computeWeight c+        where medianDur = sort (toListOf (traverse.noteDur) phrase) !! (phraseLength `div` 2)+              phraseLength = length phrase+              phraseDur = sumDurs phrase+              tsDur = tsToRatio ts+              -- scale by pulse coverage, subtract by divisibility by ts duration+              computeWeight w = (w * pulseCoverage pulse phrase) - (phraseDur `frem` tsDur)++-- | 'rem' for 'RealFrac'+frem :: RealFrac a => a -> a -> a+frem a b = let (_ :: Int,f) = properFraction (a/b) in f++isDivBy :: RealFrac a => a -> a -> Bool+isDivBy a b = 0 == frem a b++-- | Compute percentage of notes falling on pulse values.+pulseCoverage :: HasRatioNotes t n p => Rational -> t n -> Rational+pulseCoverage pulse phrase = fromIntegral pulseNoteCount % fromIntegral (length phrase)+    where+      pulseNoteCount = length . filter ((`isDivBy` pulse) . fst) . mapTime $ phrase
+ src/Fadno/Midi.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+++module Fadno.Midi where++import Sound.MIDI.File as MFile+import Data.EventList.Relative.TimeBody as EList hiding (concat,traverse)+import Sound.MIDI.File.Event as MEvent+import Sound.MIDI.File.Event.Meta as MMeta+import Sound.MIDI.Message.Channel as MChan+import Sound.MIDI.Message.Channel.Voice as MVoice+import Sound.MIDI.File.Load+import Sound.MIDI.File.Save+import Sound.MIDI.General+import Fadno.Note+import Data.List (mapAccumL)+import Control.Lens+import Control.Arrow+import System.Process+import Control.Monad+import Data.Ratio++-- | Serializable midi data.+type MidiData = MFile.T++type IPitch = Int+type IDur = Int++-- | Convert some note value to midi-ready values.+class MidiNotes a where+    toMidiNotes :: a -> [([IPitch],IDur)]++instance MidiNotes [([IPitch],IDur)] where toMidiNotes = id++instance {-# OVERLAPPING #-} (Integral p, Traversable c, Integral d, Traversable t) => MidiNotes (t (Note (c p) d))  where+    toMidiNotes = map ((map fromIntegral . toListOf traverse) *** fromIntegral) .+                  toListOf (traverse.toPair)++instance (Integral p, Integral d, Traversable t) => MidiNotes (t (Note p d))  where+    toMidiNotes = map (return.fromIntegral *** fromIntegral) . toListOf (traverse.toPair)+++-- | Tempo in microseconds per quarter. See 'fromBPM'.+newtype MidiTempo = MidiTempo Int+    deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)++-- | Midi channel, 1-16 presumably.+newtype MidiChan = MidiChan Int+    deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)++-- | note velocity, 0-127+newtype MidiVelocity = MidiVelocity Int+    deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)++-- | Midi program. See 'fromInstrument'.+newtype MidiProgram = MidiProgram Int+    deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)++-- | Midi ticks per quarter.+newtype MidiTicks = MidiTicks Int+    deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)++-- | Rational to ticks+toTicks :: MidiTicks -> Iso' Rational IDur+toTicks t = iso to' from' where+    to' = truncate . (* fromIntegral (t*4))+    from' = (% fromIntegral (t*4)) . fromIntegral+++-- | Internal type for midi event or pad.+data MidiEvent = Pad IDur | Event MEvent.T++-- | cover our tracks+type MidiTrack = Track+++-- | write to disk.+writeMidiFile :: FilePath -> MidiData -> IO ()+writeMidiFile = toFile++-- | debug midi file.+showMidiFile :: FilePath -> IO ()+showMidiFile = showFile++-- | Make midi file data+midi :: MidiTicks -> [MidiTrack] -> MidiData+midi ticks = MFile.Cons Parallel (Ticks (toTempo $ fromIntegral ticks))++-- | make a standard track which specifies tempo and program.+-- | see 'makeTrack' for more control.+makeTrackFull+  :: (MidiNotes notes) =>+     MidiTempo+     -> MidiChan+     -> MidiProgram+     -> MidiVelocity+     -> notes+     -> MidiTrack+makeTrackFull tempo chan prog vel notes =+    makeTrack $ setTempo tempo:+                programChange chan prog:+                toNoteEvents chan vel notes+++-- | BPM to microseconds per quarter note.+fromBPM :: (Real a, Show a) => a -> MidiTempo+fromBPM b | b > 0 = floor (60 * 1000000 / toRational b)+          | otherwise = error $ "fromBPM: must be > 0: " ++ show b++-- | convert a General MIDI 'Instrument'.+fromInstrument :: Instrument -> MidiProgram+fromInstrument = fromIntegral . fromEnum++-- | make a track from track events.+makeTrack :: [MidiEvent] -> MidiTrack+makeTrack = fromPairList . concat . snd . mapAccumL conv 0+    where conv :: IDur -> MidiEvent -> (IDur,[(ElapsedTime,MEvent.T)])+          conv _ (Pad dur) = (dur,[])+          conv off (Event e) = (0,[(toElapsedTime $ fromIntegral off,e)])+++-- | turn notes into track events.+toNoteEvents :: MidiNotes notes => MidiChan -> MidiVelocity -> notes -> [MidiEvent]+toNoteEvents chan vel = concatMap (noteEvents chan vel) . toMidiNotes+++-- | create a "Voice" MIDI event+voiceEvent :: MidiChan -> MVoice.T -> MidiEvent+voiceEvent chan = midiEvent chan . Voice++-- | tempo meta event.+setTempo :: MidiTempo -> MidiEvent+setTempo = metaEvent . SetTempo . toTempo . fromIntegral++-- | create a "Meta" MIDI event+metaEvent :: MMeta.T -> MidiEvent+metaEvent = Event . MetaEvent++-- | create a "Voice" or "Mode" MIDI event.+midiEvent :: MidiChan -> MChan.Body -> MidiEvent+midiEvent chan = Event . MIDIEvent . MChan.Cons (toChannel $ fromIntegral chan)++-- TODO: sysex.++-- | program change MIDI Voice event.+programChange :: MidiChan -> MidiProgram -> MidiEvent+programChange chan prog = voiceEvent chan (ProgramChange (toProgram $ fromIntegral prog))++-- | note on + note off events, using 'Pad' to carve out space.+noteEvents :: MidiChan -> MidiVelocity -> ([IPitch],IDur) -> [MidiEvent]+noteEvents chan vel (ps,dur) = evs noteOn ++ [Pad dur] ++ evs noteOff+    where evs f = map (f chan vel . fromIntegral) ps++-- TODO: figure out polymorphic way to attach velocity and anything else to notes.++-- | note on or note off event.+noteEvent :: (Pitch -> Velocity -> MVoice.T) ->+             MidiChan -> MidiVelocity -> IPitch -> MidiEvent+noteEvent f chan vel pitch = voiceEvent chan+                             (f (toPitch (fromIntegral pitch))+                                    (toVelocity $ fromIntegral vel))+noteOn :: MidiChan -> MidiVelocity -> IPitch -> MidiEvent+noteOn = noteEvent NoteOn++noteOff :: MidiChan -> MidiVelocity -> IPitch -> MidiEvent+noteOff = noteEvent NoteOff+++test1 :: IO ()+test1 = playMidi "/tmp/first.midi" 120 [(AcousticGrandPiano,+         map (uncurry Note)+                 [([60 :: Int],48 :: Int),([61],48),([62],24),([64],64),+                  ([],96),([60,66],96)])]+++playMidi :: MidiNotes n => FilePath -> Int -> [(Instrument,n)] -> IO ()+playMidi file bpm tracks = do+    writeMidiFile file $ midi 96 $ map (\(inst,notes) -> makeTrackFull (fromBPM bpm) 0 (fromInstrument inst) 127 notes) tracks+    void $ createProcess (shell $ "scripts/qt7play.applescript " ++ file)++++-- playMidi "/tmp/boston.mid" DrawbarOrgan notes+-- let boston = [Db@:5,F@:4,Db@:5,Eb@:5,Ab@:4,C@:5]+-- map (\p -> (p - 60) * 2 + 60)+-- let notes = concat $ replicate 8 $ map (`Note` (1 % 16)) boston+-- playMidi "/tmp/boston.mid" DrawbarOrgan 140+--    (toListOf (traverse.seconding (toTicks 96)) notes)
+ src/Fadno/Notation.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Fadno.Notation where++import GHC.Generics+import Data.String+import Data.Default+import Fadno.Note+import Control.Lens hiding (pre)+import Data.Typeable+import Data.Ratio+import Data.Sequence (Seq,fromList)+import Data.Foldable+import Test.HUnit+import Data.List+import Data.Maybe+++-- valid time sig denoms+data Quanta = Q2|Q4|Q8|Q16|Q32|Q64+               deriving (Eq,Show,Ord,Enum,Bounded,Typeable)++qToInt :: Quanta -> Int+qToInt = (2^) . succ . fromEnum+qFromInt :: Integral i => i -> Maybe Quanta+qFromInt = fmap toEnum . (`elemIndex` [2,4,8,16,32,64])+++data TimeSignature = TimeSignature { _tsLength :: Int, _tsUnit :: Quanta }+   deriving (Eq,Ord)+instance Show TimeSignature where+    show (TimeSignature l u) = show l ++ "/:" ++ show u+makeLenses ''TimeSignature+class HasTimeSignature a where timeSignature :: Lens' a (Maybe TimeSignature)++(/:) :: Int -> Quanta -> TimeSignature+(/:) = TimeSignature++-- PPQ: valid midi divisions, named after equivalent Quantum+-- as in, "1 means ..."; PQ4 is "1 means quarter note"+data PPQ = PQ4|PQ8|PQ16|PQ32|PQ64|PQ128|PQ256+         deriving (Eq,Show,Ord,Enum,Bounded)+++-- convert to midi division value+ppqDiv :: Integral a => PPQ -> a+ppqDiv = (2^) . fromEnum+++-- Compute duration of TS+tsToRatio :: TimeSignature -> Rational+tsToRatio (TimeSignature n d) = fromIntegral n % fromIntegral (qToInt d)++-- Derive TS from duration, with 1 denominator implying Q4+tsFromRatio :: Rational -> Maybe TimeSignature+tsFromRatio r = toTs (if d == 1 then 4 else (if n == 1 then 2 else 1))+    where toTs m = (fromIntegral (n * m) /:) <$> qFromInt (d * m)+          d = denominator r+          n = numerator r+++tsFromRatio' :: TimeSignature -> Rational -> Maybe TimeSignature+tsFromRatio' (TimeSignature _ src) = fmap adjust . tsFromRatio where+    adjust t@(TimeSignature n d) | src <= d = t+                                 | otherwise = (n * m) /: src+                                 where qd = qToInt d+                                       qs = qToInt src+                                       m = qs `div` qd+++-- | Duration iso, from Integral to Rational, given PPQ+ratioPPQ :: Integral a => PPQ -> Iso' a Rational+ratioPPQ p = iso toRat toInt where+    ppq4 = ppqDiv p * 4+    toRat i = fromIntegral i % fromIntegral ppq4+    toInt r = truncate (r * toRational ppq4)++-- | Adapt a type to its HasXXX "Maybe Lens'"+adaptHas :: Lens' a (Maybe a)+adaptHas f s = fromMaybe s <$> f (Just s)++-- | Adapt a non-Maybe lens to the HasXXX "Maybe Lens'"+adaptHasLens :: Lens' s a -> Lens' s (Maybe a)+adaptHasLens l f s = fmap (maybe s (\a -> set l a s)) (f (Just (view l s)))++-- | Adapt a type that does NOT support the HasXXX feature.+adaptHasNot :: Lens' s (Maybe a)+adaptHasNot f s = fmap (const s) (f Nothing)+++-- | Tied notes.+data Tie = TStart | TStop | TBoth+    deriving (Eq,Bounded,Enum,Ord,Show)+makeLenses ''Tie+class HasTie a where tie :: Lens' a (Maybe Tie)+instance HasTie Tie where tie = adaptHas+instance HasTie (Note p d) where tie = adaptHasNot+++-- | Slurred notes.+data Slur = SStart | SStop+    deriving (Eq,Bounded,Enum,Ord,Show)+makeLenses ''Slur+class HasSlur a where slur :: Lens' a (Maybe Slur)+instance HasSlur Slur where slur = adaptHas++-- | Note articulations.+data Articulation = Staccato | Accent+    deriving (Eq,Show,Bounded,Enum,Ord)+class HasArticulation a where articulation :: Lens' a (Maybe Articulation)+instance HasArticulation Articulation where articulation = adaptHas+++-- | Bar rehearsal mark.+newtype RehearsalMark = RehearsalMark { _rehearsalText :: String }+    deriving (Eq,Ord,IsString,Generic,Monoid,Default)+makeLenses ''RehearsalMark+instance Show RehearsalMark where show = show . _rehearsalText+class HasRehearsalMark a where rehearsalMark :: Lens' a (Maybe RehearsalMark)+instance HasRehearsalMark RehearsalMark where rehearsalMark = adaptHas++-- | Musical direction.+newtype Direction = Direction { _directionText :: String }+    deriving (Eq,Ord,IsString,Generic,Monoid,Default)+makeLenses ''Direction+instance Show Direction where show = show . _directionText+class HasDirection a where direction :: Lens' a (Maybe Direction)+instance HasDirection Direction where direction = adaptHas++-- | Barline.+data Barline = Double | Final+    deriving (Eq,Show,Ord,Generic)+class HasBarline a where barline :: Lens' a (Maybe Barline)+instance HasBarline Barline where barline = adaptHas++data Repeats = RStart | REnd | RBoth+    deriving (Eq,Show,Ord,Generic)+class HasRepeats a where repeats :: Lens' a (Maybe Repeats)+instance HasRepeats Repeats where repeats = adaptHas++data Clef = TrebleClef | BassClef | AltoClef | PercClef+    deriving (Eq,Show,Ord,Generic)+makeLenses ''Clef+class HasClef a where clef :: Lens' a (Maybe Clef)+instance HasClef Clef where clef = adaptHas+++-- | Part identifier, prefers 'Num' or 'IsString' values.+newtype Part a = Part { _partIdx :: a }+    deriving (Eq,Generic,Ord,Functor,Bounded,Foldable,Traversable,Real,Num,IsString)+makeLenses ''Part+instance (Show a) => Show (Part a) where show = show._partIdx+class HasPart a b | a -> b where part :: Lens' a (Maybe (Part b))++-- | Lensy show of a Maybe field, given a 'Getter' and its name.+mshow :: (Show a) => Getter s (Maybe a) -> String -> s -> String+mshow l n = maybe "" (\v -> " & " ++ n ++ " ?~ " ++ show v) . view l++-- | 'concatMap' show functions with a prelude.+mshows :: s -> String -> [s -> String] -> String+mshows s pre = (pre ++) . concatMap ($ s)++-- Example types.++-- | Note with notations.+data Note' p d = Note' {+      _nNote :: Note p d+    , _nTie :: Maybe Tie+    , _nSlur :: Maybe Slur+    , _nArticulation :: Maybe Articulation+    } deriving (Eq,Generic)++makeLenses ''Note'+instance HasNote (Note' p d) p d where+    note = nNote+    fromNote = note' . view note+instance HasTie (Note' p d) where tie = nTie+instance HasSlur (Note' p d) where slur = nSlur+instance HasArticulation (Note' p d) where articulation = nArticulation+instance (Show p, Show d) => Show (Note' p d) where+    show n = mshows n ("note' (" ++ show (view nNote n) ++ ")")+             [mshow tie "tie"+             ,mshow slur "slur"+             ,mshow articulation "articulation"+             ]+++-- | Note smart ctor, used in 'Show'.+note' :: Note p d -> Note' p d+note' n = Note' n Nothing Nothing Nothing++testNote :: Note' [Int] Int+testNote = note' ([60]|:2) & tie ?~ TStart & articulation ?~ Accent++-- | Bar as list of notes, with notations.+data Bar n = Bar {+      _bNotes :: Seq n+    , _bRehearsalMark :: Maybe RehearsalMark+    , _bDirection :: Maybe Direction+    , _bBarline :: Maybe Barline+    , _bRepeats :: Maybe Repeats+    , _bTimeSignature :: Maybe TimeSignature+    , _bClef :: Maybe Clef+    } deriving (Eq,Generic,Functor,Foldable,Traversable)+makeLenses ''Bar+instance Default (Bar n) where def = bar []+instance Snoc (Bar n) (Bar n) n n where+    _Snoc = prism (\(b,n) -> over bNotes (review _Snoc . (,n)) b) $+            \b -> case firstOf _Snoc (view bNotes b) of+                    Nothing -> Left (def :: Bar n)+                    (Just (as,a)) -> Right (set bNotes as b,a)+instance Cons (Bar n) (Bar n) n n where+    _Cons = prism (\(n,b) -> over bNotes (review _Cons . (n,)) b) $+            \b -> case firstOf _Cons (view bNotes b) of+                    Nothing -> Left (def :: Bar n)+                    (Just (a,as)) -> Right (a,set bNotes as b)+instance HasRehearsalMark (Bar n) where rehearsalMark = bRehearsalMark+instance HasDirection (Bar n) where direction = bDirection+instance HasBarline (Bar n) where barline = bBarline+instance HasTimeSignature (Bar n) where timeSignature = bTimeSignature+instance HasClef (Bar n) where clef = bClef+instance HasRepeats (Bar n) where repeats = bRepeats+instance (Show n) => Show (Bar n) where+    show b = mshows b ("bar " ++ show (toList $ view bNotes b))+             [mshow rehearsalMark "rehearsalMark"+             ,mshow direction "direction"+             ,mshow barline "barline"+             ,mshow repeats "repeat"+             ,mshow timeSignature "timeSignature"+             ,mshow clef "clef"+             ]+instance Monoid (Bar n) where+    mempty = def+    a `mappend` b = over bNotes (`mappend` view bNotes b) a++-- | Bar smart ctor, used in 'Show'.+bar :: [n] -> Bar n+bar ns = Bar (fromList ns) Nothing Nothing Nothing Nothing Nothing Nothing++testBar :: Bar (Note [Int] Int)+testBar = bar [[60]|:2,[62]|:1] & timeSignature ?~ TimeSignature 4 Q4 & direction ?~ "Softly"
+ src/Fadno/Note.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}++module Fadno.Note+    (Note(..),pitch,dur+    ,HasNote(..),toPair,(|:)+    ,Mono(..),maybeMono,mono,mono',mPitch,unMono,catMonos,_M+    ,rest,isRest+    ,Spelling(..),fromChroma,toChroma,spelling+    ,PitchRep(..),prPitch,prOctave,(@:),pitchRep+    ,sumDurs,mapTime+    ,tied,tied',legato,legato',merge+    ,transpose,transpose'+    ,(%)+    )+where++import Control.Lens+import Control.Arrow+import Data.Ratio+import GHC.Generics (Generic)+import Data.Traversable+import Data.Function+import Data.Foldable++-- | Note = pitch and duration.+data Note p d = Note { _pitch :: p, _dur :: d }+                deriving (Eq,Generic)+$(makeLenses ''Note)++instance (Show p, Show d) => Show (Note p d) where+    show (Note p d) = show p ++ "|:" ++ show d+instance Bifunctor Note where+    bimap f g (Note a b) = Note (f a) (g b)+instance Field1 (Note a b) (Note a' b) a a'+instance Field2 (Note a b) (Note a b') b b'++-- | Hand-rolled class providing monomorphic lenses.+class HasNote s p d | s -> p d where+  note :: Lens' s (Note p d)+  fromNote :: (HasNote n p d) => n -> s+  notePitch :: Lens' s p+  notePitch = note.pitch+  noteDur :: Lens' s d+  noteDur = note.dur+instance HasNote (Note p d) p d where+    note = ($)+    fromNote = view note++-- iso with pair+toPair :: Iso' (Note p d) (p,d)+toPair = iso (\(Note p d) -> (p,d)) (uncurry Note)+++infixl 5 |:+-- | 'Note' smart constructor.+(|:) :: p -> d -> Note p d+(|:) = Note++-- | Monophonic pitch functor, i.e. Maybe with a sum monoid.+data Mono p = Rest | M { _mPitch :: p }+    deriving (Eq,Ord,Functor)+instance (Show p)=>Show (Mono p) where+    show Rest = "Rest"+    show (M p) = "M " ++ show p+makeLenses ''Mono+makePrisms ''Mono+instance Num p => Monoid (Mono p) where+    mempty = Rest+    mappend Rest b = b+    mappend a Rest = a+    mappend (M a) (M b) = M (a + b)+-- | Mono/Maybe isomorphism.+maybeMono :: Iso' (Maybe a) (Mono a)+maybeMono = iso toMono toMaybe+    where toMono Nothing = Rest+          toMono (Just a) = M a+          toMaybe Rest = Nothing+          toMaybe (M a) = Just a++-- | Mono 'HasNote'+mono :: HasNote n (Mono p) d => p -> d -> n+mono p = fromNote . mono' p++-- | Mono 'Note'.+mono' :: p -> d -> Note (Mono p) d+mono' p = Note (M p)++-- | Mono eliminator+unMono :: b -> (a -> b) -> Mono a -> b+unMono b _ Rest = b+unMono _ f (M a) = f a++-- | cf 'catMaybe'. Grab all non-rest values.+catMonos :: Foldable f => f (Mono a) -> [a]+catMonos = foldMap (unMono [] pure)++-- | 'Note' from duration, given 'Monoid' pitch.+-- Interoperates with 'chord' and 'mono'.+-- Useful for batch duration conversion.+rest :: (HasNote n p d, Monoid p) => d -> n+rest = fromNote . rest'++rest' :: Monoid p => d -> Note p d+rest' = Note mempty++isRest :: (Monoid p, Eq p, HasNote n p d) => n -> Bool+isRest = (mempty ==) . view notePitch+++++-- | Chroma as enharmonic names.+data Spelling = C|Cs|Db|D|Ds|Eb|E|F|Fs|Gb|G|Gs|Ab|A|As|Bb|B+            deriving (Eq,Show,Read,Enum,Ord,Bounded,Generic)++-- | Convert to 'Spelling' with 0==C, using 'Cs','Eb','Fs','Gs','Bb' enharmonics.+fromChroma :: Integral a => a -> Spelling+fromChroma 0 = C+fromChroma 1 = Cs+fromChroma 2 = D+fromChroma 3 = Eb+fromChroma 4 = E+fromChroma 5 = F+fromChroma 6 = Fs+fromChroma 7 = G+fromChroma 8 = Gs+fromChroma 9 = A+fromChroma 10 = Bb+fromChroma 11 = B+fromChroma n | n > 11 = fromChroma $ n `mod` 12+             | otherwise = fromChroma $ n `mod` 12 + 12++-- | 'Spelling' to 0-11.+toChroma :: Integral a => Spelling -> a+toChroma C = 0+toChroma Cs = 1+toChroma Db = 1+toChroma D = 2+toChroma Ds = 3+toChroma Eb = 3+toChroma E = 4+toChroma F = 5+toChroma Fs = 6+toChroma Gb = 6+toChroma G = 7+toChroma Gs = 8+toChroma Ab = 8+toChroma A = 9+toChroma As = 10+toChroma Bb = 10+toChroma B = 11++-- | 'Spelling'-to-chroma degenerate 'Iso'.+spelling :: Integral a => Iso' a Spelling+spelling = iso fromChroma toChroma++-- | Represent pitch as chroma and octave.+-- It's a full 'Num', 'Integral' instance, so negative octave values OK.+-- Instances use C4 == 60.+data PitchRep = PitchRep { _prPitch :: Spelling, _prOctave :: Int  }+              deriving (Eq,Bounded,Generic)+instance Show PitchRep where show (PitchRep s o) = show s ++ "@:" ++ show o+$(makeLenses ''PitchRep)++infixl 6 @:+(@:) :: Spelling -> Int -> PitchRep+(@:) = PitchRep++instance Num PitchRep where+    fromInteger i = fromChroma i @: ((fromIntegral i `div` 12) - 1)+    a * b = fromIntegral (toInteger a * toInteger b)+    a + b = fromIntegral (toInteger a + toInteger b)+    abs = fromIntegral . abs . toInteger+    signum = fromIntegral . signum . toInteger+    negate = fromIntegral . negate . toInteger++instance Enum PitchRep where+    toEnum = fromInteger . fromIntegral+    fromEnum = fromIntegral . toInteger++instance Ord PitchRep where+    a <= b = fromIntegral a <= fromIntegral b++instance Real PitchRep where+    toRational (PitchRep s o) = (((fromIntegral o + 1) * 12) + toChroma s) % 1++instance Integral PitchRep where+    toInteger = truncate . toRational+    a `quotRem` b = (fromInteger *** fromInteger) (toInteger a `quotRem` toInteger b)++-- | Iso to integrals.+pitchRep :: Integral a => Iso' a PitchRep+pitchRep = iso fromIntegral (fromIntegral . toInteger)+++--+-- Utilities+--++-- | compute total duration of notes+sumDurs :: (Num d, HasNote a p d, Traversable t) => t a -> d+sumDurs = sumOf (traverse.noteDur)++-- | map notes to arrival time+mapTime :: (Num d, Ord d, HasNote a p d, Traversable t) => t a -> [(d,a)]+mapTime = toList . snd .+          mapAccumL (\t n -> (t + view noteDur n,(t,n))) 0++-- | merge same-pitch notes+tied :: (Eq p,Num d,HasNote a p d,Traversable t,+          Traversable u,Snoc (u a) (u a) a a,Monoid (u a)) => t a -> u a+tied = merge ((==) `on` view notePitch)++tied' :: (Eq p,Num d,HasNote a p d,Traversable t) => t a -> [a]+tied' = tied++-- | merge rests with prior note+legato :: (Eq p,Monoid p,Num d,HasNote a p d,Traversable t,+          Traversable u,Snoc (u a) (u a) a a,Monoid (u a)) => t a -> u a+legato = merge $ \_ n -> view notePitch n == mempty++legato' :: (Eq p,Monoid p,Num d,HasNote a p d,Traversable t) => t a -> [a]+legato' = legato+++-- | merge notes meeting some comparison by accumulating durations+merge :: (Num d,HasNote a p d,Traversable t,+          Traversable u,Snoc (u a) (u a) a a,Monoid (u a)) => (a -> a -> Bool) -> t a -> u a+merge cmp = acc mempty . toListOf traverse where+    acc rs [] = rs+    acc (rs :> r) (n:ns) | cmp r n = acc (rs |> over noteDur (+ view noteDur n) r) ns+    acc rs (n:ns) = acc (rs |> n) ns+++-- | Pitch addition+transpose :: (Num p,HasNote a p d,Traversable t) => p -> t a -> t a+transpose by = over (traverse.notePitch) (+by)++-- | Pitch addition over a functor+transpose' :: (Num p,Functor f, HasNote a (f p) d,Traversable t) => p -> t a -> t a+transpose' by = over (traverse.notePitch.mapped) (+by)
+ src/Fadno/Util.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE RankNTypes #-}+module Fadno.Util where++import Control.Applicative+import Control.Monad (replicateM)+import Test.HUnit+import Data.List+import Data.Function (on)+import qualified Debug.Trace as T+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad.State+import Control.Lens++-- compute intervals+diff :: Num a => [a] -> [a]+diff = zipTail (flip (-))++-- a simple reducer.+-- quicksilver says: zip`ap`tail - the Aztec god of consecutive numbers+zipTail :: (a -> a -> c) -> [a] -> [c]+zipTail f = zipWith f <*> tail++-- opposite of diff, compute concrete notes from intervals+integ :: Int -> [Int] -> [Int]+integ = scanl (+)++-- | 'Debug.Trace.trace' with brackets.+trace :: String -> a -> a+trace s = T.trace ("<" ++ s ++ ">")+-- | trace with output of result.+trace' :: Show a => String -> a -> a+trace' s a = trace1 s a a+-- | trace with extra variable, not showing result.+trace1 :: Show b => String -> b -> a -> a+trace1 s a = trace (s ++ ":" ++ show a)+-- | trace with extra variable and output of result.+trace1' :: (Show a, Show b) => String -> b -> a -> a+trace1' s a b = trace (s ++ ":" ++ show a ++ "," ++ show b) b++++-- | pop items off a stateful list, use for monadic function.+popping :: (MonadState s m) => Int -> Lens' s [a] -> ([a] -> m b) -> m b+popping n l f = do+  as <- use l+  l .= drop n as+  f (take n as)++-- | 'popping' but only runs function if popped items are non-empty+popping' :: (MonadState s m) => Int -> Lens' s [a] -> ([a] -> m b) -> m (Maybe b)+popping' n l f = popping n l+                     (\as -> if null as then return Nothing else Just <$> f as)++-- | popping with only head+popping1 :: (MonadState s m) => Lens' s [a] -> (a -> m b) -> m (Maybe b)+popping1 l f = popping' 1 l (f . head)++-- | 'succ' with wraparound.+wrapSucc :: (Bounded a, Enum a, Eq a) => a -> a+wrapSucc s = if s == maxBound then minBound else succ s+-- | 'pred' with wraparound.+wrapPred :: (Bounded a, Enum a, Eq a) => a -> a+wrapPred s = if s == minBound then maxBound else pred s++-- | do monadic 'over' -- '(%=)' -- with pass-through of (before,after)+mutating :: MonadState s m => Lens' s a -> (a -> a) -> m (a,a)+mutating l f = do+  a <- use l+  a' <- l <.= f a+  return (a,a')++-- | reorganize 'maybe' for chaining on Just+maybe' :: Maybe a -> b -> (a -> b) -> b+maybe' m n j = maybe n j m++median :: Integral a => [a] -> Maybe a+median [] = Nothing+median ls = Just $ if odd len then sorted !! mid+                   else (sorted !! mid + sorted !! (mid - 1)) `div` 2+    where len = length ls+          sorted = sort ls+          mid = len `div` 2++++++-- subtract all by minimum to "normalize" around 0+normalize :: (Num a, Ord a) => [a] -> [a]+normalize l = map (flip (-) $ minimum l) l++-- PC rules state you must rotate the scale through the gamut,+-- and selecting for the least distance from tail -> head, tail-1 -> head, etc.+-- Line can be any melody, gets normalized to gamut.+pitchClassSet :: Int -> [Int] -> [Int]+pitchClassSet gamut line = let+    modg = flip mod gamut+    norm = normalize . sort . nub . map modg $ line+    -- rotate through gamut+    alts = nub $ map (\x -> normalize . sort $ map (modg . (x+)) norm) [0..(gamut-1)]+    -- compute "values" as distance from head, reversed+    vals = map (\x -> reverse $ map (flip (-) (head x)) x) alts+    min = minimum vals+    in fst . minimumBy (compare `on` snd) $ zip alts vals+++lfsr :: Int -> Int -> Int -> [Bool]+lfsr len tap1 tap2 =+    if len<tap1 || len<tap2 || tap1==tap2 || len<2 then+        error ("lfsr: invalid arguments: " ++ show [len,tap1,tap2])+    else+        map snd . shift $ replicate len True where+            shift r = v:next v where v = (r, r !! tap1 /= r !! tap2)+            next (register,prev) = shift $ prev:register++-- | generate "A" .. "Z", "AA" .. "AZ", "BA" .. "BZ", .. "AAA" etc+rehMarks :: [String]+rehMarks = a ++ ((++) <$> a <*> a) where a = map (:[]) ['A'..'Z']++-- apply 'i' rotations to list+rotate :: Int -> [a] -> [a]+rotate i l = zipWith const (drop i $ cycle l) l++-- get all rotations of a list+rotations :: [a] -> [[a]]+rotations l = flip rotate l <$> [1..(length l)]++-- Cartesian product of specified dimension+allTuples :: Int -> [a] -> [[a]]+allTuples = replicateM++monotonic :: [Int] -> Bool+monotonic = (2 >) . length . nub . filter (EQ /=) . zipTail compare++interleave :: [[a]] -> [a]+interleave = concat . pivot++pivot :: [[a]] -> [[a]]+pivot chords = map iter [0..maxLength] where+    maxLength = minimum (map length chords) - 1+    iter i = map (!! i) chords++filterOnKeys :: (Ord a) => [a] -> M.Map a b -> M.Map a b+filterOnKeys ks = M.filterWithKey (\k _ -> S.member k $ S.fromList ks)++pairBy :: (a -> b) -> [a] -> [(a,b)]+pairBy f = map (\a -> (a,f a))++delim :: String -> [String] -> String+delim _ []              =  ""+delim _ [w]             = w+delim d (w:ws)          = w ++ d ++ delim d ws
+ src/Fadno/Xml.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+module Fadno.Xml+    ( -- * Score and Part+     xmlScore,xmlPart,xmlPartClef+    -- * Bars+    ,xmlMeasure+    ,xmlPrependMeasureData,xmlPrependMeasureDatas+    ,xmlAppendMeasureData,xmlAppendMeasureDatas+    ,xmlClef,xmlClef'+    ,xmlRepeats,xmlRepeats'+    ,xmlBarline,xmlTimeSig,xmlRehearsalMark,xmlDirection+    -- * Notes+    ,xmlNote,xmlChord+    ,xmlTie+    -- * Rendering+    ,renderFile,renderString,renderElement,Element+    ) where+++import Fadno.MusicXml.MusicXml20+import Fadno.Xml.EmitXml+import qualified Data.Map.Strict as M+import qualified Fadno.Note as N+import qualified Fadno.Notation as N+import Data.List (mapAccumL)+import Data.Maybe+import Data.Ratio+import Control.Arrow+import Text.XML.Light+import Data.String+import Control.Lens hiding (Empty)+import Data.Foldable+import Data.Monoid+++makeClassy_ ''ChxMusicData+makeClassy_ ''Note+makeClassy_ ''ChxNote+makeClassy_ ''GrpFullNote+makeClassy_ ''MusicData+makeClassy_ ''Measure++makeClassy_ ''ScorePartwise+makeClassy_ ''ScoreHeader+makeClassy_ ''Identification+makeClassy_ ''PartList+makeClassy_ ''CmpPart++++_testFile :: IO ()+_testFile = renderFile "output/newtest.xml" $+           xmlScore "Test" "Stoobie"+           [xmlPartClef "Hurdy Gurdy" "HGy" N.TrebleClef+            [xmlMeasure "1" $ xmlChord _testNote]]++++-- | Hardcoded divisions.+xmlDivisions :: PositiveDivisions+xmlDivisions = 768++--+-- SCORE & PART+--++type MeasureList f = (Traversable f, Cons (f Measure) (f Measure) Measure Measure,+                      Snoc (f Measure) (f Measure) Measure Measure)++-- | Partwise score.+xmlScore :: String -> String -> [(CmpPart,ScorePart)] -> ScorePartwise+xmlScore title composer xmlParts =+    (mkScorePartwise+     ((mkScoreHeader doPartList)+      { scoreHeaderMovementTitle = Just title+      , scoreHeaderIdentification =+          Just (mkIdentification+                { identificationCreator =+                  [TypedText composer (Just "composer") ]}) })+        ) { scorePartwisePart = toListOf (traverse._1) xmlParts }+    where+      doPartList =+          PartList []+          (xmlParts ^?! _head._2)+          (map PartListScorePart (toListOf (_tail.traverse._2) xmlParts))+++-- | Render partwise part and score parts.+xmlPart :: MeasureList f => String -> String -> f Measure -> (CmpPart,ScorePart)+xmlPart longName shortName measures =+    (CmpPart (fromString shortName) (toList $ addDivs measures),+     ScorePart+     (mkCmpScorePart (fromString shortName)+      (mkPartName (fromString longName)))+     { scorePartPartAbbreviation =+       Just (mkPartName (fromString shortName)) })+    where addDivs = xmlPrependMeasureData+                    (MusicDataAttributes+                      ((mkAttributes mkEditorial)+                       { attributesDivisions = Just xmlDivisions }))++-- | Render partwise part with clef.+xmlPartClef :: MeasureList f => String -> String -> N.Clef -> f Measure -> (CmpPart,ScorePart)+xmlPartClef l s c ms = xmlPart l s (xmlPrependMeasureData (xmlClef' c) ms)+++--+-- BARS+--++type ApplyMonoid c t = (Applicative c,Monoid (c t))++-- | Partwise measure.+xmlMeasure :: Traversable t => String -> t ChxMusicData -> Measure+xmlMeasure mNumber = mkMeasure (fromString mNumber) . MusicData . toList++-- | Add datum to beginning of first measure+xmlPrependMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure+xmlPrependMeasureData = xmlPrependMeasureDatas . pure++-- | Add data to beginning of first measure+xmlPrependMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure+xmlPrependMeasureDatas d = over (_head._measureMusicData._musicDataMusicData) (d <>)++-- | Add datum to beginning of last measure+xmlAppendMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure+xmlAppendMeasureData = xmlAppendMeasureDatas . pure++-- | Add data to beginning of last measure+xmlAppendMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure+xmlAppendMeasureDatas d = over (_last._measureMusicData._musicDataMusicData) (d <>)+++-- | Use a "Maybe Lens" to generate some or none of a datum.+maybeMusicDatas :: (ApplyMonoid c t) => Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t+maybeMusicDatas l f = maybe mempty f . view l++-- | Use a "Maybe Lens" to generate one or none of a datum.+maybeMusicData :: (ApplyMonoid c t) => Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t+maybeMusicData l f = maybeMusicDatas l (pure.f)++-- | Clef in bar+xmlClef :: (ApplyMonoid c ChxMusicData, N.HasClef a) => a -> c ChxMusicData+xmlClef = maybeMusicData N.clef xmlClef'++-- | Clef alone.+xmlClef' :: N.Clef -> ChxMusicData+xmlClef' c =+    case c of+      N.TrebleClef -> mkC ClefSignG 2+      N.BassClef -> mkC ClefSignF 4+      N.AltoClef -> mkC ClefSignC 3+      N.PercClef -> mkC ClefSignPercussion 3+    where mkC cs cl =+              MusicDataAttributes+              ((mkAttributes mkEditorial)+               { attributesClef = [(mkClef cs)+                                   { clefLine = Just cl }]})+++-- | Measure barlines.+xmlBarline :: (ApplyMonoid c ChxMusicData) => N.HasBarline a => a -> c ChxMusicData+xmlBarline = maybeMusicData N.barline $ \b ->+      case b of+        N.Double -> mdBarline RightLeftMiddleLeft+                    BarStyleLightLight Nothing+        N.Final -> mdBarline RightLeftMiddleRight+                   BarStyleLightHeavy Nothing++-- | Measure repeats for a single measure.+xmlRepeats :: (ApplyMonoid t ChxMusicData) => N.HasRepeats a => a -> t ChxMusicData+xmlRepeats = maybeMusicDatas N.repeats $ \r ->+     case r of+        N.RStart -> pure startRepeat+        N.REnd -> pure endRepeat+        N.RBoth -> pure startRepeat <> pure endRepeat+    where++startRepeat :: ChxMusicData+startRepeat = mdBarline RightLeftMiddleLeft+              BarStyleHeavyLight (Just BackwardForwardForward)+endRepeat :: ChxMusicData+endRepeat = mdBarline RightLeftMiddleRight+            BarStyleLightHeavy (Just BackwardForwardBackward)++-- | Measure repeats bracketing existing measures.+xmlRepeats' :: (N.HasRepeats a, MeasureList f) => a -> f Measure -> f Measure+xmlRepeats' s measures =+    case view N.repeats s of+      Nothing -> measures+      Just N.RStart -> doStart measures+      Just N.REnd -> doEnd measures+      Just N.RBoth -> doStart . doEnd $ measures+    where doStart = xmlPrependMeasureData startRepeat+          doEnd = xmlAppendMeasureData endRepeat++-- | utility+mdBarline :: RightLeftMiddle -> BarStyle ->+             Maybe BackwardForward -> ChxMusicData+mdBarline rml bs bf =+    MusicDataBarline+    ((mkBarline mkEditorial)+     { barlineLocation = Just rml+     , barlineBarStyle = Just (mkBarStyleColor bs)+     , barlineRepeat = fmap mkRepeat bf })++-- | Measure time signature.+xmlTimeSig :: (ApplyMonoid t ChxMusicData, N.HasTimeSignature a) => a -> t ChxMusicData+xmlTimeSig = maybeMusicData N.timeSignature $ \(N.TimeSignature n q) ->+       MusicDataAttributes $+       (mkAttributes mkEditorial)+        { attributesTime =+          [mkTime (TimeTime [SeqTime (fromString $ show n)+                             (fromString $ show $ N.qToInt q)])]}++-- | Measure rehearsal mark.+xmlRehearsalMark :: (ApplyMonoid t ChxMusicData,N.HasRehearsalMark a) => a -> t ChxMusicData+xmlRehearsalMark = maybeMusicData N.rehearsalMark+               (makeDirection . DirectionTypeRehearsal . return .+                mkRehearsal . view N.rehearsalText)++-- | Measure direction.+xmlDirection :: (ApplyMonoid t ChxMusicData,N.HasDirection a) => a -> t ChxMusicData+xmlDirection = maybeMusicData N.direction+                   (makeDirection . DirectionTypeWords . return .+                    mkFormattedText . view N.directionText)++-- | Utility for direction types+makeDirection :: ChxDirectionType -> ChxMusicData+makeDirection dt = MusicDataDirection+                        ((mkDirection mkEditorialVoiceDirection)+                         { directionDirectionType = [DirectionType dt] })++++--+-- NOTES+--++++-- | render note/rest as xml+xmlNote :: (N.HasNote a (N.Mono N.PitchRep) Rational) => a -> ChxMusicData+xmlNote n = MusicDataNote+            (mkNote (NoteFullNote+                     (GrpFullNote Nothing+                      (fullNote (view N.notePitch n)))+                     (Duration durDivs) [])+             mkEditorialVoice)+            { noteType = Just (mkNoteType durNoteType)+            , noteDot = nds }+    where (durDivs,durNoteType,durDots) = convertDurR xmlDivisions $ view N.noteDur n+          nds = replicate durDots mkEmptyPlacement+          fullNote (N.M p) = FullNotePitch (convertPitchRep p)+          fullNote N.Rest = FullNoteRest mkDisplayStepOctave++-- | render notes as xml chord or rest.+xmlChord :: (N.HasNote a [N.PitchRep] Rational) =>+            a -> [ChxMusicData]+xmlChord ch =+    case view N.notePitch ch of+      [] -> [doNote N.Rest]+      ps -> zipWith doChord [(0 :: Int)..] $ map (doNote.N.M) ps+    where doNote p = xmlNote (N.Note p (view N.noteDur ch))+          doChord i | i == 0 = id+                    | otherwise =+                        set (_musicDataNote._noteNote._noteFullNote2._fullNoteChord)+                            (Just Empty)+++_testNote :: N.Note' [N.PitchRep] Rational+_testNote = over N.nNote (view (bimapping (mapping N.pitchRep) (N.ratioPPQ N.PQ4))) N.testNote++-- | Adapt a rendered note to account for tie information.+-- > xmlTie testNote <$> xmlChord 128 testNote+xmlTie :: (N.HasTie a) => a -> ChxMusicData -> ChxMusicData+xmlTie a = over (_musicDataNote._noteNotations) (++adapt mkTNot) .+           over (_musicDataNote._noteNote._noteTie1) (++adapt Tie)+    where adapt fc = maybe [] (fmap fc . conv) $ view N.tie a+          conv N.TStart = [StartStopStart]+          conv N.TStop = [StartStopStop]+          conv N.TBoth = [StartStopStop,StartStopStart]+          mkTNot s = (mkNotations mkEditorial)+                     {notationsNotations = [NotationsTied (mkTied s)]}++-- | Steps and enharmonics.+steps :: [(Step,Maybe Semitones)]+steps = [(StepC,Nothing),+         (StepC,sharp),+         (StepD,Nothing),+         (StepE,flat),+         (StepE,Nothing),+         (StepF,Nothing),+         (StepF,sharp),+         (StepG,Nothing),+         (StepA,flat),+         (StepA,Nothing),+         (StepB,flat),+         (StepB,Nothing)]+    where sharp = Just 1+          flat = Just (-1)++-- | Note values indexed by powers of two. [(1,Long) .. (1024,256th)]+noteTypeValues :: M.Map Int NoteTypeValue+noteTypeValues = M.fromList $ snd $ mapAccumL acc (256*4) [minBound .. maxBound]+    where acc v nt = (v `div` 2,(v,nt))++-- | Int pitch to xml. TODO C3 vs C4?+convertPitch :: Int -> Pitch+convertPitch i = Pitch step semi oct where+    oct = fromIntegral $ (i `div` 12) - 1+    (step, semi) = steps !! (i `mod` 12)++convertPitchRep :: N.PitchRep -> Pitch+convertPitchRep (N.PitchRep s o) = Pitch step semi (fromIntegral o)+    where (step,semi) = ss s+          sharp = Just 1+          flat = Just (-1)+          ss N.C = (StepC,Nothing)+          ss N.Cs = (StepC,sharp)+          ss N.Db = (StepD,flat)+          ss N.D = (StepD,Nothing)+          ss N.Ds = (StepD,sharp)+          ss N.Eb = (StepE,flat)+          ss N.E = (StepE,Nothing)+          ss N.F = (StepF,Nothing)+          ss N.Fs = (StepF,sharp)+          ss N.Gb = (StepG,flat)+          ss N.G = (StepG,Nothing)+          ss N.Gs = (StepG,sharp)+          ss N.Ab = (StepA,flat)+          ss N.A = (StepA,Nothing)+          ss N.As = (StepA,sharp)+          ss N.Bb = (StepB,flat)+          ss N.B = (StepB,Nothing)+++-- | Int duration/PPQ to xml values.+convertDur :: N.PPQ -> Int -> PositiveDivisions -> (PositiveDivisions,NoteTypeValue,Int)+convertDur ppq dur xdivs = (fromIntegral divs,findValue,dots)+    where+      ppqd = N.ppqDiv ppq+      divs = floor xdivs * dur `div` ppqd+      (num,denom) = numerator &&& denominator $ (dur % (ppqd * 16))+      dots = fromMaybe 0 $ M.lookup num dotValues+      findValue = fromMaybe NoteTypeValue256th $+                  M.lookup (denom `div` (2 ^ dots))  noteTypeValues++-- | Rational duration (ie, '1 % 4' for quarter note) to xml values.+convertDurR :: PositiveDivisions -> Rational -> (PositiveDivisions,NoteTypeValue,Int)+convertDurR xdivs r = (fromIntegral divs,findValue,dots)+    where+      divs :: Int+      divs = floor $ toRational xdivs * (r * 4)+      (num,denom) = numerator &&& denominator $ (r / 4)+      dots = fromMaybe 0 $ M.lookup (fromIntegral num) dotValues+      findValue = fromMaybe NoteTypeValue256th $+                  M.lookup (fromIntegral denom `div` (2 ^ dots)) noteTypeValues++-- | Numerator values to dots.+dotValues :: M.Map Int Int+dotValues = M.fromList $ takeWhile (<= 1024) (dot 3 4) `zip` [1..]+    where dot v i = v:dot (v + i) (i * 2)
+ tests/Tests.hs view
@@ -0,0 +1,17 @@+module Main where++import qualified MeterSpec+import qualified NotationSpec+import qualified NoteSpec+import qualified UtilSpec+import Test.HUnit+import System.IO+import Control.Monad+import Test.Hspec+import Test.Hspec.Contrib.HUnit++main = hspec $ fromHUnitTest $ TestList+           [MeterSpec.tests,+            NotationSpec.tests,+            NoteSpec.tests,+            UtilSpec.tests]