hsc3-lang 0.11 → 0.12

raw patch · 19 files changed

+920/−280 lines, 19 filesdep +bytestringdep +hmatrix-specialdep +mtldep ~hoscdep ~hsc3PVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, hmatrix-special, mtl, transformers

Dependency ranges changed: hosc, hsc3

API changes (from Hackage documentation)

Files

• README +12/−9
• Sound/SC3/Lang/Collection.hs +66/−2
• Sound/SC3/Lang/Collection/Universal/Datum.hs +10/−39
• Sound/SC3/Lang/Control/Duration.hs +10/−8
• Sound/SC3/Lang/Control/Event.hs +82/−48
• Sound/SC3/Lang/Control/Instrument.hs +8/−2
• Sound/SC3/Lang/Control/Midi.hs +176/−0
• Sound/SC3/Lang/Control/OverlapTexture.hs +129/−84
• Sound/SC3/Lang/Control/Pitch.hs +4/−4
• Sound/SC3/Lang/Data/Modal.hs +46/−0
• Sound/SC3/Lang/Math.hs +23/−1
• Sound/SC3/Lang/Math/Warp.hs +101/−0
• Sound/SC3/Lang/Math/Window.hs +110/−0
• Sound/SC3/Lang/Pattern/ID.hs +59/−44
• Sound/SC3/Lang/Random/Gen.hs +3/−11
• Sound/SC3/Lang/Random/IO.hs +26/−19
• Sound/SC3/Lang/Random/Lorrain_1980.hs +36/−0
• Sound/SC3/Lang/Random/Monad.hs +2/−1
• hsc3-lang.cabal +17/−8

@@ -1,12 +1,15 @@-hsc3-lang - Haskell SuperCollider Language Library+hsc3-lang+--------- -hsc3-lang provides Sound.SC3.Lang, a Haskell module that-defines a subset of functions from the SuperCollider-class library.+[hsc3-lang][hsc3-lang] provides `Sound.SC3.Lang`, a [Haskell][hs]+module that defines a subset of functions from the [SuperCollider+Language][sc3] class library. -  http://slavepianos.org/rd/-  http://haskell.org/-  http://audiosynth.com/+© [rohan drape][rd], 2007-2012, [gpl][gpl]. -(c) rohan drape, 2007-2011-    gpl, http://gnu.org/copyleft/+[hs]: http://haskell.org/+[sc3]: http://audiosynth.com/+[hsc3]:  http://rd.slavepianos.org/?t=hsc3+[hsc3-lang]:  http://rd.slavepianos.org/?t=hsc3-lang+[rd]:  http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/

@@ -1,7 +1,6 @@ -- | In cases where a method takes arguments, these precede the -- collection argument in the haskell variant, so that @c.m(i,j)@ -- becomes @m i j c@.- module Sound.SC3.Lang.Collection where  import Data.List.Split {- split -}@@ -445,7 +444,7 @@ -- > [1,2,3,4,5,6,7,8].clump(3) == [[1,2,3],[4,5,6],[7,8]] -- > clump 3 [1,2,3,4,5,6,7,8] == [[1,2,3],[4,5,6],[7,8]] clump :: Int -> [a] -> [[a]]-clump = splitEvery+clump = chunksOf  -- | @SequenceableCollection.clumps@ is a synonym for -- 'Data.List.Split.splitPlaces'.@@ -563,3 +562,68 @@ -- > rotate 3 [1..5] == [3,4,5,1,2] rotate :: Int -> [a] -> [a] rotate n = if n < 0 then rotateLeft n else rotateRight n++-- | @ArrayedCollection.windex@ takes a list of probabilities, which+-- should sum to /n/, and returns the an index value given a (0,/n/)+-- input.+--+-- > mapMaybe (windex [0.1,0.3,0.6]) [0,0.1 .. 0.4] == [0,1,1,1,2]+windex :: (Ord a,Num a) => [a] -> a -> Maybe Int+windex w n = findIndex (n <) (integrate w)++-- * Signals & wavetables++-- | List of 2-tuples of elements at distance (stride) /n/.+--+-- > t2_window 3 [1..9] == [(1,2),(4,5),(7,8)]+t2_window :: Int -> [t] -> [(t,t)]+t2_window n x =+    case x of+      i:j:_ -> (i,j) : t2_window n (L.drop n x)+      _ -> []+++-- | List of 2-tuples of adjacent elements.+--+-- > t2_adjacent [1..6] == [(1,2),(3,4),(5,6)]+-- > t2_adjacent [1..5] == [(1,2),(3,4)]+t2_adjacent :: [t] -> [(t,t)]+t2_adjacent = t2_window 2++-- | List of 2-tuples of overlapping elements.+--+-- > t2_overlap [1..4] == [(1,2),(2,3),(3,4)]+t2_overlap :: [b] -> [(b,b)]+t2_overlap x = zip x (tail x)++-- | Concat of 2-tuples.+--+-- > t2_concat (t2_adjacent [1..6]) == [1..6]+-- > t2_concat (t2_overlap [1..4]) == [1,2,2,3,3,4]+t2_concat :: [(a,a)] -> [a]+t2_concat x =+    case x of+      [] -> []+      (i,j):x' -> i : j : t2_concat x'++-- | A Signal is half the size of a Wavetable, each element is the sum+-- of two adjacent elements of the Wavetable.+--+-- > from_wavetable [-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5] == [0.0,0.5,1.0,0.5]+-- > let s = [0,0.5,1,0.5] in from_wavetable (to_wavetable s) == s+from_wavetable :: Num n => [n] -> [n]+from_wavetable = map (uncurry (+)) . t2_adjacent++-- | A Wavetable is has /n * 2 + 2/ elements, where /n/ is the number+-- of elements of the Signal.  Each signal element /e0/ expands to the+-- two elements /(2 * e0 - e1, e1 - e0)/ where /e1/ is the next+-- element, or zero at the final element.  Properly wavetables are+-- only of power of two element signals.+--+-- > Signal[0,0.5,1,0.5].asWavetable == Wavetable[-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5]+--+-- > to_wavetable [0,0.5,1,0.5] == [-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5]+to_wavetable :: Num a => [a] -> [a]+to_wavetable =+    let f (e0,e1) = (2 * e0 - e1,e1 - e0)+    in t2_concat . map f . t2_overlap . (++ [0])

@@ -5,45 +5,14 @@ -- 'Floating', 'Real', 'RealFrac', 'Ord', 'Enum' and 'Random'. module Sound.SC3.Lang.Collection.Universal.Datum where -import Data.Maybe import Data.Ratio import GHC.Exts (IsString(..))-import Sound.OpenSoundControl.Type (Datum(..))+import Sound.OpenSoundControl.Type import System.Random  instance IsString Datum where     fromString = String --- | 'Datum' as real number if 'Double', 'Float' or 'Int', else 'Nothing'.------ > map datum_r [Int 5,Float 5,String "5"] == [Just 5,Just 5,Nothing]-datum_r :: Datum -> Maybe Double-datum_r d =-    case d of-      Double n -> Just n-      Float n -> Just n-      Int n -> Just (fromIntegral n)-      _ -> Nothing---- | A 'fromJust' variant of 'datum_r'.------ > map datum_r' [Int 5,Float 5] == [5,5]-datum_r' :: Datum -> Double-datum_r' = fromJust . datum_r---- | Extract 'String' from 'Datum', else 'Nothing'.------ > map datum_str [String "5",Int 5] == [Just "5",Nothing]-datum_str :: Datum -> Maybe String-datum_str d =-    case d of-      String s -> Just s-      _ -> Nothing---- | A 'fromJust' variant of 'datum_str'.-datum_str' :: Datum -> String-datum_str' = fromJust . datum_str- -- | Lift an equivalent set of 'Int' and 'Double' unary functions to -- 'Datum'. --@@ -91,7 +60,7 @@       (Int n1,Int n2) -> Int (fi n1 n2)       (Float n1,Float n2) -> Float (fd n1 n2)       (Double n1,Double n2) -> Double (fd n1 n2)-      _ -> case (datum_r d1,datum_r d2) of+      _ -> case (datum_real d1,datum_real d2) of              (Just n1,Just n2) -> Double (fd n1 n2)              _ -> error "datum_lift2" @@ -147,14 +116,16 @@           _ -> error "datum,real,partial"  instance RealFrac Datum where-  properFraction d = let (i,j) = properFraction (datum_r' d) in (i,Double j)-  truncate = truncate . datum_r'-  round = round . datum_r'-  ceiling = ceiling . datum_r'-  floor = floor . datum_r'+  properFraction d =+      let (i,j) = properFraction (datum_real_err d)+      in (i,Double j)+  truncate = truncate . datum_real_err+  round = round . datum_real_err+  ceiling = ceiling . datum_real_err+  floor = floor . datum_real_err  instance Ord Datum where-    p < q = case (datum_r p,datum_r q) of+    p < q = case (datum_real p,datum_real q) of               (Just i,Just j) -> i < j               _ -> error "datum,ord,partial" 

