packages feed

hspear (empty) → 0.12

raw patch · 6 files changed

+398/−0 lines, 6 filesdep +basedep +bytestringdep +bytestring-lexingsetup-changed

Dependencies added: base, bytestring, bytestring-lexing, split, utf8-string, zlib

Files

+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ Sound/Analysis/Spear/PTPF.hs view
@@ -0,0 +1,250 @@+-- | /Spear/ @PTPF@ (par-text-partials-format) files.+module Sound.Analysis.Spear.PTPF where++import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -}+import Data.ByteString.Lex.Lazy.Double {- bytestring-lexing -}+import Data.Function+import Data.List+import Data.List.Split {- split -}++-- * Tuple++-- | Adjacent duples.+--+-- > duples [1..6] == [(1,2),(3,4),(5,6)]+duples :: [t] -> [(t,t)]+duples =+    let f x = case x of+                [i,j] -> (i,j)+                _ -> error "duples"+    in map f . chunksOf 2++-- | Adjacent triples.+--+-- > triples [1..6] == [(1,2,3),(4,5,6)]+triples :: [t] -> [(t,t,t)]+triples =+    let f x = case x of+                [i,j,k] -> (i,j,k)+                _ -> error "triples"+    in map f . chunksOf 3++-- * List++-- | Apply /f/ at last element.+--+-- > at_last negate [1..3] == [1,2,-3]+at_last :: (a -> a) -> [a] -> [a]+at_last f x =+    case x of+      [] -> []+      [e] -> [f e]+      e:x' -> e : at_last f x'++-- | Numerically stable mean+--+-- > map mean [[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [3,5,7,9]+mean :: Floating a => [a] -> a+mean =+    let f (m,n) x = (m + (x - m) / (n + 1),n + 1)+    in fst . foldl' f (0,0)++-- | 'minimum' & 'maximum'.+--+-- > minmax [0..5] == (0,5)+minmax :: Ord b => [b] -> (b, b)+minmax l =+    let f (p,q) n = (min p n,max q n)+    in case l of+         [] -> error "minmax: empty list"+         e:l' -> foldl f (e,e) l'++-- * Node++-- | Record to hold data for single node of a partial track.+data Node = Node {n_partial_id :: Int -- ^ Partial identifier+                 ,n_time :: Double+                 ,n_frequency :: Double+                 ,n_amplitude :: Double}+            deriving (Eq,Show)++-- | Set 'n_amplitude' at 'Node' to @0@.+n_zero_amplitude :: Node -> Node+n_zero_amplitude e = e {n_amplitude = 0}++-- | Set 'n_partial_id' at 'Node'.+n_set_partial_id :: Int -> Node -> Node+n_set_partial_id k e = e {n_partial_id = k}++-- | Apply transform /f/ at 'n_time'.+n_temporal_f :: (Double -> Double) -> Node -> Node+n_temporal_f f e = e {n_time = f (n_time e)}++-- * Seq++-- | A sequence of partial 'Node' data.+data Seq = Seq {s_identifier :: Int -- ^ '==' to 'n_partial_id' at 's_data'.+               ,s_start_time :: Double -- ^ 'minimum' 'n_time' at 's_data'.+               ,s_end_time :: Double -- ^ 'maximum' 'n_time' at 's_data'.+               ,s_nodes :: Int -- ^ '==' to 'length' 's_data'+               ,s_data :: [Node]}+           deriving (Eq,Show)++-- | Apply /f/ at 's_data' of 'Seq' and re-calculate temporal bounds.+s_map :: (Node -> Node) -> Seq -> Seq+s_map f (Seq i _ _ n d) =+    let d' = map f d+        (s,e) = minmax (map n_time d')+    in Seq i s e n d'++s_summarise :: ([a] -> b) -> (Node -> a) -> Seq -> b+s_summarise f g = f . map g . s_data++-- | 'maximum' 'n_amplitude' at 's_data'.+s_max_amplitude :: Seq -> Double+s_max_amplitude = s_summarise maximum n_amplitude++-- | 'minimum' 'n_amplitude' at 's_data'.+s_min_amplitude :: Seq -> Double+s_min_amplitude = s_summarise minimum n_amplitude++-- | 'mean' 'n_amplitude' at 's_data'.+s_mean_amplitude :: Seq -> Double+s_mean_amplitude = s_summarise mean n_amplitude++-- | 'mean' 'n_frequency' at 's_data'.+s_mean_frequency :: Seq -> Double+s_mean_frequency = s_summarise mean n_frequency++-- | 's_end_time' '-' 's_start_time'.+s_duration :: Seq -> Double+s_duration s = s_end_time s - s_start_time s++-- | Set 's_identifier' and associated 'n_partial_id'.+s_set_identifier :: Int -> Seq -> Seq+s_set_identifier k s = s {s_identifier = k+                         ,s_data = map (n_set_partial_id k) (s_data s)}++-- | '==' 'on' 's_identifier'.+s_eq_identifier :: Seq -> Seq -> Bool+s_eq_identifier = (==) `on` s_identifier++-- | 'unionBy' 's_eq_identifier'.+s_union :: [Seq] -> [Seq] -> [Seq]+s_union = unionBy s_eq_identifier++-- | Apply transform /f/ at 'n_time'.+s_temporal_f :: (Double -> Double) -> Seq -> Seq+s_temporal_f f s =+    let (Seq i st et n d) = s+    in Seq i (f st) (f et) n (map (n_temporal_f f) d)++-- * PTPF++-- | A 'PTPF' is a set of 'Seq'.+data PTPF = PTPF {p_partials :: Int+                 ,p_seq :: [Seq]}+            deriving (Eq,Show)++-- | 'minimum' 's_start_time' at 'p_seq'.+p_start_time :: PTPF -> Double+p_start_time = minimum . map s_start_time . p_seq++-- | 'maximum' 's_end_time' at 'p_seq'.+p_end_time :: PTPF -> Double+p_end_time = maximum . map s_end_time . p_seq++-- | 'sum' of 's_nodes' of 'p_seq'.+p_nodes :: PTPF -> Int+p_nodes = sum . map s_nodes . p_seq++-- | Generate 'PTPF' from set of 'Seq'.  Re-assigns partial identifiers.+p_from_seq :: [Seq] -> PTPF+p_from_seq s =+    let n = length s+        s' = zipWith s_set_identifier [0..] s+    in PTPF n s'++p_temporal_f :: (Double -> Double) -> PTPF -> PTPF+p_temporal_f f (PTPF n s) = PTPF n (map (s_temporal_f f) s)++p_map :: (Seq -> Seq) -> PTPF -> PTPF+p_map f (PTPF n s) = PTPF n (map f s)++p_filter :: (Seq -> Bool) -> PTPF -> PTPF+p_filter f (PTPF _ s) =+    let s' = filter f s+    in PTPF (length s') s'++p_node_map :: (Node -> Node) -> PTPF -> PTPF+p_node_map f = p_map (s_map f)++-- * Parser++type STR = C.ByteString++str_int :: C.ByteString -> Int+str_int = maybe 0 fst . C.readInt++str_double :: C.ByteString -> Double+str_double = maybe 0 fst . readDouble++str_words :: C.ByteString -> [C.ByteString]+str_words = C.split ' '++str_lines :: C.ByteString -> [C.ByteString]+str_lines = filter (not . C.null) . C.split '\n'++-- | Parse 'Node'.+ptpf_node :: Int -> (STR,STR,STR) -> Node+ptpf_node n (t,f,a) = Node n (str_double t) (str_double f) (str_double a)++-- | Parse 'Seq' from pair of input lines.+ptpf_seq :: (STR,STR) -> Seq+ptpf_seq (i,j) =+    let [ix,n,st,et] = str_words i+        ix' = str_int ix+        n' = str_int n+        p = map (ptpf_node ix') (triples (str_words j))+    in if n' /= length p+       then error "ptpf_seq"+       else Seq ix' (str_double st) (str_double et) n' (at_last n_zero_amplitude p)++-- | Parse header section, result is number of partials.+ptpf_header :: [STR] -> Maybe Int+ptpf_header h =+    let mk = C.pack+        r0 = mk "par-text-partials-format"+        r1 = mk "point-type time frequency amplitude"+        r2 = mk "partials-count "+        r3 = mk "partials-data"+    in case h of+         [h0,h1,h2,h3] -> if h0 == r0 && h1 == r1 && h3 == r3+                          then Just (str_int (C.drop (C.length r2) h2))+                          else Nothing+         _ -> Nothing++-- | Parse 'PTPF' at 'STR'.+parse_ptpf :: STR -> Either String PTPF+parse_ptpf s =+    let l = str_lines s+        (h,d) = splitAt 4 l+    in case ptpf_header h of+         Just np -> let p = map ptpf_seq (duples d)+                    in if length p /= np+                       then Left ("parse_ptpf: partial count: " ++ show (np,length p))+                       else Right (PTPF np p)+         _ -> Left "parse_ptpf: illegal header"++-- * Operations++-- | All 'Node's grouped into sets with equal start times.+ptpf_time_asc :: PTPF -> [(Double,[Node])]+ptpf_time_asc =+    let f x = (n_time (head x),x)+    in map f .+       groupBy ((==) `on` n_time) .+       sortBy (compare `on` n_time) .+       concatMap s_data .+       p_seq+
+ Sound/Analysis/Spear/PTPF/GZ.hs view
@@ -0,0 +1,22 @@+-- | Variants for handling @GZIP@ compressed data.+module Sound.Analysis.Spear.PTPF.GZ where++import qualified Codec.Compression.GZip as Z {- zlib -}+import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -}+import Sound.Analysis.Spear.PTPF++-- | Variant of 'parse_ptpf' running 'Z.decompress'.+parse_ptpf_gz :: C.ByteString -> Either String PTPF+parse_ptpf_gz = parse_ptpf . Z.decompress++-- | Load compressed spear data.+load_ptpf_gz :: FilePath -> IO (Either String PTPF)+load_ptpf_gz = fmap parse_ptpf_gz . C.readFile++-- | Apply /f/ at 'Right', else 'id'.+at_right :: (a -> b) -> Either t a -> Either t b+at_right f = either (Left . id) (Right . f)++-- | Variant of 'load_ptpf_gz' transforming with 'ptpf_time_asc'.+load_ptpf_gz_time_asc :: FilePath -> IO (Either String [(Double, [Node])])+load_ptpf_gz_time_asc = fmap (at_right ptpf_time_asc) . load_ptpf_gz
+ Sound/Analysis/Spear/PTPF/Reduce.hs view
@@ -0,0 +1,42 @@+module Sound.Analysis.Spear.PTPF.Reduce where++import Sound.Analysis.Spear.PTPF++-- | True if (n1,n2,n3) can be reduced to (n1,n3).+type N_Reduction_F = ((Node,Node,Node) -> Bool)++n_reduction :: N_Reduction_F -> [Node] -> [Node]+n_reduction f n =+    case n of+      n1:n2:n3:n' -> if f (n1,n2,n3)+                     then n_reduction f (n1:n3:n')+                     else n1 : n_reduction f (n2:n3:n')+      _ -> n++s_reduction :: N_Reduction_F -> Seq -> Seq+s_reduction f (Seq i s e _ d) =+    let d' = n_reduction f d+    in Seq i s e (length d') d'++cps_to_fmidi :: Floating a => a -> a+cps_to_fmidi a = (logBase 2 (a * (1 / 440)) * 12) + 69++ampDb :: Floating a => a -> a+ampDb a = logBase 10 a * 20++-- | Frequency (FMIDI) and amplitude (DB) gradient from /n1/ to /n2/.+n_gradient :: Node -> Node -> (Double,Double)+n_gradient (Node _ t1 f1 a1) (Node _ t2 f2 a2) =+    let dt = t2 - t1+    in ((cps_to_fmidi f2 - cps_to_fmidi f1) / dt+       ,(ampDb a2 - ampDb a1) / dt)++s_reduction_gradient :: (Double,Double) -> Seq -> Seq+s_reduction_gradient (p,q) =+    let f (n1,n2,n3) = let (a,b) = n_gradient n1 n2+                           (c,d) = n_gradient n1 n3+                       in abs (a - c) < p && abs (b - d) < q+    in s_reduction f++p_reduction_gradient :: (Double,Double) -> PTPF -> PTPF+p_reduction_gradient g (PTPF n s) = PTPF n (map (s_reduction_gradient g) s)
+ Sound/Analysis/Spear/PTPF/String.hs view
@@ -0,0 +1,45 @@+-- | 'String' variant of parser.+module Sound.Analysis.Spear.PTPF.String where++import Data.List+import Sound.Analysis.Spear.PTPF hiding (ptpf_node,ptpf_seq,ptpf_header,parse_ptpf)++-- | Parse 'Node'.+ptpf_node :: Int -> (String,String,String) -> Node+ptpf_node n (t,f,a) = Node n (read t) (read f) (read a)++-- | Parse 'Seq' from pair of input lines.+ptpf_seq :: (String,String) -> Seq+ptpf_seq (i,j) =+    let [ix,n,st,et] = words i+        ix' = read ix+        n' = read n+        p = map (ptpf_node ix') (triples (words j))+    in if n' /= length p+       then error "ptpf_seq"+       else Seq ix' (read st) (read et) n' (at_last n_zero_amplitude p)++-- | Parse header section, result is number of partials.+ptpf_header :: [String] -> Maybe Int+ptpf_header h =+    let r0 = "par-text-partials-format"+        r1 = "point-type time frequency amplitude"+        r2 = "partials-count "+        r3 = "partials-data"+    in case h of+         [h0,h1,h2,h3] -> if h0 == r0 && h1 == r1 && h3 == r3+                          then fmap read (stripPrefix r2 h2)+                          else Nothing+         _ -> Nothing++-- | Parse 'PTPF' at 'String'.+parse_ptpf :: String -> Either String PTPF+parse_ptpf s =+    let l = lines s+        (h,d) = splitAt 4 l+    in case ptpf_header h of+         Just np -> let p = map ptpf_seq (duples d)+                    in if length p /= np+                       then Left "parse_ptpf: partial count"+                       else Right (PTPF np p)+         _ -> Left "parse_ptpf: illegal header"
+ hspear.cabal view
@@ -0,0 +1,36 @@+Name:              hspear+Version:           0.12+Synopsis:          Haskell Spear Parser+Description:       Parser for the analysis files produced by the+                   Spear frequency partial tracker.+License:           GPL+Category:          Sound+Copyright:         Rohan Drape, 2012+Author:            Rohan Drape+Maintainer:        rd@slavepianos.org+Stability:         Experimental+Homepage:          http://rd.slavepianos.org/?t=hspear+Tested-With:       GHC == 7.6.1+Build-Type:        Simple+Cabal-Version:     >= 1.8++Library+  Build-Depends:   base == 4.*,+                   bytestring,+                   bytestring-lexing,+                   split,+                   utf8-string,+                   zlib+  GHC-Options:     -Wall -fwarn-tabs+  Exposed-modules: Sound.Analysis.Spear.PTPF+                   Sound.Analysis.Spear.PTPF.GZ+                   Sound.Analysis.Spear.PTPF.Reduce+                   Sound.Analysis.Spear.PTPF.String++Source-Repository  head+  Type:            darcs+  Location:        http://rd.slavepianos.org/sw/spear++-- Local Variables:+-- truncate-lines:t+-- End: