diff --git a/Control/Arrow/ArrowP.lhs b/Control/Arrow/ArrowP.lhs new file mode 100644 --- /dev/null +++ b/Control/Arrow/ArrowP.lhs @@ -0,0 +1,38 @@ +> {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} + +> module Control.Arrow.ArrowP where + +> import Control.Arrow +> import Control.Arrow.Operations +#if __GLASGOW_HASKELL__ >= 610 +> import Control.Category +> import Prelude hiding ((.), id) +#endif + +> newtype ArrowP a p b c = ArrowP { strip :: a b c } + +#if __GLASGOW_HASKELL__ >= 610 +> instance Category a => Category (ArrowP a p) where +> id = ArrowP id +> ArrowP g . ArrowP f = ArrowP (g . f) + +> instance Arrow a => Arrow (ArrowP a p) where +> arr f = ArrowP (arr f) +> first (ArrowP f) = ArrowP (first f) +#else +> instance Arrow a => Arrow (ArrowP a p) where +> arr f = ArrowP (arr f) +> first (ArrowP f) = ArrowP (first f) +> ArrowP f >>> ArrowP g = ArrowP (f >>> g) +#endif + +> instance ArrowLoop a => ArrowLoop (ArrowP a p) where +> loop (ArrowP f) = ArrowP (loop f) + +> instance ArrowCircuit a => ArrowCircuit (ArrowP a p) where +> delay i = ArrowP (delay i) + +> instance ArrowChoice a => ArrowChoice (ArrowP a p) where +> left (ArrowP f) = ArrowP (left f) +> ArrowP f ||| ArrowP g = ArrowP (f ||| g) + diff --git a/Control/CCA/ArrowP.lhs b/Control/CCA/ArrowP.lhs deleted file mode 100644 --- a/Control/CCA/ArrowP.lhs +++ /dev/null @@ -1,59 +0,0 @@ -> {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} - -> module Control.CCA.ArrowP where - -> import Control.Arrow -> import Control.CCA.Types -> import Control.CCA.CCNF -> import Language.Haskell.TH -> import Prelude hiding (init, (.), id) - -#if __GLASGOW_HASKELL__ >= 610 - -> import Control.Category -> instance Category a => Category (ArrowP a p) where -> id = ArrowP id -> ArrowP g . ArrowP f = ArrowP (g . f) - -> instance Arrow a => Arrow (ArrowP a p) where -> arr f = ArrowP (arr f) -> first (ArrowP f) = ArrowP (first f) - -#else - - -> instance Arrow a => Arrow (ArrowP a p) where -> arr f = ArrowP (arr f) -> first (ArrowP f) = ArrowP (first f) -> ArrowP f >>> ArrowP g = ArrowP (f >>> g) - -#endif - - -> newtype ArrowP a p b c = ArrowP (a b c) - -> class (ArrowInit (ArrowP a p), ArrowInit a) => ArrowInitP a p where -> strip :: ArrowP a p b c -> a b c -> strip (ArrowP f) = f - -> instance ArrowLoop a => ArrowLoop (ArrowP a p) where -> loop (ArrowP f) = ArrowP (loop f) - -> instance ArrowInit a => ArrowInit (ArrowP a p) where -> init i = ArrowP (init i) -- error "use init' instead" -> arr' f f' = ArrowP (arr' f f') -> init' i i' = ArrowP (init' i i') - -> instance ArrowChoice a => ArrowChoice (ArrowP a p) where -> left (ArrowP f) = ArrowP (left f) -> ArrowP f ||| ArrowP g = ArrowP (f ||| g) - -> instance ArrowInitP ASyn p - -> normP :: ArrowP ASyn p b c -> ExpQ -> normP (ArrowP x) = norm x - -> normOptP :: ArrowP ASyn p b c -> ExpQ -> normOptP x = normOpt (strip x) - - diff --git a/Control/SF/SF.lhs b/Control/SF/SF.lhs --- a/Control/SF/SF.lhs +++ b/Control/SF/SF.lhs @@ -1,24 +1,19 @@ -> {-# LANGUAGE CPP, TemplateHaskell, BangPatterns, FlexibleInstances, MultiParamTypeClasses #-} +> {-# LANGUAGE CPP, BangPatterns #-} > module Control.SF.SF where #if __GLASGOW_HASKELL__ >= 610 > import Control.Category -> import Prelude hiding ((.), init, exp) -#else -> import Prelude hiding (init, exp) +> import Prelude hiding ((.), id) #endif > import Control.Arrow -> import Control.CCA.Types -> import Control.CCA.ArrowP +> import Control.Arrow.ArrowP > import Control.Arrow.Operations > newtype SF a b = SF { runSF :: (a -> (b, SF a b)) } -> instance ArrowInitP SF p - #if __GLASGOW_HASKELL__ >= 610 > instance Category SF where > id = SF h where h x = (x, SF h) @@ -89,17 +84,9 @@ > Left a -> let (y, f') = runSF f a in f' `seq` (Left y, SF (g f')) > Right b -> (Right b, SF (g f)) > -> instance ArrowInit SF where -> init i = SF (f i) -> where f i x = (i, SF (f x)) -> loopD i g = SF (f i) -> where -> f i x = -> let (y, i') = g (x, i) -> in (y, SF (f i')) - > instance ArrowCircuit SF where -> delay = init +> delay i = SF (f i) +> where f i x = (i, SF (f x)) > run :: SF a b -> [a] -> [b] > run _ [] = [] diff --git a/Euterpea.cabal b/Euterpea.cabal --- a/Euterpea.cabal +++ b/Euterpea.cabal @@ -1,5 +1,5 @@ name: Euterpea -version: 1.0.0 +version: 1.1.0 Cabal-Version: >= 1.8 license: BSD3 license-file: License @@ -10,11 +10,10 @@ author: Paul Hudak , Eric Cheng , Hai (Paul) Liu -maintainer: Paul Hudak , - Donya Quick , +maintainer: Donya Quick , Dan Winograd-Cort , Mark Santolucito -bug-reports: mailto:paul.hudak@yale.edu +bug-reports: https://github.com/Euterpea/Euterpea/issues homepage: http://haskell.cs.yale.edu/ synopsis: Library for computer music research and education description: @@ -77,11 +76,12 @@ Library hs-source-dirs: . ghc-options: -O2 -funbox-strict-fields -fexcess-precision + extensions: CPP exposed-modules: Euterpea, Euterpea.Experimental, Euterpea.ExperimentalPlay, - Control.CCA.ArrowP, + Control.Arrow.ArrowP, Control.SF.SF, Euterpea.Examples.EuterpeaExamples Euterpea.Examples.Interlude, @@ -126,13 +126,10 @@ System.Random.Distributions other-modules: build-depends: - base >= 3 && < 5, array, bytestring, random, - mtl, containers, markov-chain, - CCA >= 0.1.3, UISF >= 0.3, PortMidi, - HCodecs >= 0.2, heap == 0.6.0, - template-haskell, - monadIO, deepseq, - pure-fft, - stm, arrows >= 0.4 + base >= 3 && < 5, arrows >= 0.4, array, deepseq, random, + PortMidi, HCodecs >= 0.2, + stm, containers, bytestring, heap == 0.6.0, + markov-chain, pure-fft, + UISF >= 0.3 if (impl(ghc >= 6.10)) - build-depends: base >= 4 && < 5, syb, ghc-prim + build-depends: base >= 4 && < 5, ghc-prim diff --git a/Euterpea.lhs b/Euterpea.lhs --- a/Euterpea.lhs +++ b/Euterpea.lhs @@ -10,7 +10,7 @@ > module Euterpea.IO.MUI, > module Control.Arrow, > -- These 4 lines are from FRP.UISF.AuxFunctions -> SEvent, edge, accum, constA, constSF, foldA, foldSF, (~++), +> SEvent, edge, accum, constA, constSF, foldA, foldSF, > unique, hold, now, mergeE, > delay, vdelay, fdelay, > timer, genEvents, Time, DeltaT, @@ -26,9 +26,9 @@ > import Euterpea.IO.MUI > import Control.Arrow -> import FRP.UISF.AuxFunctions +> import FRP.UISF.AuxFunctions hiding ((~++)) > import Codec.Midi(exportFile, importFile) - +> import Control.Arrow.Operations diff --git a/Euterpea/Examples/Additive.hs b/Euterpea/Examples/Additive.hs --- a/Euterpea/Examples/Additive.hs +++ b/Euterpea/Examples/Additive.hs @@ -1,14 +1,18 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/Additive.lhs. (See HSoM/MakeCode.bat.) - -{-# LANGUAGE Arrows #-} +{-# LINE 8 "Additive.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/Additive.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "Additive.lhs" #-} +{-# LANGUAGE Arrows #-} module Euterpea.Examples.Additive where import Euterpea --- TBD --- TBD +{-# LINE 383 "Additive.lhs" #-} +-- TBD +{-# LINE 393 "Additive.lhs" #-} +-- TBD +{-# LINE 426 "Additive.lhs" #-} bell1 :: Instr (Mono AudRate) - -- |Dur -> AbsPitch -> Volume -> AudSF () Double| + -- Dur -> AbsPitch -> Volume -> AudSF () Double bell1 dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -23,6 +27,7 @@ tab1 = tableSinesN 4096 [1] bellTest1 = outFile "bell1.wav" 6 (bell1 6 (absPitch (C,5)) 100 []) +{-# LINE 449 "Additive.lhs" #-} bell'1 :: Instr (Mono AudRate) bell'1 dur ap vol [] = let f = apToHz ap @@ -37,8 +42,9 @@ (2.74,1,0), (2,1,0), (1.71,1,0), (1.19,1,0), (0.92,1,0), (0.56,1,0)] bellTest1' = outFile "bell'1.wav" 6 (bell'1 6 (absPitch (C,5)) 100 []) +{-# LINE 491 "Additive.lhs" #-} bell2 :: Instr (Mono AudRate) - -- |Dur -> AbsPitch -> Volume -> AudSF () Double| + -- Dur -> AbsPitch -> Volume -> AudSF () Double bell2 dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -55,19 +61,22 @@ outA -< s*aenv bellTest2 = outFile "bell2.wav" 6 (bell2 6 (absPitch (C,5)) 100 []) +{-# LINE 739 "Additive.lhs" #-} sineTable :: Table sineTable = tableSinesN 4096 [1] env1 :: AudSF () Double env1 = envExpon 20 10 10000 +{-# LINE 764 "Additive.lhs" #-} good = outFile "good.wav" 10 (osc sineTable 0 <<< envExpon 20 10 10000 :: AudSF () Double) bad = outFile "bad.wav" 10 (osc sineTable 0 <<< envLine 20 10 10000 :: AudSF () Double) +{-# LINE 774 "Additive.lhs" #-} sfTest1 :: AudSF (Double,Double) Double -> Instr (Mono AudRate) - -- |AudSF (Double,Double) Double -> | - -- |Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double| + -- AudSF (Double,Double) Double -> + -- Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double sfTest1 sf dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -75,6 +84,7 @@ a1 <- osc sineTable 0 <<< env1 -< () a2 <- sf -< (a1,f) outA -< a2*v +{-# LINE 789 "Additive.lhs" #-} tLow = outFile "low.wav" 10 $ sfTest1 filterLowPass 10 (absPitch (C,5)) 80 [] @@ -86,6 +96,7 @@ tHiBW = outFile "hiBW.wav" 10 $ sfTest1 filterHighPassBW 10 (absPitch (C,5)) 80 [] +{-# LINE 805 "Additive.lhs" #-} addBandWidth :: AudSF (Double,Double,Double) Double -> AudSF (Double,Double) Double addBandWidth filter = @@ -102,20 +113,22 @@ tBSBW = outFile "bsBW.wav" 10 $ sfTest1 (addBandWidth filterBandStopBW) 10 (absPitch (C,6)) 80 [] +{-# LINE 826 "Additive.lhs" #-} noise1 :: Instr (Mono AudRate) - -- |Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double| + -- Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double noise1 dur ap vol [] = let v = fromIntegral vol / 100 in proc () -> do a1 <- noiseWhite 42 -< () outA -< a1*v test1 = outFile "noise1.wav" 6 (noise1 6 (absPitch (C,5)) 100 []) +{-# LINE 839 "Additive.lhs" #-} env2 :: AudSF () Double env2 = envExpon 1 10 2000 sfTest2 :: AudSF (Double,Double,Double) Double -> Instr (Mono AudRate) - -- |AudSF (Double,Double,Double) Double -> | - -- |Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double| + -- AudSF (Double,Double,Double) Double -> + -- Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double sfTest2 sf dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -124,7 +137,7 @@ bw <- env2 -< () a2 <- sf -< (a1,f,bw) outA -< a2 - +{-# LINE 856 "Additive.lhs" #-} tBP' = outFile "bp'.wav" 10 $ sfTest2 (filterBandPass 1) 10 (absPitch (C,5)) 80 [] @@ -136,6 +149,7 @@ tBSBW' = outFile "bsBW'.wav" 10 $ sfTest2 filterBandStopBW 10 (absPitch (C,5)) 80 [] +{-# LINE 872 "Additive.lhs" #-} noise2 :: Instr (Mono AudRate) noise2 dur ap vol [] = let f = apToHz ap @@ -144,6 +158,7 @@ a1 <- noiseBLI 42 -< f outA -< a1*v test2 = outFile "noise2.wav" 6 (noise2 6 (absPitch (C,5)) 100 []) +{-# LINE 885 "Additive.lhs" #-} ss1 :: Instr (Mono AudRate) ss1 dur ap vol [] = let v = fromIntegral vol / 100 @@ -152,6 +167,7 @@ a2 <- filterBandPass 2 -< (a1, 1000, 200) outA -< a2*v/5 test3 = outFile "ss1.wav" 6 (ss1 6 (absPitch (C,5)) 100 []) +{-# LINE 898 "Additive.lhs" #-} wind :: Instr (Mono AudRate) wind dur ap vol [] = let f = apToHz ap @@ -163,6 +179,7 @@ a2 <- filterBandPass 2 -< (a1, f + 100*(lfo1+lfo2), 200) outA -< a2*v/5 test4 = outFile "wind.wav" 6 (wind 6 (absPitch (C,7)) 100 []) +{-# LINE 914 "Additive.lhs" #-} buzzy :: Instr (Mono AudRate) buzzy dur ap vol [] = let f = apToHz ap @@ -171,6 +188,7 @@ a1 <- oscPartials sineTable 0 -< (f,20) outA -< a1*v test5 = outFile "buzzy.wav" 6 (buzzy 6 (absPitch (C,5)) 100 []) +{-# LINE 927 "Additive.lhs" #-} buzzy2 :: Instr (Mono AudRate) buzzy2 dur ap vol [] = let f = apToHz ap @@ -182,6 +200,7 @@ a2 <- filterLowPass -< (a1,20000*env) outA -< a2*v*env test6 = outFile "buzzy2.wav" 6 (buzzy2 6 (absPitch (C,5)) 100 []) +{-# LINE 943 "Additive.lhs" #-} scifi1 :: Instr (Mono AudRate) scifi1 dur ap vol [] = let v = fromIntegral vol / 100 @@ -190,6 +209,7 @@ a2 <- osc sineTable 0 -< 600 + 200*a1 outA -< a2*v test7 = outFile "scifi1.wav" 10 (scifi1 10 (absPitch (C,5)) 100 []) +{-# LINE 956 "Additive.lhs" #-} scifi2 :: Instr (Mono AudRate) scifi2 dur ap vol [] = let v = fromIntegral vol / 100 diff --git a/Euterpea/Examples/EnableGUI.hs b/Euterpea/Examples/EnableGUI.hs --- a/Euterpea/Examples/EnableGUI.hs +++ b/Euterpea/Examples/EnableGUI.hs @@ -1,4 +1,24 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-- +On Mac OS X, with versions of GHC prior to 7.8, you will have to use this +``EnableGUI trick'' to run GUI programs for Euterpea from within ghci. + +To do so, first compile this file, EnableGUI.hs, to binary: + ghc -c -fffi EnableGUI.hs + +(Note: on some systems it is necessary to add the option +``-framework ApplicationServices'') +Then, run your Euterpea GUI programs in ghci like this: + +ghci UIExamples.hs EnableGUI +*UIExamples> :m +EnableGUI +*UIExamples EnableGUI> enableGUI >> main + +With this, GHCi will be able to fully activate the Graphics Window. (Fully +compiled GUI programs do not suffer from this anomaly.) + +--} + module EnableGUI(enableGUI) where import Data.Int diff --git a/Euterpea/Examples/Instruments.hs b/Euterpea/Examples/Instruments.hs --- a/Euterpea/Examples/Instruments.hs +++ b/Euterpea/Examples/Instruments.hs @@ -2,10 +2,10 @@ module Euterpea.Examples.Instruments where import Euterpea import Euterpea.Experimental -import FRP.UISF.AuxFunctions ((~++)) -- Here is a demonstration of the guitar and piano widgets available in Euterpea. +main = instrumentDemo instrumentDemo :: IO () instrumentDemo = runMUI (defaultMUIParams {uiSize=(1038,706), uiTitle="Instrument Demo"}) $ proc _ -> do devId <- selectOutput -< () @@ -16,8 +16,7 @@ -- If you want to be able to change these settings at runtime, a structure like this is necessary -- addNotation presents a checkbox that allows the user to toggle the display of pitch classes -- on the instruements. In this example, a single settings variable is used. - rec settings' <- addNotation -< settings - settings <- hold defaultInstrumentData -< Just settings' + settings <- addNotation -< defaultInstrumentData -- The guitar UISF takes in a keymap (sixString is the only one available at the moment) and -- a midi channel. Any midi messages passed into the guitar will be coerced to that channel. guitar1 <- guitar sixString 1 -< (settings, Nothing) diff --git a/Euterpea/Examples/Interlude.hs b/Euterpea/Examples/Interlude.hs --- a/Euterpea/Examples/Interlude.hs +++ b/Euterpea/Examples/Interlude.hs @@ -1,59 +1,72 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/Interlude.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "Interlude.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/Interlude.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 94 "Interlude.lhs" #-} module Euterpea.Examples.Interlude - ( childSong6, -- :: Music Pitch, - prefix -- :: [Music a] -> Music a) + ( childSong6, -- :: Music Pitch, + prefix -- :: [Music a] -> Music a) ) where import Euterpea - +{-# LINE 179 "Interlude.lhs" #-} addDur :: Dur -> [Dur -> Music a] -> Music a addDur d ns = let f n = n d in line (map f ns) +{-# LINE 198 "Interlude.lhs" #-} graceNote :: Int -> Music Pitch -> Music Pitch +{-# LINE 206 "Interlude.lhs" #-} graceNote n (Prim (Note d p)) = note (d/8) (trans n p) :+: note (7*d/8) p graceNote n _ = error "Can only add a grace note to a note." - +{-# LINE 232 "Interlude.lhs" #-} b1 = addDur dqn [b 3, fs 4, g 4, fs 4] b2 = addDur dqn [b 3, es 4, fs 4, es 4] b3 = addDur dqn [as 3, fs 4, g 4, fs 4] +{-# LINE 241 "Interlude.lhs" #-} bassLine = timesM 3 b1 :+: timesM 2 b2 :+: timesM 4 b3 :+: timesM 5 b1 +{-# LINE 253 "Interlude.lhs" #-} mainVoice = timesM 3 v1 :+: v2 -v1 = v1a :+: graceNote (-1) (d 5 qn) :+: v1b -- bars 1-2 +{-# LINE 258 "Interlude.lhs" #-} +v1 = v1a :+: graceNote (-1) (d 5 qn) :+: v1b -- bars 1-2 v1a = addDur en [a 5, e 5, d 5, fs 5, cs 5, b 4, e 5, b 4] v1b = addDur en [cs 5, b 4] +{-# LINE 266 "Interlude.lhs" #-} v2 = v2a :+: v2b :+: v2c :+: v2d :+: v2e :+: v2f :+: v2g +{-# LINE 289 "Interlude.lhs" #-} v2a = line [ cs 5 (dhn+dhn), d 5 dhn, - f 5 hn, gs 5 qn, fs 5 (hn+en), g 5 en] -- bars 7-11 + f 5 hn, gs 5 qn, fs 5 (hn+en), g 5 en] -- bars 7-11 v2b = addDur en [ fs 5, e 5, cs 5, as 4] :+: a 4 dqn :+: - addDur en [ as 4, cs 5, fs 5, e 5, fs 5] -- bars 12-13 + addDur en [ as 4, cs 5, fs 5, e 5, fs 5] -- bars 12-13 v2c = line [ g 5 en, as 5 en, cs 6 (hn+en), d 6 en, cs 6 en] :+: e 5 en :+: enr :+: line [ as 5 en, a 5 en, g 5 en, d 5 qn, c 5 en, cs 5 en] - -- bars 14-16 + -- bars 14-16 v2d = addDur en [ fs 5, cs 5, e 5, cs 5, - a 4, as 4, d 5, e 5, fs 5] -- bars 17-18.5 + a 4, as 4, d 5, e 5, fs 5] -- bars 17-18.5 v2e = line [ graceNote 2 (e 5 qn), d 5 en, graceNote 2 (d 5 qn), cs 5 en, graceNote 1 (cs 5 qn), b 4 (en+hn), cs 5 en, b 4 en ] - -- bars 18.5-20 + -- bars 18.5-20 v2f = line [ fs 5 en, a 5 en, b 5 (hn+qn), a 5 en, fs 5 en, e 5 qn, - d 5 en, fs 5 en, e 5 hn, d 5 hn, fs 5 qn] -- bars 21-23 + d 5 en, fs 5 en, e 5 hn, d 5 hn, fs 5 qn] -- bars 21-23 v2g = tempo (3/2) (line [cs 5 en, d 5 en, cs 5 en]) :+: - b 4 (3*dhn+hn) -- bars 24-28childSong6 :: Music Pitch + b 4 (3*dhn+hn) -- bars 24-28 +{-# LINE 326 "Interlude.lhs" #-} +childSong6 :: Music Pitch childSong6 = let t = (dhn/qn)*(69/120) in instrument RhodesPiano (tempo t (bassLine :=: mainVoice)) +{-# LINE 376 "Interlude.lhs" #-} prefixes :: [a] -> [[a]] prefixes [] = [] prefixes (x:xs) = let f pf = x:pf in [x] : map f (prefixes xs) +{-# LINE 394 "Interlude.lhs" #-} prefix :: [Music a] -> Music a prefix mel = let m1 = line (concat (prefixes mel)) m2 = transpose 12 (line (concat (prefixes (reverse mel)))) m = instrument Flute m1 :=: instrument VoiceOohs m2 in m :+: transpose 5 m :+: m +{-# LINE 404 "Interlude.lhs" #-} mel1 = [c 5 en, e 5 sn, g 5 en, b 5 sn, a 5 en, f 5 sn, d 5 en, b 4 sn, c 5 en] mel2 = [c 5 sn, e 5 sn, g 5 sn, b 5 sn, a 5 sn, f 5 sn, d 5 sn, b 4 sn, c 5 sn] diff --git a/Euterpea/Examples/IntervalTrainer.lhs b/Euterpea/Examples/IntervalTrainer.lhs --- a/Euterpea/Examples/IntervalTrainer.lhs +++ b/Euterpea/Examples/IntervalTrainer.lhs @@ -100,7 +100,7 @@ > -- edge-detect pushbuttons: > let guessesE = foldl1 (.|.) $ zipWith (->>) guesses intNameList > rec -- the state -> state <- accum Start -< updates +> state <- delay Start <<< accum Start -< updates > -- event filter based on MUI state > let whileIn' :: SEvent a -> State -> SEvent a > e `whileIn'` s = if s == state then e else Nothing @@ -118,12 +118,12 @@ > -- state variables: > let matchE = snapshot (guessesE `whileIn` Base) interval =>> > \(g,(r,i)) -> if g==intNameList!!i then succ else id -> total <- accum 0 -< ((guessesE `whileIn` Base ->> succ) .|. +> total <- delay 0 <<< accum 0 -< ((guessesE `whileIn` Base ->> succ) .|. > (nextE `whileIn` Base ->> succ) .|. > (giveUpE `whileIn` Base ->> succ) .|. > (resetE ->> const 0) ) -> correct <- accum 0 -< (matchE .|. (resetE ->> const 0)) -> repeats <- accum 0 -< ((repeatE `whileIn` Base ->> succ) .|. +> correct <- delay 0 <<< accum 0 -< (matchE .|. (resetE ->> const 0)) +> repeats <- delay 0 <<< accum 0 -< ((repeatE `whileIn` Base ->> succ) .|. > (resetE ->> const 0) ) > -- Note delays > let f n pn dur = if pn==n then 1 / fromIntegral (2 ^ dur) else 0 @@ -135,13 +135,12 @@ > nowE <- now -< () > let progChan = nowE ->> (map Std $ > zipWith ProgramChange [0,1,2,3,4] [0,4,40,66,73]) -> midiMsgs = progChan .|. mergeE (++) note0 note1 +> midiMsgs = progChan .|. (note0 ~++ note1) > -- Display results: -> (| leftRight (do -> title "Score:" $ setSize (120,50) $ -> display -< showScore correct total -> title "Repeats:" $ setSize (120,50) $ display -< show repeats -> title "Answer:" $ setSize (120,50) $ display -< +> (| (setSize (600,30) . leftRight) (do +> title "Score:" $ display -< showScore correct total +> title "Repeats:" $ display -< show repeats +> title "Answer:" $ display -< > if state==Guessed then intNameList!!(snd interval) else "" > returnA -< () )|) > -- Midi output diff --git a/Euterpea/Examples/LSystems.hs b/Euterpea/Examples/LSystems.hs --- a/Euterpea/Examples/LSystems.hs +++ b/Euterpea/Examples/LSystems.hs @@ -1,18 +1,21 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/LSystems.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "LSystems.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/LSystems.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 19 "LSystems.lhs" #-} module Euterpea.Examples.LSystems where import Euterpea import Data.List hiding (transpose) import System.Random - -data DetGrammar a = DetGrammar a -- start symbol - [(a,[a])] -- productions +{-# LINE 81 "LSystems.lhs" #-} +data DetGrammar a = DetGrammar a -- start symbol + [(a,[a])] -- productions deriving Show +{-# LINE 89 "LSystems.lhs" #-} detGenerate :: Eq a => DetGrammar a -> [[a]] detGenerate (DetGrammar st ps) = iterate (concatMap f) [st] where f a = maybe [a] id (lookup a ps) +{-# LINE 131 "LSystems.lhs" #-} redAlgae = DetGrammar 'a' [ ('a',"b|c"), ('b',"b"), ('c',"b|d"), ('d',"e\\d"), ('e',"f"), ('f',"g"), @@ -20,10 +23,13 @@ ('(',"("), (')',")"), ('/',"\\"), ('\\',"/") ] +{-# LINE 157 "LSystems.lhs" #-} t n g = sequence_ (map putStrLn (take n (detGenerate g))) -data Grammar a = Grammar a -- start sentence - (Rules a) -- production rules +{-# LINE 221 "LSystems.lhs" #-} +data Grammar a = Grammar a -- start sentence + (Rules a) -- production rules deriving Show +{-# LINE 232 "LSystems.lhs" #-} data Rules a = Uni [Rule a] | Sto [(Rule a, Prob)] deriving (Eq, Ord, Show) @@ -32,8 +38,10 @@ deriving (Eq, Ord, Show) type Prob = Double +{-# LINE 247 "LSystems.lhs" #-} type ReplFun a = [[(Rule a, Prob)]] -> (a, [Rand]) -> (a, [Rand]) type Rand = Double +{-# LINE 264 "LSystems.lhs" #-} gen :: Ord a => ReplFun a -> Grammar a -> Int -> [a] gen f (Grammar s rules) seed = let Sto newRules = toStoRules rules @@ -41,6 +49,7 @@ in if checkProbs newRules then generate f newRules (s,rands) else (error "Stochastic rule-set is malformed.") +{-# LINE 280 "LSystems.lhs" #-} toStoRules :: (Ord a, Eq a) => Rules a -> Rules a toStoRules (Sto rs) = Sto rs toStoRules (Uni rs) = @@ -49,7 +58,8 @@ insertProb :: [a] -> [(a, Prob)] insertProb rules = let prb = 1.0 / fromIntegral (length rules) - in zip rules (repeat prb) + in zip rules (repeat prb) +{-# LINE 300 "LSystems.lhs" #-} checkProbs :: (Ord a, Eq a) => [(Rule a, Prob)] -> Bool checkProbs rs = and (map checkSum (groupBy sameLHS (sort rs))) @@ -61,6 +71,7 @@ sameLHS :: Eq a => (Rule a, Prob) -> (Rule a, Prob) -> Bool sameLHS (r1,f1) (r2,f2) = lhs r1 == lhs r2 +{-# LINE 317 "LSystems.lhs" #-} generate :: Eq a => ReplFun a -> [(Rule a, Prob)] -> (a,[Rand]) -> [a] generate f rules xs = @@ -68,11 +79,13 @@ probDist rrs = let (rs,ps) = unzip rrs in zip rs (tail (scanl (+) 0 ps)) in map fst (iterate (f newRules) xs) +{-# LINE 347 "LSystems.lhs" #-} data LSys a = N a | LSys a :+ LSys a | LSys a :. LSys a | Id deriving (Eq, Ord, Show) +{-# LINE 366 "LSystems.lhs" #-} replFun :: Eq a => ReplFun (LSys a) replFun rules (s, rands) = case s of @@ -84,6 +97,7 @@ in (a' :. b', rands'') Id -> (Id, rands) N x -> (getNewRHS rules (N x) (head rands), tail rands) +{-# LINE 384 "LSystems.lhs" #-} getNewRHS :: Eq a => [[(Rule a, Prob)]] -> a -> Rand -> a getNewRHS rrs ls rand = let loop ((r,p):rs) = if rand <= p then rhs r else loop rs @@ -91,7 +105,8 @@ in case (find (\ ((r,p):_) -> lhs r == ls) rrs) of Just rs -> loop rs Nothing -> error "No rule match" -type IR a b = [(a, Music b -> Music b)] -- ``interpetation rules'' +{-# LINE 405 "LSystems.lhs" #-} +type IR a b = [(a, Music b -> Music b)] -- ``interpetation rules'' interpret :: (Eq a) => LSys a -> IR a b -> Music b -> Music b interpret (a :. b) r m = interpret a r (interpret b r m) @@ -100,6 +115,7 @@ interpret (N x) r m = case (lookup x r) of Just f -> f m Nothing -> error "No interpetation rule" +{-# LINE 418 "LSystems.lhs" #-} data LFun = Inc | Dec | Same deriving (Eq, Ord, Show) @@ -112,7 +128,9 @@ inc = N Inc dec = N Dec same = N Same +{-# LINE 437 "LSystems.lhs" #-} sc = inc :+ dec +{-# LINE 442 "LSystems.lhs" #-} r1a = Rule inc (sc :. sc) r1b = Rule inc sc r2a = Rule dec (sc :. sc) @@ -120,6 +138,8 @@ r3a = Rule same inc r3b = Rule same dec r3c = Rule same same +{-# LINE 452 "LSystems.lhs" #-} g1 = Grammar same (Uni [r1b, r1a, r2b, r2a, r3a, r3b]) +{-# LINE 458 "LSystems.lhs" #-} t1 n = instrument Vibraphone $ interpret (gen replFun g1 42 !! n) ir (c 5 tn) diff --git a/Euterpea/Examples/MUI.hs b/Euterpea/Examples/MUI.hs --- a/Euterpea/Examples/MUI.hs +++ b/Euterpea/Examples/MUI.hs @@ -1,69 +1,77 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/MUI.lhs. (See HSoM/MakeCode.bat.) - -{-# LANGUAGE Arrows #-} +{-# LINE 8 "MUI.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/MUI.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 19 "MUI.lhs" #-} +{-# LANGUAGE Arrows, CPP #-} module Euterpea.Examples.MUI where import Euterpea -import Control.Arrow +{-# LINE 25 "MUI.lhs" #-} import Data.Maybe (mapMaybe) - +import Euterpea.Experimental +#if MIN_VERSION_UISF(0,4,0) +import FRP.UISF.Graphics (withColor', rgbE, rectangleFilled) +import FRP.UISF.Widget.Construction (mkWidget) +#else +import FRP.UISF.SOE (withColor', rgb, polygon) +import FRP.UISF.Widget (mkWidget) +#endif +{-# LINE 585 "MUI.lhs" #-} ui0 :: UISF () () ui0 = proc _ -> do ap <- hiSlider 1 (0,100) 0 -< () display -< pitch ap - ---mui0 = runMUI' "Simple MUI" ui0 - +{-# LINE 605 "MUI.lhs" #-} +mui0 = runMUI' ui0 +{-# LINE 686 "MUI.lhs" #-} ui1 :: UISF () () -ui1 = setLayout (makeLayout (Fixed 150) (Fixed 150)) $ +ui1 = setSize (150,150) $ proc _ -> do ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap ---mui1 = runMUI' "Simple MUI (sized and titled)" ui1 +mui1 = runMUI' ui1 +{-# LINE 708 "MUI.lhs" #-} ui2 :: UISF () () ui2 = leftRight $ proc _ -> do ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap ---mui2 = runMUI' "Simple MUI (left-to-right layout)" ui2 ---ui3 :: UISF () () ---ui3 = proc _ -> do --- ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () --- title "Pitch" display -< pitch ap --- uap <- unique -< ap --- midiOut -< (0, fmap (\k-> [ANote 0 k 100 0.1]) uap) - ---mui3 = runMUI' "Pitch Player" ui3 - -ui4 :: UISF () () -ui4 = proc _ -> do +mui2 = runMUI' ui2 +{-# LINE 837 "MUI.lhs" #-} +ui3 :: UISF () () +ui3 = proc _ -> do devid <- selectOutput -< () ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap uap <- unique -< ap midiOut -< (devid, fmap (\k-> [ANote 0 k 100 0.1]) uap) ---mui4 = runMUI' "Pitch Player with MIDI Device Select" ui4 - -ui5 :: UISF () () -ui5 = proc _ -> do +mui3 = runMUI' ui3 +{-# LINE 871 "MUI.lhs" #-} +ui4 :: UISF () () +ui4 = proc _ -> do mi <- selectInput -< () mo <- selectOutput -< () m <- midiIn -< mi midiOut -< (mo, m) ---mui5 = runMUI' "MIDI Input / Output UI" ui5 - +mui4 = runMUI' ui4 +{-# LINE 885 "MUI.lhs" #-} getDeviceIDs = topDown $ proc () -> do mi <- selectInput -< () mo <- selectOutput -< () outA -< (mi,mo) -ui6 :: UISF () () -ui6 = proc _ -> do +{-# LINE 935 "MUI.lhs" #-} +mui'4 = runMUI (defaultMUIParams + { uiTitle = "MIDI Input / Output UI", + uiSize = (200,200)}) + ui4 +{-# LINE 1111 "MUI.lhs" #-} +ui5 :: UISF () () +ui5 = proc _ -> do devid <- selectOutput -< () ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap @@ -71,8 +79,9 @@ tick <- timer -< 1/f midiOut -< (devid, fmap (const [ANote 0 ap 100 0.1]) tick) ---mui6 = runMUI' "Pitch Player with Timer" ui6 - +-- Pitch Player with Timer +mui5 = runMUI' ui5 +{-# LINE 1233 "MUI.lhs" #-} chordIntervals :: [ (String, [Int]) ] chordIntervals = [ ("Maj", [4,3,5]), ("Maj7", [4,3,4,1]), ("Maj9", [4,3,4,3]), ("Maj6", [4,3,2,3]), @@ -81,16 +90,16 @@ ("mMaj7", [3,4,4,1]), ("dim", [3,3,3]), ("dim7", [3,3,3,3]), ("Dom7", [4,3,3,2]), ("Dom9", [4,3,3,4]), ("Dom7b9", [4,3,3,3]) ] - -toChord :: Int -> [MidiMessage] -> [MidiMessage] -toChord i ms@(m:_) = +{-# LINE 1250 "MUI.lhs" #-} +toChord :: Int -> MidiMessage -> [MidiMessage] +toChord i m = case m of Std (NoteOn c k v) -> f NoteOn c k v Std (NoteOff c k v) -> f NoteOff c k v - _ -> ms + _ -> [] where f g c k v = map (\k' -> Std (g c k' v)) (scanl (+) k (snd (chordIntervals !! i))) - +{-# LINE 1277 "MUI.lhs" #-} buildChord :: UISF () () buildChord = leftRight $ proc _ -> do @@ -98,16 +107,20 @@ m <- midiIn -< mi i <- topDown $ title "Chord Type" $ radio (fst (unzip chordIntervals)) 0 -< () - midiOut -< (mo, fmap (toChord i) m) - ---chordBuilder = runMUI (600,400) "Chord Builder" buildChord -grow :: Double -> Double -> Double -grow r x = r * x * (1-x) + midiOut -< (mo, fmap (concatMap $ toChord i) m) +chordBuilder = runMUI (defaultMUIParams + { uiTitle = "Chord Builder", + uiSize = (600,400)}) + buildChord +{-# LINE 1338 "MUI.lhs" #-} +grow :: Double -> Double -> Double +grow r x = r * x * (1-x) +{-# LINE 1370 "MUI.lhs" #-} popToNote :: Double -> [MidiMessage] popToNote x = [ANote 0 n 64 0.05] where n = truncate (x * 127) - +{-# LINE 1380 "MUI.lhs" #-} bifurcateUI :: UISF () () bifurcateUI = proc _ -> do mo <- selectOutput -< () @@ -118,27 +131,25 @@ _ <- title "Population" $ display -< pop midiOut -< (mo, fmap (const (popToNote pop)) tick) ---bifurcate = runMUI (300,500) "Bifurcate!" $ bifurcateUI - +bifurcate = runMUI (defaultMUIParams + { uiTitle = "Bifurcate!", + uiSize = (300,500)}) + bifurcateUI +{-# LINE 1434 "MUI.lhs" #-} echoUI :: UISF () () echoUI = proc _ -> do - mi <- selectInput -< () - mo <- selectOutput -< () + (mi, mo) <- getDeviceIDs -< () m <- midiIn -< mi r <- title "Decay rate" $ withDisplay (hSlider (0, 0.9) 0.5) -< () f <- title "Echoing frequency" $ withDisplay (hSlider (1, 10) 10) -< () - rec let m' = removeNull $ mergeE (++) m s - s <- vdelay -< (1/f, fmap (mapMaybe (decay 0.1 r)) m') + rec s <- vdelay -< (1/f, fmap (mapMaybe (decay 0.1 r)) m') + let m' = m ~++ s midiOut -< (mo, m') ---echo = runMUI (500,500) "Echo" echoUI - -removeNull :: Maybe [MidiMessage] -> Maybe [MidiMessage] -removeNull (Just []) = Nothing -removeNull mm = mm - +echo = runMUI' echoUI +{-# LINE 1451 "MUI.lhs" #-} decay :: Time -> Double -> MidiMessage -> Maybe MidiMessage decay dur r m = let f c k v d = if v > 0 @@ -149,3 +160,69 @@ ANote c k v d -> f c k v d Std (NoteOn c k v) -> f c k v dur _ -> Nothing +{-# LINE 1712 "MUI.lhs" #-} +gAndPUI :: UISF () () +gAndPUI = proc _ -> do + (mi, mo) <- getDeviceIDs -< () + m <- midiIn -< mi + settings <- addNotation -< defaultInstrumentData + outG <- guitar sixString 1 -< (settings, Nothing) + outP <- piano defaultMap0 0 -< (settings, m) + midiOut -< (mo, outG ~++ outP) + +gAndP = runMUI (defaultMUIParams { uiSize=(1050,700), + uiTitle="Guitar and Piano"}) + gAndPUI +{-# LINE 1783 "MUI.lhs" #-} +colorSwatchUI :: UISF () () +colorSwatchUI = setSize (300, 220) $ pad (4,0,4,0) $ leftRight $ + proc _ -> do + r <- newColorSlider "R" -< () + g <- newColorSlider "G" -< () + b <- newColorSlider "B" -< () + e <- unique -< (r,g,b) +#if MIN_VERSION_UISF(0,4,0) + let rect = withColor' (rgbE r g b) (rectangleFilled ((0,0),d)) +#else + let rect = withColor' (rgb r g b) (box ((0,0),d)) +#endif + pad (4,8,0,0) $ canvas d -< fmap (const rect) e + where + d = (170,170) + newColorSlider l = title l $ withDisplay $ viSlider 16 (0,255) 0 +#if MIN_VERSION_UISF(0,4,0) +#else + box ((x,y), (w, h)) = + polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)] +#endif + +colorSwatch = runMUI' colorSwatchUI +{-# LINE 1898 "MUI.lhs" #-} +ui6 = topDown $ proc _ -> do + b1 <- button "Button 1" -< () + (b2, b3) <- leftRight (proc _ -> do + b2 <- button "Button 2" -< () + b3 <- button "Button 3" -< () + returnA -< (b2, b3)) -< () + b4 <- button "Button 4" -< () + display -< b1 || b2 || b3 || b4 +{-# LINE 1916 "MUI.lhs" #-} +ui'6 = topDown $ proc _ -> do + b1 <- button "Button 1" -< () + (b2, b3) <- leftRight (proc b1 -> do + b2 <- button "Button 2" -< () + display -< b1 + b3 <- button "Button 3" -< () + returnA -< (b2, b3)) -< b1 + b4 <- button "Button 4" -< () + display -< b1 || b2 || b3 || b4 +{-# LINE 1947 "MUI.lhs" #-} +ui''6 = proc () -> do + b1 <- button "Button 1" -< () + (b2, b3) <- (| leftRight (do + b2 <- button "Button 2" -< () + display -< b1 + b3 <- button "Button 3" -< () + returnA -< (b2, b3)) |) + b4 <- button "Button 4" -< () + display -< b1 || b2 || b3 || b4 diff --git a/Euterpea/Examples/RandomMusic.hs b/Euterpea/Examples/RandomMusic.hs --- a/Euterpea/Examples/RandomMusic.hs +++ b/Euterpea/Examples/RandomMusic.hs @@ -1,6 +1,7 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/RandomMusic.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "RandomMusic.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/RandomMusic.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 19 "RandomMusic.lhs" #-} module Euterpea.Examples.RandomMusic where import Euterpea @@ -8,11 +9,14 @@ import System.Random import System.Random.Distributions import qualified Data.MarkovChain as M +{-# LINE 55 "RandomMusic.lhs" #-} sGen :: StdGen sGen = mkStdGen 42 +{-# LINE 84 "RandomMusic.lhs" #-} randInts :: StdGen -> [Int] randInts g = let (x,g') = next g in x : randInts g' +{-# LINE 114 "RandomMusic.lhs" #-} randFloats :: [Float] randFloats = randomRs (-1,1) sGen @@ -21,43 +25,49 @@ randString :: String randString = randomRs ('a','z') sGen +{-# LINE 136 "RandomMusic.lhs" #-} randIO :: IO Float randIO = randomRIO (0,1) +{-# LINE 143 "RandomMusic.lhs" #-} randIO' :: IO () randIO' = do r1 <- randomRIO (0,1) :: IO Float r2 <- randomRIO (0,1) :: IO Float print (r1 == r2) +{-# LINE 338 "RandomMusic.lhs" #-} toAbsP1 :: Float -> AbsPitch toAbsP1 x = round (40*x + 30) +{-# LINE 347 "RandomMusic.lhs" #-} mkNote1 :: AbsPitch -> Music Pitch mkNote1 = note tn . pitch mkLine1 :: [AbsPitch] -> Music Pitch mkLine1 rands = line (take 32 (map mkNote1 rands)) --- uniform distribution +{-# LINE 361 "RandomMusic.lhs" #-} +-- uniform distribution m1 :: Music Pitch m1 = mkLine1 (randomRs (30,70) sGen) --- linear distribution +-- linear distribution m2 :: Music Pitch m2 = let rs1 = rands linear sGen in mkLine1 (map toAbsP1 rs1) --- exponential distribution +-- exponential distribution m3 :: Float -> Music Pitch m3 lam = let rs1 = rands (exponential lam) sGen in mkLine1 (map toAbsP1 rs1) --- Gaussian distribution +-- Gaussian distribution m4 :: Float -> Float -> Music Pitch m4 sig mu = let rs1 = rands (gaussian sig mu) sGen in mkLine1 (map toAbsP1 rs1) --- Gaussian distribution with mean set to 0 +{-# LINE 421 "RandomMusic.lhs" #-} +-- Gaussian distribution with mean set to 0 m5 :: Float -> Music Pitch m5 sig = let rs1 = rands (gaussian sig 0) sGen in mkLine2 50 (map toAbsP2 rs1) --- exponential distribution with mean adjusted to 0 +-- exponential distribution with mean adjusted to 0 m6 :: Float -> Music Pitch m6 lam = let rs1 = rands (exponential lam) sGen in mkLine2 50 (map (toAbsP2 . subtract (1/lam)) rs1) @@ -68,6 +78,7 @@ mkLine2 :: AbsPitch -> [AbsPitch] -> Music Pitch mkLine2 start rands = line (take 64 (map mkNote1 (scanl (+) start rands))) +{-# LINE 445 "RandomMusic.lhs" #-} m2' = let rs1 = rands linear sGen in sum (take 1000 rs1) / 1000 :: Float @@ -77,24 +88,26 @@ m6' lam = let rs1 = rands (exponential lam) sGen rs2 = map (subtract (1/lam)) rs1 in sum (take 1000 rs2) --- some sample training sequences +{-# LINE 534 "RandomMusic.lhs" #-} +-- some sample training sequences ps0,ps1,ps2 :: [Pitch] ps0 = [(C,4), (D,4), (E,4)] ps1 = [(C,4), (D,4), (E,4), (F,4), (G,4), (A,4), (B,4)] ps2 = [ (C,4), (E,4), (G,4), (E,4), (F,4), (A,4), (G,4), (E,4), (C,4), (E,4), (G,4), (E,4), (F,4), (D,4), (C,4)] --- functions to package up |run| and |runMulti| +-- functions to package up |run| and |runMulti| mc ps n = mkLine3 (M.run n ps 0 (mkStdGen 42)) mcm pss n = mkLine3 (concat (M.runMulti n pss 0 (mkStdGen 42))) --- music-making functions +-- music-making functions mkNote3 :: Pitch -> Music Pitch mkNote3 = note tn mkLine3 :: [Pitch] -> Music Pitch mkLine3 ps = line (take 64 (map mkNote3 ps)) --- testing the Markov output directly +{-# LINE 556 "RandomMusic.lhs" #-} +-- testing the Markov output directly lc ps n = take 1000 (M.run n ps 0 (mkStdGen 42)) lcl pss n m = take 1000 (M.runMulti n pss 0 (mkStdGen 42) !! m) diff --git a/Euterpea/Examples/SelfSimilar.hs b/Euterpea/Examples/SelfSimilar.hs --- a/Euterpea/Examples/SelfSimilar.hs +++ b/Euterpea/Examples/SelfSimilar.hs @@ -1,11 +1,13 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/SelfSimilar.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "SelfSimilar.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/SelfSimilar.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "SelfSimilar.lhs" #-} module Euterpea.Examples.SelfSimilar where import Euterpea - +{-# LINE 64 "SelfSimilar.lhs" #-} data Cluster = Cluster SNote [Cluster] type SNote = (Dur,AbsPitch) +{-# LINE 85 "SelfSimilar.lhs" #-} selfSim :: [SNote] -> Cluster selfSim pat = Cluster (0,0) (map mkCluster pat) where mkCluster note = @@ -13,29 +15,37 @@ addMult :: SNote -> SNote -> SNote addMult (d0,p0) (d1,p1) = (d0*d1,p0+p1) +{-# LINE 103 "SelfSimilar.lhs" #-} fringe :: Int -> Cluster -> [SNote] fringe 0 (Cluster note cls) = [note] fringe n (Cluster note cls) = concatMap (fringe (n-1)) cls +{-# LINE 130 "SelfSimilar.lhs" #-} simToMusic :: [SNote] -> Music Pitch simToMusic = line . map mkNote mkNote :: (Dur,AbsPitch) -> Music Pitch mkNote (d,ap) = note d (pitch ap) +{-# LINE 143 "SelfSimilar.lhs" #-} ss pat n tr te = transpose tr $ tempo te $ simToMusic $ fringe n $ selfSim pat +{-# LINE 151 "SelfSimilar.lhs" #-} m0 :: [SNote] m0 = [(1,2),(1,0),(1,5),(1,7)] tm0 = instrument Vibraphone (ss m0 4 50 20) +{-# LINE 159 "SelfSimilar.lhs" #-} ttm0 = tm0 :=: transpose (12) (revM tm0) +{-# LINE 165 "SelfSimilar.lhs" #-} m1 :: [SNote] m1 = [(1,0),(0.5,0),(0.5,0)] tm1 = instrument Percussion (ss m1 4 43 2) +{-# LINE 178 "SelfSimilar.lhs" #-} m2 :: [SNote] m2 = [(dqn,0),(qn,4)] tm2 = ss m2 6 50 (1/50) +{-# LINE 187 "SelfSimilar.lhs" #-} m3 :: [SNote] m3 = [(hn,3),(qn,4),(qn,0),(hn,6)] @@ -51,16 +61,21 @@ (qn,0),(qn,5),(qn,15),(wn,6),(wn,9),(wn,19) ] tm4 = ss m4 3 50 8 +{-# LINE 245 "SelfSimilar.lhs" #-} fringe' :: Int -> Cluster -> [[SNote]] fringe' 0 (Cluster note cls) = [[note]] fringe' n (Cluster note cls) = map (fringe (n-1)) cls +{-# LINE 257 "SelfSimilar.lhs" #-} simToMusic' :: [[SNote]] -> Music Pitch simToMusic' = chord . map (line . map mkNote) +{-# LINE 263 "SelfSimilar.lhs" #-} ss' pat n tr te = transpose tr $ tempo te $ simToMusic' $ fringe' n $ selfSim pat +{-# LINE 270 "SelfSimilar.lhs" #-} ss1 = ss' m2 4 50 (1/8) ss2 = ss' m3 4 50 (1/2) ss3 = ss' m4 3 50 2 +{-# LINE 284 "SelfSimilar.lhs" #-} m5 = [(en,4),(sn,7),(en,0)] ss5 = ss m5 4 45 (1/500) ss6 = ss' m5 4 45 (1/1000) diff --git a/Euterpea/Examples/SigFuns.hs b/Euterpea/Examples/SigFuns.hs --- a/Euterpea/Examples/SigFuns.hs +++ b/Euterpea/Examples/SigFuns.hs @@ -1,57 +1,73 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/SigFuns.lhs. (See HSoM/MakeCode.bat.) - -{-# LANGUAGE Arrows #-} +{-# LINE 8 "SigFuns.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/SigFuns.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "SigFuns.lhs" #-} +{-# LANGUAGE Arrows #-} module Euterpea.Examples.SigFuns where import Euterpea import Control.Arrow ((>>>),(<<<),arr) +{-# LINE 461 "SigFuns.lhs" #-} s1 :: Clock c => SigFun c () Double s1 = proc () -> do s <- oscFixed 440 -< () outA -< s +{-# LINE 480 "SigFuns.lhs" #-} tab1 :: Table tab1 = tableSinesN 4096 [1] +{-# LINE 487 "SigFuns.lhs" #-} s2 :: Clock c => SigFun c () Double s2 = proc () -> do osc tab1 0 -< 440 +{-# LINE 570 "SigFuns.lhs" #-} tab2 = tableSinesN 4096 [1.0,0.5,0.33] +{-# LINE 577 "SigFuns.lhs" #-} s3 :: Clock c => SigFun c () Double s3 = proc () -> do osc tab2 0 -< 440 +{-# LINE 583 "SigFuns.lhs" #-} s4 :: Clock c => SigFun c () Double s4 = proc () -> do f0 <- oscFixed 440 -< () f1 <- oscFixed 880 -< () f2 <- oscFixed 1320 -< () outA -< (f0 + 0.5*f1 + 0.33*f2) / 1.83 +{-# LINE 622 "SigFuns.lhs" #-} vibrato :: Clock c => Double -> Double -> SigFun c Double Double vibrato vfrq dep = proc afrq -> do vib <- osc tab1 0 -< vfrq aud <- osc tab2 0 -< afrq + vib * dep outA -< aud +{-# LINE 635 "SigFuns.lhs" #-} s5 :: AudSF () Double s5 = constA 1000 >>> vibrato 5 20 +{-# LINE 712 "SigFuns.lhs" #-} simpleClip :: Clock c => SigFun c Double Double simpleClip = arr f where f x = if abs x <= 1.0 then x else signum x +{-# LINE 734 "SigFuns.lhs" #-} time :: Clock c => SigFun c () Double time = integral <<< constA 1 +{-# LINE 787 "SigFuns.lhs" #-} simpleInstr :: InstrumentName simpleInstr = Custom "Simple Instrument" +{-# LINE 828 "SigFuns.lhs" #-} myInstr :: Instr (AudSF () Double) - -- |Dur -> AbsPitch -> Volume -> [Double] -> (AudSF () Double)| + -- Dur -> AbsPitch -> Volume -> [Double] -> (AudSF () Double) myInstr dur ap vol [vfrq,dep] = proc () -> do vib <- osc tab1 0 -< vfrq aud <- osc tab2 0 -< apToHz ap + vib * dep outA -< aud +{-# LINE 851 "SigFuns.lhs" #-} myInstrMap :: InstrMap (AudSF () Double) myInstrMap = [(simpleInstr, myInstr)] +{-# LINE 875 "SigFuns.lhs" #-} (dr, sf) = renderSF mel myInstrMap main = outFile "simple.wav" dr sf +{-# LINE 884 "SigFuns.lhs" #-} mel :: Music1 mel = let m = Euterpea.line [ na1 (c 4 en), na1 (ef 4 en), na1 (f 4 en), diff --git a/Euterpea/Experimental.lhs b/Euterpea/Experimental.lhs --- a/Euterpea/Experimental.lhs +++ b/Euterpea/Experimental.lhs @@ -35,6 +35,10 @@ > import FRP.UISF.AuxFunctions > import FRP.UISF.UISF +#if MIN_VERSION_UISF(0,4,0) +> import FRP.UISF.Asynchrony +> asyncUISFE x = asyncE x +#endif diff --git a/Euterpea/IO/Audio/BasicSigFuns.lhs b/Euterpea/IO/Audio/BasicSigFuns.lhs --- a/Euterpea/IO/Audio/BasicSigFuns.lhs +++ b/Euterpea/IO/Audio/BasicSigFuns.lhs @@ -1,4 +1,4 @@ -> {-# LANGUAGE Arrows, TemplateHaskell, BangPatterns, +> {-# LANGUAGE Arrows, BangPatterns, > ExistentialQuantification, FlexibleContexts, > FunctionalDependencies, ScopedTypeVariables, > NoMonomorphismRestriction #-} @@ -85,20 +85,15 @@ > -- gen12, gen12', > -- butterlp, butterhp, butterbp, butterbr, -> import Prelude hiding (init) - > import Euterpea.IO.Audio.Basics > import Euterpea.IO.Audio.Types > import Control.Arrow -> import Control.CCA.ArrowP -> import Control.CCA.Types +> import Control.Arrow.Operations +> import Control.Arrow.ArrowP > import FRP.UISF.AuxFunctions (SEvent, constA) > import Data.Array.Base (unsafeAt) > import Data.Array.Unboxed -> import Language.Haskell.TH -> import Language.Haskell.TH.Syntax - > import Foreign.Marshal > import Foreign.Ptr > import Foreign.Storable @@ -136,43 +131,36 @@ > data Table = Table > !Int -- size > !(UArray Int Double) -- table implementation -> ExpQ -- TH expression to construct -> -- the table at compile time > !Bool -- Whether the table is normalized > instance Show Table where -> show (Table sz a _ n) = "Table with " ++ show sz ++ " entries: " ++ -> show a - -> instance Language.Haskell.TH.Syntax.Lift Table where -> lift (Table sz uarr fexp norm) = -> [| funToTable ($(fexp)) fexp norm sz |] +> show (Table sz a n) = "Table with " ++ show sz ++ " entries: " ++ show a -> funToTable :: (Double->Double) -> ExpQ -> Bool -> Int -> Table -> funToTable f f' normalize size = +> funToTable :: (Double->Double) -> Bool -> Int -> Table +> funToTable f normalize size = > let delta = 1 / fromIntegral size > ys = take size (map f [0, delta.. ]) ++ [head ys] > -- make table one size larger as an extended guard point > zs = if normalize then map (/ maxabs ys) ys else ys > maxabs = maximum . map abs -> in Table size (listArray (0, size) zs) f' normalize +> in Table size (listArray (0, size) zs) normalize > readFromTable :: Table -> Double -> Double -> readFromTable (Table sz array _ _) pos = +> readFromTable (Table sz array _) pos = > let idx = truncate (fromIntegral sz * pos) -- range must be [0,size] > in array `unsafeAt` idx > {-# INLINE [0] readFromTable #-} -> readFromTableA :: ArrowInit a => Table -> a Double Double -> readFromTableA t = arr' [| readFromTable t |] (readFromTable t) +> readFromTableA :: Arrow a => Table -> a Double Double +> readFromTableA = arr . readFromTable > readFromTableRaw :: Table -> Int -> Double -> readFromTableRaw (Table _ a _ _) idx = a `unsafeAt` idx +> readFromTableRaw (Table _ a _) idx = a `unsafeAt` idx Like readFromTable, but with linear interpolation. > readFromTablei :: Table -> Double -> Double -> readFromTablei (Table sz array _ _) pos = +> readFromTablei (Table sz array _) pos = > let idx = fromIntegral sz * pos -- fractional "index" in table ([0,sz]) > idx0 = (truncate idx) `mod` sz :: Int > idx1 = idx0 + 1 :: Int @@ -181,14 +169,14 @@ > in val0 + (val1 - val0) * (idx - fromIntegral idx0) > {-# INLINE [0] readFromTablei #-} -> readFromTableiA :: ArrowInit a => Table -> a Double Double -> readFromTableiA t = arr' [| readFromTablei t |] (readFromTablei t) +> readFromTableiA :: Arrow a => Table -> a Double Double +> readFromTableiA = arr . readFromTablei Accesses table values by direct indexing with linear interpolation. The index 'pos' is expected to be normalized (between 0 and 1). Values out of bounds are either clipped or wrapped. -> tablei :: (Clock p, ArrowInit a) => +> tablei :: (Clock p, Arrow a) => > Table -- Table to read from. > -> Bool -- Whether to wrap around index; > -- if not, index is clipped within bounds @@ -203,7 +191,7 @@ Accesses table values by direct indexing; the index is normalized (between 0 and 1). -> table :: (Clock p, ArrowInit a) => Table -> Bool -> ArrowP a p Double Double +> table :: (Clock p, Arrow a) => Table -> Bool -> ArrowP a p Double Double > table tab True = > proc pos -> do > outA -< readFromTable tab (wrap pos 1) @@ -214,26 +202,26 @@ Like tablei, but the index is interpreted as a raw value (between 0 and (size of table - 1), inclusive). -> tableiIx :: (Clock p, ArrowInit a) => +> tableiIx :: (Clock p, Arrow a) => > Table -> Bool -> ArrowP a p Double Double -> tableiIx tab@(Table sz array _ _) True = +> tableiIx tab@(Table sz array _) True = > proc idx -> do > let idx0 = (truncate idx) `mod` sz > val0 = readFromTableRaw tab idx0 > val1 = readFromTableRaw tab (idx0 + 1) > outA -< val0 + (val1 - val0) * (idx - fromIntegral idx0) -> tableiIx tab@(Table sz _ _ _) False = +> tableiIx tab@(Table sz _ _) False = > proc idx -> do > let pos = idx / fromIntegral (sz-1) > outA -< readFromTablei tab (clip pos 0 1) Like table, but index interpreted as raw value. -> tableIx :: (Clock p, ArrowInit a) => Table -> Bool -> ArrowP a p Double Double -> tableIx tab@(Table sz array _ _) True = +> tableIx :: (Clock p, Arrow a) => Table -> Bool -> ArrowP a p Double Double +> tableIx tab@(Table sz array _) True = > proc idx -> do > outA -< readFromTableRaw tab (truncate idx `mod` (sz-1)) -> tableIx tab@(Table sz array _ _) False = +> tableIx tab@(Table sz array _) False = > proc idx -> do > outA -< readFromTableRaw tab (clip (truncate idx) 0 (sz-1)) @@ -244,7 +232,7 @@ from sampling a stored function table. The internal phase is simultaneously advanced in accordance with the input signal 'freq'. -> osc :: (Clock p, ArrowInit a) => +> osc :: (Clock p, ArrowCircuit a) => > Table > -> Double -- Initial phase of sampling, expressed as a > -- fraction of a cycle (0 to 1). @@ -253,7 +241,7 @@ 'oscI' is like 'osc', but with linear interpolation. -> oscI :: (Clock p, ArrowInit a) => +> oscI :: (Clock p, ArrowCircuit a) => > Table > -> Double > -> ArrowP a p Double Double @@ -261,7 +249,7 @@ Helper function for osc and oscI. -> osc_ :: forall p a. (Clock p, ArrowInit a) => +> osc_ :: forall p a. (Clock p, ArrowCircuit a) => > Double -> ArrowP a p Double Double > osc_ phs = > let sr = rate (undefined :: p) @@ -269,14 +257,14 @@ > rec > let delta = 1 / sr * freq > phase = if next > 1 then frac next else next -> next <- init phs -< frac (phase + delta) +> next <- delay phs -< frac (phase + delta) > outA -< phase Simple, fast sine oscillator, that uses only one multiply and two add operations to generate one sample of output, and does not require a function table. -> oscFixed :: forall p a . (Clock p, ArrowInit a) => +> oscFixed :: forall p a . (Clock p, ArrowCircuit a) => > Double -> ArrowP a p () Double > oscFixed freq = > let omh = 2 * pi * freq / sr @@ -286,8 +274,8 @@ > sf = proc () -> do > rec > let r = c * d2 - d1 -> d1 <- init 0 -< d2 -> d2 <- init d -< r +> d1 <- delay 0 -< d2 +> d2 <- delay d -< r > outA -< r > in sf @@ -298,7 +286,7 @@ another 'dur' seconds; from that time on (i.e. after 'del' + 'dur' seconds) it will remain pointing at the last location. -> oscDur :: (Clock p, ArrowChoice a, ArrowInit a) => +> oscDur :: (Clock p, ArrowChoice a, ArrowCircuit a) => > Table > -> Double > -- delay in seconds before 'oscDur' incremental sampling begins @@ -309,7 +297,7 @@ Like 'oscDur', but with linear interpolation. -> oscDurI :: (Clock p, ArrowChoice a, ArrowInit a) => +> oscDurI :: (Clock p, ArrowChoice a, ArrowCircuit a) => > Table > -> Double > -- delay in seconds before 'oscDur' incremental sampling begins. @@ -320,10 +308,10 @@ Helper function for oscDur and oscDurI. -> oscDur_ :: forall p a . (Clock p, ArrowChoice a, ArrowInit a) => +> oscDur_ :: forall p a . (Clock p, ArrowChoice a, ArrowCircuit a) => > (Table -> Double -> ArrowP a p Double Double) > -> Table -> Double -> Double -> ArrowP a p () Double -> oscDur_ osc table@(Table sz _ _ _) del dur = +> oscDur_ osc table@(Table sz _ _) del dur = > let sr = rate (undefined :: p) > t1 = del * sr > t2 = t1 + dur * sr @@ -340,7 +328,7 @@ These are not implemented. -> foscil, foscili :: (Clock p, ArrowInit a) => +> foscil, foscili :: (Clock p, Arrow a) => > Table -> ArrowP a p (Double,Double,Double,Double) Double > foscil table = > proc (freq,carfreq,modfreq,modindex) -> do @@ -350,7 +338,7 @@ > proc (freq,carfreq,modfreq,modindex) -> do > outA -< 0 -> loscil :: (Clock p, ArrowInit a) => Table -> ArrowP a p Double Double +> loscil :: (Clock p, Arrow a) => Table -> ArrowP a p Double Double > loscil table = > proc freq -> do > outA -< 0 @@ -371,7 +359,7 @@ > rec > let delta = 1 / sr * freq > phase = if next > 1 then frac next else next -> next <- init initialPhase -< frac (phase + delta) +> next <- delay initialPhase -< frac (phase + delta) > outA -< sum [ readFromTable table (frac (phase * fromIntegral pn)) | > pn <- [1..nharms] ] > / fromIntegral nharms @@ -379,12 +367,6 @@ Pluck ----- -> instance Lift PluckDecayMethod where -> lift SimpleAveraging = [| SimpleAveraging |] -> lift (WeightedAveraging a b) = [| WeightedAveraging a b |] -> lift _ = error "Euterpea.IO.Audio.BasicSigFuns: Lift PluckDecayMethod not yet defined (in TODO)" -> -- TODO: rest of the methods - > data PluckDecayMethod > = SimpleAveraging > -- A simple smoothing process. @@ -413,7 +395,7 @@ > in proc cps -> do > rec > z <- delayLineT (max 64 (truncate (sr / pitch))) table -< y -> z' <- init 0 -< z +> z' <- delay 0 -< z > let y = case method of > SimpleAveraging -> 0.5 * (z + z') > -- or is this "RecursiveFilter?" @@ -451,9 +433,6 @@ > data Buf = Buf !Int !(Ptr Double) -> instance Lift Buf where -> lift (Buf sz _) = [| mkArr sz |] - > updateBuf :: Buf -> Int -> Double -> IO Double > updateBuf (Buf _ a) i u = a `seq` i `seq` u `seq` do > let p = a `advancePtr` i @@ -483,8 +462,8 @@ > in proc x -> do > rec > let i' = if i == size-1 then 0 else i+1 -> i <- init 0 -< i' -> y <- init 0 -< x +> i <- delay 0 -< i' +> y <- delay 0 -< x > -- TODO: this proc can't be strict on x, but how can we > -- deal with strictness better without this hack? > outA -< unsafePerformIO $ updateBuf buf i y @@ -500,8 +479,8 @@ > in proc x -> do > rec > let i' = if i == sz-1 then 0 else i+1 -> i <- init 0 -< i' -> y <- init 0 -< x +> i <- delay 0 -< i' +> y <- delay 0 -< x > outA -< unsafePerformIO $ updateBuf buf i y delay line with one tap. @@ -517,8 +496,8 @@ > dl = min maxdel dlt > tap = i - truncate (sr * dl) > tapidx = if tap < 0 then sz + tap else tap -> i <- init 0 -< i' -> y <- init 0 -< sig +> i <- delay 0 -< i' +> y <- delay 0 -< sig > outA -< unsafePerformIO $ do > s <- peekBuf buf tapidx > _ <- updateBuf buf i y @@ -545,9 +524,6 @@ > proc (sig, dlt1, dlt2, dlt3, dlt4) -> do > outA -< 0 -> instance Language.Haskell.TH.Syntax.Lift StdGen where -> lift g = [| g |] - Noise Generators ---------------- @@ -562,7 +538,7 @@ > in proc () -> do > rec > let (a,g') = random g :: (Double,StdGen) -> g <- init gen -< g' +> g <- delay gen -< g' > outA -< a * 2 - 1 Controlled band-limited noise with interpolation between each new @@ -580,7 +556,7 @@ > in proc cps -> do > let bound = sr / cps > rec -> state <- init (0, i_pr) -< state' +> state <- delay (0, i_pr) -< state' > let (cnt, pr@(n1, n2, g)) = state > n = n1 + (n2 - n1) * cnt / bound > state' = if cnt + 1 < bound @@ -603,7 +579,7 @@ > in proc cps -> do > let bound = sr / cps > rec -> state <- init (0, i_pr) -< state' +> state <- delay (0, i_pr) -< state' > let (cnt, pr@(n, g)) = state > state' = if cnt + 1 < bound > then (cnt + 1, pr) @@ -621,7 +597,7 @@ > balance ihp = > proc (sig, ref) -> do > rec -> (sqrsum, refsum) <- init (0, 0) -< (sqrsum', refsum') +> (sqrsum, refsum) <- delay (0, 0) -< (sqrsum', refsum') > let sqrsum' = c1 * sig * sig + c2 * sqrsum > refsum' = c1 * ref * ref + c2 * refsum > ratio = if sqrsum == 0 then sqrt $ refsum @@ -667,7 +643,7 @@ > filterBandPass scale = > proc (sig, kcf, kbw) -> do > rec -> rsnData <- init rsnDefault -< rsnData' +> rsnData <- delay rsnDefault -< rsnData' > currData <- if kcf == rsnKcf rsnData && kbw == rsnKbw rsnData > then outA -< rsnData > else update -< (rsnData, kcf, kbw) @@ -808,8 +784,8 @@ > butter = proc (sig, ButterData a1 a2 a3 a4 a5) -> do > rec let t = sig - a4 * y' - a5 * y'' > y = t * a1 + a2 * y' + a3 * y'' -> y' <- init 0 -< t -> y'' <- init 0 -< y' +> y' <- delay 0 -< t +> y'' <- delay 0 -< y' > outA -< y This filter reiterates input with an echo density determined by loop @@ -854,7 +830,7 @@ > b = 2 - cos (2 * pi * hp / sr) > c2 = b - sqrt (b * b - 1.0) > c1 = 1 - c2 -> y <- init 0 -< y' +> y <- delay 0 -< y' > outA -< y A high-pass filter whose transfer function is the complement of that @@ -891,7 +867,7 @@ > let sr = rate (undefined :: p) > in proc () -> do > rec -> y <- init a -< y + (b-a) * (1 / sr / dur) +> y <- delay a -< y + (b-a) * (1 / sr / dur) > outA -< y Trace an exponential curve between specified points. @@ -906,7 +882,7 @@ > let sr = rate (undefined :: p) > in proc () -> do > rec -> y <- init a -< y * pow (b/a) (1 / sr / dur) +> y <- delay a -< y * pow (b/a) (1 / sr / dur) > outA -< y Unfortunately, envLine and envExpon cannot be abstracted to a common @@ -914,10 +890,6 @@ > data Tab = Tab [Double] !Int !(UArray Int Double) -> instance Language.Haskell.TH.Syntax.Lift Tab where -> lift (Tab xs sz uarr) = -> [| Tab xs sz (listArray (0, sz-1) xs) |] - > aAt :: Tab -> Int -> Double > aAt (Tab _ sz a) i = unsafeAt a (min (sz-1) i) @@ -939,8 +911,8 @@ > let (t', i') = if t >= durs `aAt` i > then if i == sz-2 then (t+1, i) else (0, i+1) > else (t+1, i) -> i <- init 0 -< i' -> t <- init 0 -< t' +> i <- delay 0 -< i' +> t <- delay 0 -< t' > let a1 = aAt amps i > a2 = aAt amps (i+1) > d = aAt durs i @@ -1041,7 +1013,7 @@ > rec > i <- countUp -< () > let i' = fromIntegral i -> y <- init (readFromTableRaw tab 0) -< y' +> y <- delay (readFromTableRaw tab 0) -< y' > y' <- case (i' < rise * sr, i' < (dur-dec) * sr) of > (True, _) -> table tab False -< i' / (rise*sr+0.5) > (False, True) -> outA -< y * mlt1 @@ -1083,7 +1055,6 @@ > tableExpon size sp segs = tableExp_ sp segs False size > tableExp_ :: StartPt -> [(SegLength, EndPt)] -> Bool -> Int -> Table > tableExp_ sp segs = funToTable (interpLine sp segs interpExpLine) -> [| interpLine sp segs interpExpLine |] Analogous to csound's gen07 routine. @@ -1102,7 +1073,6 @@ > tableLinear size sp segs = tableLin_ sp segs False size > tableLin_ :: StartPt -> [(SegLength, EndPt)] -> Bool -> Int -> Table > tableLin_ sp segs = funToTable (interpLine sp segs interpStraightLine) -> [| interpLine sp segs interpStraightLine |] Make a table from a collection of sine waves at different offsets and strengths. @@ -1120,7 +1090,6 @@ > tableSines3 size ps = tableSines3_ ps False size > tableSines3_ :: [(PartialNum, PartialStrength, PhaseOffset)] -> Bool -> Int -> Table > tableSines3_ ps = funToTable (makeCompositeSineFun ps) -> [| makeCompositeSineFun ps |] > tableSinesF :: (Floating a, Enum a) => [a] -> a -> a > tableSinesF pss x = let phase = 2 * pi * x @@ -1133,7 +1102,7 @@ > tableSines :: Int -> [Double] -> Table > tableSines size pss = tableSinesN_ pss False size > tableSinesN_ :: [Double] -> Bool -> Int -> Table -> tableSinesN_ pss = funToTable (tableSinesF pss) [| tableSinesF pss |] +> tableSinesN_ pss = funToTable (tableSinesF pss) Generates the log of a modified Bessel function of the second kind, order 0, suitable for use in amplitude-modulated FM. @@ -1148,7 +1117,7 @@ > tableBessel :: Int -> Double -> Table > tableBessel size xint = tableBess_ xint False size > tableBess_ :: Double -> Bool -> Int -> Table -> tableBess_ xint = funToTable (tableBessF xint) [| tableBessF xint |] +> tableBess_ xint = funToTable (tableBessF xint) > tableBessF :: Floating s => s -> s -> s > tableBessF xint x = > log $ 1 + @@ -1253,7 +1222,7 @@ > timeBuilder d = > let r = (rate (undefined :: p))*d > in proc _ -> do -> rec i <- init 0 -< if i >= r then i-r else i+1 +> rec i <- delay 0 -< if i >= r then i-r else i+1 > outA -< if i < 1 then Just () else Nothing > milliseconds :: Clock p => Signal p () (SEvent ()) @@ -1265,6 +1234,6 @@ > countTime :: Clock p => Int -> Signal p () (SEvent ()) -> Signal p () (SEvent ()) > countTime n t = proc _ -> do > e <- t -< () -> rec i <- init 0 -< maybe i' (const $ i'+1) e +> rec i <- delay 0 -< maybe i' (const $ i'+1) e > let (i',o) = if i == n then (0, Just ()) else (i, Nothing) > outA -< o diff --git a/Euterpea/IO/Audio/Basics.hs b/Euterpea/IO/Audio/Basics.hs --- a/Euterpea/IO/Audio/Basics.hs +++ b/Euterpea/IO/Audio/Basics.hs @@ -1,76 +1,63 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, ExistentialQuantification, TemplateHaskell, Arrows #-} -module Euterpea.IO.Audio.Basics - (outA, integral, countDown, countUp, upsample, pchToHz, apToHz) - where -import Prelude hiding (init) +{-# LANGUAGE Arrows, ExistentialQuantification, FlexibleContexts, ScopedTypeVariables #-} + +module Euterpea.IO.Audio.Basics ( + outA, + integral, + countDown, countUp, + upsample, + pchToHz, apToHz +) where + import Euterpea.Music.Note.Music import Euterpea.IO.Audio.Types import Control.Arrow -import Control.CCA.ArrowP -import Control.CCA.Types - -outA :: forall a b . (ArrowInit a) => a b b -outA = arr' [| id |] id - -integral :: - forall a p . (ArrowInitP a p, Clock p) => ArrowP a p Double Double -integral - = let dt = 1 / rate (undefined :: p) in - (loop - ((arr' [| (\ (x, i) -> let i' = i + x * dt in i') |] - (\ (x, i) -> let i' = i + x * dt in i') - >>> init' [| 0 |] 0) - >>> arr' [| (\ i -> (i, i)) |] (\ i -> (i, i))) - >>> outA) - -countDown :: forall a . (ArrowInit a) => Int -> a () Int -countDown x - = (loop - (arr' [| (\ (_, i) -> i - 1) |] (\ (_, i) -> i - 1) >>> - (init' [| x |] x >>> arr' [| (\ i -> (i, i)) |] (\ i -> (i, i)))) - >>> outA) - -countUp :: forall a . (ArrowInit a) => a () Int -countUp - = (loop - (arr' [| (\ (_, i) -> i + 1) |] (\ (_, i) -> i + 1) >>> - (init' [| 0 |] 0 >>> arr' [| (\ i -> (i, i)) |] (\ i -> (i, i)))) - >>> outA) - -upsample :: - forall a p1 p2 b x . - (ArrowChoice a, ArrowInitP a p1, ArrowInitP a p2, Clock p1, - Clock p2, AudioSample b) => - ArrowP a p1 x b -> ArrowP a p2 x b -upsample f = g - where g = (loop - (arr' [| (\ (x, ~(cc, y)) -> (cc, (x, y))) |] - (\ (x, ~(cc, y)) -> (cc, (x, y))) - >>> - (first - (arr' [| (\ cc -> if cc >= r - 1 then 0 else cc + 1) |] - (\ cc -> if cc >= r - 1 then 0 else cc + 1) - >>> init' [| 0 |] 0) - >>> - arr' [| (\ (cc, (x, y)) -> ((cc, x, y), cc)) |] - (\ (cc, (x, y)) -> ((cc, x, y), cc))) - >>> - (first - (arr' [| (\ (cc, x, y) -> if cc == 0 then Left x else Right y) |] - (\ (cc, x, y) -> if cc == 0 then Left x else Right y) - >>> (ArrowP (strip f) ||| init' [| zero |] zero)) - >>> - arr' [| (\ (y, cc) -> (y, (cc, y))) |] - (\ (y, cc) -> (y, (cc, y))))) - >>> outA) - r = if outRate < inRate then - error "Cannot upsample a signal of higher rate to lower rate" else - outRate / inRate - inRate = rate (undefined :: p1) - outRate = rate (undefined :: p2) - -apToHz :: forall a . (Floating a) => AbsPitch -> a -apToHz ap = 440 * 2 ** (fromIntegral (ap - absPitch (A, 5)) / 12) - -pchToHz :: forall a . (Floating a) => Pitch -> a +import Control.Arrow.Operations +import Control.Arrow.ArrowP + + +outA :: (Arrow a) => a b b +outA = arr id + +integral :: forall a p. (ArrowCircuit a, Clock p) => ArrowP a p Double Double +integral = + let dt = 1 / rate (undefined :: p) + in proc x -> do + rec let i' = i + x * dt + i <- delay 0 -< i' + outA -< i + +countDown :: ArrowCircuit a => Int -> a () Int +countDown x = proc _ -> do + rec i <- delay x -< i - 1 + outA -< i + +countUp :: ArrowCircuit a => a () Int +countUp = proc _ -> do + rec i <- delay 0 -< i + 1 + outA -< i + + +upsample :: forall a b c p1 p2. (ArrowChoice a, ArrowCircuit a, Clock p1, Clock p2, AudioSample c) + => ArrowP a p1 b c -> ArrowP a p2 b c +upsample f = g + where g = proc x -> do + rec + cc <- delay 0 -< if cc >= r-1 then 0 else cc+1 + y <- if cc == 0 then ArrowP (strip f) -< x + else delay zero -< y + outA -< y + r = if outRate < inRate + then error "Cannot upsample a signal of higher rate to lower rate" + else outRate / inRate + inRate = rate (undefined :: p1) + outRate = rate (undefined :: p2) + +-- Some useful auxiliary functions. + +-- | Converting an AbsPitch to hertz (cycles per second): +apToHz :: Floating a => AbsPitch -> a +apToHz ap = 440 * 2 ** (fromIntegral (ap - absPitch (A,5)) / 12) + +-- | Converting from a Pitch value to Hz: +pchToHz :: Floating a => Pitch -> a pchToHz = apToHz . absPitch diff --git a/Euterpea/IO/Audio/IO.hs b/Euterpea/IO/Audio/IO.hs --- a/Euterpea/IO/Audio/IO.hs +++ b/Euterpea/IO/Audio/IO.hs @@ -6,8 +6,7 @@ -- outFileA, outFileNormA, RecordStatus, maxSample) where -import Prelude hiding (init) -import Control.CCA.ArrowP +import Control.Arrow.ArrowP import Control.SF.SF import Euterpea.IO.Audio.Types hiding (Signal) @@ -97,7 +96,7 @@ let numChannels = numChans (undefined :: a) writeWavSink = sink (writeWav f filepath sr numChannels) in proc (a, rs) -> do - rec dat <- init [] -< dat' + rec dat <- delay [] -< dat' dat' <- case rs of Pause -> returnA -< dat Record -> returnA -< a:dat diff --git a/Euterpea/IO/Audio/Render.hs b/Euterpea/IO/Audio/Render.hs --- a/Euterpea/IO/Audio/Render.hs +++ b/Euterpea/IO/Audio/Render.hs @@ -9,8 +9,8 @@ ) where import Control.Arrow -import Control.CCA.Types -import Control.CCA.ArrowP +import Control.Arrow.Operations +import Control.Arrow.ArrowP import Control.SF.SF import Euterpea.Music.Note.Music @@ -19,12 +19,10 @@ import Euterpea.IO.Audio.Basics import Euterpea.IO.Audio.Types -import Data.List hiding (init) +import Data.List import qualified Data.IntMap as M import Data.Ord (comparing) -import Prelude hiding (init) - -- Every instrument is a function that takes a duration, absolute -- pitch, volume, and a list of parameters (Doubles). What the function -- actually returns is implementation independent. @@ -72,7 +70,7 @@ in proc _ -> do rec t <- integral -< 1 - es <- init evts -< next + es <- delay evts -< next let (evs, next) = span ((<= t) . fst) es -- Trim events that are due off the list and output them, -- retaining the rest @@ -106,7 +104,7 @@ evts <- esig -< () rec -- perhaps this can be run at a lower rate using upsample - sfcol <- init col -< mod sfcol' evts + sfcol <- delay col -< mod sfcol' evts let rs = fmap (\s -> runSF (strip s) ()) sfcol :: col (a, SF () a) (as, sfcol' :: col (Signal p () a)) = (fmap fst rs, fmap (ArrowP . snd) rs) outA -< as diff --git a/Euterpea/IO/Audio/Types.hs b/Euterpea/IO/Audio/Types.hs --- a/Euterpea/IO/Audio/Types.hs +++ b/Euterpea/IO/Audio/Types.hs @@ -2,8 +2,7 @@ module Euterpea.IO.Audio.Types where -import Control.CCA.CCNF -import Control.CCA.ArrowP +import Control.Arrow.ArrowP import Control.SF.SF @@ -24,7 +23,6 @@ type Signal clk a b = ArrowP SF clk a b type SigFun clk a b = ArrowP SF clk a b -type SignalSyn clk a b = ArrowP ASyn clk a b -- Arbitrary number of channels (say, 5.1) can be supported by just adding more -- instances of the AudioSample type class. @@ -51,44 +49,3 @@ -- Some useful type synonyms: type Mono p = Signal p () Double type Stereo p = Signal p () (Double,Double) - - -{- --- Experimental stuff -class Unlifted a where - expose :: a -> b -> b - expose = seq - unlifted_dummy :: a - unlifted_dummy = error "unlifted_dummy" - -instance Unlifted Double -instance Unlifted Float -instance Unlifted Int -instance Unlifted () -instance Unlifted a => Unlifted [a] - -instance (Unlifted a, Unlifted b) => Unlifted (a -> b) - -data a :!: b = (Unlifted a, Unlifted b) => !a :!: !b -instance Unlifted (a :!: b) where - expose (a :!: b) s = expose a (expose b s) - {-# INLINE expose #-} - -instance (Unlifted a, Unlifted b) => Unlifted (a,b) where - expose (a, b) s = expose a (expose b s) - {-# INLINE expose #-} - -instance (Unlifted a, Unlifted b, Unlifted c) => Unlifted (a,b,c) where - expose (a, b, c) s = expose a (expose b (expose c s)) - {-# INLINE expose #-} - -instance (Unlifted a, Unlifted b, Unlifted c, Unlifted d) - => Unlifted (a,b,c,d) where - expose (a, b, c,d) s = expose a (expose b (expose c (expose d s))) - {-# INLINE expose #-} - -instance (Unlifted a, Unlifted b, Unlifted c, Unlifted d, Unlifted e) - => Unlifted (a,b,c,d,e) where - expose (a, b, c,d,e) s = expose a (expose b (expose c (expose d (expose e s)))) - {-# INLINE expose #-} --} diff --git a/Euterpea/IO/MIDI/GeneralMidi.hs b/Euterpea/IO/MIDI/GeneralMidi.hs --- a/Euterpea/IO/MIDI/GeneralMidi.hs +++ b/Euterpea/IO/MIDI/GeneralMidi.hs @@ -1,7 +1,7 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/GeneralMidi.lhs. (See HSoM/MakeCode.bat.) - - +{-# LINE 9 "GeneralMidi.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/GeneralMidi.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 16 "GeneralMidi.lhs" #-} module Euterpea.IO.MIDI.GeneralMidi where import Euterpea.Music.Note.Music (InstrumentName(..)) @@ -144,7 +144,7 @@ fromEnum Helicopter = 125 fromEnum Applause = 126 fromEnum Gunshot = 127 - fromEnum i = error $ "fromEnum: " ++ show i ++ " inot implemented" + fromEnum i = error $ "fromEnum: " ++ show i ++ " is not implemented" toEnum 0 = AcousticGrandPiano toEnum 1 = BrightAcousticPiano @@ -275,4 +275,3 @@ toEnum 126 = Applause toEnum 127 = Gunshot toEnum n = error $ "toEnum: " ++ show n ++ " is not implemented for InstrumentName" - diff --git a/Euterpea/IO/MIDI/ToMidi.hs b/Euterpea/IO/MIDI/ToMidi.hs --- a/Euterpea/IO/MIDI/ToMidi.hs +++ b/Euterpea/IO/MIDI/ToMidi.hs @@ -1,6 +1,7 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/ToMidi.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "ToMidi.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/ToMidi.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "ToMidi.lhs" #-} module Euterpea.IO.MIDI.ToMidi(toMidi, UserPatchMap, defST, defUpm, testMidi, testMidiA, test, testA, writeMidi, writeMidiA, @@ -17,8 +18,11 @@ import Data.List(partition) import Data.Char(toLower,toUpper) import Codec.Midi +{-# LINE 136 "ToMidi.lhs" #-} type ProgNum = Int +{-# LINE 170 "ToMidi.lhs" #-} type UserPatchMap = [(InstrumentName, Channel)] +{-# LINE 197 "ToMidi.lhs" #-} makeGMMap :: [InstrumentName] -> UserPatchMap makeGMMap ins = mkGMMap 0 ins where mkGMMap _ [] = [] @@ -28,13 +32,15 @@ (Percussion, 9) : mkGMMap n ins mkGMMap n (i : ins) = (i, chanList !! n) : mkGMMap (n+1) ins - chanList = [0..8] ++ [10..15] -- channel 9 is for percussion + chanList = [0..8] ++ [10..15] -- channel 9 is for percussion +{-# LINE 219 "ToMidi.lhs" #-} upmLookup :: UserPatchMap -> InstrumentName -> (Channel, ProgNum) upmLookup upm iName = (chan, toGM iName) where chan = maybe (error ( "instrument " ++ show iName ++ " not in patch map") ) id (lookup iName upm) +{-# LINE 371 "ToMidi.lhs" #-} toMidi :: Performance -> UserPatchMap -> Midi toMidi pf upm = let split = splitByInst pf @@ -47,16 +53,19 @@ (map (fromAbsTime . performToMEvs rightMap) split) division = 96 :: Int +{-# LINE 388 "ToMidi.lhs" #-} allValid :: UserPatchMap -> [InstrumentName] -> Bool allValid upm = and . map (lookupB upm) lookupB :: UserPatchMap -> InstrumentName -> Bool lookupB upm x = or (map ((== x) . fst) upm) +{-# LINE 401 "ToMidi.lhs" #-} splitByInst :: Performance -> [(InstrumentName,Performance)] splitByInst [] = [] splitByInst pf = (i, pf1) : splitByInst pf2 where i = eInst (head pf) (pf1, pf2) = partition (\e -> eInst e == i) pf +{-# LINE 430 "ToMidi.lhs" #-} type MEvent = (Ticks, Message) defST = 500000 @@ -72,6 +81,7 @@ loop (e:es) = let (mev1,mev2) = mkMEvents chan e in mev1 : insertMEvent mev2 (loop es) in setupInst : setTempo : loop pf +{-# LINE 453 "ToMidi.lhs" #-} mkMEvents :: Channel -> Event -> (MEvent,MEvent) mkMEvents mChan (Event { eTime = t, ePitch = p, eDur = d, eVol = v}) @@ -80,14 +90,16 @@ where v' = max 0 (min 127 (fromIntegral v)) toDelta t = round (t * 2.0 * fromIntegral division) +{-# LINE 477 "ToMidi.lhs" #-} insertMEvent :: MEvent -> [MEvent] -> [MEvent] insertMEvent mev1 [] = [mev1] insertMEvent mev1@(t1,_) mevs@(mev2@(t2,_):mevs') = if t1 <= t2 then mev1 : mevs else mev2 : insertMEvent mev1 mevs' - +{-# LINE 558 "ToMidi.lhs" #-} defUpm :: UserPatchMap -defUpm = [(AcousticGrandPiano,1), +defUpm = [(AcousticGrandPiano,0), + (Marimba,1), (Vibraphone,2), (AcousticBass,3), (Flute,4), @@ -95,15 +107,15 @@ (AcousticGuitarSteel,6), (Viola,7), (StringEnsemble1,8), - (AcousticGrandPiano,9)] - -- the GM name for drums is unimportant, only channel 9 - + (AcousticGrandPiano,9)] + -- the GM name for drums is unimportant, only channel 9 +{-# LINE 579 "ToMidi.lhs" #-} testMidi :: Performable a => Music a -> Midi testMidi m = toMidi (defToPerf m) defUpm testMidiA :: Performable a => PMap Note1 -> Context Note1 -> Music a -> Midi testMidiA pm con m = toMidi (toPerf pm con m) defUpm - +{-# LINE 590 "ToMidi.lhs" #-} test :: Performable a => Music a -> IO () test m = exportMidiFile "test.mid" (testMidi m) @@ -116,40 +128,40 @@ writeMidiA :: Performable a => FilePath -> PMap Note1 -> Context Note1 -> Music a -> IO () writeMidiA fn pm con m = exportMidiFile fn (testMidiA pm con m) - +{-# LINE 609 "ToMidi.lhs" #-} play :: Performable a => Music a -> IO () play = playM . testMidi - +{-# LINE 617 "ToMidi.lhs" #-} playM :: Midi -> IO () playM midi = do initialize (defaultOutput playMidi) midi terminate return () - +{-# LINE 629 "ToMidi.lhs" #-} playA :: Performable a => PMap Note1 -> Context Note1 -> Music a -> IO () playA pm con m = let pf = fst $ perfDur pm con m in playM (toMidi pf defUpm) +{-# LINE 641 "ToMidi.lhs" #-} makeMidi :: (Music1, Context Note1, UserPatchMap) -> Midi makeMidi (m,c,upm) = toMidi (perform defPMap c m) upm - +{-# LINE 649 "ToMidi.lhs" #-} mToMF :: PMap a -> Context a -> UserPatchMap -> FilePath -> Music a -> IO () mToMF pmap c upm fn m = let pf = perform pmap c m mf = toMidi pf upm in exportMidiFile fn mf - +{-# LINE 666 "ToMidi.lhs" #-} gmUpm :: UserPatchMap gmUpm = map (\n -> (toEnum n, mod n 16 + 1)) [0..127] - +{-# LINE 675 "ToMidi.lhs" #-} gmTest :: Int -> IO () gmTest i = let gMM = take 8 (drop (i*8) [0..127]) mu = line (map simple gMM) simple n = Modify (Instrument (toEnum n)) cMajArp in mToMF defPMap defCon gmUpm "test.mid" mu -cMaj = [ n 4 qn | n <- [c,e,g] ] -- octave 4, quarter notes +cMaj = [ n 4 qn | n <- [c,e,g] ] -- octave 4, quarter notes cMajArp = toMusic1 (line cMaj) - diff --git a/Euterpea/IO/MUI.hs b/Euterpea/IO/MUI.hs --- a/Euterpea/IO/MUI.hs +++ b/Euterpea/IO/MUI.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Euterpea.IO.MUI ( -- UI functions UISF @@ -18,7 +20,7 @@ , display -- :: Show a => UISF a () , withDisplay -- :: Show b => UISF a b -> UISF a b , textboxE -- :: String -> UISF (SEvent String) String - , textbox -- :: UISF String String + , textbox -- :: String -> UISF (SEvent String) String , title -- :: String -> UISF a b -> UISF a b , button -- :: String -> UISF () Bool , stickyButton -- :: String -> UISF () Bool @@ -47,25 +49,23 @@ , makeLayout -- :: LayoutType -> LayoutType -> Layout , LayoutType (..) -- data LayoutType = Stretchy { minSize :: Int } | Fixed { fixedSize :: Int } , Color (..) -- data Color = Black | Blue | Green | Cyan | Red | Magenta | Yellow | White + , (~++) ) where import Euterpea.IO.MUI.MidiWidgets import Euterpea.IO.MIDI.MidiIO (initializeMidi, terminateMidi) -import FRP.UISF - -import Control.CCA.Types - -instance ArrowInit UISF where - init = delay +import FRP.UISF hiding ((~++)) defaultMUIParams :: UIParams -defaultMUIParams = defaultUIParams { uiInitialize = initializeMidi, uiClose = terminateMidi, uiTitle = "MUI" } +defaultMUIParams = defaultUIParams { uiTitle = "MUI" } runMUI :: UIParams -> UISF () () -> IO () -runMUI = runUI +runMUI params = runUI (params { uiInitialize = uiInitialize params >> initializeMidi, + uiClose = uiClose params >> terminateMidi}) runMUI' :: UISF () () -> IO () -runMUI' = runUI defaultMUIParams - - +runMUI' = runMUI defaultMUIParams +#if MIN_VERSION_UISF(0,4,0) +asyncV x = asyncVT x +#endif diff --git a/Euterpea/IO/MUI/FFT.hs b/Euterpea/IO/MUI/FFT.hs --- a/Euterpea/IO/MUI/FFT.hs +++ b/Euterpea/IO/MUI/FFT.hs @@ -8,10 +8,8 @@ {-# LANGUAGE Arrows #-} module Euterpea.IO.MUI.FFT where -import Control.CCA.Types -import Prelude hiding (init) - import FRP.UISF +import Control.Arrow.Operations import Numeric.FFT (fft) import Data.Complex import Data.Map (Map) @@ -33,9 +31,9 @@ -- | Returns n samples of type b from the input stream at a time, -- updating after k samples. This function is good for chunking -- data and is a critical component to fftA -quantize :: ArrowInit a => Int -> Int -> a b (SEvent [b]) +quantize :: ArrowCircuit a => Int -> Int -> a b (SEvent [b]) quantize n k = proc d -> do - rec (ds,c) <- init ([],0) -< (take n (d:ds), c+1) + rec (ds,c) <- delay ([],0) -< (take n (d:ds), c+1) returnA -< if c >= n && c `mod` k == 0 then Just ds else Nothing -- | Converts the vector result of a dft into a map from frequency to magnitude. @@ -51,7 +49,7 @@ -- successive FFT calculation) and a fundamental period, this will decompose -- the input signal into its constituent frequencies. -- NOTE: The fundamental period must be a power of two! -fftA :: ArrowInit a => Int -> Int -> a Double (SEvent [Double]) +fftA :: ArrowCircuit a => Int -> Int -> a Double (SEvent [Double]) fftA qf fp = proc d -> do carray <- quantize fp qf -< d :+ 0 returnA -< fmap (map magnitude . take (fp `div` 2) . fft) carray diff --git a/Euterpea/IO/MUI/Guitar.hs b/Euterpea/IO/MUI/Guitar.hs --- a/Euterpea/IO/MUI/Guitar.hs +++ b/Euterpea/IO/MUI/Guitar.hs @@ -1,16 +1,35 @@ -{-# LANGUAGE Arrows #-} +{-# LANGUAGE Arrows, CPP #-} module Euterpea.IO.MUI.Guitar where -import FRP.UISF -import FRP.UISF.SOE -import FRP.UISF.UITypes (Layout(..), nullLayout) -import FRP.UISF.Widget +import FRP.UISF hiding ((~++)) +import FRP.UISF.UITypes import Euterpea.IO.MIDI import Euterpea.Music.Note.Music hiding (transpose) import Euterpea.IO.MUI.InstrumentBase +import Euterpea.IO.MUI.MidiWidgets ((~++)) import qualified Codec.Midi as Midi import Data.Maybe import qualified Data.Char as Char +#if MIN_VERSION_UISF(0,4,0) +import FRP.UISF.Graphics +import FRP.UISF.Widget.Construction +import FRP.UISF.Widget +withColorC = withColor +#else +import qualified FRP.UISF.SOE as SOE +import FRP.UISF.SOE hiding (arc, ellipse) +import qualified FRP.UISF.Widget as W +import FRP.UISF.Widget hiding (pushed, popped, marked) +pushed = let [(to,bo),(ti,bi)] = W.pushed + in (to,ti,bi,bo) +popped = let [(to,bo),(ti,bi)] = W.popped + in (to,ti,bi,bo) +arc ((x,y),(w,h)) = SOE.arc (x,y) (x+w,y+h) +ellipse ((x,y),(w,h)) = SOE.ellipse (x,y) (x+w,y+h) +rectangleFilled = block +withColorC = withColor' +#endif + --Note, only valid for standard US keyboards: --Also, this is an ugly hack that can't stay --it's mostly to test the new key events @@ -35,18 +54,22 @@ -- Draws an individual fret -drawFret [] ((x, y), (w, h)) = nullGraphic -drawFret ((t, b):cs) ((x, y), (w, h)) = - drawFret cs ((x + 1, y + 1), (w - 2, h )) // - withColor' t (line (x, y) (x, y + h)) // - withColor' b (line (x + w - 1, y) (x + w - 1, y + h)) +#if MIN_VERSION_UISF(0,4,0) +drawFret :: (Color,Color,Color,Color) -> Rect -> Graphic +#endif +drawFret (to,ti,bi,bo) ((x, y), (w, h)) = + withColorC ti (line (x + 1, y + 1) (x + 1, y + h + 1)) // + withColorC bi (line (x + w - 2, y + 1) (x + w - 2, y + h + 1)) // + withColorC to (line (x, y) (x, y + h)) // + withColorC bo (line (x + w - 1, y) (x + w - 1, y + h)) + -- Draws the string on top of each fret - +drawString :: Bool -> Rect -> Graphic drawString down ((x, y), (w, h)) = - withColor Black (if down then arc (x,midY+2) (x+w, midY-2) (-180) 180 + withColor Black (if down then arc ((x,midY-2),(w, 4)) (-180) 180 else line (x-1, y+ h `div` 2) (x+w, y+h `div` 2)) // - if down then withColor Blue (ellipse (midX - d, midY - d) (midX + d, midY + d)) else nullGraphic + if down then withColor Blue $ ellipse ((midX - d, midY - d), (2*d, 2*d)) else nullGraphic where d = 10 midX = x + w `div` 2 midY = y + h `div` 2 @@ -58,7 +81,7 @@ concatA (map (mkBasicWidget layout . draw) [n,n-1..1]) >>> constA () where draw k ((x,y),(w,h)) = withColor Black $ line (x, y + h `div` 2 + 5 * (3 - k)) (x + w, y + h `div` 2) - layout = Layout 0 0 fw fh fw fh + layout = makeLayout (Fixed fw) (Fixed fh) --drawHead :: Int -> UISF () () @@ -76,7 +99,7 @@ mkKey c kt = mkWidget iState d process draw where iState = (KeyState False False False 127, Nothing) - d = Layout 0 0 0 minh minw minh + d = makeLayout (Fixed minw) (Fixed minh) (minh, minw) = (fh, fw - kt * 3) draw box@((x,y),(w,h)) _ (kb, showNote) = @@ -96,7 +119,11 @@ if detectKey c' (hasShiftModifier ms) then kb' { keypad = down, vel = 127 } else kb' +#if MIN_VERSION_UISF(0,4,0) + Button pt LeftButton down -> +#else Button pt True down -> +#endif case (mouse kb', down, pt `inside` box) of (False, True, True) -> kb' { mouse = True, vel = getVel pt box } (True, False, True) -> kb' { mouse = False, vel = getVel pt box } @@ -138,11 +165,15 @@ draw ((x,y),(w,h)) _ down = let x' = x + (w - tw) `div` 2 + if down then 0 else -1 y' = y + (h - th) `div` 2 + if down then 0 else -1 - in withColor (if down then White else Black) $ block ((0,0),(10,10)) + in withColor (if down then White else Black) $ rectangleFilled ((0,0),(10,10)) process _ s _ evt = (s', s', s /= s') where s' = case evt of +#if MIN_VERSION_UISF(0,4,0) + Button pt LeftButton down -> down +#else Button pt True down -> down +#endif Key c' _ down -> down && c == c' _ -> s diff --git a/Euterpea/IO/MUI/InstrumentBase.hs b/Euterpea/IO/MUI/InstrumentBase.hs --- a/Euterpea/IO/MUI/InstrumentBase.hs +++ b/Euterpea/IO/MUI/InstrumentBase.hs @@ -1,10 +1,10 @@ {-# LANGUAGE Arrows #-} module Euterpea.IO.MUI.InstrumentBase where import qualified Codec.Midi as Midi -import FRP.UISF +import FRP.UISF hiding ((~++)) import Data.Maybe import Control.Monad -import Euterpea.IO.MUI.MidiWidgets (musicToMsgs) +import Euterpea.IO.MUI.MidiWidgets (musicToMsgs, (~++)) import Euterpea.IO.MIDI import Euterpea.Music.Note.Music hiding (transpose) import Euterpea.Music.Note.Performance diff --git a/Euterpea/IO/MUI/MidiWidgets.lhs b/Euterpea/IO/MUI/MidiWidgets.lhs --- a/Euterpea/IO/MUI/MidiWidgets.lhs +++ b/Euterpea/IO/MUI/MidiWidgets.lhs @@ -1,7 +1,8 @@ > {-# LANGUAGE RecursiveDo, Arrows, TupleSections #-} > module Euterpea.IO.MUI.MidiWidgets ( -> midiIn +> (~++) +> , midiIn > , midiOut > , midiInM > , midiOutM, midiOutB, midiOutMB @@ -11,12 +12,15 @@ > , selectInput, selectOutput > , selectInputM, selectOutputM > , BufferOperation (..) -- Reexported for use with midiOutMB +#if MIN_VERSION_UISF(0,4,0) +> , asyncMidi, asyncMidiOn +#endif > ) where -> import FRP.UISF +> import FRP.UISF hiding ((~++)) > import Euterpea.IO.MIDI.MidiIO -> import Control.Monad (liftM) +> import Control.Monad (liftM, forM_, when) > -- These four imports are just for musicToMsgs > import Euterpea.IO.MIDI.GeneralMidi (toGM) @@ -25,13 +29,29 @@ > import Data.List (nub, elemIndex, sortBy) > -- These three imports are for the runMidi functions +> import FRP.UISF.UISF (addTerminationProc) > import Euterpea.IO.MUI.UISFCompat > import Control.SF.SF > import Control.DeepSeq +> import Control.Concurrent (threadDelay, killThread) +> import Data.IORef +> import Data.Monoid +#if MIN_VERSION_UISF(0,4,0) +> import FRP.UISF.Asynchrony +> import Data.Maybe (listToMaybe) +#endif + +> (~++) :: SEvent [a] -> SEvent [a] -> SEvent [a] +> (~++) = mappend + + + + + ============================================================ ========================= Widgets ========================== ============================================================ @@ -133,7 +153,7 @@ corresponding to Multiple input/output (M), Batch (B), and message flooding (Flood). -> runMidi :: NFData b +> runMidi :: (NFData b, NFData c) > => SF (b, SEvent [MidiMessage]) > (c, SEvent [MidiMessage]) > -> UISF (b, (Maybe InputDeviceID, Maybe OutputDeviceID)) [c] @@ -149,7 +169,7 @@ > sf' = toAutomaton $ arr (\((b,(idev,odev)),mms) -> ((b,mms),odev)) >>> first sf >>> > arr (\((c,mms),odev) -> (c, (odev, mms))) -> runMidiM :: NFData b +> runMidiM :: (NFData b, NFData c) > => SF (b, ([(InputDeviceID, SEvent [MidiMessage])], [OutputDeviceID])) > (c, [(OutputDeviceID, SEvent [MidiMessage])]) > -> UISF (b, ([InputDeviceID],[OutputDeviceID])) [c] @@ -167,13 +187,13 @@ > oAction rst > sf' = toAutomaton $ arr (\((b,(idevs,odevs)),mms) -> (b,(mms,odevs))) >>> sf -> runMidiMFlood :: NFData b +> runMidiMFlood :: (NFData b, NFData c) > => SF (b, SEvent [MidiMessage]) > (c, SEvent [MidiMessage]) > -> UISF (b, ([InputDeviceID],[OutputDeviceID])) [c] > runMidiMFlood = runMidiFloodHelper runMidiM -> runMidiMB :: NFData b +> runMidiMB :: (NFData b, NFData c) > => SF (b, ([(InputDeviceID, SEvent [MidiMessage])], [OutputDeviceID])) > (c, [(OutputDeviceID, BufferOperation MidiMessage)]) > -> UISF (b, ([InputDeviceID],[OutputDeviceID])) [(c, Bool)] --([c], Bool) @@ -209,7 +229,7 @@ > shouldClear _ = False -> runMidiMBFlood :: NFData b +> runMidiMBFlood :: (NFData b, NFData c) > => SF (b, SEvent [MidiMessage]) > (c, BufferOperation MidiMessage) > -> UISF (b, ([InputDeviceID],[OutputDeviceID])) [(c, Bool)] --([c], Bool) @@ -303,4 +323,64 @@ > in title t $ checkGroup $ map (\(i,d) -> (name d, i)) devs +#if MIN_VERSION_UISF(0,4,0) +> -- For backward compatibility with runMidi, which should be rewritten +> asyncC' :: (ArrowIO a, ArrowLoop a, ArrowCircuit a, ArrowChoice a, NFData b, NFData c) => +> x -- ^ The thread handler +> -> (b -> IO d, e -> IO ()) -- ^ Effectful input and output channels for the automaton +> -> (Automaton (->) (b,d) (c,e)) -- ^ The automaton to convert to asynchronize +> -> a b [c] +> asyncC' _ (ia, oa) sf = asyncCIO (return (), const $ return ()) sf' where +> sf' _ = (arr id &&& actionToIOAuto ia) >>> pureAutoToIOAuto sf >>> second (actionToIOAuto oa) >>> arr fst + + +> asyncMidiHelper asy rinit (_defb, defc) dd f = asy (ini, term) sf >>> arr listToMaybe >>> hold defc where +> sf _ = proc b -> do +> rec r <- delay rinit -< r' +> (omt, r', c) <- arr f -< (r,b) +> actionToIOAuto action -< omt +> returnA -< c +> ini = return () +> term _ = putStrLn "MIDI back-end terminated." +> action omt = do +> let td = sum $ map snd omt +> forM_ omt $ \(om, t) -> do +> forM_ om $ \(odev,mm) -> do +> outputMidi odev +> forM_ mm (\m -> deliverMidiEvent odev (0, m)) +> when (t > 0) (threadDelay t) +> when (td <= 0) (threadDelay dd) + + + +> asyncMidi :: NFData c => r -> (b,c) -> Int -> ((r, b) -> ([([(OutputDeviceID, [MidiMessage])], Int)], r, c)) -> UISF b c +> asyncMidi = asyncMidiHelper asyncCIO + +> asyncMidiOn :: NFData c => Int -> r -> (b,c) -> Int -> ((r, b) -> ([([(OutputDeviceID, [MidiMessage])], Int)], r, c)) -> UISF b c +> asyncMidiOn n = asyncMidiHelper (asyncCIOOn n) + +asyncMidiHelper asy r (defb, defc) dd f = initialAIO (newIORef Nothing) go where +-- >>> arr (\x -> if null x then Nothing else Just (last x)) +-- >>> hold defc where +-- go die = asy th ((r,defb),g) where + go die = asy (defb, defc) th (r,uncurry h) where + th tid = addTerminationProc $ do + writeIORef die (Just tid) + putStrLn "MIDI back-end closing..." +-- g ((r,b),[]) = h r b +-- g ((r,_),bs) = h r (last bs) + h r b = do + let (omt, r', c) = f (r, b) + td = sum $ map snd omt + forM_ omt $ \(om, t) -> do + forM_ om $ \(odev,mm) -> do + outputMidi odev + forM_ mm (\m -> deliverMidiEvent odev (0, m)) + when (t > 0) (threadDelay t) + continue <- readIORef die + maybe (return ()) killThread continue + when (td <= 0) (threadDelay dd) +-- return ((r',b),c) + return (r',c) +#endif diff --git a/Euterpea/IO/MUI/Piano.hs b/Euterpea/IO/MUI/Piano.hs --- a/Euterpea/IO/MUI/Piano.hs +++ b/Euterpea/IO/MUI/Piano.hs @@ -1,15 +1,32 @@ -{-# LANGUAGE Arrows #-} +{-# LANGUAGE Arrows, CPP #-} module Euterpea.IO.MUI.Piano where -import FRP.UISF -import FRP.UISF.SOE -import FRP.UISF.UITypes (Layout(..)) -import FRP.UISF.Widget +import FRP.UISF hiding ((~++)) +import FRP.UISF.UITypes import Euterpea.Music.Note.Music hiding (transpose) import Euterpea.IO.MUI.InstrumentBase +import Euterpea.IO.MUI.MidiWidgets ((~++)) import qualified Codec.Midi as Midi import Data.Maybe import qualified Data.Char as Char +#if MIN_VERSION_UISF(0,4,0) +import FRP.UISF.Graphics +import FRP.UISF.Widget.Construction +import FRP.UISF.Widget +withColorC = withColor +#else +import FRP.UISF.SOE +import qualified FRP.UISF.Widget as W +import FRP.UISF.Widget hiding (pushed, popped, marked) +pushed = let [(to,bo),(ti,bi)] = W.pushed + in (to,ti,bi,bo) +popped = let [(to,bo),(ti,bi)] = W.popped + in (to,ti,bi,bo) +rectangleFilled = block +withColorC = withColor' +#endif + + --Note, only valid for standard US keyboards: --Also, this is an ugly hack that can't stay --it's mostly to test the new key events @@ -41,7 +58,7 @@ topW White2 = ww - bw `div` 2 topW White3 = ww -insideKey :: KeyType -> (Int,Int) -> ((Int,Int),(Int,Int)) -> Bool +insideKey :: KeyType -> Point -> Rect -> Bool insideKey Black1 pt ((x, y), (w, h)) = pt `inside` ((x,y),(bw,bh)) insideKey White1 pt ((x, y), (w, h)) = let b1 = ((x,y), (ww - bw `div` 2, bh)) @@ -64,66 +81,80 @@ -- ***************************************************************************** -- Drawing routines for each key type -- ***************************************************************************** --- This has a complicated type, so I'm leaving it out. -drawBox kt | kt == White1 = white1 - | kt == White2 = white2 - | kt == White3 = white3 - | kt == Black1 = black1 -drawBox _ = error "Euterpea.IO.MUI.Piano.drawBox: Unexpected input" - -white1 [] _ = nullGraphic -white1 ((t, b):cs) ((x, y), (w, h)) = - let x' = x + w - bw `div` 2 - y' = y + bh - in white1 cs ((x + 1, y + 1), (w - 2, h - 2)) // - withColor' t (line (x, y) (x, y + h - 1) // - line (x, y) (x' - 2, y) // - line (x' - 2, y+bh) (x + w - 2, y+bh)) // - withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // - line (x + w - 2 - bw `div` 2, y) (x + w - 2 - bw `div` 2, y+bh) // - line (x + w - 1, y + bh) (x + w - 1, y + h - 1)) +#if MIN_VERSION_UISF(0,4,0) +drawKey :: KeyType -> (Color,Color,Color,Color) -> Rect -> Graphic +#endif +drawKey White1 (to,ti,bi,bo) ((x, y), (w, h)) = + let val = x + w - bw `div` 2 + in withColorC ti (line (x + 1, y + 1) (x + 1, y + h - 2) // + line (x + 1, y + 1) (val - 3, y + 1) // + line (val - 3, y + 1 + bh) (x + w - 3, y + 1 + bh)) + // withColorC bi (line (x + 2, y + h - 2) (x + w - 2, y + h - 2) // + line (val - 3, y + 1) (val - 3, y + 1 + bh) // + line (x + w - 2, y + 1 + bh) (x + w - 2, y + h - 2)) + // withColorC to (line (x, y) (x, y + h - 1) // + line (x, y) (val - 2, y) // + line (val - 2, y + bh) (x + w - 2, y + bh)) + // withColorC bo (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // + line (val - 2, y) (val - 2, y + bh) // + line (x + w - 1, y + bh) (x + w - 1, y + h - 1)) -white2 [] _ = nullGraphic -white2 ((t, b):cs) ((x, y), (w, h)) = - let x1 = x + bw `div` 2 - x2 = x + w - bw `div` 2 - y' = y + bh - in white2 cs ((x + 1, y + 1), (w - 2, h - 2)) // - withColor' t (line (x1+2, y) (x1+2, y' - 1) // - line (x1+2, y) (x2 - 2, y) // - line (x - 2, y') (x1 - 2, y') // - line (x2- 2, y') (x + w - 2, y')) // - withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // - line (x2 - 1, y) (x2 - 1, y') // - line (x + w - 1, y + bh) (x + w - 1, y + h - 1)) +drawKey White2 (to,ti,bi,bo) ((x, y), (w, h)) = + let valP = x + bw `div` 2 + valM = x + w - bw `div` 2 + in withColorC ti (line (valP + 3, y + 1) (valP + 3, y + bh) // + line (valP + 3, y + 1) (valM - 3, y + 1) // + line (x - 1, y + bh + 1) (valP - 1, y + bh + 1) // + line (valM - 3, y + bh + 1) (x + w - 3, y + bh + 1)) + // withColorC bi (line (x + 2, y + h - 2) (x + w - 2, y + h - 2) // + line (valM - 2, y + 1) (valM - 2, y + bh + 1) // + line (x + w - 2, y + bh + 1) (x + w - 2, y + h - 2)) + // withColorC to (line (valP + 2, y) (valP + 2, y + bh - 1) // + line (valP + 2, y) (valM - 2, y) // + line (x - 2, y + bh) (valP - 2, y + bh) // + line (valM - 2, y + bh) (x + w - 2, y + bh)) + // withColorC bo (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // + line (valM - 1, y) (valM - 1, y + bh) // + line (x + w - 1, y + bh) (x + w - 1, y + h - 1)) -white3 [] _ = nullGraphic -white3 ((t, b):cs) ((x, y), (w, h)) = - let x1 = x + bw `div` 2 - y' = y + bh - in white3 cs ((x + 1, y + 1), (w - 2, h - 2)) // - withColor' t (line (x1+2, y) (x1+2, y' - 1) // - line (x1+2, y) (x + w - 2, y) // - line (x - 2, y') (x1 - 2, y')) // - withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // - line (x + w - 1, y) (x + w - 1, y') // - line (x + w - 1, y + bh) (x + w - 1, y + h - 1)) +drawKey White3 (to,ti,bi,bo) ((x, y), (w, h)) = + let val = x + bw `div` 2 + in withColorC ti (line (val + 3, y + 1) (val + 3, y + bh) // + line (val + 3, y + 1) (x + w - 3, y + 1) // + line (x - 1, y + bh + 1) (val - 1, y + bh + 1)) + // withColorC bi (line (x + 2, y + h - 2) (x + w - 2, y + h - 2) // + line (x + w - 2, y + 1) (x + w - 2, y + bh + 1) // + line (x + w - 2, y + bh + 1) (x + w - 2, y + h - 2)) + // withColorC to (line (val + 2, y) (val + 2, y + bh - 1) // + line (val + 2, y) (x + w - 2, y) // + line (x - 2, y + bh) (val - 2, y + bh)) + // withColorC bo (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // + line (x + w - 1, y) (x + w - 1, y + bh) // + line (x + w - 1, y + bh) (x + w - 1, y + h - 1)) -black1 [] _ = nullGraphic -black1 ((t, b):cs) ((x, y), (w, h)) = - black1 cs ((x + 1, y + 1), (w - 2, h - 2)) // - withColor' t (line (x, y) (x, y + h - 1) // - line (x, y) (x + w - 2, y)) // - withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // +drawKey Black1 (to,ti,bi,bo) ((x, y), (w, h)) = + withColorC ti (line (x + 1, y + 1) (x + 1, y + h - 2) // + line (x + 1, y + 1) (x + w - 3, y + 1)) + // withColorC bi (line (x + 2, y + h - 2) (x + w - 2, y + h - 2) // + line (x + w - 2, y + 1) (x + w - 2, y + h - 2)) + // withColorC to (line (x, y) (x, y + h - 1) // + line (x, y) (x + w - 2, y)) + // withColorC bo (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) // line (x + w - 1, y) (x + w - 1, y + h - 1)) -colorKey Black1 b = withColor Black $ block b -colorKey kt ((x,y), (w,h)) = withColor White $ block ((x, y+bh), (ww, wh-bh)) // f kt - where f White1 = block ((x,y), (ww - bw `div` 2, bh)) - f White2 = block ((x+ bw `div` 2, y), (ww-bw, bh)) - f White3 = block ((x+ bw `div` 2, y), (ww-bw `div` 2, bh)) - f _ = error "Euterpea.IO.MUI.Piano.colorKey: Unexpected input" +colorKey :: KeyType -> Rect -> Graphic +colorKey Black1 r = withColor Black $ rectangleFilled r +colorKey White1 ((x,y), (w,h)) = withColor White $ + rectangleFilled ((x, y+bh), (ww, wh-bh)) + // rectangleFilled ((x,y), (ww - bw `div` 2, bh)) +colorKey White2 ((x,y), (w,h)) = withColor White $ + rectangleFilled ((x, y+bh), (ww, wh-bh)) + // rectangleFilled ((x+ bw `div` 2, y), (ww-bw, bh)) +colorKey White3 ((x,y), (w,h)) = withColor White $ + rectangleFilled ((x, y+bh), (ww, wh-bh)) + // rectangleFilled ((x+ bw `div` 2, y), (ww-bw `div` 2, bh)) + -- ***************************************************************************** -- Single-key widget: handles key/mouse input and check if the song is playing -- ***************************************************************************** @@ -131,7 +162,7 @@ mkKey c kt = mkWidget iState d process draw where iState = (KeyState False False False 127, Nothing) - d = Layout 0 0 0 minh minw minh + d = makeLayout (Fixed minw) (Fixed minh) minw = topW kt minh | isBlack kt = bh | otherwise = wh @@ -144,7 +175,7 @@ drawNotation s = withColor Red $ text (x'+(1-length s)*tw `div` 2, y'- th + 2) s in withColor (if isBlack kt then White else Black) (text (x',y') [c]) // maybe nullGraphic drawNotation showNote - // withColor White (drawBox kt (if isDown then pushed else popped) b) + // withColor White (drawKey kt (if isDown then pushed else popped) b) // colorKey kt b realBBX ((x,y),(w,h)) = let (w', h') | isBlack kt = (bw,bh) | otherwise = (ww,wh) @@ -157,7 +188,11 @@ if detectKey c' (hasShiftModifier ms) then kb' { keypad = down, vel = 127 } else kb' +#if MIN_VERSION_UISF(0,4,0) + Button pt LeftButton down -> case (mouse kb', down, insideKey kt pt bbx) of +#else Button pt True down -> case (mouse kb', down, insideKey kt pt bbx) of +#endif (False, True, True) -> kb' { mouse = True, vel = getVel pt bbx } (True, False, True) -> kb' { mouse = False, vel = getVel pt bbx } otherwise -> kb' @@ -171,7 +206,7 @@ -- ***************************************************************************** mkKeys :: [(Char, KeyType, AbsPitch)] -> UISF InstrumentData (SEvent [(AbsPitch, Bool, Midi.Velocity)]) -mkKeys [] = proc instr -> returnA -< Nothing +mkKeys [] = constA Nothing mkKeys ((c,kt,ap):ckas) = proc instr -> do msg <- unique <<< mkKey c kt -< getKeyData ap instr let on = maybe False isKeyPlay msg @@ -189,7 +224,7 @@ -- ***************************************************************************** type PianoKeyMap = (String, Pitch) defaultMap1, defaultMap2, defaultMap0 :: PianoKeyMap -defaultMap1 = ("q2w3er5t6y7uQ@W#ERT^Y&U*", (C,2)) +defaultMap1 = ("q2w3er5t6y7uQ@W#ER%T^Y&U", (C,2)) defaultMap2 = ("zsxdcvgbhnjmZSXDCVGBHNJM", (C,3)) defaultMap0 = (fst defaultMap1 ++ fst defaultMap2, (C,3)) diff --git a/Euterpea/IO/MUI/UISFCompat.lhs b/Euterpea/IO/MUI/UISFCompat.lhs --- a/Euterpea/IO/MUI/UISFCompat.lhs +++ b/Euterpea/IO/MUI/UISFCompat.lhs @@ -1,15 +1,20 @@ -> {-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} +> {-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, FlexibleContexts, CPP #-} > module Euterpea.IO.MUI.UISFCompat where > import FRP.UISF.AuxFunctions > import FRP.UISF.UISF > import Control.SF.SF -> import Control.CCA.ArrowP +> import Control.Arrow.ArrowP > import Euterpea.IO.Audio.Types > import Control.DeepSeq > import Control.Concurrent (killThread, ThreadId) +#if MIN_VERSION_UISF(0,4,0) +> import FRP.UISF.Asynchrony +> asyncUISFV x = asyncVT x +#endif + The below function is useful for making use of asyncUISF* which both make use of Automatons rather than SFs. NOTE: Actually, SF and Automaton (->) are the same thing. Perhaps we should @@ -20,7 +25,7 @@ The below function is useful for directly asynchronizing AudSFs and CtrSFs in UISF. -> clockedSFToUISF :: forall a b c . (NFData b, Clock c) => Double -> SigFun c a b -> UISF a [(b, Time)] +> clockedSFToUISF :: forall a b c . (NFData b, Clock c) => DeltaT -> SigFun c a b -> UISF a [(b, Time)] > clockedSFToUISF buffer ~(ArrowP sf) = let r = rate (undefined :: c) > in asyncUISFV r buffer (toAutomaton sf) diff --git a/Euterpea/Music/Note/MoreMusic.hs b/Euterpea/Music/Note/MoreMusic.hs --- a/Euterpea/Music/Note/MoreMusic.hs +++ b/Euterpea/Music/Note/MoreMusic.hs @@ -1,8 +1,10 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/MoreMusic.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "MoreMusic.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/MoreMusic.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "MoreMusic.lhs" #-} module Euterpea.Music.Note.MoreMusic where import Euterpea.Music.Note.Music +{-# LINE 47 "MoreMusic.lhs" #-} line, chord :: [Music a] -> Music a line = foldr (:+:) (rest 0) chord = foldr (:=:) (rest 0) @@ -10,20 +12,23 @@ line1, chord1 :: [Music a] -> Music a line1 = foldr1 (:+:) chord1 = foldr1 (:=:) +{-# LINE 66 "MoreMusic.lhs" #-} delayM :: Dur -> Music a -> Music a delayM d m = rest d :+: m - +{-# LINE 76 "MoreMusic.lhs" #-} timesM :: Int -> Music a -> Music a timesM 0 m = rest 0 timesM n m = m :+: timesM (n-1) m - +{-# LINE 89 "MoreMusic.lhs" #-} repeatM :: Music a -> Music a repeatM m = m :+: repeatM m +{-# LINE 115 "MoreMusic.lhs" #-} lineToList :: Music a -> [Music a] lineToList (Prim (Rest 0)) = [] lineToList (n :+: ns) = n : lineToList ns lineToList _ = error "lineToList: argument not created by function line" +{-# LINE 124 "MoreMusic.lhs" #-} invert :: Music Pitch -> Music Pitch invert m = let l@(Prim (Note _ r) : _) = lineToList m @@ -31,11 +36,12 @@ note d (pitch (2 * absPitch r - absPitch p)) inv (Prim (Rest d)) = rest d in line (map inv l) +{-# LINE 147 "MoreMusic.lhs" #-} retro, retroInvert, invertRetro :: Music Pitch -> Music Pitch retro = line . reverse . lineToList retroInvert = retro . invert invertRetro = invert . retro - +{-# LINE 224 "MoreMusic.lhs" #-} pr1, pr2 :: Pitch -> Music Pitch pr1 p = tempo (5/6) ( tempo (4/3) ( mkLn 1 p qn :+: @@ -44,6 +50,7 @@ mkLn 1 p qn ) :+: mkLn 1 p qn) :+: tempo (3/2) ( mkLn 6 p en)) +{-# LINE 238 "MoreMusic.lhs" #-} pr2 p = let m1 = tempo (5/4) (tempo (3/2) m2 :+: m2) m2 = mkLn 3 p en @@ -54,11 +61,13 @@ mkLn :: Int -> p -> Dur -> Music p mkLn n p d = line $ take n $ repeat $ note d p +{-# LINE 263 "MoreMusic.lhs" #-} pr12 :: Music Pitch pr12 = pr1 (C,4) :=: pr2 (G,4) - +{-# LINE 274 "MoreMusic.lhs" #-} (=:=) :: Dur -> Dur -> Music a -> Music a old =:= new = tempo (new/old) +{-# LINE 289 "MoreMusic.lhs" #-} dur :: Music a -> Dur dur (Prim (Note d _)) = d dur (Prim (Rest d)) = d @@ -66,6 +75,7 @@ dur (m1 :=: m2) = dur m1 `max` dur m2 dur (Modify (Tempo r) m) = dur m / r dur (Modify _ m) = dur m +{-# LINE 327 "MoreMusic.lhs" #-} revM :: Music a -> Music a revM n@(Prim _) = n revM (Modify c m) = Modify c (revM m) @@ -75,7 +85,7 @@ d2 = dur m2 in if d1>d2 then revM m1 :=: (rest (d1-d2) :+: revM m2) else (rest (d2-d1) :+: revM m1) :=: revM m2 - +{-# LINE 359 "MoreMusic.lhs" #-} takeM :: Dur -> Music a -> Music a takeM d m | d <= 0 = rest 0 takeM d (Prim (Note oldD p)) = note (min oldD d) p @@ -86,8 +96,10 @@ in m'1 :+: m'2 takeM d (Modify (Tempo r) m) = tempo r (takeM (d*r) m) takeM d (Modify c m) = Modify c (takeM d m) +{-# LINE 381 "MoreMusic.lhs" #-} cut :: Dur -> Music a -> Music a cut = takeM +{-# LINE 390 "MoreMusic.lhs" #-} dropM :: Dur -> Music a -> Music a dropM d m | d <= 0 = m dropM d (Prim (Note oldD p)) = note (max (oldD-d) 0) p @@ -98,6 +110,7 @@ in m'1 :+: m'2 dropM d (Modify (Tempo r) m) = tempo r (dropM (d*r) m) dropM d (Modify c m) = Modify c (dropM d m) +{-# LINE 426 "MoreMusic.lhs" #-} removeZeros :: Music a -> Music a removeZeros (Prim p) = Prim p removeZeros (m1 :+: m2) = @@ -119,7 +132,9 @@ (m, Prim (Rest 0 )) -> m (m1, m2) -> m1 :=: m2 removeZeros (Modify c m) = Modify c (removeZeros m) +{-# LINE 534 "MoreMusic.lhs" #-} type LazyDur = [Dur] +{-# LINE 543 "MoreMusic.lhs" #-} durL :: Music a -> LazyDur durL m@(Prim _) = [dur m] durL (m1 :+: m2) = let d1 = durL m1 @@ -127,16 +142,19 @@ durL (m1 :=: m2) = mergeLD (durL m1) (durL m2) durL (Modify (Tempo r) m) = map (/r) (durL m) durL (Modify _ m) = durL m +{-# LINE 553 "MoreMusic.lhs" #-} mergeLD :: LazyDur -> LazyDur -> LazyDur mergeLD [] ld = ld mergeLD ld [] = ld mergeLD ld1@(d1:ds1) ld2@(d2:ds2) = if d1 Dur -> Dur minL [] d' = d' minL [d] d' = min d d' minL (d:ds) d' = if d < d' then minL ds d' else d' +{-# LINE 571 "MoreMusic.lhs" #-} takeML :: LazyDur -> Music a -> Music a takeML [] m = rest 0 takeML (d:ds) m | d <= 0 = takeML ds m @@ -149,8 +167,10 @@ in m'1 :+: m'2 takeML ld (Modify (Tempo r) m) = tempo r (takeML (map (*r) ld) m) takeML ld (Modify c m) = Modify c (takeML ld m) +{-# LINE 589 "MoreMusic.lhs" #-} (/=:) :: Music a -> Music a -> Music a m1 /=: m2 = takeML (durL m2) m1 :=: takeML (durL m1) m2 +{-# LINE 688 "MoreMusic.lhs" #-} trill :: Int -> Dur -> Music Pitch -> Music Pitch trill i sDur (Prim (Note tDur p)) = if sDur >= tDur then note tDur p @@ -161,17 +181,22 @@ trill i d (Modify c m) = Modify c (trill i d m) trill _ _ _ = error "trill: input must be a single note." +{-# LINE 702 "MoreMusic.lhs" #-} trill' :: Int -> Dur -> Music Pitch -> Music Pitch trill' i sDur m = trill (negate i) sDur (transpose i m) +{-# LINE 710 "MoreMusic.lhs" #-} trilln :: Int -> Int -> Music Pitch -> Music Pitch trilln i nTimes m = trill i (dur m / fromIntegral nTimes) m +{-# LINE 715 "MoreMusic.lhs" #-} trilln' :: Int -> Int -> Music Pitch -> Music Pitch trilln' i nTimes m = trilln (negate i) nTimes (transpose i m) +{-# LINE 722 "MoreMusic.lhs" #-} roll :: Dur -> Music Pitch -> Music Pitch rolln :: Int -> Music Pitch -> Music Pitch roll dur m = trill 0 dur m rolln nTimes m = trilln 0 nTimes m +{-# LINE 736 "MoreMusic.lhs" #-} ssfMel :: Music Pitch ssfMel = line (l1 ++ l2 ++ l3 ++ l4) where l1 = [ trilln 2 5 (bf 6 en), ef 7 en, ef 6 en, ef 7 en ] @@ -181,21 +206,24 @@ starsAndStripes :: Music Pitch starsAndStripes = instrument Flute ssfMel +{-# LINE 763 "MoreMusic.lhs" #-} grace :: Int -> Rational -> Music Pitch -> Music Pitch grace n r (Prim (Note d p)) = note (r*d) (trans n p) :+: note ((1-r)*d) p grace n r _ = error "grace: can only add a grace note to a note" +{-# LINE 782 "MoreMusic.lhs" #-} grace2 :: Int -> Rational -> Music Pitch -> Music Pitch -> Music Pitch grace2 n r (Prim (Note d1 p1)) (Prim (Note d2 p2)) = note (d1-r*d2) p1 :+: note (r*d2) (trans n p2) :+: note d2 p2 grace2 _ _ _ _ = error "grace2: can only add a grace note to a note" +{-# LINE 839 "MoreMusic.lhs" #-} data PercussionSound = - AcousticBassDrum -- MIDI Key 35 - | BassDrum1 -- MIDI Key 36 - | SideStick -- ... + AcousticBassDrum -- MIDI Key 35 + | BassDrum1 -- MIDI Key 36 + | SideStick -- ... | AcousticSnare | HandClap | ElectricSnare | LowFloorTom | ClosedHiHat | HighFloorTom | PedalHiHat | LowTom | OpenHiHat | LowMidTom | HiMidTom | CrashCymbal1 @@ -207,11 +235,12 @@ | Maracas | ShortWhistle | LongWhistle | ShortGuiro | LongGuiro | Claves | HiWoodBlock | LowWoodBlock | MuteCuica | OpenCuica | MuteTriangle - | OpenTriangle -- MIDI Key 82 + | OpenTriangle -- MIDI Key 82 deriving (Show,Eq,Ord,Enum) - +{-# LINE 869 "MoreMusic.lhs" #-} perc :: PercussionSound -> Dur -> Music Pitch perc ps dur = note dur (pitch (fromEnum ps + 35)) +{-# LINE 896 "MoreMusic.lhs" #-} funkGroove :: Music Pitch funkGroove = let p1 = perc LowTom qn @@ -220,23 +249,29 @@ ( ( p1 :+: qnr :+: p2 :+: qnr :+: p2 :+: p1 :+: p1 :+: qnr :+: p2 :+: enr) :=: roll en (perc ClosedHiHat 2) ) +{-# LINE 962 "MoreMusic.lhs" #-} pMap :: (a -> b) -> Primitive a -> Primitive b pMap f (Note d x) = Note d (f x) pMap f (Rest d) = Rest d +{-# LINE 969 "MoreMusic.lhs" #-} mMap :: (a -> b) -> Music a -> Music b mMap f (Prim p) = Prim (pMap f p) mMap f (m1 :+: m2) = mMap f m1 :+: mMap f m2 mMap f (m1 :=: m2) = mMap f m1 :=: mMap f m2 mMap f (Modify c m) = Modify c (mMap f m) +{-# LINE 982 "MoreMusic.lhs" #-} type Volume = Int +{-# LINE 988 "MoreMusic.lhs" #-} addVolume :: Volume -> Music Pitch -> Music (Pitch,Volume) addVolume v = mMap (\p -> (p,v)) +{-# LINE 1022 "MoreMusic.lhs" #-} data NoteAttribute = - Volume Int -- MIDI convention: 0=min, 127=max + Volume Int -- MIDI convention: 0=min, 127=max | Fingering Integer | Dynamics String | Params [Double] deriving (Eq, Show) +{-# LINE 1064 "MoreMusic.lhs" #-} mFold :: (Primitive a -> b) -> (b->b->b) -> (b->b->b) -> (Control -> b -> b) -> Music a -> b mFold f (+:) (=:) g m = @@ -246,16 +281,21 @@ m1 :+: m2 -> rec m1 +: rec m2 m1 :=: m2 -> rec m1 =: rec m2 Modify c m -> g c (rec m) +{-# LINE 1133 "MoreMusic.lhs" #-} rep :: (Music a -> Music a) -> (Music a -> Music a) -> Int -> Music a -> Music a rep f g 0 m = rest 0 rep f g n m = m :=: g (rep f g (n-1) (f m)) +{-# LINE 1144 "MoreMusic.lhs" #-} run, cascade, cascades, final :: Music Pitch run', cascade', cascades', final' :: Music Pitch +{-# LINE 1149 "MoreMusic.lhs" #-} run = rep (transpose 5) (delayM tn) 8 (c 4 tn) cascade = rep (transpose 4) (delayM en) 8 run cascades = rep id (delayM sn) 2 cascade +{-# LINE 1155 "MoreMusic.lhs" #-} final = cascades :+: revM cascades +{-# LINE 1159 "MoreMusic.lhs" #-} run' = rep (delayM tn) (transpose 5) 8 (c 4 tn) cascade' = rep (delayM en) (transpose 4) 8 run' cascades' = rep (delayM sn) id 2 cascade' diff --git a/Euterpea/Music/Note/Music.hs b/Euterpea/Music/Note/Music.hs --- a/Euterpea/Music/Note/Music.hs +++ b/Euterpea/Music/Note/Music.hs @@ -1,38 +1,46 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/Music.lhs. (See HSoM/MakeCode.bat.) - +{-# LINE 8 "Music.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/Music.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 25 "Music.lhs" #-} module Euterpea.Music.Note.Music where infixr 5 :+:, :=: - +{-# LINE 51 "Music.lhs" #-} type Octave = Int +{-# LINE 63 "Music.lhs" #-} type Pitch = (PitchClass, Octave) +{-# LINE 80 "Music.lhs" #-} type Dur = Rational +{-# LINE 116 "Music.lhs" #-} data PitchClass = Cff | Cf | C | Dff | Cs | Df | Css | D | Eff | Ds | Ef | Fff | Dss | E | Ff | Es | F | Gff | Ess | Fs | Gf | Fss | G | Aff | Gs | Af | Gss | A | Bff | As | Bf | Ass | B | Bs | Bss deriving (Show, Eq, Ord, Read, Enum, Bounded) +{-# LINE 218 "Music.lhs" #-} data Primitive a = Note Dur a | Rest Dur deriving (Show, Eq, Ord) +{-# LINE 271 "Music.lhs" #-} data Music a = - Prim (Primitive a) -- primitive value - | Music a :+: Music a -- sequential composition - | Music a :=: Music a -- parallel composition - | Modify Control (Music a) -- modifier + Prim (Primitive a) -- primitive value + | Music a :+: Music a -- sequential composition + | Music a :=: Music a -- parallel composition + | Modify Control (Music a) -- modifier deriving (Show, Eq, Ord) +{-# LINE 390 "Music.lhs" #-} data Control = - Tempo Rational -- scale the tempo - | Transpose AbsPitch -- transposition - | Instrument InstrumentName -- instrument label - | Phrase [PhraseAttribute] -- phrase attributes - | Player PlayerName -- player label - | KeySig PitchClass Mode -- key signature and mode + Tempo Rational -- scale the tempo + | Transpose AbsPitch -- transposition + | Instrument InstrumentName -- instrument label + | Phrase [PhraseAttribute] -- phrase attributes + | Player PlayerName -- player label + | KeySig PitchClass Mode -- key signature and mode deriving (Show, Eq, Ord) type PlayerName = String data Mode = Major | Minor deriving (Show, Eq, Ord) +{-# LINE 420 "Music.lhs" #-} data InstrumentName = AcousticGrandPiano | BrightAcousticPiano | ElectricGrandPiano | HonkyTonkPiano | RhodesPiano | ChorusedPiano @@ -78,7 +86,9 @@ | BirdTweet | TelephoneRing | Helicopter | Applause | Gunshot | Percussion | Custom String +{-# LINE 469 "Music.lhs" #-} deriving (Show, Eq, Ord) +{-# LINE 479 "Music.lhs" #-} data PhraseAttribute = Dyn Dynamic | Tmp Tempo | Art Articulation @@ -111,7 +121,7 @@ data NoteHead = DiamondHead | SquareHead | XHead | TriangleHead | TremoloHead | SlashHead | ArtHarmonic | NoHead deriving (Show, Eq, Ord) - +{-# LINE 535 "Music.lhs" #-} note :: Dur -> a -> Music a note d p = Prim (Note d p) @@ -135,6 +145,7 @@ keysig :: PitchClass -> Mode -> Music a -> Music a keysig pc mo m = Modify (KeySig pc mo) m +{-# LINE 592 "Music.lhs" #-} cff,cf,c,cs,css,dff,df,d,ds,dss,eff,ef,e,es,ess,fff,ff,f, fs,fss,gff,gf,g,gs,gss,aff,af,a,as,ass,bff,bf,b,bs,bss :: Octave -> Dur -> Music Pitch @@ -157,38 +168,44 @@ bff o d = note d (Bff, o); bf o d = note d (Bf, o) b o d = note d (B, o); bs o d = note d (Bs, o) bss o d = note d (Bss, o) +{-# LINE 622 "Music.lhs" #-} bn, wn, hn, qn, en, sn, tn, sfn, dwn, dhn, dqn, den, dsn, dtn, ddhn, ddqn, dden :: Dur bnr, wnr, hnr, qnr, enr, snr, tnr, sfnr, dwnr, dhnr, dqnr, denr, dsnr, dtnr, ddhnr, ddqnr, ddenr :: Music Pitch -bn = 2; bnr = rest bn -- brevis rest -wn = 1; wnr = rest wn -- whole note rest -hn = 1/2; hnr = rest hn -- half note rest -qn = 1/4; qnr = rest qn -- quarter note rest -en = 1/8; enr = rest en -- eighth note rest -sn = 1/16; snr = rest sn -- sixteenth note rest -tn = 1/32; tnr = rest tn -- thirty-second note rest -sfn = 1/64; sfnr = rest sfn -- sixty-fourth note rest +bn = 2; bnr = rest bn -- brevis rest +wn = 1; wnr = rest wn -- whole note rest +hn = 1/2; hnr = rest hn -- half note rest +qn = 1/4; qnr = rest qn -- quarter note rest +en = 1/8; enr = rest en -- eighth note rest +sn = 1/16; snr = rest sn -- sixteenth note rest +tn = 1/32; tnr = rest tn -- thirty-second note rest +sfn = 1/64; sfnr = rest sfn -- sixty-fourth note rest -dwn = 3/2; dwnr = rest dwn -- dotted whole note rest -dhn = 3/4; dhnr = rest dhn -- dotted half note rest -dqn = 3/8; dqnr = rest dqn -- dotted quarter note rest -den = 3/16; denr = rest den -- dotted eighth note rest -dsn = 3/32; dsnr = rest dsn -- dotted sixteenth note rest -dtn = 3/64; dtnr = rest dtn -- dotted thirty-second note rest +dwn = 3/2; dwnr = rest dwn -- dotted whole note rest +dhn = 3/4; dhnr = rest dhn -- dotted half note rest +dqn = 3/8; dqnr = rest dqn -- dotted quarter note rest +den = 3/16; denr = rest den -- dotted eighth note rest +dsn = 3/32; dsnr = rest dsn -- dotted sixteenth note rest +dtn = 3/64; dtnr = rest dtn -- dotted thirty-second note rest -ddhn = 7/8; ddhnr = rest ddhn -- double-dotted half note rest -ddqn = 7/16; ddqnr = rest ddqn -- double-dotted quarter note rest -dden = 7/32; ddenr = rest dden -- double-dotted eighth note restt251 :: Music Pitch +ddhn = 7/8; ddhnr = rest ddhn -- double-dotted half note rest +ddqn = 7/16; ddqnr = rest ddqn -- double-dotted quarter note rest +dden = 7/32; ddenr = rest dden -- double-dotted eighth note rest +{-# LINE 662 "Music.lhs" #-} +t251 :: Music Pitch t251 = let dMinor = d 4 wn :=: f 4 wn :=: a 4 wn gMajor = g 4 wn :=: b 4 wn :=: d 5 wn cMajor = c 4 bn :=: e 4 bn :=: g 4 bn in dMinor :+: gMajor :+: cMajor +{-# LINE 804 "Music.lhs" #-} type AbsPitch = Int +{-# LINE 810 "Music.lhs" #-} absPitch :: Pitch -> AbsPitch absPitch (pc,oct) = 12*oct + pcToInt pc +{-# LINE 864 "Music.lhs" #-} pcToInt :: PitchClass -> Int pcToInt pc = case pc of Cff -> -2; Cf -> -1; C -> 0; Cs -> 1; Css -> 2; @@ -198,9 +215,11 @@ Gff -> 5; Gf -> 6; G -> 7; Gs -> 8; Gss -> 9; Aff -> 7; Af -> 8; A -> 9; As -> 10; Ass -> 11; Bff -> 9; Bf -> 10; B -> 11; Bs -> 12; Bss -> 13 +{-# LINE 895 "Music.lhs" #-} pitch :: AbsPitch -> Pitch pitch ap = let (oct, n) = divMod ap 12 in ([C,Cs,D,Ds,E,F,Fs,G,Gs,A,As,B] !! n, oct) +{-# LINE 918 "Music.lhs" #-} trans :: Int -> Pitch -> Pitch trans i p = pitch (absPitch p + i) diff --git a/Euterpea/Music/Note/Performance.hs b/Euterpea/Music/Note/Performance.hs --- a/Euterpea/Music/Note/Performance.hs +++ b/Euterpea/Music/Note/Performance.hs @@ -1,13 +1,14 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/Performance.lhs. (See HSoM/MakeCode.bat.) - -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LINE 8 "Performance.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/Performance.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "Performance.lhs" #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Euterpea.Music.Note.Performance where import Euterpea.Music.Note.Music import Euterpea.Music.Note.MoreMusic - +{-# LINE 55 "Performance.lhs" #-} type Performance = [Event] data Event = Event { eTime :: PTime, @@ -17,8 +18,10 @@ eVol :: Volume, eParams :: [Double]} deriving (Show,Eq,Ord) +{-# LINE 73 "Performance.lhs" #-} type PTime = Rational type DurT = Rational +{-# LINE 143 "Performance.lhs" #-} data Context a = Context { cTime :: PTime, cPlayer :: Player a, cInst :: InstrumentName, @@ -27,18 +30,19 @@ cVol :: Volume, cKey :: (PitchClass, Mode) } deriving Show +{-# LINE 164 "Performance.lhs" #-} metro :: Int -> Dur -> DurT metro setting dur = 60 / (fromIntegral setting * dur) - +{-# LINE 191 "Performance.lhs" #-} type PMap a = PlayerName -> Player a - +{-# LINE 339 "Performance.lhs" #-} merge :: Performance -> Performance -> Performance merge [] es2 = es2 merge es1 [] = es1 merge a@(e1:es1) b@(e2:es2) = if eTime e1 < eTime e2 then e1 : merge es1 b else e2 : merge a es2 - +{-# LINE 351 "Performance.lhs" #-} perform :: PMap a -> Context a -> Music a -> Performance perform pm c m = fst (perf pm c m) @@ -62,14 +66,16 @@ Modify (KeySig pc mo) m -> perf pm (c {cKey = (pc,mo)}) m Modify (Player pn) m -> perf pm (c {cPlayer = pm pn}) m Modify (Phrase pas) m -> interpPhrase pl pm c pas m +{-# LINE 474 "Performance.lhs" #-} type Note1 = (Pitch, [NoteAttribute]) type Music1 = Music Note1 - +{-# LINE 480 "Performance.lhs" #-} toMusic1 :: Music Pitch -> Music1 toMusic1 = mMap (\p -> (p, [])) toMusic1' :: Music (Pitch, Volume) -> Music1 toMusic1' = mMap (\(p, v) -> (p, [Volume v])) +{-# LINE 507 "Performance.lhs" #-} data Player a = MkPlayer { pName :: PlayerName, playNote :: NoteFun a, interpPhrase :: PhraseFun a, @@ -82,12 +88,14 @@ instance Show a => Show (Player a) where show p = "Player " ++ pName p +{-# LINE 535 "Performance.lhs" #-} defPlayer :: Player Note1 defPlayer = MkPlayer { pName = "Default", playNote = defPlayNote defNasHandler, interpPhrase = defInterpPhrase defPasHandler, notatePlayer = () } +{-# LINE 554 "Performance.lhs" #-} defPlayNote :: (Context (Pitch,[a]) -> a -> Event-> Event) -> NoteFun (Pitch, [a]) defPlayNote nasHandler @@ -105,7 +113,7 @@ defInterpPhrase :: (PhraseAttribute -> Performance -> Performance) -> - ( PMap a -> Context a -> [PhraseAttribute] -> --PhraseFun + ( PMap a -> Context a -> [PhraseAttribute] -> -- PhraseFun Music a -> (Performance, DurT) ) defInterpPhrase pasHandler pm context pas m = let (pf,dur) = perf pm context m @@ -119,6 +127,7 @@ defPasHandler (Art (Legato x)) = map (\e -> e {eDur = x * eDur e}) defPasHandler _ = id +{-# LINE 686 "Performance.lhs" #-} defPMap :: PMap Note1 defPMap "Fancy" = fancyPlayer defPMap "Default" = defPlayer @@ -132,7 +141,7 @@ cPch = 0, cKey = (C, Major), cVol = 127 } - +{-# LINE 815 "Performance.lhs" #-} fancyPlayer :: Player (Pitch, [NoteAttribute]) fancyPlayer = MkPlayer { pName = "Fancy", playNote = defPlayNote defNasHandler, @@ -182,9 +191,10 @@ in (map setDur pf, dur) Art _ -> pfd Orn _ -> pfd +{-# LINE 879 "Performance.lhs" #-} class Performable a where perfDur :: PMap Note1 -> Context Note1 -> Music a -> (Performance, DurT) - +{-# LINE 888 "Performance.lhs" #-} instance Performable Note1 where perfDur pm c m = perf pm c m diff --git a/Euterpea/Music/Signal/SpectrumAnalysis.hs b/Euterpea/Music/Signal/SpectrumAnalysis.hs --- a/Euterpea/Music/Signal/SpectrumAnalysis.hs +++ b/Euterpea/Music/Signal/SpectrumAnalysis.hs @@ -1,7 +1,8 @@ --- This code was automatically generated by lhs2tex --code, from the file --- HSoM/SpectrumAnalysis.lhs. (See HSoM/MakeCode.bat.) - -{-# LANGUAGE Arrows #-} +{-# LINE 8 "SpectrumAnalysis.lhs" #-} +-- This code was automatically generated by lhs2tex --code, from the file +-- HSoM/SpectrumAnalysis.lhs. (See HSoM/MakeCode.bat.) +{-# LINE 18 "SpectrumAnalysis.lhs" #-} +{-# LANGUAGE Arrows #-} module Euterpea.Music.Signal.SpectrumAnalysis where @@ -10,7 +11,7 @@ import Data.Complex (Complex ((:+)), polar) import Data.Maybe (listToMaybe, catMaybes) - +{-# LINE 560 "SpectrumAnalysis.lhs" #-} dft :: RealFloat a => [Complex a] -> [Complex a] dft xs = let lenI = length xs @@ -20,6 +21,7 @@ in (1/lenC) * sum [ (xs!!n) * exp (0 :+ i * fromIntegral n) | n <- [0,1..lenI-1] ] | k <- [0,1..lenI-1] ] +{-# LINE 583 "SpectrumAnalysis.lhs" #-} mkTerm :: Int -> Double -> [Complex Double] mkTerm num n = let f = 2 * pi / fromIntegral num in [ sin (n * f * fromIntegral i) / n :+ 0 @@ -29,6 +31,7 @@ mkxa num = mkTerm num 1 mkxb num = zipWith (+) (mkxa num) (mkTerm num 3) mkxc num = zipWith (+) (mkxb num) (mkTerm num 5) +{-# LINE 610 "SpectrumAnalysis.lhs" #-} printComplexL :: [Complex Double] -> IO () printComplexL xs = let f (i,rl:+im) = @@ -48,10 +51,13 @@ spaces :: Int -> String spaces n = take n (repeat ' ') +{-# LINE 679 "SpectrumAnalysis.lhs" #-} mkPulse :: Int -> [Complex Double] mkPulse n = 100 : take (n-1) (repeat 0) +{-# LINE 721 "SpectrumAnalysis.lhs" #-} x1 num = let f = pi * 2 * pi / fromIntegral num in map (:+ 0) [ sin (f * fromIntegral i) | i <- [0,1..num-1] ] +{-# LINE 757 "SpectrumAnalysis.lhs" #-} mkPolars :: [Complex Double] -> [Complex Double] mkPolars = map ((\(m,p)-> m:+p) . polar) diff --git a/HSoM/Additive.lhs b/HSoM/Additive.lhs --- a/HSoM/Additive.lhs +++ b/HSoM/Additive.lhs @@ -315,7 +315,7 @@ \begin{figure}[hbtp] \centering \includegraphics[height=8.5in]{pics/DPlots/ClarinetModes.eps} -\vspace{-.2in} +\vspace{ -.2in} \caption{The Modes of a Clarinet Seen as a Cylindrical Tube} \label{fig:clarinet-mode} \end{figure} @@ -424,7 +424,7 @@ \begin{figure} \begin{code} bell1 :: Instr (Mono AudRate) - -- |Dur -> AbsPitch -> Volume -> AudSF () Double| + typecomment(Dur -> AbsPitch -> Volume -> AudSF () Double) bell1 dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -489,7 +489,7 @@ \begin{figure} \begin{code} bell2 :: Instr (Mono AudRate) - -- |Dur -> AbsPitch -> Volume -> AudSF () Double| + typecomment(Dur -> AbsPitch -> Volume -> AudSF () Double) bell2 dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -570,7 +570,7 @@ \begin{figure}[hbtp] \centering \includegraphics[height=7.5in]{pics/DPlots/FilterTypes.eps} -\vspace{-.2in} +\vspace{ -.2in} \caption{Transfer Functions for Four Common Filter Types} \label{fig:filter-types} \end{figure} @@ -772,8 +772,8 @@ \begin{code} sfTest1 :: AudSF (Double,Double) Double -> Instr (Mono AudRate) - -- |AudSF (Double,Double) Double -> | - -- |Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double| + typecomment(AudSF (Double,Double) Double -> ) + typecomment(Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double) sfTest1 sf dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -824,7 +824,7 @@ \begin{code} noise1 :: Instr (Mono AudRate) - -- |Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double| + typecomment(Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double) noise1 dur ap vol [] = let v = fromIntegral vol / 100 in proc () -> do @@ -840,8 +840,8 @@ env2 = envExpon 1 10 2000 sfTest2 :: AudSF (Double,Double,Double) Double -> Instr (Mono AudRate) - -- |AudSF (Double,Double,Double) Double -> | - -- |Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double| + typecomment(AudSF (Double,Double,Double) Double -> ) + typecomment(Dur -> AbsPitch -> Volume -> [Double] -> AudSF () Double) sfTest2 sf dur ap vol [] = let f = apToHz ap v = fromIntegral vol / 100 @@ -850,7 +850,9 @@ bw <- env2 -< () a2 <- sf -< (a1,f,bw) outA -< a2 +\end{code} +\begin{code} tBP' = outFile "bp'.wav" 10 $ sfTest2 (filterBandPass 1) 10 (absPitch (C,5)) 80 [] diff --git a/HSoM/HSoM.bib b/HSoM/HSoM.bib --- a/HSoM/HSoM.bib +++ b/HSoM/HSoM.bib @@ -635,3 +635,25 @@ ,publisher={A.K. Peters Press} ,address={Natick MA, USA} } + +@techreport{WinogradCort-TR1446, + author = {Winograd-Cort, Daniel and Liu, Hai and Hudak, Paul}, + title = {Virtualizing {R}eal-{W}orld {O}bjects in {FRP}}, + institution = {Yale University}, + year = {2011}, + month = {July}, + number = {YALEU/DCS/RR-1446} +} + +@InProceedings{WinogradCort2012HS, + author = {Winograd-Cort, Daniel and Hudak, Paul}, + title = {Wormholes: {I}ntroducing {E}ffects to {FRP}}, + booktitle = {Haskell Symposium}, + pages = {91--103}, + numpages = {13}, + publisher = {{ACM}}, + year = {2012}, + location = {Copenhagen, Denmark}, + month = {September} +} + diff --git a/HSoM/HSoM.lhs b/HSoM/HSoM.lhs --- a/HSoM/HSoM.lhs +++ b/HSoM/HSoM.lhs @@ -117,6 +117,17 @@ \addtocontents{toc}{\vskip5pt} } +%--------------------------------------------------------------------- +%--------------------------------------------------------------------- +% These lines should not be necessary, but they are included because +% images are occasionally missing from the repository. +\LetLtxMacro\latexincludegraphics\includegraphics +\renewcommand{\includegraphics}[2][]{% +\IfFileExists{#2}{\latexincludegraphics[#1]{#2}} + {\framebox[1.1\width]{Image not in repository!}}} +%--------------------------------------------------------------------- +%--------------------------------------------------------------------- + \begin{document} %--------------------------------------------------------------------- @@ -178,11 +189,15 @@ \newpage +\setcounter{tocdepth}{1}% Set contents to display Chapters and Sections and nothing deeper \tableofcontents +\addcontentsline{toc}{chapter}{Table of Contents}% Add ToC to ToC (and bookmarks) \listoffigures +\addcontentsline{toc}{chapter}{List of Figures}% Add LoF to ToC (and bookmarks) \listoftables +\addcontentsline{toc}{chapter}{List of Tables}% Add LoT to ToC (and bookmarks) % Preface \include{Preface} @@ -272,6 +287,8 @@ % --------------------------------------------------------------------- % \backmatter +\phantomsection\addcontentsline{toc}{part}{Appendix}% Add appendix to ToC (and bookmarks) +\part*{Appendix} \appendix % Tour of PreludeList @@ -286,10 +303,11 @@ % Pattern-Matching Details \include{Patterns} -\newpage +\clearpage % Bibliography \bibliographystyle{alpha} +\phantomsection\addcontentsline{toc}{part}{Bibliography}% Add references to ToC (and bookmarks) \bibliography{HSoM} % Index diff --git a/HSoM/Interlude.lhs b/HSoM/Interlude.lhs --- a/HSoM/Interlude.lhs +++ b/HSoM/Interlude.lhs @@ -112,7 +112,7 @@ }{ % We use a parbox here to make sure that the figure takes up a full page, % just like ChildSong6, so that page numbers will remain consistent. - \parbox[c][8in][c]{\textwidth}{\center{\framebox[1.1\width]{Image omitted due to respository space issues.}}} + \parbox[c][8in][c]{\textwidth}{\center{\framebox[1.1\width]{Image omitted due to repository space issues.}}} } \caption{Excerpt from Chick Corea's \emph{Children's Songs No.\ 6}} \label{fig:childsong6} diff --git a/HSoM/MUI.lhs b/HSoM/MUI.lhs --- a/HSoM/MUI.lhs +++ b/HSoM/MUI.lhs @@ -15,15 +15,21 @@ \chapterauthor{Daniel Winograd-Cort} \label{ch:MUI} -\begin{code} +\noindent\begin{code} {-# LANGUAGE Arrows #-} module Euterpea.Examples.MUI where import Euterpea +\end{code} +\out{\begin{code} import Data.Maybe (mapMaybe) +import Euterpea.Experimental +import FRP.UISF.Graphics (withColor', rgbE, rectangleFilled) +import FRP.UISF.Widget.Construction (mkWidget) -\end{code} +\end{code}} + This module is not part of the standard Euterpea module hierarchy (i.e.\ those modules that get imported by the header command ``|import Euterpea|''), but it can be found in the |Examples| folder in the @@ -82,9 +88,9 @@ A \emph{signal function} is an abstract function that converts one signal into another. Using the examples above, a signal function may -be one that adds an offset to a time-varying mouse position, filters -out noise from the time-varying voltage for a robot motor, or speeds -up or slows down an animation. +add an offset to a time-varying mouse position, filter +out noise from the time-varying voltage for a robot motor, or speed +up or slow down an animation. Perhaps the simplest way to understand Euterpea's approach to programming with signals is to think of it as a language for @@ -95,7 +101,7 @@ diagram has two signals, |x| and |y|, and one signal function, |sigfun|: \begin{center} - \includegraphics[scale=0.70]{pics/frp-circuit} + \includegraphics[scale=0.80]{pics/frp-circuit} \end{center} Using Haskell's \emph{arrow syntax} \cite{Hughes2000,Paterson2001}, this diagram can be expressed as a code fragment in Euterpea simply @@ -154,8 +160,8 @@ %% function. That, in fact, is the purpose of the arrow syntax. For example, suppose the signal function |sigfun| used earlier has type -|SF T1 T2|, for some types |T1| and |T2|. In that case, again -using the example give earlier, |x| will have type |T1|, and |y| will +|SF T1 T2|, for some types |T1| and |T2|. In that case, and +using the example above, |x| will have type |T1|, and |y| will have type |T2|. Although signal functions act on signals, the arrow notation allows us to manipulate the instantaneous values of the signals, such as |x| and |y| above, directly. @@ -181,8 +187,8 @@ operations to \emph{compose} one signal function with another in several ways. The |Arrow| class and how all this works for signal functions will be described in Chapter~\ref{ch:arrows}. For -now, suffice it to say that programming in this style can be -awkward---and thus Haskell provides the arrow syntax described above +now, it suffices to say that programming in this style can be +awkward and that Haskell provides the arrow syntax described above to make the programming easier and more natural. A Euterpea MUI program expresses the composition of a possibly large @@ -230,9 +236,9 @@ \end{spec} The important difference, however, is that |sigfun| works on a signal, i.e.\ a time-varying quantity. To make the analogy a little stronger, -we could imagine a signal being implemented as a stream of dicrete +we could imagine a signal being implemented as a stream of discrete values. In which case, to achieve the effect of the arrow code given -earlier, we would have to write something like this: +d, we would have to write something like this: \begin{spec} \ ys -> let xs = sigfun'' (map (+1) ys) @@ -343,7 +349,7 @@ How can a signal function depend on its own output? At some point in the loop, we need to introduce a \emph{delay} function. Euterpea -has a few different delay function that we will decribe in more detail +has a few different delay functions that we will decribe in more detail later in this chapter (Section~\ref{ch:mui:sec:delays}), but for now, we will casually introduce the simplest of these: |fcdelay|. \begin{spec} @@ -388,7 +394,7 @@ functions to add, multiply, take the sine of, and so on, signals represented in this way. For example, |Signal Float| would be the type of a time-varying floating-point number, |Signal AbsPitch| would -be the type of a time-varing absolute pitch, and so on. Then given +be the type of a time-varying absolute pitch, and so on. Then given |s1,s2 :: Signal Float| we might simply write |s1 + s2|, |s1 * s2|, and |sin s1| as examples of applying the above operations. Haskell's numeric type class hierarchy makes this particularly easy to do. @@ -413,7 +419,7 @@ actual signal itself. By not giving the user direct access to signals, and providing a disciplined way to compose signal functions (namely arrow syntax), time- and space-leaks are avoided. In fact, -the resulting framwework is highly amenable to optimization, although +the resulting framework is highly amenable to optimization, although this requires using special features in Haskell, as described in Chapter \ref{ch:arrows}. @@ -481,7 +487,7 @@ \item A simple (static) text string can be displayed using: \begin{spec} -label :: String -> UISF () () +label :: String -> UISF a a \end{spec} \item @@ -561,7 +567,7 @@ \item |hSlider|, |vSlider|, |hiSlider| and |viSlider| are four kinds of -``sliders''---a graphical widget that looks like an s slider control +``sliders''---a graphical widget that looks like a slider control as found on a hardware device. The first two yield floating-point numbers in a given range, and are oriented horizontally and vertically, respectively, whereas the latter two return integral @@ -602,6 +608,20 @@ The resulting MUI, once the slider has been moved a bit, is shown in Figure \ref{fig:simple-mui}(a). +\syn{ + Any MUI widgets have the capacity to be \emph{focusable}, which is + particularly relevant for graphical widgets. When a focusable widget + is ``in focus,'' not only can it update its appearance, but any key + presses from the computer keyboard become visible to it as input + events. This means that keyboard controls are possible with MUI + widgets. Obviously, typing will affect the value of a textbox + widget, but also, for instance, the arrow keys as well as the + ``Home'' and + ``End'' keys will affect the value of a slider widget. Focus can + be shifted between widgets by clicking on them with the mouse as + well as by using ``Tab'' and ``Shift+Tab'' to cycle focus through + focusable widgets.} + \begin{figure}[hbtp] \centering \subfigure[Very Simple]{ @@ -630,8 +650,9 @@ \begin{figure} \cbox{ \begin{spec} -title :: String -> UISF a b -> UISF a b -setLayout :: Layout -> UISF a b -> UISF a b +title :: String -> UISF a b -> UISF a b +setLayout :: Layout -> UISF a b -> UISF a b +setSize :: (Int, Int) -> UISF a b -> UISF a b pad :: (Int, Int, Int, Int) -> UISF a b -> UISF a b topDown, bottomUp, leftRight, rightLeft :: UISF a b -> UISF a b @@ -652,12 +673,18 @@ be either stretchy (with a minimum size in pixels but that will expand to fill the space it is given) or fixed (measured in pixels). +The |setSize| function is a convenient function for setting the layout +of a widget when both dimensions need to be fixed. It is defined as: +\begin{spec} +setSize (w,h) = setLayout (makeLayout (Fixed w) (Fixed h)) +\end{spec} + For example we can modify the previous example to both set a fixed layout for the overall widget, and attach titles to both the slider and display: \begin{code} ui1 :: UISF () () -ui1 = setLayout (makeLayout (Fixed 150) (Fixed 150)) $ +ui1 = setSize (150,150) $ proc _ -> do ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap @@ -698,24 +725,31 @@ %%%% The UISF Arrow - MIDI Input and Output %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{MIDI Input and Output} +\label{ch:mui:sec:midiinout} % TODO: This (and the deviceID) section may need to be rewritten % FIXME: Even if it stays basically the same, the following code uses % the "unique" mediator, which hasn't been introduced yet. An important application of events in Euterpea is real-time, -interactive MIDI. There are two UISF signal functions that handle +interactive MIDI. There are two main UISF signal functions that handle MIDI, one for input and the other for output, but neither of them displays anything graphically: \begin{spec} -midiIn :: UISF DeviceID (SEvent [MidiMessage]) -midiOut :: UISF (DeviceID, SEvent [MidiMessage]) () +midiIn :: UISF ( Maybe InputDeviceID) + ( SEvent [MidiMessage]) +midiOut :: UISF ( Maybe OutputDeviceID, + SEvent [MidiMessage]) () \end{spec} -Except for the |DeviceID| (about which more will be said shortly), +Except for the input and output deviceIDs (about which more will be said shortly), these signal functions are fairly straightforward: |midiOut| takes a stream of |MidiMessage| events and sends them to the MIDI output device (thus a signal sink), whereas |midiIn| generates a stream of |MidiMessage| events corresponding to the messages sent by the MIDI -input device (thus a signal source). In both cases, note that the +input device (thus a signal source)\footnote{Technically, this is + not a proper signal source because it accepts an input stream of + |Maybe InputDeviceID|, but the way in which it generates MIDI + messages makes it feel very much like a source.}. +In both cases, note that the events carry \emph{lists} of MIDI messages, thus accounting for the possibility of simultaneous events. @@ -767,95 +801,85 @@ example, a MIDI message |NoteOn c k v| plays MIDI key |k| on MIDI channel |c| with velocity |v|. -As an example of the use of |midiOut|, let's modify our previous MUI -program to output an |ANote| message every time the absolute pitch -changes: -\begin{code} -ui3 :: UISF () () -ui3 = proc _ -> do - ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () - title "Pitch" display -< pitch ap - uap <- unique -< ap - midiOut -< (0, fmap (\k-> [ANote 0 k 100 0.1]) uap) -mui3 = runMUI' "Pitch Player" ui3 - -\end{code} -Note the use of the mediator |unique| to generate an event whenever -the absolute pitch changes. Each of those events, say |uap| above, -carries the new absolute pitch, and that pitch is used directly as the -MIDI key field in |ANote|. - -To understand how the latter is done, recall that |fmap| is the -primary method in the |Functor| class as described in -Section~\ref{sec:functor-class}, and the |Maybe| type is an instance -of |Functor|. Therefore, since |EventS| is a type synonym for -|Maybe|, the use of |fmap| above is valid---and all it does is apply -the functional argument to the value ``attached to'' the event, which -in this case is an absolute pitch. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% The UISF Arrow - MIDI Device IDs %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{MIDI Device IDs} +\label{ch:mui:sec:mididevs} -Note in the previous example that the |DeviceID| argument to |midiOut| -is set to 0. The MIDI device ID is a system-dependent concept that +Before we can create an example using |midiIn| or |midiOut|, we first +must consider their other arguments: |InputDeviceID| and +|OutputDeviceID|. +The MIDI device ID is a system-dependent concept that provides an operating system with a simple way to uniquely identify various MIDI devices that may be attached to a computer. Indeed, as devices are dynamically connected and disconnected from a computer, -the mapping of these IDs to a particular device may change. If you -try to run the above code, it may or may not work, depending on -whether the MIDI device with ID 0 corresponds to the preferred MIDI -output device on your machine. - -To overcome this problem, most MIDI software programs allow the user -to select the preferred MIDI input and output devices. The user -usually has the best knowledge of which devices are connected, and -which devices to use. In Euterpea, the easiest way to do this is using -the UI widgets: +the mapping of these IDs to a particular device may change. +Thus, the only way to get an input or output device ID is by selection +with one of the following widgets: \begin{spec} -selectInput, selectOutput :: UISF () DeviceID +selectInput :: UISF () (Maybe InputDeviceID) +selectOutput :: UISF () (Maybe OutputDeviceID) \end{spec} Each of these widgets automatically queries the operating system to obtain a list of connected MIDI devices, and then displays the list as -a set of radio buttons, allowing the user to select one of them. -This makes wiring up the -user choice very easy. For example, we can modify the previous -program to look like this: +a set of radio buttons, allowing the user to select one of them. In +the event that there are no available devices, the widget can then +return |Nothing|. +%% This makes wiring up the user choice very easy. + +With these functions, we can now create an example using MIDI output. +Let's modify our previous MUI +program to output an |ANote| message every time the absolute pitch +changes: \begin{code} -ui4 :: UISF () () -ui4 = proc _ -> do +ui3 :: UISF () () +ui3 = proc _ -> do devid <- selectOutput -< () ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap uap <- unique -< ap midiOut -< (devid, fmap (\k-> [ANote 0 k 100 0.1]) uap) -mui4 = runMUI' "Pitch Player with MIDI Device Select" ui4 +mui3 = runMUI' ui3 \end{code} +The |unique| signal function used here is an example of a +\emph{mediator}, or a signal function that mediates between continuous +and discrete signals. We will explore more mediators in +Section~\ref{ch:mui:sec:mediators}, but in this case, note that +|unique| will generate an event whenever its input, the continuous +absolute pitch stream, changes. Each of those events, named |uap| above, +carries the new absolute pitch, and that pitch is used directly as the +MIDI key field in |ANote|. -It is a good idea to always take this approach when dealing with MIDI, -even if you think you know the exact device ID. +To understand how that last part is done on the |midiOut| line, +recall that |fmap| is the +primary method in the |Functor| class as described in +Section~\ref{sec:functor-class}, and the |Maybe| type is an instance +of |Functor|. Therefore, since |SEvent| is a type synonym for +|Maybe|, the use of |fmap| above is valid---and all it does is apply +the functional argument to the value ``attached to'' the event, which +in this case is an absolute pitch. For an example using MIDI input as well, here is a simple program that copies each MIDI message verbatim from the selected input device to the selected output device: \begin{code} -ui5 :: UISF () () -ui5 = proc _ -> do +ui4 :: UISF () () +ui4 = proc _ -> do mi <- selectInput -< () mo <- selectOutput -< () m <- midiIn -< mi midiOut -< (mo, m) -mui5 = runMUI' "MIDI Input / Output UI" ui5 +mui4 = runMUI' ui4 \end{code} -Since determining device IDs for both input and ouput is common, we +Since determining device IDs for both input and output is common, we define a simple signal function to do both: \begin{code} getDeviceIDs = topDown $ @@ -864,14 +888,16 @@ mo <- selectOutput -< () outA -< (mi,mo) -\end{code} %% $ +\end{code} + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% The UISF Arrow - Putting It All Together %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Putting It All Together} -\label{sec:runui} +\label{sec:runmui} Recall that a Haskell program must eventually be a value of type |IO ()|, and thus we need a function to turn a |UISF| value into a |IO| @@ -906,12 +932,12 @@ measured in pixels). By default, the size is |(300,300)| and the title is |"MUI"|, but we can change these like so: \begin{code} -mui'5 = runMUI (defaultMUIParams +mui'4 = runMUI (defaultMUIParams { uiTitle = "MIDI Input / Output UI", uiSize = (200,200)}) - ui5 + ui4 \end{code} -This version of |mui5| (from the previous subsection) will run +This version of |mui4| (from the previous subsection) will run identically to the original except for the fact that its title will read ``MIDI Input / Output UI'' and its initial size will be smaller. @@ -933,10 +959,11 @@ \syn{Note that the mediators and folds in the next two subsections are generic signal functions, and are not restricted to use only in MUIs. To highlight this, we present them with the |SF| type -rather than the |UISF| type. They can be (and often are) used in -MUIs. +rather than the |UISF| type. However, they can be (and often are) +used as |UISF|s in MUIs. -The timers and delay functions in Subsection~\ref{ch:mui:sec:delays} +The timers and delay functions in Subsections~\ref{ch:mui:sec:timers} +and \ref{ch:mui:sec:delays} require the MUI's internal notion of time, and so we present those directly with the |UISF| type.} @@ -944,6 +971,7 @@ %%%% Non-Widget Signal Functions - Mediators %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Mediators} +\label{ch:mui:sec:mediators} In order to use event streams in the context of continuous signals, Euterpea defines a set of functions that mediate between the @@ -951,7 +979,7 @@ functions that deal exclusively with events, are shown in Figure~\ref{fig:mediators} along with their type signatures and brief descriptions. Their use will be better understood through some -examples that follow. +examples that follow in Section~\ref{ch:mui:sec:examples}. \begin{figure} %% in signal processing this is called an ``edge @@ -959,27 +987,25 @@ \cbox{\small \begin{spec} unique :: Eq a => SF a (SEvent a) - -- generates an event whenever the input changes + -- Generates an event whenever the input changes edge :: SF Bool (SEvent ()) - -- generates an event whenever the input changes from |False| to |True| + -- Generates an event whenever the input changes from |False| to |True| +hold :: a -> SF (SEvent a) a + -- |hold x| begins as value |x|, but changes to the subsequent values + -- attached to each of its input events + accum :: a -> SF (SEvent (a -> a)) a -- |accum x| starts with the value |x|, but then applies the function -- attached to the first event to |x| to get the next value, and so on -mergeE :: (a -> a -> a) -> SEvent a -> SEvent a -> SEvent a - -- |mergeE f e1 e2| merges two events, using |f| to resolve two |Just| values - -hold :: b -> SF (SEvent b) b - -- |hold x| begins as value |x|, but changes to the subsequent values - -- attached to each of its input events - now :: SF () (SEvent ()) - -- creates a single event ``right now'' + -- Creates a single event ``now'' and forever after does nothing. -evMap :: SF b c -> UISF (SEvent b) (SEvent c) - -- lifts a continuous signal function into one that handles events +evMap :: SF a b -> SF (SEvent a) (SEvent b) + -- Lifts a continuous signal function into one that handles events + \end{spec}} \caption{Mediators Between the Continuous and the Discrete} \label{fig:mediators} @@ -991,7 +1017,7 @@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Folds} -In traditional functional prgramming, a folding, or reducing, operation +In traditional functional programming, a folding, or reducing, operation is one that joins together a set of data. The typical case would be an operation that operates over a list of data, such as a function that sums all elements of a list of numbers. @@ -1029,7 +1055,8 @@ as its input streaming argument. \end{itemize} -|concatA| and |runDynamic| are definitely similar, but they are also +The |concatA| and |runDynamic| signal functions are definitely similar, +but they are also subtly different. With |concatA|, there can be many different signal functions that are grouped together, but with |runDynamic|, there is only one. However, |runDynamic| may have a variable number of @@ -1040,20 +1067,21 @@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% Non-Widget Signal Functions - Timers and Delays %%%% +%%%% Non-Widget Signal Functions - Timers %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Timers and Delays} -\label{ch:mui:sec:delays} +\subsection{Timers} +\label{ch:mui:sec:timers} -The Euterpea MUI has an implicit notion of elapsed time. The current -elapsed time can be accessed explicitly by this signal source: +The Euterpea MUI has an implicit notion of elapsed time, but it can +be made explicit by the following signal source: \begin{spec} getTime :: UISF () Time \end{spec} where |Time| is a type synonym for |Double|. -But some MUI widgets depend on the time implicitly. For example, the -following pre-defined signal function creates a \emph{timer}: +Although the explicit time may be desired, some MUI widgets depend +on the time implicitly. For example, the +following signal function creates a \emph{timer}: \begin{spec} timer :: UISF DeltaT (SEvent ()) \end{spec} @@ -1068,13 +1096,13 @@ %% generic |ArrowInit|. However, as |UISF| is an instance of %% |ArrowInit|, we can use |timer| in our MUIs. -To see how a timer might be used, let's modify our previous MUI so -that, instead of playing a note every time the absolute pitch changes, -we will output a note continuously, at a rate controlled by a second -slider: +To see how a timer might be used, let's modify our MUI working example +from earlier so that, instead of playing a note every time the absolute +pitch changes, we will output a note continuously, at a rate controlled +by a second slider: \begin{code} -ui6 :: UISF () () -ui6 = proc _ -> do +ui5 :: UISF () () +ui5 = proc _ -> do devid <- selectOutput -< () ap <- title "Absolute Pitch" (hiSlider 1 (0,100) 0) -< () title "Pitch" display -< pitch ap @@ -1083,16 +1111,17 @@ midiOut -< (devid, fmap (const [ANote 0 ap 100 0.1]) tick) -- Pitch Player with Timer -mui6 = runMUI ui6 +mui5 = runMUI' ui5 \end{code} Note that the rate of |tick|s is controlled by the second slider---a larger slider value causes a smaller time between ticks, and thus a higher frequency, or tempo. -The |genEvents| signal function is very similar to |timer|, in that -it will generate specific, recurring events, but it differs in that -those events contain data based on an input list: +In some cases, the simple unit events of the |timer| are not enough. +Rather, we would like each event to be different while we progress +through a predetermined sequence. To do this, we can use the +|genEvents| signal function: \begin{spec} genEvents :: [b] -> UISF DeltaT (SEvent b) \end{spec} @@ -1102,20 +1131,39 @@ |lst| has been emitted, |genEvents lst| will never again produce an event. -Another way in which a widget can use time implictly is in a -\emph{delay}. Euterpea comes with four different delaying widgets, + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%% Non-Widget Signal Functions - Delays %%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Delays} +\label{ch:mui:sec:delays} + + +Another way in which a widget can use time implicitly is in a +\emph{delay}. Euterpea comes with five different delaying widgets, which each serve a specific role depending on whether the streams are continuous or event-based and if the delay is a fixed length or can be variable: \cbox{ \begin{spec} +delay :: b -> UISF b b fcdelay :: b -> DeltaT -> UISF b b fdelay :: DeltaT -> UISF (SEvent b) (SEvent b) vdelay :: UISF (DeltaT, SEvent b) (SEvent b) vcdelay :: DeltaT -> b -> UISF (DeltaT, b) b \end{spec}} -To start, we will examine the most straightforward one: +To start, we will examine the most straightforward one. The +|delay| function creates what is called a ``unit delay'', which +can be thought of as a delay by the shortest amount of time possible. +This delay should be treated in the same way that one may treat a +$\delta t$ in calculus; that is, although one can assume that a delay +takes place, the amount of time delayed approaches zero. +Thus, in practice, this should be used only in continuous cases and +should only be used as a means to initialize arrow feedback. + +The rest of the delay operators delay by some amount of actual time, +and we will look at each in turn. |fcdelay b t| will emit the constant value |b| for the first |t| seconds of the output stream and will from then on emit its input stream delayed by |t| seconds. The name comes from ``fixed continuous @@ -1146,7 +1194,7 @@ the maximum amount that the widget can delay. Due to the variable nature of |vcdelay|, some portions of the input signal may be omitted entirely from the output signal while others may even be outputted -more than once. Thus, once again, it is higly advised to use +more than once. Thus, once again, it is highly advised to use |vdelay| rather than |vcdelay| when dealing with event-based signals. @@ -1156,10 +1204,15 @@ %%%% Musical Examples %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Musical Examples} +\label{ch:mui:sec:examples} In this section we work through three larger musical examples that use Euterpea's MUI in interesting ways. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%% Musical Examples - Chord Builder %%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Chord Builder} This MUI will display a collection of chord types (Maj, Maj7, Maj9, @@ -1183,24 +1236,16 @@ We will display the list of chords on the screen as radio buttons for the user to click on. -\begin{figure}[hbtp] -\centering -\includegraphics[height=2.3in]{pics/chordBuilder.eps} -\caption{A Chord Builder MUI} -\label{fig:chordbuilder} -\end{figure} - The |toChord| function takes an input MIDI message as the root note, and the index of the selected chord, and outputs the notes of the -selected chord. For simplicity, we only process the head of the -message list and ignore everything else. +selected chord. \begin{code} -toChord :: Int -> [MidiMessage] -> [MidiMessage] -toChord i ms@(m:_) = +toChord :: Int -> MidiMessage -> [MidiMessage] +toChord i m = case m of Std (NoteOn c k v) -> f NoteOn c k v Std (NoteOff c k v) -> f NoteOff c k v - _ -> ms + _ -> [] where f g c k v = map (\k' -> Std (g c k' v)) (scanl (+) k (snd (chordIntervals !! i))) @@ -1229,17 +1274,38 @@ m <- midiIn -< mi i <- topDown $ title "Chord Type" $ radio (fst (unzip chordIntervals)) 0 -< () - midiOut -< (mo, fmap (toChord i) m) + midiOut -< (mo, fmap (concatMap $ toChord i) m) -chordBuilder = runMUI (600,400) "Chord Builder" buildChord +chordBuilder = runMUI (defaultMUIParams + { uiTitle = "Chord Builder", + uiSize = (600,400)}) + buildChord +\end{code} -\end{code} %% $ +\syn{|unzip :: [(a,b)] -> ([a],[b])| is a standard Haskell function + that does the opposite of |zip :: [a] -> [b] -> [(a,b)]|. + + |concatMap :: (a -> [b]) -> [a] -> [b]| is another standard Haskell + function that acts as a combination of |map| and |concat|. It maps + the given function over the given list and then concatenates all of + the outputs into a single output list.} + Figure \ref{fig:chordbuilder} shows this MUI in action. -\syn{|unzip :: [(a,b)] -> ([a],[b])| is a standard Haskell function - that does the opposite of |zip :: [a] -> [b] -> [(a,b)]|.} +\begin{figure}[hbtp] +\centering +\includegraphics[height=2.3in]{pics/chordBuilder.eps} +\caption{A Chord Builder MUI} +\label{fig:chordbuilder} +\end{figure} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%% Musical Examples - Chaotic Composition %%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Chaotic Composition} +\label{ch:mui:sec:chatoiccomp} In this section we describe a UISF that borrows some ideas from Gary Lee Nelson's composition ``Bifurcate Me, Baby!'' @@ -1253,7 +1319,7 @@ Mathematically, we start with an initial population $x_0$ and iteratively apply the growth function to it, where $r$ is the growth -rate. For certain values of $r$, the population stablizes to a +rate. For certain values of $r$, the population stabilizes to a certain value, but as $r$ increases, the period doubles, quadruples, and eventually leads to chaos. It is one of the classic examples of chaotic behavior. @@ -1262,14 +1328,16 @@ function that, given a rate |r| and current population |x|, generates the next population: \begin{code} -grow :: Double -> Double -> Double -grow r x = r * x * (1-x) +grow :: Double -> Double -> Double +grow r x = r * x * (1-x) \end{code} To generate a time-varying population, the |accum| signal function -comes in handy. |accum| takes an initial value and an event signal -carrying a modifying function, and updates the current value by +comes in handy. |accum| is one of the mediators mentioned in +Section~\ref{ch:mui:sec:mediators}: it takes an initial value and an +event signal +carrying a modifying function, and it updates the current value by applying the function to it. \begin{spec} ... @@ -1312,10 +1380,17 @@ _ <- title "Population" $ display -< pop midiOut -< (mo, fmap (const (popToNote pop)) tick) -bifurcate = runMUI (300,500) "Bifurcate!" $ bifurcateUI +bifurcate = runMUI (defaultMUIParams + { uiTitle = "Bifurcate!", + uiSize = (300,500)}) + bifurcateUI \end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%% Musical Examples - MIDI Echo Effect %%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{MIDI Echo Effect} As a final example we present a program that receives a MIDI event @@ -1337,42 +1412,36 @@ messages by replacing them with Nothing. The resulting signal |m'| is then processed further as follows. -%% Whenever there is an event in |m'|, we take a snapshot of the current -%% decay rate specified by a slider |r|. The MIDI messages and the current decay rate are processed with |decay|, which softens each note in the list of messages. Specifically, |decay| works by reducing the velocity of each note by the given rate and removing the note if the velocity drops to 0. The resulting signal is then delayed by the amount of time determined by another slider |f|, -producing signal |s|. |s| is then fed back to the |mergeE| function, -closing the loop of the recursive signal. At the same time, |m'| is -sent to the output device. +producing signal |s|. Signal |s| is then merged with |m| in order to +define |m'| (note that |~++| is a Euterpea function that +merges event lists), thus closing the loop of the recursive signal. +Finally, |m'| is sent to the output device. \begin{code} echoUI :: UISF () () echoUI = proc _ -> do - mi <- selectInput -< () - mo <- selectOutput -< () + (mi, mo) <- getDeviceIDs -< () m <- midiIn -< mi r <- title "Decay rate" $ withDisplay (hSlider (0, 0.9) 0.5) -< () f <- title "Echoing frequency" $ withDisplay (hSlider (1, 10) 10) -< () - rec let m' = removeNull $ mergeE (++) m s - s <- vdelay -< (1/f, fmap (mapMaybe (decay 0.1 r)) m') + rec s <- vdelay -< (1/f, fmap (mapMaybe (decay 0.1 r)) m') + let m' = m ~++ s midiOut -< (mo, m') -echo = runMUI (500,500) "Echo" echoUI +echo = runMUI' echoUI -\end{code} %% $ +\end{code} \begin{code} -removeNull :: Maybe [MidiMessage] -> Maybe [MidiMessage] -removeNull (Just []) = Nothing -removeNull mm = mm - decay :: Time -> Double -> MidiMessage -> Maybe MidiMessage decay dur r m = let f c k v d = if v > 0 @@ -1394,10 +1463,14 @@ Although the widgets and signal functions described so far enable the creation of many basic MUIs, there are times when something more specific is required. -Thus, in this section, we will look at some more special purpose +Thus, in this section, we will look at some special purpose widgets as well as some functions that aid in the creation of custom widgets. +Some of the functions described in this subsection are included in +Euterpea by default, but others require extra imports of specific +Euterpea modules. We will note this where applicable. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Custom Widgets - Realtime graphs, histograms %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1413,9 +1486,12 @@ Euterpea provides support for a few different widgets that will graph streaming data visually. \begin{spec} -realtimeGraph :: RealFrac a => Layout -> Time -> Color -> UISF [(a,Time)] () -histogram :: RealFrac a => Layout -> UISF (SEvent [a]) () -histogramWithScale :: RealFrac a => Layout -> UISF (SEvent [(a,String)]) () +realtimeGraph :: RealFrac a => Layout + -> Time -> Color -> UISF [(a,Time)] () +histogram :: RealFrac a => Layout + -> UISF (SEvent [a]) () +histogramWithScale :: RealFrac a => Layout + -> UISF (SEvent [(a,String)]) () \end{spec} Note that each of these three functions requires a |Layout| argument (recall the |Layout| data type from Section~\ref{ch:mui:sec:wt}); @@ -1429,94 +1505,493 @@ |l|. This graph will accept as input a stream of events of pairs of values and time\footnote{These events are represented as a list rather than using the |SEvent| type because there may be more than - one event at the same time. The absense of any events would be + one event at the same time. The absence of any events would be indicated by an empty list.}. The values are plotted vertically in color |c|, and the horizontal axis represents time, where the width of the graph represents an amount of time |t|. \item -The histogram widgets take as input events that each contain a complete +The histogram widgets' input are events that each contain a complete set of data. The data are plotted as a histogram within the given layout. For the histogram with the scale, each value must be paired with a |String| representing its label, and the labels are printed under the plot. \end{itemize} +These widgets will prove useful when we are dealing with sound +signals directly in future chapters. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Custom Widgets - More MIDI Widgets %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{More MIDI Widgets} -This may be filled in later with midiOutMB and other similar stuff, -but I will refrain from writing about them until I know if they're -going to stay in Euterpea. +In Sections~\ref{ch:mui:sec:midiinout} and \ref{ch:mui:sec:mididevs}, +we presented simple widgets for selecting devices and polling and +playing midi messages. However, these widgets allow for only one +input device and one output device at a time. For a more complex +scenario where multiple devices are to be used simultaneously, we +have the following four widgets: + +\begin{spec} +midiInM :: UISF [InputDeviceID] (SEvent [MidiMessage]) +midiOutM :: UISF [(OutputDeviceID, SEvent [MidiMessage])] () +selectInputM :: UISF () [InputDeviceID] +selectOutputM :: UISF () [OutputDeviceID] +\end{spec} + +The M on the end can be read as ``Multiple.'' These widgets can +be used just like their singular counterparts to handle MIDI, +except that they allow for multiple simultaneous device usage. + +We can add even more behavior into the midi output widgets by +considering a \emph{buffered} output. When using |midiOut| (or +|midiOutM|), all of the MIDI messages sent to the device are +immediately played, but sometimes, we would prefer to queue +messages up for playback later. We can do this with the following +two midi output widgets: +\begin{spec} +midiOutB :: UISF ( Maybe OutputDeviceID, + BufferOperation MidiMessage) Bool +midiOutMB :: UISF [ ( OutputDeviceID, + BufferOperation MidiMessage)] Bool +\end{spec} +Notice that these two widgets have a |Bool| output stream; this stream +is |True| when the buffer is empty and there is nothing queued up to +play and |False| otherwise. +The |BufferOperation| data type gives information along with +the MIDI messages about when or how to play the messages. It is defined +as follows: +\begin{spec} +data BufferOperation b = + NoBOp + | ClearBuffer + | SkipAheadInBuffer DeltaT + | MergeInBuffer [(DeltaT, b)] + | AppendToBuffer [(DeltaT, b)] + | SetBufferPlayStatus Bool (BufferOperation b) + | SetBufferTempo Tempo (BufferOperation b) +\end{spec} +where +\begin{itemize} +\item |NoBOp| indicates that there is no new information for the buffer. +\item |ClearBuffer| erases the current buffer. +\item |SkipAheadInBuffer t| skips ahead in the buffer by |t| seconds. +\item |MergeInBuffer ms| merges messages |ms| into the buffer to play + concurrently with what is currently playing. +\item |AppendToBuffer ms| adds messages |ms| to the end of the buffer + to play immediately following whatever is playing. +\item |SetBufferPlayStatus p b| indicates whether the buffer should be + playing (|True|) or paused (|False|). +\item |SetBufferTempo t b| sets the play speed of the buffer to |t| + (the default is 1, indicating realtime). +\end{itemize} +Note that the final two options recursively take a buffer operation, +meaning that they can be attached to any other buffer operation as +additional modifications. + +\syn{The |midiOutB| and |midiOutMB| widgets are essentially the + regular |midiOut| widgets connected to an |eventBuffer|. The + |eventBuffer| signal function can also be used directly to buffer any + kind of data that fits into the |BufferOperation| format. It can be + brought into scope by importing FRP.UISF.AuxFunctions.} + +In practice, the most common time to use the buffered midi output +widgets as opposed to the regular ones is when dealing with |Music| +values. Thus, Euterpea.IO.MUI.MidiWidgets also exports the following +function: +\begin{spec} +musicToMsgs :: Maybe [InstrumentName] -> Music1 + -> [(DeltaT, MidiMessage)] +\end{spec} +The first argument should be a |Just| value if the |Music1| value is +infinite and |Nothing| otherwise. If it is a |Just| value, then its +value should be the override for the instrument channels. + +The |musicToMsgs| function will convert a |Music1| value into a format +that can be easily sent to the buffered midi widget. Once converted +in this way, it can be wrapped by |MergeInBuffer| or |AppendToBuffer| +to be sent to the buffer. + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% Custom Widgets - Instruments %%%% +%%%% Custom Widgets - Virtual Instruments %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Instruments} +\subsection{Virtual Instruments} Euterpea provides two special widgets that create virtual instruments -that the user can interact with: a piano and a guitar. +that the user can interact with: a piano and a guitar. These two +widgets are not fully supported by Euterpea at present, so to bring +them into scope, we will need to import Euterpea.Experimental. \begin{spec} +import Euterpea.Experimental +\end{spec} + +\syn{Euterpea's Experimental package contains functions and features +that are still in process. They may be unreliable, and they are likely +to change in future versions of Euterpea. Thus, feel free to experiment +with them, but use them with caution.} + +The piano and guitar are virtual instruments in the +MUI that look and behave like a piano keyboard or guitar strings: the strings can be +plucked or the piano keys pressed with either the mouse or keyboard, and +the output is in the form of MIDI messages. Note that these widgets do +not actually produce any sound. Thus, in most cases, the output should +then be sent to a MIDI output widget. + +The two widgets have the following similar types: +\begin{spec} guitar :: GuitarKeyMap -> Midi.Channel - -> UISF (InstrumentData, SEvent [MidiMessage]) (SEvent [MidiMessage]) + -> UISF (InstrumentData, SEvent [MidiMessage]) + (SEvent [MidiMessage]) piano :: PianoKeyMap -> Midi.Channel - -> UISF (InstrumentData, SEvent [MidiMessage]) (SEvent [MidiMessage]) + -> UISF (InstrumentData, SEvent [MidiMessage]) + (SEvent [MidiMessage]) \end{spec} +Given a key mapping and a MIDI channel, the functions make the virtual +instrument widgets. The widgets themselves accept an |InstrumentData| +argument, which contains some settings for the instrument, and a stream +of input MIDI messages, and they produce a stream of MIDI messages. They +do not make any sound themselves---these widgets are purely visual. -There are actually a whole bunch of helper functions that go along -with these. However, all of this is in Experimental right now, so -I don't know how I should write about it here. +Let's look at how these widgets work in a little more detail. First, +the widgets take a key map, either a |GuitarKeyMap| or a |PianoKeyMap|. +These maps indicate what keyboard keys one can use to play the +instruments with a standard computer keyboard. These are customizable +values, but we provide a couple for use with a qwerty keyboard: +\begin{itemize} +\item |defaultMap1| treats the characters from Q to U as one octave + from C2 to B3. The black notes are predictably at 2, 3, 5, 6, and 7. + Holding a shift key while pressing the same keys plays the notes one + octave higher. +\item |defaultMap2| is the same as |defaultMap1| except that it uses + the bottom two rows of the keyboard, with Z through M as the white + keys and S through J (but not F) as black keys. Once again, hold + shift for the higher octave. +\item |defaultMap0| is for a four octave keyboard and uses both maps + in sequence. +\end{itemize} +For the guitar, we provide |sixString|, a mapping using the first +six columns of keys (e.g. 1, Q, A, Z would be the first column) to +represent the six strings of the guitar. +The next argument to making a virtual instrument widget is a MIDI +channel. Because they can create MIDI messages from just a mouse +click, these widgets need +information about what MIDI channel the messages should use. The +|Midi.Channel| type is brought in from |Codec.Midi|, and it is a type +synonym for |Int|---really, any number from 0 to 127 is probably an okay +candidate, but it depends on what channels your MIDI devices support. +The streaming input to the widgets includes both MIDI messages (which +will visually ``play'' on the instrument) as well as a value of +|InstrumentData|. By default, one should use the value +|defaultInstrumentData|, but this can be modified with the following +three widgets: +\begin{spec} +addNotation :: UISF InstrumentData InstrumentData +addTranspose :: UISF InstrumentData InstrumentData +addPedal :: UISF InstrumentData InstrumentData +\end{spec} +Each one will create a checkbox or slider to allow for adding +notation (visual text that indicates what keys are what on the +instrument), transposition (the ability to raise or lower the notes +by some amount) or pedal (only used for the piano). + +Now that we have some idea of how the widgets work, let's create a +sample MUI that uses them both. + +\begin{code} +gAndPUI :: UISF () () +gAndPUI = proc _ -> do + (mi, mo) <- getDeviceIDs -< () + m <- midiIn -< mi + settings <- addNotation -< defaultInstrumentData + outG <- guitar sixString 1 -< (settings, Nothing) + outP <- piano defaultMap0 0 -< (settings, m) + midiOut -< (mo, outG ~++ outP) + +gAndP = runMUI (defaultMUIParams { uiSize=(1050,700), + uiTitle="Guitar and Piano"}) + gAndPUI +\end{code} + +This MUI will provide a checkbox for whether it should display +notation or not and then shows both virtual instruments. Any messages +played on the input MIDI device will be shown and heard as if played +on the virtual piano. + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Custom Widgets - A Graphical Canvas %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{A Graphical Canvas} \label{sec:canvas} +In addition to the standard musical widgets, the musical user interface +provides support for arbitrary graphical output. It does this via the +|canvas| widget, which allows the user to ``paint'' graphics right into +the MUI: \begin{spec} -canvas :: Dimension -> UISF (SEvent Graphic) () +canvas :: Dimension -> UISF (Event Graphic) () +canvas' :: Layout -> (a -> Dimension -> Graphic) -> UISF (Event a) () \end{spec} +The main |canvas| widget takes a fixed size and displays in the MUI +the most recent |Graphic| it received. The |canvas'| function is a +little more complex as it can handle a changing size: rather than a +fixed dimension, it accepts a layout and a function that, when given +the dimension (which is generated at runtime based on the window size), +can produce the appropriate graphic. -|canvas| creates a graphical canvas on which images can be drawn. +In either case, the user is responsible for generating the graphic +that should be shown by generating a value of type |Graphic|. However, +Euterpea does not export |Graphic| constructors by default, +so we will need to add the following import to our file: +\begin{spec} +import FRP.UISF.SOE +\end{spec} +The name of this import, SOE, comes from the book The Haskell School +of Expression, the predecessor to this text. Rather than go into +detail about the various types of graphics one can create with this +import, we will leave it to the reader to read this other text or to +look at the documentation directly. Instead, we will only point out +three functions as we will use them in our upcoming example: +\begin{spec} +rectangleFilled :: Rect -> Graphic +rgbE :: Int -> Int -> Int -> RGB +withColor' :: RGB -> Graphic -> Graphic +\end{spec} +The |rectangleFilled| function takes a |Rect|, which is a pair of +a point representing the bottom left corner and a width and height, +and constructs a rectangle bounded by the |Rect|. +The |rgbE| function produces an |RGB| color +from red, green, and blue values, and |withColor'| applies the given +|RGB| color to the given |Graphic|. -Details TBD. +In the following example, we will create three sliders to control +the red, green, and blue values, and then we will use these to create +a simple color swatch out of the |canvas| widget. +\begin{code} +colorSwatchUI :: UISF () () +colorSwatchUI = setSize (300, 220) $ pad (4,0,4,0) $ leftRight $ + proc _ -> do + r <- newColorSlider "R" -< () + g <- newColorSlider "G" -< () + b <- newColorSlider "B" -< () + e <- unique -< (r,g,b) + let rect = withColor' (rgbE r g b) (rectangleFilled ((0,0),d)) + pad (4,8,0,0) $ canvas d -< fmap (const rect) e + where + d = (170,170) + newColorSlider l = title l $ withDisplay $ viSlider 16 (0,255) 0 +colorSwatch = runMUI' colorSwatchUI +\end{code} + +We use the |polygon| function to create a simple box, and then we color +it with the data from the sliders. Whenever the color changes, we redraw +the box by sending a new |Graphic| event to the |canvas| widget. + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Custom Widgets - [Advanced] mkWidget %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{[Advanced] mkWidget} -Even more advanced than canvas. Perhaps this need not be documented -in HSoM +In some cases, even the |canvas| widget is not powerful enough, and +we would like to create our own custom widget. For this, there is +the |mkWidget| function. To bring this into scope, we must import +UISF's widget module directly: +\begin{spec} +import FRP.UISF.Widget (mkWidget) +\end{spec} +The type of |mkWidget| is as follows: +\begin{spec} +mkWidget :: s + -> Layout + -> (a -> s -> Rect -> UIEvent -> (b, s, DirtyBit)) + -> (Rect -> Bool -> s -> Graphic) + -> UISF a b +\end{spec} +This widget building function takes arguments particularly desgined +to make a realtime, interactive widget. The arguments work like so: +\begin{itemize} +\item The first argument is an initial state for the widget. The + widget will be able to internally keep track of state, and the + value that it should start with is given here. +\item The second argument is the layout of the widget. +\item The third argument is the computation that this layout performs. + Given an instantaneous value of the streaming input, the current + state, the rectangle describing the current allotted dimensions, + and the current |UIEvent|\footnote{The |UIEvent| can contain + information like mouse clicks or key presses. For complete + documentation on |UIEvent|, look to the FRP.UISF documentation.}, + it should produce an output value, a new state, and a |DirtyBit|, + which is a boolean value indicating whether the visual representation + of the widget will change. +\item The final argument is the drawing routine. Given the rectangle + describing the current allotted dimensions for the widget (the same + as given to the computation function), a boolean indicating whether + this widget is in focus, and the state, it produces the graphic + that this widget will appear as. +\end{itemize} + +The specifics of |mkWidget| are beyond the scope of this text, and +those interested in making their own widgets are encouraged to look +at the documentation of the UISF package. However, as a demonstration +of its use, here we will show the definition of |canvas| using +|mkWidget|. +\begin{spec} +canvas (w, h) = mkWidget nullGraphic layout process draw + where + layout = makeLayout (Fixed w) (Fixed h) + draw ((x,y),(w,h)) _ = translateGraphic (x,y) + process (Just g) _ _ _ = ((), g, True) + process Nothing g _ _ = ((), g, False) +\end{spec} + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Advanced Topics %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Advanced Topics} - +In the final section of this chapter, we will explore some advanced +topics related to the MUI. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Advanced Topics - Banana brackets %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Banana brackets} +When dealing with layout, we have so far shown two ways to apply the +various layout transformers (e.g.\ |topDown|, |leftRight|, etc.) to +signal functions. One way involves using the transformer on the +whole signal function by applying it on the first line like so: +\begin{spec} +... = leftRight $ proc _ -> do ... +\end{spec} +The other option is to apply the transformation in-line for the signal +function it should act upon: +\begin{spec} +... + x <- topDown mySF -< y +... +\end{spec} +However, the situation is not so clear cut, and at times, we may +want a sub-portion of our signal function to have a different layout +flow than the rest. +For example, assume we have a signal function +that should have four buttons. The second and third buttons should +be left-right aligned, but vertically, they together should be between +the first and second. One way we may try to write this is like so: +\begin{code} +ui6 = topDown $ proc _ -> do + b1 <- button "Button 1" -< () + (b2, b3) <- leftRight (proc _ -> do + b2 <- button "Button 2" -< () + b3 <- button "Button 3" -< () + returnA -< (b2, b3)) -< () + b4 <- button "Button 4" -< () + display -< b1 || b2 || b3 || b4 +\end{code} +This looks a little funny, especially because we have an extra arrow +tail (the |-<| part) after the inner |returnA| on the sixth line, but +it gets the job done. + +However, what if we wanted to do something with the value |b1| within +the inner |proc| part? In its current state, |b1| is not in scope in +there. We can add it to the scope, but we would have to explicitly +accept that value from the outer scope. It would look like so: +\begin{code} +ui'6 = topDown $ proc _ -> do + b1 <- button "Button 1" -< () + (b2, b3) <- leftRight (proc b1 -> do + b2 <- button "Button 2" -< () + display -< b1 + b3 <- button "Button 3" -< () + returnA -< (b2, b3)) -< b1 + b4 <- button "Button 4" -< () + display -< b1 || b2 || b3 || b4 +\end{code} +This is getting hard to deal with! Fortunately, there is an arrow +syntax feature to help us with this known as \emph{banana brackets}. + +Banana brackets are a component of the arrow syntax that allows one +to apply a function to one or more arrow commands without losing the +scope of the arrow syntax. To use, one writes in the form: +\begin{spec} +(| f cmd1 cmd2 ... |) +\end{spec} +where |f| is a function on arrow commands +and |cmd1|, |cmd2|, etc.\ are arrow commands. + +\syn{An \emph{arrow command} is the portion of arrow syntax that + contains the arrow and the input but not the binding to output. + Generally, this looks like |sf -< x|, but if it starts with |do|, + then it can be an entire arrow in itself (albeit, one that does + not start with |proc _ -> |).} + +Banana brackets preserve the original arrow scope, so we can rewrite +our example to: +\begin{code} +ui''6 = proc () -> do + b1 <- button "Button 1" -< () + (b2, b3) <- (| leftRight (do + b2 <- button "Button 2" -< () + display -< b1 + b3 <- button "Button 3" -< () + returnA -< (b2, b3)) |) + b4 <- button "Button 4" -< () + display -< b1 || b2 || b3 || b4 +\end{code} +Note that we no longer need the |proc _ ->| in the third line nor +do we have an arrow tail on the seventh line. That said, banana +brackets do have a limitation in that the variables used internally +are not exposed outside; that is, we still need the seventh line to +explicitly return |b2| and |b3| in order to bind them to the outer +scope in the third line so that they are visible when displayed on the +last line. + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Advanced Topics - General I/O From Within a MUI %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{General I/O From Within a MUI} \label{sec:mui-general-io} +So far, through specific widgets, we have shown how to perform specific +effects through the MUI: one can poll MIDI devices, send MIDI output, +display graphics on the screen, and so on. However, +the MUI is capable of arbitrary |IO| actions. In general, arbitrary +|IO| actions can be dangerous, so the functions that allow them are +relegated to Euterpea.Experimental, and they should be used with care. -[This section needs further elaboration] +The first arbitrary |IO| arrow to consider is: +\begin{spec} +initialAIO :: IO d -> (d -> UISF b c) -> UISF b c +\end{spec} +This function allows an |IO| action to be performed upon MUI +initialization, the result of which is used to finish constructing +the widget. Thus, its name can be read as ``initial Arrow IO.'' -Euterpea has sources, sinks, and pipes for UISFs as well as a general -event buffer and a hook into it for MIDI out. +In practice one might use |initialAIO| to do something like read the +contents of a file to be used at runtime. For instance, if we had a +file called ``songData'' that contained data we would like to use in +the MUI, we could use the following function: +\begin{spec} +initialAIO (readFile "songData") + (\x -> now >>> arr (fmap $ const x)) + :: UISF () (SEvent String) +\end{spec} +This function will read the file and then produce a single event +containing the contents of the file when the MUI first starts. -The following six functions: +Performing an initial action is simple and useful, but at times, we +would like the freedom to perform actions mid-execution as well, and +for that, we have the following six functions: \begin{spec} uisfSource :: IO c -> UISF () c uisfSink :: (b -> IO ()) -> UISF b () @@ -1525,56 +2000,107 @@ uisfSinkE :: (b -> IO ()) -> UISF (SEvent b) (SEvent ()) uisfPipeE :: (b -> IO c) -> UISF (SEvent b) (SEvent c) \end{spec} -work as expected. Without resource types, these functions are unsafe -and should be used with caution. - -Here are four examples: -\begin{spec} -uisfPipeE randomRIO :: Random c => UISF (SEvent (c,c)) (SEvent c) -uisfSourceE randomIO :: Random c => UISF (SEvent ()) (SEvent c) -uisfPipeE readFile :: UISF (SEvent FilePath) (SEvent String) -uisfSinkE $ uncurry writeFile :: - UISF (SEvent (FilePath, String)) (SEvent ()) -\end{spec} %% $ - -Euterpea also has an event buffer: +The first three of these are for continuous-type actions and the +last three are for event-based actions. As an example of a continuous +action, one could consider a stream of random numbers: \begin{spec} -data BufferControl b = Play | Pause | Clear | AddData [(DeltaT, b)] -eventBuffer :: UISF (SEvent (BufferControl a), Time) (SEvent [a], Bool) +uisfSource randomIO :: Random r => UISF () r \end{spec} -|Pause| and |Play| are states that determine whether time continues or -not, |Clear| empties the buffer, and |AddData| adds new data, -merging as necessary. Infinite data streams are supported. The -output includes an event of values that are ready and a |Bool| -indicating if there are values left in the buffer. -|eventBuffer| can be used directly, but it also hooks directly into -|midiOut| with: -\begin{spec} -midiOutB :: UISF (DeviceID, SEvent [(DeltaT, MidiMessage)]) Bool -midiOutB' :: UISF (DeviceID, SEvent (BufferControl MidiMessage)) Bool -\end{spec} -There is also a function that converts |Music| values into the event -structure used above: +Most |IO| actions are better handled by the event-based functions. +For instance, we could update our file reading widget from earlier +so that it is capable of reading a dynamically named file, and it can +perform more than one read at runtime: \begin{spec} -musicToMsgs :: Bool -> [InstrumentName] -> Music1 -> [(DeltaT, MidiMessage)] +uisfPipeE readFile :: UISF (SEvent FilePath) (SEvent String) \end{spec} -in which the |Bool| argument tells whether the |Music1| value is -infinite, and the list is for instrument channels in the infinite case. - -(Perhaps this should just be one argument of type |Maybe -[InstrumentName]|?) +Whenever this signal function is given an event containing a file, +it reads the file and returns an event containing the contents. +\syn{This sort of arbitrary |IO| access that the functions from this + subsection allow can have negative effects on a program ranging from + unusual behavior to performance problems to crashing. Research has + been done to handle these problems, and a promising solution using + what are called \emph{resource types} has been proposed + \cite{WinogradCort-TR1446, WinogradCort2012HS}. + However, Euterpea does not implement resource types, so it is left to + the programmer to be exceptionally careful to use these appropriately.} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Advanced Topics - Asynchrony %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Asynchrony} -(and tying in with SigFuns -- "In Chapter 19, you will learn about SigFuns ..., we can tie them into MUIs like so") +Although we have discussed the MUI as being able to act both +continuously and discretely (event-based) depending on the required +circumstances, in actual fact, the system is entirely built in a +discrete way. When run, the MUI does many calculations per second +to create the illusion of continuity, and as long as this sample +rate is high enough, the illusion persists without any problem. +However, there are two primary ways in which the illusion of continuity +fails: +\begin{itemize} +\item Computations can be sensitive to the sampling rate itself such + that a low enough rate will cause poor behavior. +\item Computations can be sensitive to the variability of the sampling + rate such that drastic differences in the rate can cause poor + behavior. +\end{itemize} +These are two subtly different problems, and we will address both with +subtly different forms of \emph{asynchrony}. +The idea of using asynchrony is to allow these sensitive computations +to run separately from the MUI process so that they are unaffected by +the MUI's sampling rate and are allowed to set and use their own +arbitrary rate. We achieve this with the following functions: +\begin{spec} +asyncUISFE . toAutomaton :: NFData b => + SF a b -> UISF (SEvent a) (SEvent b) +clockedSFToUISF :: (NFData b, Clock c) => + DeltaT -> SigFun c a b -> UISF a [(b, Time)] +\end{spec} +Note that the |SF| and |SigFun| types will be discussed further in +Chapter~\ref{ch:sigfuns}), but they are both arrows, and thus we can +lift pure functions of type |a -> b| to them with the |arr| function. +These two functions are designed to address the two different sampling +rate pitfalls we raised above. + +\begin{itemize} +\item |asyncUISFE . toAutomaton| is technically a composition of + two functions, but in Euterpea, it would be rare to use them apart. + Together, they are used to deal with the scenario where a computation + takes a long time to compute (or perhaps blocks internally, delaying + its completion). This slow computation may have deleterious effects + on the MUI, causing it to become unresponsive and slow, so we allow + it to run asynchronously. The computation is lifted into the discrete, + event realm, and for each input event given to it, a corresponding + output event will be created eventually. Of course, the output + event will likely not be generated immediately, but it will be + generated eventually, and the ordering of output events will match + the ordering of input events. +\item The |clockedSFToUISF| function can convert a signal function + with a fixed, virtual clockrate to a realtime UISF. The first + input parameter is a buffer size in seconds that indicates how + far ahead of real time the signal function is allowed to get, but + the goal is to allow it to run at a fixed clockrate as close to + realtime as possible. Thus, the output stream is a list of pairs + providing the output values along with the timestamp for when they + were generated. This should contain the right number of samples to + approach real time, but on slow computers or when the virtual + clockrate is exceptionally high, it will lag behind. This can be + checked and monitored by checking the length of the output list + and the time associated with the final element of the list on + each time step. +\end{itemize} + +Rather than show an example here, we will wait until +Chapter~\ref{ch:spectrum-analysis} once the |SigFun| type has been +introduced. An example that uses |clockedSFToUISF| can be found at +the end of the chapter in Figure~\ref{fig:fft-mui} + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Exercises %%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1583,7 +2109,7 @@ \begin{exercise}{\em Define a MUI that has a text box in which the user can type a pitch using the normal syntax |(C,4)|, |(D,5)|, etc., and a pushbutton -labeled ``Play'' that, when pushed, will play the pitch appearing in +labelled ``Play'' that, when pushed, will play the pitch appearing in the textbox. Hint: use the Haskell function |reads :: Read a => String -> diff --git a/HSoM/Music.lhs b/HSoM/Music.lhs --- a/HSoM/Music.lhs +++ b/HSoM/Music.lhs @@ -285,7 +285,7 @@ \end{spec} These four constructors then are also polymorphic functions. -%% | Music a :=/ Music a -- parallel composition +%% | Music a /=: Music a -- parallel composition %% (short) %% The first line here looks odd: the name |Primitive| appears @@ -343,7 +343,7 @@ chapter. You can see now that they are actually constructors of an algebraic data type.) -%% \item |m1 :=/ m2| is also a parallel composition of |m1| and |m2|, but +%% \item |m1 /=: m2| is also a parallel composition of |m1| and |m2|, but %% its duration is that of the shorter of |m1| and |m2|. \item |Modify cntrl m| is an ``annotated'' version of |m| in which the diff --git a/HSoM/Performance.lhs b/HSoM/Performance.lhs --- a/HSoM/Performance.lhs +++ b/HSoM/Performance.lhs @@ -378,7 +378,7 @@ \label{fig:real-perform} \end{figure} -%% m1 :=/ m2 -> +%% m1 /=: m2 -> %% let (pf1,d1) = perf pm c m1 %% (pf2,d2) = perf pm c m2 %% in (merge pf1 pf2, max d1 d2) diff --git a/HSoM/SigFuns.lhs b/HSoM/SigFuns.lhs --- a/HSoM/SigFuns.lhs +++ b/HSoM/SigFuns.lhs @@ -826,7 +826,7 @@ a (rather primitive) instrument: \begin{code} myInstr :: Instr (AudSF () Double) - -- |Dur -> AbsPitch -> Volume -> [Double] -> (AudSF () Double)| + typecomment(Dur -> AbsPitch -> Volume -> [Double] -> (AudSF () Double)) myInstr dur ap vol [vfrq,dep] = proc () -> do vib <- osc tab1 0 -< vfrq diff --git a/HSoM/SpectrumAnalysis.lhs b/HSoM/SpectrumAnalysis.lhs --- a/HSoM/SpectrumAnalysis.lhs +++ b/HSoM/SpectrumAnalysis.lhs @@ -908,7 +908,7 @@ fftEx :: UISF () () fftEx = proc _ -> do f <- hSlider (1, 2000) 440 -< () - (d,_) <- convertToUISF 100 simpleSig -< f + (d,_) <- clockedSFToUISF 100 simpleSig -< f let (s, fft) = unzip d _ <- histogram (500, 150) 20 -< listToMaybe (catMaybes fft) _ <- realtimeGraph' (500, 150) 200 20 Black -< s diff --git a/HSoM/ToMidi.lhs b/HSoM/ToMidi.lhs --- a/HSoM/ToMidi.lhs +++ b/HSoM/ToMidi.lhs @@ -557,7 +557,8 @@ \begin{code} defUpm :: UserPatchMap -defUpm = [(AcousticGrandPiano,1), +defUpm = [(AcousticGrandPiano,0), + (Marimba,1), (Vibraphone,2), (AcousticBass,3), (Flute,4), @@ -565,7 +566,7 @@ (AcousticGuitarSteel,6), (Viola,7), (StringEnsemble1,8), - (AcousticGrandPiano,9)] + (AcousticGrandPiano,9)] -- the GM name for drums is unimportant, only channel 9 \end{code} diff --git a/HSoM/myFormat.fmt b/HSoM/myFormat.fmt --- a/HSoM/myFormat.fmt +++ b/HSoM/myFormat.fmt @@ -1,3 +1,5 @@ +%if style /= newcode +%format typecomment(a) = "\texttt{--}\ " a %format bottom = "\bot" %format forall = "\forall" %format == = "==" @@ -26,6 +28,7 @@ %format =>> = "\mathbin{=\!\gg}" %format / = "\mathbin{\!/\!}" %format !++ = "\mathbin{\ +\!\!\!+}" +%format ~++ = "\mathbin{\sim\!\!\!+\!\!\!+}" %format -< = "\mathbin{-\!\!\!\prec}" %format >>> = "\mathbin{>\!\!\!>\!\!\!>}" %format <<< = "\mathbin{<\!\!\!<\!\!\!<}" @@ -102,6 +105,7 @@ %format b1 %format b2 %format b3 +%format b4 %format ma1 %format ma2 %format mb1 @@ -151,13 +155,15 @@ %format ui4 %format ui5 %format ui6 +%format ui'6 +%format ui''6 %format mui0 %format mui1 %format mui2 %format mui3 %format mui4 +%format mui'4 %format mui5 -%format mui'5 %format mui6 %format n1 %format n2 @@ -211,4 +217,13 @@ %format bell1 %format bell'1 %format bell2 +%format defaultMap0 +%format defaultMap1 +%format defaultMap2 +%format withColor' +%format cmd1 +%format cmd2 +%else +%format typecomment(a) = "-- " a +%endif diff --git a/ReadMe.txt b/ReadMe.txt --- a/ReadMe.txt +++ b/ReadMe.txt @@ -31,7 +31,7 @@ ==== Getting the Source ==== ============================ -Currently (2/8/2014), the most up-to-date version of Euterpea is +Currently (9/2/2015), the most up-to-date version of Euterpea is available through GitHub at: https://github.com/Euterpea/Euterpea @@ -46,8 +46,12 @@ ======= Installation ======= ============================ -Installing from source RECOMMENDED (updated 2/8/2014) +There is a stable version of Euterpea on Hackage, so one can easily +install Euterpea with: + cabal install euterpea +For the most up to date version, install from source: + 1) Clone the source from github git clone https://github.com/Euterpea/Euterpea @@ -78,31 +82,23 @@ --------- Mac OS X --------- -OS X is the least desirable platform on which to run Euterpea. In fact, -the latest release of OS X (Mavericks) has trouble with GHC in general. - -We, the maintainers, currently do not have a Mac to test with, and so we -have no exact instructions for how to set up GHC and Euterpea to get them -into a functioning condition. +Euterpea is known to work fine on OS X (including Mavericks) when used with +GHC 7.8.3 & Haskell Platform 2014.2.0.0 or later. -Once Euterpea is set up, you may require additional steps to get MIDI sound -output working. Download SimpleSynth and open it before you run ghci. It’s +Once Euterpea is set up, you may require additional steps to get MIDI sound +output working. Download SimpleSynth and open it before you run ghci. It’s a software MIDI synthesizer that plays MIDI output through the speaker. -Furthermore, you will have to use the ``EnableGUI trick'' to run GUI -programs for Euterpea. To do so, first compile EnableGUI.hs from the -Euterpea/Examples directory to binary: -ghc -c -fffi EnableGUI.hs -(Note: on some systems it is necessary to add the option -``-framework ApplicationServices'') -Then, run your Euterpea GUI programs in ghci like this: +With GHC 7.8.3 or later, to run the GUI examples in ghci reliably, you need +to start gchi with -fno-ghci-sandbox, or set it within ghci as follows: -ghci UIExamples.hs EnableGUI -*UIExamples> :m +EnableGUI -*UIExamples EnableGUI> enableGUI >> main + ghci -fno-ghci-sandbox + *: :set -fno-ghci-sandbox + *: :m + Euterpea.Examples.MUI + *: mui5 -With this, GHCi will be able to fully activate the Graphics Window. (Fully -compiled GUI programs do not suffer from this anomaly.) +With older versions of GHC, you may need the ``EnableGUI trick''. See +Euterpea/Examples/EnableGUI.hs for details. ------ Troubleshooting ----- @@ -183,5 +179,5 @@ Donya Quick , Dan Winograd-Cort -This file was last modified on 2/8/2014 +This file was last modified on 9/2/2015 by Daniel Winograd-Cort