@@ -13,20 +13,22 @@              ,fwd' :: Maybe a -- ^ Possible non-sequential delta time field              } --- | Run 'delta_f' for 'Duration'.+-- | Run 'delta_f' for 'Duration'.  This is the interval from the+-- start of the current event to the start of the next event. -- -- > delta (defaultDuration {dur = 2,stretch = 2}) == 4 delta :: Duration a -> a delta d = delta_f d d --- | Run 'sustain_f' for 'Duration'.+-- | Run 'sustain_f' for 'Duration'.  This is the /sounding/ duration+-- of the event. -- -- > sustain defaultDuration == 0.8 sustain :: Duration a -> a sustain d = sustain_f d d --- | If 'fwd'' field is set at 'Duration' extract value, else--- calculate 'delta'.+-- | If 'fwd'' field is set at 'Duration' extract value and multiply+-- by 'stretch', else calculate 'delta'. -- -- > fwd (defaultDuration {fwd' = Just 0}) == 0 fwd :: Num a => Duration a -> a@@ -38,16 +40,16 @@ -- | The default 'delta_f' field for 'Duration'.  Equal to 'dur' '*' -- 'stretch' '*' (@60@ '/' 'tempo'). ----- > default_sustain_f (defaultDuration {legato = 1.2}) == 1.2+-- > default_delta_f (defaultDuration {legato = 1.2}) == 1.0 default_delta_f :: (Num a,Fractional a) => Duration a -> a default_delta_f d = dur d * stretch d * (60 / tempo d) --- | The default 'sustain_f' field for 'Duration'.  Equal to 'dur' '*'--- 'legato' '*' 'stretch' '*' (@60@ '/' 'tempo').+-- | The default 'sustain_f' field for 'Duration'.  This is equal to+-- 'delta' '*' 'legato'. -- -- > default_sustain_f (defaultDuration {legato = 1.2}) == 1.2 default_sustain_f :: (Num a,Fractional a) => Duration a -> a-default_sustain_f d = dur d * legato d * stretch d * (60 / tempo d)+default_sustain_f d = delta d * legato d  -- | Default 'Duration' value, equal to one second. --

@@ -16,7 +16,7 @@ type Value = Double  -- | The /type/ of an 'Event'.-type Type = String+data Type = E_s_new | E_n_set | E_rest deriving (Eq,Show)  -- | An 'Event' has a 'Type', possibly an integer identifier, possibly -- an 'I.Instrument' and a map of ('Key','Value') pairs.@@ -29,7 +29,7 @@ -- | The /default/ empty event. defaultEvent :: Event defaultEvent =-    Event {e_type = "unknown"+    Event {e_type = E_s_new           ,e_id = Nothing           ,e_instrument = Nothing           ,e_map = M.empty}@@ -98,13 +98,6 @@ insert :: Key -> Value -> Event -> Event insert k v e = e {e_map = M.insert k v (e_map e)} --- | The frequency of the 'pitch' of /e/.------ > freq (event [("degree",5)]) == 440--- > freq (event [("midinote",69)]) == 440-freq :: Event -> Double-freq = P.detunedFreq . pitch- -- | Lookup /db/ field of 'Event', the default value is @-20db@. db :: Event -> Value db = lookup_v (-20) "db"@@ -125,21 +118,31 @@ fwd :: Event -> Double fwd = D.fwd . duration --- | The /sustain/ value of the duration model at /e/.------ > sustain (event [("dur",1),("legato",0.5)]) == 0.5-sustain :: Event -> Double-sustain = D.sustain . duration+-- | The /latency/ to compensate for when sending messages based on+-- the event.  Defaults to @0.1@.+latency :: Event -> Double+latency = lookup_v 0.1 "latency" --- | List of reserved /keys/ for pitch, duration and amplitude models.+-- | List of 'Key's used in pitch, duration and amplitude models. ----- > ("degree" `elem` reserved) == True-reserved :: [Key]-reserved =+-- > ("degree" `elem` model_keys) == True+model_keys :: [Key]+model_keys =     ["amp","db"     ,"delta","dur","legato","fwd'","stretch","sustain","tempo"-    ,"ctranspose","degree","freq","midinote","mtranspose","note","octave"]+    ,"ctranspose","degree","freq","midinote","mtranspose","note","octave"+    ,"rest"] +-- | List of reserved 'Key's used in pitch, duration and amplitude+-- models.  These are keys that may be provided explicitly, but if not+-- will be calculated implicitly.+--+-- > ("freq" `elem` reserved) == True+reserved :: [Key]+reserved = ["freq","midinote","note"+           ,"delta","sustain"+           ,"amp"]+ -- | If 'Key' is 'reserved' then 'Nothing', else 'id'. parameters' :: (Key,Value) -> Maybe (Key,Value) parameters' (k,v) =@@ -179,7 +182,7 @@ -- > lookup_m "k" (event [("k",1)]) == Just 1 event :: [(Key,Value)] -> Event event l =-    Event {e_type = "s_new"+    Event {e_type = E_s_new           ,e_id = Nothing           ,e_instrument = Nothing           ,e_map = M.fromList l}@@ -189,17 +192,24 @@ instrument_name e =     case e_instrument e of       Nothing -> "default"-      Just (I.InstrumentDef s) -> S.synthdefName s-      Just (I.InstrumentName s) -> s+      Just (I.InstrumentDef s _) -> S.synthdefName s+      Just (I.InstrumentName s _) -> s  -- | Extract 'I.Instrument' definition from 'Event' if present. instrument_def :: Event -> Maybe S.Synthdef instrument_def e =     case e_instrument e of       Nothing -> Nothing-      Just (I.InstrumentDef s) -> Just s-      Just (I.InstrumentName _) -> Nothing+      Just (I.InstrumentDef s _) -> Just s+      Just (I.InstrumentName _ _) -> Nothing +-- | 'I.send_release' of 'I.Instrument' at 'Event'.+instrument_send_release :: Event -> Bool+instrument_send_release e =+    case e_instrument e of+      Nothing -> True+      Just i -> I.send_release i+ -- | Merge two sorted sequence of (/location/,/value/) pairs. -- -- > let m = f_merge (zip [0,2..6] ['a'..]) (zip [0,3,6] ['A'..])@@ -237,31 +247,55 @@ merge :: (Time,[Event]) -> (Time,[Event]) -> [Event] merge p q = add_fwd (merge' p q) --- | Generate @SC3@ 'O.OSC' messages describing 'Event'.  If the--- 'Event' 'Type' has a @_p@ suffix, where @p@ stands for /persist/,--- this does not generate a gate command.-to_sc3_osc :: Time -> Int -> Event -> Maybe (O.OSC,O.OSC)-to_sc3_osc t j e =+-- | Does 'Event' have a non-zero @rest@ key.+is_rest :: Event -> Bool+is_rest e =+    case lookup_m "rest" e of+      Just r -> r > 0+      Nothing -> False++-- | Generate @SC3@ 'O.Bundle' messages describing 'Event'.  Consults the+-- 'instrument_send_release' in relation to gate command.+to_sc3_bundle :: Time -> Int -> Event -> Maybe (O.Bundle,O.Bundle)+to_sc3_bundle t j e =     let s = instrument_name e-        rt = sustain e {- rt = release time -}-        f = freq e-        pr = ("freq",f) : ("amp",amp e) : ("sustain",rt) : parameters e+        sr = instrument_send_release e+        p = pitch e+        d = duration e+        rt = D.sustain d {- rt = release time -}+        f = P.detunedFreq p+        pr = ("freq",f) : ("midinote",P.midinote p) : ("note",P.note p) :+             ("delta",D.delta d) : ("sustain",rt) :+             ("amp",amp e) :+             parameters e         i = fromMaybe j (e_id e)-    in if isNaN f+        t' = t + latency e+    in if is_rest e || isNaN f        then Nothing        else let m_on = case e_type e of-                         "s_new" -> [S.s_new s i S.AddToTail 1 pr]-                         "s_new_p" -> [S.s_new s i S.AddToTail 1 pr]-                         "n_set" -> [S.n_set i pr]-                         "n_set_p" -> [S.n_set i pr]-                         "rest" -> []-                         _ -> error "to_sc3_osc:m_on:type"-                m_off = case e_type e of-                         "s_new" -> [S.n_set i [("gate",0)]]-                         "s_new_p" -> []-                         "n_set" -> [S.n_set i [("gate",0)]]-                         "n_set_p" -> []-                         "rest" -> []-                         _ -> error "to_sc3_osc:m_off:type"-            in Just (O.Bundle (O.UTCr t) m_on-                    ,O.Bundle (O.UTCr (t+rt)) m_off)+                         E_s_new -> [S.s_new s i S.AddToTail 1 pr]+                         E_n_set -> [S.n_set i pr]+                         E_rest -> []+                m_off = if not sr+                        then []+                        else case e_type e of+                               E_s_new -> [S.n_set i [("gate",0)]]+                               E_n_set -> [S.n_set i [("gate",0)]]+                               E_rest -> []+            in Just (O.Bundle (O.UTCr t') m_on+                    ,O.Bundle (O.UTCr (t' + rt)) m_off)++{-+-- | The frequency of the 'pitch' of /e/.+--+-- > freq (event [("degree",5)]) == 440+-- > freq (event [("midinote",69)]) == 440+freq :: Event -> Double+freq = P.detunedFreq . pitch++-- | The /sustain/ value of the duration model at /e/.+--+-- > sustain (event [("dur",1),("legato",0.5)]) == 0.5+sustain :: Event -> Double+sustain = D.sustain . duration+-}

@@ -5,8 +5,10 @@  -- | An 'Instrument' is either a 'Synthdef' or the 'String' naming a -- 'Synthdef'.-data Instrument = InstrumentDef Synthdef-                | InstrumentName String+data Instrument = InstrumentDef {instrument_def :: Synthdef+                                ,send_release :: Bool}+                | InstrumentName {instrument_name :: String+                                 ,send_release :: Bool}                   deriving (Eq,Show)  -- | The SC3 /default/ instrument 'Synthdef'.@@ -21,3 +23,7 @@         l = xLine KR (rand 'c' 4000 5000) (rand 'd' 2500 3200) 1 DoNothing         z = lpf (mix (varSaw AR f3 0 0.3 * 0.3)) l * e     in synthdef "default" (out 0 (pan2 z p a))++{-+withSC3 (\fd -> async fd (d_recv defaultInstrument))+-}

@@ -0,0 +1,176 @@+{-# LANGUAGE PackageImports #-}+-- | For a single input controller, key events always arrive in+-- sequence (ie. on->off), ie. for any key on message can allocate an+-- ID and associate it with the key, an off message can retrieve the+-- ID given the key.+module Sound.SC3.Lang.Control.Midi where++import qualified Control.Exception as E+import Control.Monad+import "mtl" Control.Monad.State+import Data.Bits+import qualified Data.ByteString.Lazy as B {- bytestring -}+import qualified Data.Map as M {- containers -}+import Sound.OSC.FD {- hosc -}++-- | <http://www.midi.org/techspecs/midimessages.php>+data Midi_Message a = Chanel_Aftertouch a a+                    | Control_Change a a a+                    | Note_On a a a+                    | Note_Off a a a+                    | Polyphic_Key_Pressure a a a+                    | Program_Change a a+                    | Pitch_Bend a a+                    | Unknown [a]+                      deriving (Eq,Show)++-- | 'Control_Change' midi messages have, in some cases, commonly+-- defined meanings.+data Control_Message a = All_Notes_Off a+                       | All_Sound_Off a+                       | Balance a a+                       | Bank_Select a a+                       | Breath_Controller a a+                       | Expression_Controller a a+                       | Foot_Controller a a+                       | Local_Control a a+                       | Modulation_Wheel a a+                       | Mono_Mode_On a a+                       | Omni_Mode_Off a+                       | Omni_Mode_On a+                       | Pan a a+                       | Poly_Mode_On a+                       | Portamento_On_Off a a+                       | Portamento_Time a a+                       | Reset_All_Controllers a a+                       | Soft_Pedal_On_Off a a+                       | Sostenuto_On_Off a a+                       | Sustain_On_Off a a+                       | Undefined+                         deriving (Eq,Show)++-- | 'Control_Change' midi messages may, in some cases, have commonly+-- defined meanings.+--+-- > control_message (0,123,0) == All_Notes_Off 0+control_message :: (Eq a,Num a) => (a,a,a) -> Control_Message a+control_message (i,j,k) =+    case j of+      0 -> Bank_Select i k+      1 -> Modulation_Wheel i k+      2 -> Breath_Controller i k+      4 -> Foot_Controller i k+      5 -> Portamento_Time i k+      8 -> Balance i k+      10 -> Pan i k+      11 -> Expression_Controller i k+      64 -> Sustain_On_Off i k+      65 -> Portamento_On_Off i k+      66 -> Sostenuto_On_Off i k+      67 -> Soft_Pedal_On_Off i k+      120 -> All_Sound_Off i+      121 -> Reset_All_Controllers i k+      122 -> Local_Control i j+      123 -> All_Notes_Off i+      124 -> Omni_Mode_Off i+      125 -> Omni_Mode_On i+      126 -> Mono_Mode_On i j+      127 -> Poly_Mode_On i+      _ -> Undefined++-- | Join two 7-bit values into a 14-bit value.+--+-- > map (uncurry b_join) [(0,0),(0,64),(127,127)] == [0,8192,16383]+b_join :: Bits a => a -> a -> a+b_join p q = p .|. shiftL q 7++-- | Inverse of 'b_join'.+--+-- > map b_sep [0,8192,16383] == [(0,0),(0,64),(127,127)]+b_sep :: (Num t,Bits t) => t -> (t, t)+b_sep n = (0x7f .&. n,0xff .&. shiftR n 7)++-- | Parse @midi-osc@ @/midi/@ message.+parse_b :: Integral n => Message -> [n]+parse_b m =+    case m of+      Message "/midi" [Int _,Blob b] -> map fromIntegral (B.unpack b)+      _ -> []++-- | Variant of 'parse_b' that give status byte as low and high.+parse_c :: Integral n => Message -> [n]+parse_c m =+    case parse_b m of+      st:dt -> let (l,h) = st `divMod` 16 in l:h:dt+      _ -> []++-- | Variant of 'parse_c' that constructs a 'Midi_Message'.+parse_m :: (Bits n,Integral n) => Message -> Midi_Message n+parse_m m =+    case parse_c m of+      [0x8,i,j,k] -> Note_Off i j k+      [0x9,i,j,0] -> Note_Off i j 0+      [0x9,i,j,k] -> Note_On i j k+      [0xa,i,j,k] -> Polyphic_Key_Pressure i j k+      [0xb,i,j,k] -> Control_Change i j k+      [0xc,i,j] -> Program_Change i j+      [0xd,i,j] -> Chanel_Aftertouch i j+      [0xe,i,j,k] -> Pitch_Bend i (b_join j k)+      x -> Unknown x++-- | @SC3@ node identifiers are integers.+type Node_Id = Int++-- | Map of allocated 'Node_Id's.+data K a = K (M.Map (a,a) Node_Id) Node_Id++-- | 'StateT' of 'K' specialised to 'Int'.+type KT = StateT (K Int) IO++-- | Initialise 'K' with starting 'Node_Id'.+k_init :: Node_Id -> K a+k_init = K M.empty++-- | 'K' 'Node_Id' allocator.+k_alloc :: (Int,Int) -> KT Node_Id+k_alloc n = do+  (K m i) <- get+  put (K (M.insert n i m) (i + 1))+  return i++-- | 'K' 'Node_Id' retrieval.+k_get :: (Int,Int) -> KT Node_Id+k_get n = do+  (K m _) <- get+  return (m M.! n)++-- | The 'Midi_Receiver' is passed a 'Midi_Message' and a 'Node_Id'.+-- For 'Note_On' and 'Note_Off' messages the 'Node_Id' is positive,+-- for all other message it is @-1@.+type Midi_Receiver m n = Midi_Message n -> Int -> m ()++-- | Parse incoming midi messages, do 'K' allocation, and run+-- 'Midi_Receiver'.+midi_act :: Midi_Receiver IO Int -> Message -> StateT (K Int) IO ()+midi_act f o = do+    let m = parse_m o+    n <- case m of+           Note_Off ch k _ -> k_get (ch,k)+           Note_On ch k _ -> k_alloc (ch,k)+           _ -> return (-1)+    liftIO (f m n)++-- | Run midi system, handles 'E.AsyncException's.+start_midi :: (UDP -> Midi_Receiver IO Int) -> IO ()+start_midi receiver = do+  s_fd <- openUDP "127.0.0.1" 57110 -- midi-osc+  m_fd <- openUDP "127.0.0.1" 57150 -- midi-osc+  sendMessage m_fd (Message "/receive" [Int 0xffff])+  let step = liftIO (recvMessages m_fd) >>=+             midi_act (receiver s_fd) . head+      ex e = print ("start_midi",show (e::E.AsyncException)) >>+             close m_fd >>+             close s_fd+      runs = void (runStateT (forever step) (k_init 1000))+  E.catch runs ex+  return ()

@@ -1,51 +1,77 @@ -- | @SC2@ @OverlapTexture@ related functions.+--+-- Generate sequences of overlapping instances of a 'UGen' graph or+-- family of graphs.  The 'OverlapTexture' functions add an 'Envelope'+-- and calculate inter-onset times and durations.  There are variants+-- for different graph constructors, and to allow for a+-- post-processing stage. module Sound.SC3.Lang.Control.OverlapTexture where  import Data.List-import Sound.OpenSoundControl-import Sound.SC3-import Sound.SC3.Lang.Control.Event as E+import Sound.OSC {- hosc -}+import Sound.SC3 {- hsc3 -}+import Sound.SC3.Lang.Control.Event as E {- hsc3-lang -} import Sound.SC3.Lang.Control.Instrument import Sound.SC3.Lang.Pattern.ID  -- | Make an 'envGen' 'UGen' with 'envLinen'' structure with given--- /attack/\//delay/ and /sustain/ times.+-- /sustain/ and /transition/ times. mk_env :: UGen -> UGen -> UGen-mk_env a s =+mk_env s t =     let c = EnvNum 4-        p = envLinen' a s a 1 (c,c,c)+        p = envLinen' t s t 1 (c,c,c)     in envGen KR 1 1 0 1 RemoveSynth p  -- | Apply 'mk_env' envelope to input signal and write to output bus @0@.-with_env' :: UGen -> UGen -> UGen -> UGen-with_env' g a = out 0 . (*) g . mk_env a+with_env_u :: UGen -> UGen -> UGen -> UGen+with_env_u g a = out 0 . (*) g . mk_env a --- | Variant of 'with_env'' where envelope parameters are lifted from+-- | Variant of 'with_env_u' where envelope parameters are lifted from -- 'Double' to 'UGen'. with_env :: (Double,Double) -> UGen -> UGen-with_env (a,s) g = with_env' g (constant a) (constant s)+with_env (s,t) g = with_env_u g (constant s) (constant t)  -- | Control parameters for 'overlapTextureU' and related functions.+-- Components are: 1. sustain time, 2. transition time, 3. number of+-- overlaping (simultaneous) nodes and 4. number of nodes altogether. type OverlapTexture = (Double,Double,Double,Int) --- | Extract envelope parameters for 'with_env' from 'OverlapTexture'.+data OverlapTexture_ =+    OverlapTexture {sustain_time :: Double+                   ,transition_time :: Double+                   ,overlaps :: Double+                   ,max_repeats :: Int}++-- | Extract envelope parameters (sustain and transition times) for+-- 'with_env' from 'OverlapTexture'. overlapTexture_env :: OverlapTexture -> (Double,Double)-overlapTexture_env (a,s,_,_) = (a,s)+overlapTexture_env (s,t,_,_) = (s,t) --- | Extract /duration/ and /legato/ paramaters from 'OverlapTexture'.-overlapTexture_dt :: OverlapTexture -> (Double,Double)-overlapTexture_dt (a,s,o,_) = ((a + s + a) / o,o)+-- | (/legato/,/duration/) parameters. The /duration/ is the+-- inter-offset time, /legato/ is the scalar giving the sounding time+-- in relation to the inter-offset time.+type Texture_DT = (Double,Double) +-- | Extract /legato/ (duration of sound proportional to inter-offset+-- time) and /duration/ (inter-offset time) parameters from+-- 'OverlapTexture'.+--+-- > overlapTexture_dt (3,1,5,maxBound) == (5,1)+overlapTexture_dt :: OverlapTexture -> Texture_DT+overlapTexture_dt (s,t,o,_) = (o,(t + s + t) / o)+ -- | Control parameters for 'xfadeTextureU' and related functions.+-- Components are: 1. sustain time, 2. transition time, 3. number of+-- nodes instatiated altogether. type XFadeTexture = (Double,Double,Int)  -- | Extract envelope parameters for 'with_env' from 'XFadeTexture'. xfadeTexture_env :: XFadeTexture -> (Double,Double)-xfadeTexture_env (a,s,_) = (a,s)+xfadeTexture_env (s,t,_) = (s,t) --- | Extract /duration/ and /legato/ paramaters from 'XFadeTexture'.-xfadeTexture_dt :: XFadeTexture -> (Double,Double)-xfadeTexture_dt (a,s,_) = let dt = a + s in (dt,(dt + a) / dt)+-- | Extract /legato/ and /duration/ paramaters from 'XFadeTexture'.+xfadeTexture_dt :: XFadeTexture -> Texture_DT+xfadeTexture_dt (s,t,_) = let r = t + s in ((r + t) / r,r)  -- | Generate 'Synthdef' from envelope parameters for 'with_env' and -- a continuous signal.@@ -57,17 +83,24 @@  -- | Generate an 'Event' pattern from 'OverlapTexture' control -- parameters and a continuous signal.-overlapTextureU' :: OverlapTexture -> UGen -> P Event-overlapTextureU' k g =+overlapTextureP :: OverlapTexture -> UGen -> P Event+overlapTextureP k g =     let s = gen_synth (overlapTexture_env k) g-        (d,l) = overlapTexture_dt k+        (l,d) = overlapTexture_dt k         (_,_,_,c) = k-        i = return (InstrumentDef s)+        i = return (InstrumentDef s False)     in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)]) --- | Audition pattern given by 'overlapTextureU''.+-- | Audition pattern given by 'overlapTextureP'.+--+-- > import Sound.SC3.ID+-- > import Sound.SC3.Lang.Control.OverlapTexture+-- >+-- > let {o = sinOsc AR (rand 'α' 440 880) 0+-- >     ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)}+-- > in overlapTextureU (3,1,6,9) u overlapTextureU :: OverlapTexture -> UGen -> IO ()-overlapTextureU k = audition . overlapTextureU' k+overlapTextureU k = audition . overlapTextureP k  -- | Generate 'Synthdef' from a signal processing function over the -- indicated number of channels.@@ -79,93 +112,105 @@     in synthdef nm u  -- | Audition 'Event' pattern with specified post-processing function.-post_process_a :: Transport t =>-                  t -> P Event -> Int -> (UGen -> UGen) -> IO ()-post_process_a fd p nc f = do+post_process_a :: Transport m => P Event -> Int -> (UGen -> UGen) -> m ()+post_process_a p nc f = do   let s = post_process_s nc f-  _ <- async fd (d_recv s)-  send fd (s_new (synthdefName s) (-1) AddToTail 2 [])-  play fd p+  _ <- async (d_recv s)+  send (s_new (synthdefName s) (-1) AddToTail 2 [])+  play p +-- | Post processing function.+type PPF = (UGen -> UGen)+ -- | Variant of 'overlapTextureU' with post-processing stage.-overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> (UGen -> UGen) -> IO ()+overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> PPF -> IO () overlapTextureU_pp k u nc f = do-  let p = overlapTextureU' k u-  withSC3 (\fd -> post_process_a fd p nc f)+  let p = overlapTextureP k u+  withSC3 (post_process_a p nc f)  -- | Generate an 'Event' pattern from 'XFadeTexture' control -- parameters and a continuous signal.-xfadeTextureU' :: XFadeTexture -> UGen -> P Event-xfadeTextureU' k g =+xfadeTextureP :: XFadeTexture -> UGen -> P Event+xfadeTextureP k g =     let s = gen_synth (xfadeTexture_env k) g-        (d,l) = xfadeTexture_dt k+        (l,d) = xfadeTexture_dt k         (_,_,c) = k-        i = return (InstrumentDef s)+        i = return (InstrumentDef s False)     in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)]) --- | Audition pattern given by 'xfadeTextureU''.+-- | Audition pattern given by 'xfadeTextureP'.+--+-- > let {o = sinOsc AR (rand 'α' 440 880) 0+-- >     ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)}+-- > in xfadeTextureU (1,3,6) u xfadeTextureU :: XFadeTexture -> UGen -> IO ()-xfadeTextureU k = audition . xfadeTextureU' k+xfadeTextureU k = audition . xfadeTextureP k  -- | Variant of 'xfadeTextureU' with post-processing stage.-xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> (UGen -> UGen) -> IO ()+xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> PPF -> IO () xfadeTextureU_pp k u nc f = do-  let p = xfadeTextureU' k u-  withSC3 (\fd -> post_process_a fd p nc f)+  let p = xfadeTextureP k u+  withSC3 (post_process_a p nc f) --- | Variant of 'overlapTextureU'' where the continuous signal for+-- | UGen generating state transform function.+type USTF st = (st -> (UGen,st))++-- | Variant of 'overlapTextureP' where the continuous signal for -- each 'Event' is derived from a state transform function seeded with -- given initial state.-overlapTextureS' :: OverlapTexture -> (st -> (UGen,st)) -> st -> P Event-overlapTextureS' k u i_st =-    let (d,l) = overlapTexture_dt k+overlapTextureP_st :: OverlapTexture -> USTF st -> st -> P Event+overlapTextureP_st k u i_st =+    let (l,d) = overlapTexture_dt k         (_,_,_,c) = k         g = take c (unfoldr (Just . u) i_st)-        s = map (InstrumentDef . gen_synth (overlapTexture_env k)) g+        i = flip InstrumentDef False+        s = map (i . gen_synth (overlapTexture_env k)) g     in pinstr (fromList s) (pbind [("dur",prepeat d),("legato",prepeat l)]) --- | Audition pattern given by 'overlapTextureS''.-overlapTextureS :: OverlapTexture -> (st -> (UGen,st)) -> st -> IO ()-overlapTextureS k u = audition . overlapTextureS' k u+-- | Audition pattern given by 'overlapTextureP_st'.+overlapTextureS :: OverlapTexture -> USTF st -> st -> IO ()+overlapTextureS k u = audition . overlapTextureP_st k u  -- | Variant of 'overlapTextureS' with post-processing stage.-overlapTextureS_pp :: OverlapTexture -> (st -> (UGen,st)) -> st -> Int -> (UGen -> UGen) -> IO ()+overlapTextureS_pp :: OverlapTexture -> USTF st -> st -> Int -> PPF  -> IO () overlapTextureS_pp k u i_st nc f = do-  let p = overlapTextureS' k u i_st-  withSC3 (\fd -> post_process_a fd p nc f)+  let p = overlapTextureP_st k u i_st+  withSC3 (post_process_a p nc f) --- | Run a state transforming function /f/ that also operates with a--- delta 'E.Time' indicating the duration to pause before re-running--- the function.-at' :: st -> Double -> ((st,E.Time) -> IO (Maybe (st,E.Time))) -> IO ()-at' st t f = do-  r <- f (st,t)-  case r of-    Just (st',t') -> do pauseThreadUntil (t + t')-                        at' st' (t + t') f-    Nothing -> return ()+-- | Monadic state transform function.+type MSTF st m = (st -> m (Maybe st)) --- | Variant of 'at'' that pauses until initial 'E.Time'.-at :: st -> E.Time -> ((st,E.Time) -> IO (Maybe (st,E.Time))) -> IO ()-at st t f = do-  pauseThreadUntil t-  _ <- at' st t f-  return ()+-- | Run a monadic state transforming function /f/ that operates with+-- a delta 'E.Time' indicating the duration to pause before re-running+-- the function.+dt_rescheduler_m :: MonadIO m => MSTF (st,E.Time) m -> (st,E.Time) -> m ()+dt_rescheduler_m f =+    let rec (st,t) = do+          pauseThreadUntil t+          r <- f (st,t)+          case r of+            Just (st',dt) -> rec (st',t + dt)+            Nothing -> return ()+    in rec  -- | Underlying function of 'overlapTextureM' with explicit 'Transport'.-overlapTextureM' :: Transport t => t -> OverlapTexture -> IO UGen -> IO ()-overlapTextureM' fd k u = do-  t <- utcr-  let n = "ot_" ++ show t-      (dt,_) = overlapTexture_dt k-      (_,_,_,c) = k-      f (st,_) = do g <- u-                    let g' = with_env (overlapTexture_env k) g-                    _ <- async fd (d_recv (synthdef n g'))-                    send fd (s_new n (-1) AddToTail 1 [])-                    if st == 0 then return Nothing else return (Just (st-1,dt))-  at c t f+overlapTextureR :: Transport m => OverlapTexture -> IO UGen -> MSTF (Int,E.Time) m+overlapTextureR k uf =+  let nm = "ot_" ++ show k+      (_,dt) = overlapTexture_dt k+  in \(st,_) -> do+        u <- liftIO uf+        let g = with_env (overlapTexture_env k) u+        _ <- async (d_recv (synthdef nm g))+        send (s_new nm (-1) AddToTail 1 [])+        case st of+          0 -> return Nothing+          _ -> return (Just (st-1,dt)) --- | Variant of 'overlapTextureU' where the continuous signal is in the 'IO' monad.+-- | Variant of 'overlapTextureU' where the continuous signal is in+-- the 'IO' monad. overlapTextureM :: OverlapTexture -> IO UGen -> IO ()-overlapTextureM k u = withSC3 (\fd -> overlapTextureM' fd k u)+overlapTextureM k u = do+  t <- utcr+  let (_,_,_,c) = k+  withSC3 (dt_rescheduler_m (overlapTextureR k u) (c,t))

@@ -99,13 +99,13 @@ default_note_f :: (RealFrac a) => Pitch a -> a default_note_f e =     let d = degree e + mtranspose e-    in degree_to_key d (scale e) (stepsPerOctave e)+    in degree_to_key (scale e) (stepsPerOctave e) d  -- | Translate degree, scale and steps per octave to key. ----- > degree_to_key 5 [0,2,4,5,7,9,11] 12 == 9-degree_to_key :: (RealFrac a) => a -> [a] -> a -> a-degree_to_key d s n =+-- > degree_to_key [0,2,4,5,7,9,11] 12 5 == 9+degree_to_key :: (RealFrac a) => [a] -> a -> a -> a+degree_to_key s n d =     let l = length s         d' = round d         a = (d - fromIntegral d') * 10.0 * (n / 12.0)

@@ -0,0 +1,46 @@+-- | <http://www.csounds.com/manual/html/MiscModalFreq.html>+module Sound.SC3.Lang.Data.Modal where++-- | Table of modal frequency ratios for specified sound sources.+--+-- > import Sound.SC3+--+-- > let {f = 221+-- >     ;Just r = lookup "Tibetan bowl (180mm)" modal_frequency_ratios+-- >     ;u n = replicate (length r) n+-- >     ;k = klankSpec (map (* f) r) (u 1) (u 16)}+-- > in audition (out 0 (klank (impulse AR 0.125 0 * 0.1) 1 0 1 k))+modal_frequency_ratios :: Fractional n => [(String,[n])]+modal_frequency_ratios =+    [("Dahina tabla",[1,2.89,4.95,6.99,8.01,9.02])+    ,("Bayan tabla",[1,2.0,3.01,4.01,4.69,5.63])+    ,("Red Cedar wood plate",[1,1.47,2.09,2.56])+    ,("Redwood wood plate",[1,1.47,2.11,2.57])+    ,("Douglas Fir wood plate",[1,1.42,2.11,2.47])+    ,("Uniform wooden bar",[1,2.572,4.644,6.984,9.723,12])+    ,("Uniform aluminum bar",[1,2.756,5.423,8.988,13.448,18.680])+    ,("Xylophone",[1,3.932,9.538,16.688,24.566,31.147])+    ,("Vibraphone 1",[1,3.984,10.668,17.979,23.679,33.642])+    ,("Vibraphone 2",[1,3.997,9.469,15.566,20.863,29.440])+    ,("Chalandi plates",[1,1.72581,5.80645,7.41935,13.91935])+    ,("Tibetan bowl (180mm)",[1,2.77828,5.18099,8.16289,11.66063,15.63801,19.99])+    ,("Tibetan bowl (152mm)",[1,2.66242,4.83757,7.51592,10.64012,14.21019,18.14027])+    ,("Tibetan bowl (140mm)",[1,2.76515,5.12121,7.80681,10.78409])+    ,("Wine Glass",[1,2.32,4.25,6.63,9.38])+    ,("Small handbell",[1,1.0019054878049,1.7936737804878,1.8009908536585,2.5201981707317,2.5224085365854,2.9907012195122,2.9940548780488,3.7855182926829,3.8061737804878,4.5689024390244,4.5754573170732,5.0296493902439,5.0455030487805,6.0759908536585,5.9094512195122,6.4124237804878,6.4430640243902,7.0826219512195,7.0923780487805,7.3188262195122,7.5551829268293])+    ,("Spinel sphere (diameter=3.6675mm)",[1,1.026513174725,1.4224916858532,1.4478690202098,1.4661959580455,1.499452545408,1.7891839345101,1.8768994627782,1.9645945254541,1.9786543873113,2.0334612432847,2.1452852391916,2.1561524686621,2.2533435661294,2.2905090816065,2.3331798413917,0,2.4567715528268,2.4925556408289,2.5661806088514,2.6055768738808,2.6692760296751,2.7140956766436,2.7543617293425,2.7710411870043])+    ,("Pot lid",[1,3.2,6.23,6.27,9.92,14.15])]++-- | Table of modal frequencies for subset of 'modal_frequency_ratios'.+modal_frequencies :: Fractional n => [(String,[n])]+modal_frequencies =+    [("Chalandi plates",[62,107,360,460,863])+    ,("Tibetan bowl (180mm)",[221,614,1145,1804,2577,3456,4419])+    ,("Tibetan bowl (152mm)",[314,836,1519,2360,3341,4462,5696])+    ,("Tibetan bowl (140mm)",[528,1460,2704,4122,5694])+    ,("Small handbell",[1312.0,1314.5,2353.3,2362.9,3306.5,3309.4,3923.8,3928.2,4966.6,4993.7,5994.4,6003.0,6598.9,6619.7,7971.7,7753.2,8413.1,8453.3,9292.4,9305.2,9602.3,9912.4])+    ,("Spinel sphere (diameter=3.6675mm)",[977.25,1003.16,1390.13,1414.93,1432.84,1465.34,1748.48,1834.20,1919.90,1933.64,1987.20,2096.48,2107.10,2202.08,2238.40,2280.10,0 {- 2290.53 calculated -},2400.88,2435.85,2507.80,2546.30,2608.55,2652.35,2691.70,2708.00])]++-- Local Variables:+-- truncate-lines:t+-- End:

@@ -19,7 +19,7 @@ -- -- > parseBits "101" == 5 -- > parseBits "00001111" == 15-parseBits :: Bits a => String -> a+parseBits :: (Num a,Bits a) => String -> a parseBits x =     let x' = filter (id . bitChar . snd) (zip [0..] (reverse x))     in foldr ((.|.) . bit . fst) 0 x'@@ -55,3 +55,25 @@     else if n >= r          then r'          else ((r'/l') ** ((n-l)/(r-l))) * l'++-- * Gain++-- | Synonym for 'logBase' @10@.+log10 :: Floating a => a -> a+log10 = logBase 10++-- > map rmsToDb [1,0.75,0.5,0.25,0]+rmsToDb :: Floating a => a -> a+rmsToDb rms = log10 rms * 20++-- > map dbToRms [0,-3,-6,-9,-12]+dbToRms :: Floating a => a -> a+dbToRms db  = 10 ** (db  * 0.05)++-- > map powToDb [1,0.75,0.5,0.25,0]+powToDb :: Floating a => a -> a+powToDb pow = 10 * log10 pow++-- > map dbToPow [0,-3,-6,-9,-12]+dbToPow :: Floating a => a -> a+dbToPow db  = 10 ** (db * 0.1)

@@ -0,0 +1,101 @@+-- | A /warp/ is a mapping from the space @[0,1]@ to a user defined+-- space /[l,r]/.+module Sound.SC3.Lang.Math.Warp where++import Sound.SC3.Lang.Math++-- | Warp direction.  'W_Map' is forward, 'W_Unmap' is reverse.+data W_Direction = W_Map | W_Unmap+                   deriving (Eq,Enum,Bounded,Show)++-- | Warp type+type Warp t = W_Direction -> t -> t++-- | Forward warp.+w_map :: Warp t -> t -> t+w_map w = w W_Map++-- | Reverse warp.+w_unmap :: Warp t -> t -> t+w_unmap w = w W_Unmap++-- | A linear real value map.+--+-- > w = LinearWarp(ControlSpec(1,2))+-- > [0,0.5,1].collect{|n| w.map(n)} == [1,1.5,2]+--+-- > map (w_map (warpLinear 1 2)) [0,1/2,1] == [1,3/2,2]+-- > map (warpLinear (-1) 1 W_Map) [0,1/2,1] == [-1,0,1]+warpLinear :: (Fractional a) => a -> a -> Warp a+warpLinear l r d n =+    let z = r - l+    in if d == W_Map+       then n * z + l+       else (n - l) / z++-- | The left and right must both be non zero and have the same sign.+--+-- > w = ExponentialWarp(ControlSpec(1,2))+-- > [0,0.5,1].collect{|n| w.map(n)} == [1,pow(2,0.5),2]+--+-- > map (warpExponential 1 2 W_Map) [0,0.5,1] == [1,2 ** 0.5,2]+warpExponential :: (Floating a) => a -> a -> Warp a+warpExponential l r d n =+    let z = r / l+    in if d == W_Map+       then (z ** n) * l+       else logBase z (n / l)++-- | Cosine warp+--+-- > w = CosineWarp(ControlSpec(1,2))+-- > [0,0.25,0.5,0.75,1].collect{|n| w.map(n)}+--+-- > map (warpCosine 1 2 W_Map) [0,0.25,0.5,0.75,1]+warpCosine :: (Floating a) => a -> a -> Warp a+warpCosine l r d n =+    let w = warpLinear 0 (r - l) d+    in if d == W_Map+       then w (0.5 - (cos (pi * n) / 2))+       else acos (1.0 - (w n * 2)) / pi++-- | Sine warp+--+-- > map (warpSine 1 2 W_Map) [0,0.25,0.5,0.75,1]+warpSine :: (Floating a) => a -> a -> Warp a+warpSine l r d n =+    let w = warpLinear 0 (r - l) d+    in if d == W_Map+       then w (sin (pi * 0.5 * n))+       else asin (w n) / (pi / 2)++-- | Fader warp.  Left and right values are implicitly zero and one.+--+-- > map (warpFader W_Map) [0,0.5,1] == [0,0.25,1]+warpFader :: Floating a => Warp a+warpFader d n = if d == W_Map then n * n else sqrt n++-- | DB fader warp. Left and right values are implicitly negative+-- infinity and zero.  An input of @0@ gives @-180@.+--+-- > map (round . warpDbFader W_Map) [0,0.5,1] == [-180,-12,0]+warpDbFader :: (Eq a,Floating a) => Warp a+warpDbFader d n =+    if d == W_Map+    then if n == 0 then -180 else rmsToDb (n * n)+    else sqrt (dbToRms n)++-- | A curve warp given by a real /n/.+--+-- > w_map (warpCurve (-3) 1 2) 0.25 == 1.5552791692202022+-- > w_map (warpCurve (-3) 1 2) 0.50 == 1.8175744761936437+warpCurve :: (Ord a,Floating a) => a -> a -> a -> Warp a+warpCurve k l r d n =+    let e = exp k+        a = (r - l) / (1 - e)+        b = l + a+    in if abs k < 0.001+       then warpLinear l r d n+       else if d == W_Map+            then b - ((e ** n) * a)+            else log ((b - n) / a) / k

@@ -0,0 +1,110 @@+-- | Windowing functions.+module Sound.SC3.Lang.Math.Window where++import qualified Numeric.GSL.Special.Bessel as M {- hmatrix-special -}+import qualified Numeric.GSL.Special.Trig as M++-- * Type and conversion++-- | A function from a \(0,1)\ normalised input to an output.+type Window x = x -> x++-- | A discrete /n/ element rendering of a 'Window'.+type Table x = [x]++-- | Generate an /n/ element table from a \(0,1)\ normalised window+-- function.+window_table :: (Integral n,Fractional a,Enum a) => n -> Window a -> Table a+window_table n f =+    let k = 1 / (fromIntegral n - 1)+    in map f [0,k..1]++-- * Math++-- | Regular modified Bessel function of fractional order zero.+bessel0 :: Double -> Double+bessel0 = M.bessel_Inu 0++-- | /n/ ^ 2.+square :: Num a => a -> a+square x = x * x++-- * Window functions++-- | Gaussian window, θ <= 0.5.+gaussian :: Floating a => a -> Window a+gaussian theta i = exp (- (0.5 * square ((i - 0.5) / (theta * 0.5))))++-- | Hann raised cosine window.+hann :: Floating a => Window a+hann i = 0.5 * (1 - cos (2 * pi * i))++-- | Hamming raised cosine window.+hamming :: Floating a => Window a+hamming i = 0.54 - 0.46 * cos (2 * pi * i)++-- | Kaiser windowing function, β is shape (1,2,8).+kaiser :: Double -> Window Double+kaiser beta i =+    let beta' = bessel0 beta+    in bessel0 (beta * sqrt (1 - ((2 * i - 1) ** 2))) / beta'++-- | 'M.sinc' window.+lanczos :: Window Double+lanczos i = M.sinc (2 * i - 1)++-- | Unit ('id') window, also known as a Dirichlet window.+rectangular :: Window a+rectangular = id++-- | 'sin' window.+sine :: Floating a => Window a+sine i = sin (i * pi)++-- | Triangular window, ie. Bartlett window with zero end-points.+triangular :: Fractional a => Window a+triangular i = 2 * (0.5 - abs (i - 0.5))++-- * Tables++-- | 'window_table' . 'gaussian'.+--+-- > plot [gaussian_table 1024 0.25,gaussian_table 1024 0.5]+gaussian_table :: (Integral n, Floating b, Enum b) => n -> b -> [b]+gaussian_table n = window_table n . gaussian++-- | 'window_table' . 'hamming'.+--+-- plot [hann 128,hamming 128]+hamming_table :: Int -> [Double]+hamming_table n = window_table n hamming++-- | 'window_table' . 'hann'.+--+-- plot [hann_table 128]+hann_table :: Int -> [Double]+hann_table n = window_table n hann++-- | 'window_table' . 'kaiser'.+--+-- plot [kaiser_table 128 1,kaiser_table 128 2,kaiser_table 128 8]+kaiser_table :: Int -> Double -> [Double]+kaiser_table n = window_table n . kaiser++-- | 'window_table' . 'lanczos'.+--+-- plot [lanczos (2^9)]+lanczos_table :: Integral n => n -> [Double]+lanczos_table n = window_table n lanczos++-- | 'window_table' . 'sine'.+--+-- plot [sine 128]+sine_table :: (Integral n, Floating b, Enum b) => n -> [b]+sine_table n = window_table n sine++-- | 'window_table' . 'triangular'.+--+-- plot [triangular (2^9)]+triangular_table :: (Integral n, Fractional b, Enum b) => n -> [b]+triangular_table n = window_table n triangular

@@ -1,6 +1,6 @@ {-# Language FlexibleInstances #-} -- | @sclang@ pattern library functions.--- See <http://slavepianos.org/rd/?t=hsc3-texts> for tutorial.+-- See <http://rd.slavepianos.org/?t=hsc3-texts> for tutorial. module Sound.SC3.Lang.Pattern.ID where  import Control.Applicative hiding ((<*))@@ -11,7 +11,7 @@ import Data.Maybe import Data.Monoid import Data.Traversable-import Sound.OpenSoundControl+import Sound.OSC import Sound.SC3 import qualified Sound.SC3.Lang.Collection as C import qualified Sound.SC3.Lang.Control.Event as E@@ -101,7 +101,8 @@ inf :: Int inf = maxBound --- | Constant /NaN/ (not a number) value for use as a rest indicator.+-- | Constant /NaN/ (not a number) value for use as a rest indicator+-- at a frequency model input (not at a @rest@ key). nan :: (Monad m,Floating a) => m a nan = return (sqrt (-1)) @@ -110,7 +111,7 @@ -- | Join a set of 'M' values, if any are 'Stop' then 'Stop' else -- 'Continue'. stP_join :: [M] -> M-stP_join m = if L.any (== Stop) m then Stop else Continue+stP_join m = if Stop `elem` m then Stop else Continue  -- | Extension of a set of patterns.  If any patterns are stopping, -- the longest such pattern, else the longest of the continuing@@ -121,9 +122,7 @@ pextension :: [P a] -> [()] pextension x =     let x' = filter ((== Stop) . stP) x-    in if null x'-       then C.extension (map F.toList x)-       else C.extension (map F.toList x')+    in C.extension (map F.toList (if null x' then x else x'))  -- | Extend a set of patterns following 'pextension' rule. --@@ -254,7 +253,7 @@ -- > (pure (*) <*> toP [1,2] <*> toP [5]) == toP [5,10] pzipWith :: (a -> b -> c) -> P a -> P b -> P c pzipWith f p q =-    let u = fmap (const ())+    let u = void         x = pextension [u p,u q]         c = cycle . unP         l = zipWith3 (\_ i j -> f i j) x (c p) (c q)@@ -263,7 +262,7 @@ -- | Pattern variant of 'zipWith3'. pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d pzipWith3 f p q r =-    let u = fmap (const ())+    let u = void         x = pextension [u p,u q,u r]         c = cycle . unP         z = L.zipWith4 (\_ i j k -> f i j k) x (c p) (c q) (c r)@@ -272,7 +271,7 @@ -- | Pattern variant of 'zipWith4'. pzipWith4 :: (a -> b -> c -> d -> e) -> P a -> P b -> P c -> P d -> P e pzipWith4 f p q r s =-    let u = fmap (const ())+    let u = void         x = pextension [u p,u q,u r,u s]         c = cycle . unP         z = L.zipWith5 (\_ i j k l -> f i j k l) x (c p) (c q) (c r) (c s)@@ -328,7 +327,7 @@ -- >                 ,("y",pseq [1,2,3] 1)]) == toP' [200,200,300] pbind :: [(E.Key,P E.Value)] -> P E.Event pbind =-    let ty = repeat "s_new"+    let ty = repeat E.E_s_new         i = repeat Nothing         s = repeat Nothing     in pbind' ty i s@@ -394,8 +393,23 @@     in stopping (fromList (f 0 (unP p)))  -- | SC3 pattern to derive notes from an index into a scale.+--+-- > let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2+-- >     ;q = return [0,2,4,5,7,9,11]+-- >     ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,4,5,7,5,4,2,0,4,7,12,7,4]}+-- > in pdegreeToKey p q (return 12) == toP' r+--+-- > let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2+-- >     ;q = pseq (map return [[0,2,4,5,7,9,11],[0,2,3,5,7,8,11]]) 1+-- >     ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,3,5,7,5,3,2,0,3,7,12,7,3]}+-- > in pdegreeToKey p (pstutter 14 q) (return 12) == toP' r+--+-- This is the pattern variant of 'P.degree_to_key'.+--+-- > let s = [0,2,4,5,7,9,11]+-- > in map (P.degree_to_key s 12) [0,2,4,7,4,2,0] == [0,4,7,12,7,4,0] pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a-pdegreeToKey = pzipWith3 P.degree_to_key+pdegreeToKey = pzipWith3 (\i j k -> P.degree_to_key j k i)  -- | SC3 pattern to calculate adjacent element difference. --@@ -501,13 +515,13 @@  -- | Variant of 'pinstr' which lifts the 'String' pattern to an -- 'I.Instrument' pattern.-pinstr_s :: P String -> P E.Event -> P E.Event-pinstr_s p = pinstr (fmap I.InstrumentName p)+pinstr_s :: P (String,Bool) -> P E.Event -> P E.Event+pinstr_s p = pinstr (fmap (uncurry I.InstrumentName) p)  -- | Variant of 'pinstr' which lifts the 'Synthdef' pattern to an -- 'I.Instrument' pattern.-pinstr_d :: P Synthdef -> P E.Event -> P E.Event-pinstr_d p = pinstr (fmap I.InstrumentDef p)+pinstr_d :: P (Synthdef,Bool) -> P E.Event -> P E.Event+pinstr_d p = pinstr (fmap (uncurry I.InstrumentDef) p)  -- | Pattern to extract 'E.Value's at 'E.Key' from an 'E.Event' -- pattern.@@ -544,20 +558,20 @@ pmono :: I.Instrument -> Int -> [(E.Key,P E.Value)] -> P E.Event pmono i k =     let i' = case i of-               I.InstrumentDef d ->+               I.InstrumentDef d sr ->                    let nm = synthdefName d-                   in i : repeat (I.InstrumentName nm)-               I.InstrumentName _ -> repeat i-        ty = "s_new_p" : repeat "n_set_p"+                   in i : repeat (I.InstrumentName nm sr)+               I.InstrumentName _ _ -> repeat i+        ty = E.E_s_new : repeat E.E_n_set     in pbind' ty (repeat (Just k)) (map Just i')  -- | Variant of 'pmono' that lifts 'Synthdef' to 'I.Instrument'. pmono_d :: Synthdef -> Int -> [(E.Key,P E.Value)] -> P E.Event-pmono_d s = pmono (I.InstrumentDef s)+pmono_d = pmono . flip I.InstrumentDef False  -- | Variant of 'pmono' that lifts 'String' to 'I.Instrument'. pmono_s :: String -> Int -> [(E.Key,P E.Value)] -> P E.Event-pmono_s s = pmono (I.InstrumentName s)+pmono_s = pmono . flip I.InstrumentName False  -- | Idiom to scale 'E.Value' at 'E.Key' in an 'E.Event' pattern. pmul :: E.Key -> P E.Value -> P E.Event -> P E.Event@@ -731,6 +745,7 @@ -- | SC3 arithmetric series pattern, see also 'pgeom'. -- -- > pseries 0 2 10 == toP' [0,2,4,6,8,10,12,14,16,18]+-- > pseries 9 (-1) 10 == toP' [9,8 .. 0] -- > pseries 1.0 0.2 3 == toP' [1.0,1.2,1.4] pseries :: (Num a) => a -> a -> Int -> P a pseries i s n = P (C.series n i s) (stp n)@@ -1054,49 +1069,49 @@ -- * Pattern audition  -- | Send 'E.Event' to @scsynth@ at 'Transport'.-e_send :: Transport t => t -> E.Time -> Int -> E.Event -> IO ()-e_send fd t j e =-    case E.to_sc3_osc t j e of+e_send :: Transport m => E.Time -> Int -> E.Event -> m ()+e_send t j e =+    case E.to_sc3_bundle t j e of       Just (p,q) -> do case E.instrument_def e of-                         Just d -> async fd (d_recv d) >> return ()+                         Just d -> void (async (d_recv d))                          Nothing -> return ()-                       send fd p-                       send fd q+                       sendBundle p+                       sendBundle q       Nothing -> return ()  -- | Function to audition a sequence of 'E.Event's using the @scsynth@ -- instance at 'Transport' starting at indicated 'E.Time'.-e_tplay :: (Transport t) => t -> E.Time -> [Int] -> [E.Event] -> IO ()-e_tplay fd t j e =+e_tplay :: (Transport m) => E.Time -> [Int] -> [E.Event] -> m ()+e_tplay t j e =     case (j,e) of       (_,[]) -> return ()       ([],_) -> error "e_tplay: no-id"       (i:j',d:e') -> do let t' = t + E.fwd d-                        e_send fd t i d+                        e_send t i d                         pauseThreadUntil t'-                        e_tplay fd t' j' e'+                        e_tplay t' j' e'  -- | Variant of 'e_tplay' with current clock time from 'utcr' as start -- time.  This function is used to implement the pattern instances of -- 'Audible'.-e_play :: (Transport t) => t -> [Int] -> [E.Event] -> IO ()-e_play fd lj le = do+e_play :: (Transport m) => [Int] -> [E.Event] -> m ()+e_play lj le = do   st <- utcr-  e_tplay fd st lj le+  e_tplay st lj le  instance Audible (P E.Event) where-    play fd = e_play fd [1000..] . unP+    play = e_play [1000..] . unP  instance Audible (Synthdef,P E.Event) where-    play fd (s,p) = do-      let i_d = I.InstrumentDef s-          i_nm = I.InstrumentName (synthdefName s)+    play (s,p) = do+      let i_d = I.InstrumentDef s True+          i_nm = I.InstrumentName (synthdefName s) True           i = pcons i_d (pn (return i_nm) inf)-      _ <- async fd (d_recv s)-      e_play fd [1000..] (unP (pinstr i p))+      _ <- async (d_recv s)+      e_play [1000..] (unP (pinstr i p))  instance Audible (String,P E.Event) where-    play fd (s,p) =-        let i = I.InstrumentName s-        in e_play fd [1000..] (unP (pinstr (return i) p))+    play (s,p) =+        let i = I.InstrumentName s True+        in e_play [1000..] (unP (pinstr (return i) p)) 

@@ -1,7 +1,6 @@ -- | 'RandomGen' based @sclang@ random number functions. module Sound.SC3.Lang.Random.Gen where -import Data.List import Data.Maybe import qualified Sound.SC3.Lang.Collection as C import qualified Sound.SC3.Lang.Math as M@@ -22,6 +21,8 @@     in go [] k  -- | Variant of 'rand' generating /k/ values.+--+-- > fst (nrand 10 (5::Int) (mkStdGen 246873)) == [0,5,4,0,4,5,3,2,3,1] nrand :: (RandomGen g,Random n,Num n) => Int -> n -> g -> ([n],g) nrand k = kvariant k . rand @@ -84,19 +85,10 @@     let (_,g') = next g     in (shuffle' k (length k) g,g') --- | @ArrayedCollection.windex@ takes a list of probabilities, which--- should sums to /n/, and returns the an index value given a (0,/n/)--- input.------ > map (windex [0.1,0.3,0.6]) [0,0.1 .. 0.4] == [Just 0,Just 1,Just 1,Just 1,Just 2]-windex :: (Ord a,Num a) => [a] -> a -> Maybe Int-windex w n = findIndex (n <) (C.integrate w)- -- | @SequenceableCollection.wchoose@ selects an element from a list -- given a list of weights which sum to @1@. wchoose :: (RandomGen g,Random a,Ord a,Fractional a) => [b] -> [a] -> g -> (b,g) wchoose l w g =   let (i,g') = randomR (0.0,1.0) g-      n = fromMaybe (error "wchoose: windex") (windex w i)+      n = fromMaybe (error "wchoose: windex") (C.windex w i)   in (l !! n,g')-

@@ -1,49 +1,56 @@ -- | 'getStdRandom' based @sclang@ random number functions. module Sound.SC3.Lang.Random.IO where +import Control.Monad.IO.Class import Sound.SC3.Lang.Random.Gen as R import System.Random {- random -} +randomM :: (Random a, MonadIO m) => (a, a) -> m a+randomM = liftIO . randomRIO+ -- | @SimpleNumber.rand@ is 'randomRIO' in (0,/n/).-rand :: (Random n,Num n) => n -> IO n-rand n = randomRIO (0,n)+rand :: (MonadIO m,Random n,Num n) => n -> m n+rand n = randomM (0,n)  -- | @SimpleNumber.rand2@ is 'randomRIO' in (-/n/,/n/).-rand2 :: (Random n,Num n) => n -> IO n-rand2 n = randomRIO (-n,n)+rand2 :: (MonadIO m,Random n,Num n) => n -> m n+rand2 n = randomM (-n,n) +randomG :: MonadIO m => (StdGen -> (a, StdGen)) -> m a+randomG = liftIO . getStdRandom+ -- | Variant of 'rand2' generating /k/ values. nrand2 :: (Random a, Num a) => Int -> a -> IO [a]-nrand2 n = getStdRandom . R.nrand2 n+nrand2 k = randomG . R.nrand2 k  -- | @SimpleNumber.rrand@ is 'curry' 'randomRIO'.-rrand :: (Random n) => n -> n -> IO n-rrand = curry randomRIO+rrand :: (MonadIO m,Random n) => n -> n -> m n+rrand l r = randomM (l,r)  -- | Variant of 'rrand' generating /k/ values.-nrrand :: (Random a, Num a) => Int -> a -> a -> IO [a]-nrrand n l = getStdRandom . R.nrrand n l+nrrand :: (MonadIO m,Random a, Num a) => Int -> a -> a -> m [a]+nrrand k l = randomG . R.nrrand k l  -- | @SequenceableCollection.choose@ selects an element at random.-choose :: [a] -> IO a-choose = getStdRandom . R.choose+choose :: MonadIO m => [a] -> m a+choose = randomG . R.choose  -- | @SimpleNumber.exprand@ generates exponentially distributed random -- number in the given interval.-exprand :: (Floating n,Random n) => n -> n -> IO n-exprand l = getStdRandom . R.exprand l+exprand :: (MonadIO m,Floating n,Random n) => n -> n -> m n+exprand l = randomG . R.exprand l  -- | @SimpleNumber.coin@ is 'True' at given probability, which is in -- range (0,1).-coin :: (Random n,Fractional n,Ord n) => n -> IO Bool-coin = getStdRandom . R.coin+coin :: (MonadIO m,Random n,Fractional n,Ord n) => n -> m Bool+coin = randomG . R.coin  -- | @List.scramble@ shuffles the elements.-scramble :: [t] -> IO [t]-scramble = getStdRandom . R.scramble+scramble :: MonadIO m => [t] -> m [t]+scramble = randomG . R.scramble  -- | @SequenceableCollection.wchoose@ selects an element from a list -- given a list of weights which sum to @1@.-wchoose :: (Random a,Ord a,Fractional a) => [b] -> [a] -> IO b-wchoose l = getStdRandom . R.wchoose l+wchoose :: (MonadIO m,Random a,Ord a,Fractional a) => [b] -> [a] -> m b+wchoose l = randomG . R.wchoose l 

@@ -0,0 +1,36 @@+-- | Denis Lorrain. \"A Panoply of Stochastic 'Cannons'\". /Computer+-- Music Journal/, 4(1):53-81, Spring 1980.+module Sound.SC3.Lang.Random.Lorrain_1980 where++-- | 4.3.1 (g=1)+linear :: Floating a => a -> a -> a+linear g u = g * (1 - sqrt u)++-- | 4.3.2 (δ=[0.5,1,2])+exponential :: Floating a => a -> a -> a+exponential delta u = (- (log u)) / delta++-- | 4.3.5 (τ=1)+cauchy :: Floating a => a -> a -> a+cauchy tau u = tau * tan (pi * u)++-- | 4.3.5 (iopt=False,τ=1) (Algorithm 10)+cauchy' :: Floating a => Bool -> a -> a -> a+cauchy' iopt tau u =+    let u' = if iopt then u / 2 else u+        u'' = pi * u'+    in tau * tan u'' -- tan u'' == sin u'' / cos u''++-- | 4.3.6+hyperbolic_cosine :: Floating a => a -> a+hyperbolic_cosine u = log (tan (pi * u / 2))++-- | 4.3.7 (β=0,α=1)+logistic :: Floating a => a -> a -> a -> a+logistic beta alpha u = (- beta - log (recip u - 1)) / alpha++-- | 4.3.8+arc_sine :: Floating a => a -> a+arc_sine u =+    let x = sin (pi * u / 2)+    in x * x

@@ -7,7 +7,8 @@  -- | @SimpleNumber.rand@ is 'getRandomR' in (0,/n/). ----- > evalRand (replicateM 2 (rand 10)) (mkStdGen 6) == [5,8]+-- > evalRand (replicateM 2 (rand (10::Int))) (mkStdGen 6) == [5,8]+-- > evalRand (rand (1::Double)) (mkStdGen 6) == 0.21915126172825694 rand :: (RandomGen g,Random n,Num n) => n -> Rand g n rand n = getRandomR (0,n) 

@@ -1,16 +1,16 @@ Name:              hsc3-lang-Version:           0.11+Version:           0.12 Synopsis:          Haskell SuperCollider Language Description:       Haskell library defining operations from the                    SuperCollider language class library License:           GPL Category:          Sound-Copyright:         (c) Rohan Drape, 2007-2011+Copyright:         (c) Rohan Drape, 2007-2012 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental-Homepage:          http://slavepianos.org/rd/?t=hsc3-lang-Tested-With:       GHC == 7.2.2+Homepage:          http://rd.slavepianos.org/?t=hsc3-lang+Tested-With:       GHC == 7.6.1 Build-Type:        Simple Cabal-Version:     >= 1.8 @@ -19,14 +19,18 @@ Library   Build-Depends:   array,                    base == 4.*,+                   bytestring,                    containers,                    data-default,-                   hosc == 0.11.*,-                   hsc3 == 0.11.*,+                   hmatrix-special,+                   hosc == 0.12.*,+                   hsc3 == 0.12.*,                    MonadRandom,+                   mtl,                    split,                    random,-                   random-shuffle+                   random-shuffle,+                   transformers   GHC-Options:     -Wall -fwarn-tabs   Exposed-modules: Sound.SC3.Lang.Collection                    Sound.SC3.Lang.Collection.Extension@@ -36,16 +40,21 @@                    Sound.SC3.Lang.Control.Duration                    Sound.SC3.Lang.Control.Event                    Sound.SC3.Lang.Control.Instrument+                   Sound.SC3.Lang.Control.Midi                    Sound.SC3.Lang.Control.Pitch                    Sound.SC3.Lang.Control.OverlapTexture+                   Sound.SC3.Lang.Data.Modal                    Sound.SC3.Lang.Data.Vowel                    Sound.SC3.Lang.Math+                   Sound.SC3.Lang.Math.Warp+                   Sound.SC3.Lang.Math.Window                    Sound.SC3.Lang.Pattern.ID                    Sound.SC3.Lang.Pattern.List+                   Sound.SC3.Lang.Random.Lorrain_1980                    Sound.SC3.Lang.Random.Gen                    Sound.SC3.Lang.Random.IO                    Sound.SC3.Lang.Random.Monad  Source-Repository  head   Type:            darcs-  Location:        http://slavepianos.org/rd/sw/hsc3-lang/+  Location:        http://rd.slavepianos.org/sw/hsc3-lang/