hmt-diagrams 0.14 → 0.15

raw patch · 7 files changed

+220/−130 lines, 7 filesdep +processdep ~hcg-minusdep ~hcg-minus-cairodep ~hmtPVP ok

version bump matches the API change (PVP)

Dependencies added: process

Dependency ranges changed: hcg-minus, hcg-minus-cairo, hmt, html-minimalist

API changes (from Hackage documentation)

Files

• Music/Theory/Diagram/Grid.hs +29/−27
• Music/Theory/Diagram/Render/Grid.hs +1/−1
• Music/Theory/Diagram/Render/Hinton.hs +63/−0
• Music/Theory/Diagram/Sequencer.hs +103/−0
• Music/Theory/Tuning/Table.hs +10/−91
• README +2/−2
• hmt-diagrams.cabal +12/−9

@@ -3,15 +3,15 @@ -- /grid/ music of the 1950's. module Music.Theory.Diagram.Grid where -import Data.Maybe-import qualified Text.HTML.Light as H {- html-minimalist -}-import qualified Text.HTML.Light.Composite as H+import Data.Maybe {- base -}+ import qualified Text.XML.Light as X {- xml -} --- * Grid+import Music.Theory.Math (R) {- hmt -}+import qualified Text.HTML.Light as H {- html-minimalist -}+import qualified Text.HTML.Light.Composite as H {- html-minimalist -} --- | Real number, synonym for 'Double'.-type R = Double+-- * Grid  -- | Point given as pair of 'R'. type P = (R,R)@@ -29,15 +29,15 @@ type Grid = [Cell]  -- | Given /(x,y)/ upper-left co-ordinate of grid, /(w,h)/ cell--- dimensions, and /(r,c)/ grid dimensions, make list of upper-left+-- dimensions, and /(r,c)/ grid dimensions, make array of upper-left -- co-ordinates of cells. ----- > grid (10,10) (50,10) (2,2) == [(10,10),(60,10),(10,20),(60,20)]-grid :: P -> (R,R) -> (Int,Int) -> [P]+-- > grid (10,10) (50,10) (2,2) = [[(10,10),(60,10)],[(10,20),(60,20)]]+grid :: (Enum a,Num a) => (a,a) -> (a,a) -> (Int,Int) -> [[(a,a)]] grid (x,y) (w,h) (r,c) =     let xs = take c [x, x + w ..]         ys = take r [y, y + h ..]-    in concatMap (zip xs . repeat) ys+    in map (zip xs . repeat) ys  -- | Variant on 'grid' that constructs a single point. --@@ -60,64 +60,66 @@     let f n = (fromIntegral n + 2) * 10     in (f c,f r) --- * Table+-- * Table (HTML)  -- | A table cell is an 'X.Attr' and 'X.Content' duple. type Table_Cell = ([X.Attr],[X.Content]) +-- | A table caption. type Caption = [X.Content]  -- | Table of row order 'Table_Cell's.-type Table = (Caption,[[Table_Cell]])+type HTML_Table = (Caption,[[Table_Cell]])  -- | Construct a 'Table' with one 'X.Content' per cell.-simple_table :: Caption -> [[X.Content]] -> Table+simple_table :: Caption -> [[X.Content]] -> HTML_Table simple_table c z = (c,map (map (\x -> ([],[x]))) z)  -- | Construct a 'Table' with one 'X.Content' per cell, and an -- associated class.-simple_table_class :: Caption -> [[(String,X.Content)]] -> Table+simple_table_class :: Caption -> [[(String,X.Content)]] -> HTML_Table simple_table_class c z = (c,map (map (\(nm,x) -> ([H.class' nm],[x]))) z) +-- | A function from @(row,column)@ to 'Maybe' 'Table_Cell' type Build_F = ((Int,Int) -> Maybe Table_Cell) --- | Build a table of @(rows,columns)@ dimensions given a function--- from @(row,column)@ to 'Maybe' 'Table_Cell'.  If the function is--- 'Nothing' the cell is skipped, becase another cell has claimed it's--- locations with 'H.colspan' or 'H.rowspan'.-build_table_m :: Caption -> (Int,Int) -> Build_F -> Table+-- | Build a table of @(rows,columns)@ dimensions given a builder+-- function.  If the function is 'Nothing' the cell is skipped, becase+-- another cell has claimed it's locations with 'H.colspan' or+-- 'H.rowspan'.+build_table_m :: Caption -> (Int,Int) -> Build_F -> HTML_Table build_table_m c (m,n) f =     let mk_row i = mapMaybe (\j -> f (i,j)) [0 .. n - 1]     in (c,map mk_row [0 .. m - 1])  -- | Build a table of @(rows,columns)@ dimensions given a function -- from @(row,column)@ to 'Table_Cell'.-build_table :: Caption -> (Int,Int) -> ((Int,Int) -> Table_Cell) -> Table+build_table :: Caption -> (Int,Int) -> ((Int,Int) -> Table_Cell) -> HTML_Table build_table c (m,n) f = build_table_m c (m,n) (Just . f)  -- | Render 'Table' as @HTML@ table.-table :: Table -> X.Content+table :: HTML_Table -> X.Content table (c,z) =     let mk_r = H.tr [] . map (uncurry H.td)-    in H.table [] (H.caption [] c : map mk_r z)+    in H.table [] [H.caption [] c,H.tbody [] (map mk_r z)]  -- | A set of related tables.-type Table_Set = [Table]+type HTML_Table_Set = [HTML_Table]  -- | Render a 'Table_Set's in a @div@ with class @table-set@.-table_set :: Table_Set -> X.Content+table_set :: HTML_Table_Set -> X.Content table_set = H.div [H.class' "table-set"] . map table  -- | Render set of 'Table_Set's as @HTML@.-page :: Maybe FilePath -> [Table_Set] -> String+page :: Maybe FilePath -> [HTML_Table_Set] -> String page css xs = do     let tb = map table_set xs         bd = H.body [H.class' "table-page"] tb         css' = H.link_css "all" (fromMaybe "css/grid.css" css)-        hd = H.head [] [css']+        hd = H.head [] [H.meta [H.charset "utf-8"],css']         e = H.html [H.lang "en"] [hd, bd]     H.renderHTML5 e  -- | Write set of 'Table_Set's to @HTML@ file.-to_html :: FilePath -> Maybe FilePath -> [Table_Set] -> IO ()+to_html :: FilePath -> Maybe FilePath -> [HTML_Table_Set] -> IO () to_html o_fn css = writeFile o_fn . page css

@@ -16,7 +16,7 @@ mk_grid (r,c) (dx,dy) fs xs = do   let g = T.grid (10,10) (10,10) (r,c)       grid_pt' = uncurry Pt . T.displace (dx,dy) . T.grid_pt (10,10) (10,10)-  mapM_ (\(x,y) -> rect (opaque black) (Pt x y) (10,10)) g+  mapM_ (\(x,y) -> rect (opaque black) (Pt x y) (10,10)) (concat g)   mapM_ (\(l,clr,i) -> text (opaque (toC clr)) (grid_pt' l) fs i) xs   C.showPage 

@@ -0,0 +1,63 @@+-- | Functions for /Hinton/ diagrams of matrices.+module Music.Theory.Diagram.Render.Hinton where++import Data.Colour {- colour -}++import Data.CG.Minus+import Data.CG.Minus.Colour+import qualified Graphics.Rendering.Cairo as C {- cairo -}+import Render.CG.Minus {- hcg-minus-cairo -}+import qualified Music.Theory.Diagram.Grid as T {- hmt -}++-- * Arr++-- | Regular (unchecked) two dimensional arrays.+type Arr t = [[t]]++-- | Dimensions of 'Arr', columns are as at row @0@.+a_dimensions :: Arr t -> (Int,Int)+a_dimensions m =+    let r = length m+        m0:_ = m+        c = length m0+    in (r,c)++-- | Normalise 'Arr' such that maxima is @1@.+--+-- > a_normalise [[3,2],[4,5]] == [[0.6,0.4],[0.8,1.0]]+a_normalise :: (Fractional t,Ord t) => Arr t -> Arr t+a_normalise a = let m = maximum (map maximum a) in map (map (/ m)) a++-- | Multiply all elements at 'Arr' by /k/.+--+-- > a_scale 0.85 (a_normalise [[3,2],[4,5]]) == [[0.51,0.34],[0.68,0.85]]+a_scale :: Num t => t -> Arr t -> Arr t+a_scale k = map (map (* k))++-- * Drawing++draw_hinton_cell :: (C,C) -> ((R,R),R) -> C.Render ()+draw_hinton_cell (n,p) ((x,y),k) =+    let (d,z) = let e = sqrt (abs k) in (e,(1 - e) / 2)+        (d',z') = (d * 10,z * 10)+        fg = if k > 0 then p else n+    in rect_fill (opaque fg) (Pt (x + z') (y + z')) (d',d')++draw_hinton1 :: (C,C,C) -> (Int, Int) -> Arr R -> C.Render ()+draw_hinton1 (bg,n,p) (r,c) xs = do+  let g = T.grid (10,10) (10,10) (r,c)+  rect_fill (opaque bg) (Pt 10 10) (fromIntegral c * 10,fromIntegral r * 10)+  mapM_ (draw_hinton_cell (n,p)) (zip (concat g) (concat xs))+  C.showPage++-- | Colours are (background,negative,positive).  /s/ is a scalar for+-- normalisation of matrix data.+hinton_diagrams :: (C,C,C) -> R -> FilePath -> [Arr R] -> IO ()+hinton_diagrams (bg,n,p) s fn m =+  let m0:_ = m+      (r,c) = a_dimensions m0+      (w,h) = (c * 10 + 20,r * 10 + 20)+      (w',h') = (fromIntegral w,fromIntegral h)+      m' = map (a_scale s . a_normalise) m+      g sf = C.renderWith sf (mapM_ (draw_hinton1 (bg,n,p) (r,c)) m')+  in C.withPDFSurface fn w' h' g

@@ -0,0 +1,103 @@+-- | Sequencer type diagram.+module Music.Theory.Diagram.Sequencer where++import Data.Char {- base -}+import System.FilePath {- filepath -}+import System.Process {- process -}+import Text.Printf {- base -}++import Music.Theory.Math (R) {- hmt -}+import qualified Music.Theory.Dynamic_Mark as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}++-- | Point+type P2 = (R,R)++-- | Greyscale colour.+type Grey = R++-- | Coloured rectangle as (lower-left,upper-right,greyscale).+type C_Rect = (P2,P2,Grey)++-- | 'C_Rect' with identifier.+type K_Rect = (Int,C_Rect)++-- | Gnuplot string for 'K_Rect'.+k_rect_gnuplot :: K_Rect -> String+k_rect_gnuplot (i,((x0,y0),(x1,y1),c)) =+    let fmt = "set object %d rect from %f,%f to %f,%f fc rgbcolor \"#%02x%02x%02x\""+        c' = floor (c * 255) :: Int+    in printf fmt i x0 y0 x1 y1 c' c' c'++-- | Sequencer plot options, (image-size,x-range,y-range).  For+-- standard midi data x-range is the time window and y-range is the+-- gamut.+type Seq_Plot_Opt = ((Int,Int),(R,R),(R,R))++-- | Sane defaults for size and gamut.+default_seq_plot_opt :: (R,R) -> Seq_Plot_Opt+default_seq_plot_opt x = ((1200,400),x,(21,108))++-- | Add identifiers.+to_k_rect :: [C_Rect] -> [K_Rect]+to_k_rect = zip [1..]++-- | Names for SVG terminal have character restrictions.+clean_name :: String -> String+clean_name =+    let f c = if isAlphaNum c then c else '_'+    in map f++sequencer_plot_rect :: Seq_Plot_Opt -> FilePath -> String -> [C_Rect] -> IO ()+sequencer_plot_rect ((w,h),(x0,x1),(y0,y1)) dir nm sq = do+  let nm_plot = dir </> nm <.> "plot"+      nm_svg = dir </> nm <.> "svg"+      x_range = concat ["[",show x0,":",show x1,"]"]+      y_range = concat ["[",show y0,":",show y1,"]"]+      pre = [concat ["set terminal svg name \"",clean_name nm,"\" size ",show w,",", show h]+            ,"set output '" ++ nm_svg ++ "'"+            ,"set tics font \"cmr10, 10\""+            ,"unset key"+            ,concat ["set xrange ",x_range]+            ,concat ["set yrange ",y_range]+            ,"set bars 0"]+      post = ["plot \"/dev/null\" with xyerrorbars lc rgbcolor \"black\""]+  writeFile nm_plot (unlines (pre ++ map k_rect_gnuplot (to_k_rect sq) ++ post))+  _ <- system ("gnuplot " ++ nm_plot)+  return ()++-- * MIDI++-- | Linear amplitude to grey scale (0 = white, 1 = black).+--+-- > map (floor . (* 255) . amp_to_grey (-60)) [0,0.25,0.5,0.75,1] == [255,51,25,10,0]+amp_to_grey :: R -> R -> R+amp_to_grey z am =+    let db = max (T.amp_db am) z+        z' = abs z+    in 1 - ((db + z') / z')++-- | Midi velocity number to linear amplitude.+vel_to_amp :: Int -> R+vel_to_amp vel = fromIntegral vel / 127++-- | Midi velocity number to grey scale.+vel_to_grey :: R -> Int -> R+vel_to_grey z = amp_to_grey z . vel_to_amp++-- | Midi sequence data.+type Sequencer_Midi n = T.Wseq R (n,n)++-- | Convert 'Sequencer_Midi' node to 'C_Rect'.+sequencer_midi_to_rect :: Real n => ((R,R),(n,n)) -> C_Rect+sequencer_midi_to_rect ((st,du),(mnn,vel)) =+    let x0 = st+        x1 = st + du+        y0 = realToFrac mnn+        y1 = y0 + 1+        c = vel_to_grey (-60) (floor (realToFrac vel))+    in ((x0,y0),(x1,y1),c)++-- | Plot 'Sequencer_Midi'.+sequencer_plot_midi :: Real n => Seq_Plot_Opt -> FilePath -> String -> Sequencer_Midi n -> IO ()+sequencer_plot_midi opt dir nm = sequencer_plot_rect opt dir nm . map sequencer_midi_to_rect

@@ -1,103 +1,22 @@ -- | Tuning tables module Music.Theory.Tuning.Table where -import qualified Music.Theory.Diagram.Grid as G-import Music.Theory.List-import Music.Theory.Pitch-import Music.Theory.Pitch.Spelling-import Music.Theory.Tuning import qualified Text.HTML.Light as H {- html-minimalist -}-import Text.Printf --- * Equal temperament---- | 'octpc_to_pitch' and 'octpc_to_cps'.-octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n)-octpc_to_pitch_cps x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps x)---- | 12-tone equal temperament table equating 'Pitch' and frequency--- over range of human hearing, where @A4@ = @440@hz.------ > length tbl_12et == 132--- > min_max (map (round . snd) tbl_12et) == (16,31609)-tbl_12et :: [(Pitch,Double)]-tbl_12et =-    let z = [(o,pc) | o <- [0..10], pc <- [0..11]]-    in map octpc_to_pitch_cps z---- | 24-tone equal temperament variant of 'tbl_12et'.------ > length tbl_24et == 264--- > min_max (map (round . snd) tbl_24et) == (16,32535)-tbl_24et :: [(Pitch, Double)]-tbl_24et =-    let f x = let p = fmidi_to_pitch pc_spell_ks x-                  p' = pitch_rewrite_threequarter_alteration p-              in (p',fmidi_to_cps x)-    in map f [12,12.5 .. 143.5]---- | Given an @ET@ table (or like) find bounds of frequency.------ > let r = Just (at_pair octpc_to_pitch_cps ((3,11),(4,0)))--- > in bounds_et_table tbl_12et 256 == r-bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s))-bounds_et_table tbl =-    let f (_,p) = compare p-    in find_bounds f (adj2 1 tbl)---- | 'bounds_et_table' of 'tbl_12et'.------ > map bounds_12et_tone (hsn 17 55)-bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double))-bounds_12et_tone = bounds_et_table tbl_12et---- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@--- frequency, and deviation in hertz and 'Cents'.-type HS_R = (Double,Pitch,Double,Double,Cents)---- | Form 'HS_R' for /frequency/ by consulting table.------ > let {f = 256--- >     ;f' = octpc_to_cps (4,0)--- >     ;r = (f,Pitch C Natural 4,f',f-f',to_cents (f/f'))}--- > in nearest_et_table_tone tbl_12et 256 == r-nearest_et_table_tone :: [(Pitch,Double)] -> Double -> HS_R-nearest_et_table_tone tbl f =-    case bounds_et_table tbl f of-      Nothing -> undefined-      Just ((lp,lf),(rp,rf)) ->-          let ld = f - lf-              rd = f - rf-          in if abs ld < abs rd-             then (f,lp,lf,ld,to_cents (f/lf))-             else (f,rp,rf,rd,to_cents (f/rf))--nearest_12et_tone :: Double -> HS_R-nearest_12et_tone = nearest_et_table_tone tbl_12et+import Music.Theory.Pitch {- hmt -}+import Music.Theory.Tuning.ET {- hmt -} -nearest_24et_tone :: Double -> HS_R-nearest_24et_tone = nearest_et_table_tone tbl_24et+import qualified Music.Theory.Diagram.Grid as G  -- * Cell --- | /n/-decimal places.------ > ndp 3 (1/3) == "0.333"-ndp :: Int -> Double -> String-ndp = printf "%.*f"- -- | 'G.Table_Cell' from set of 'HS_R'.-hs_r_cell :: Int -> (Int -> String) -> [HS_R] -> (Int,Int) -> G.Table_Cell-hs_r_cell n nm_f t (i,j) =-    let dp = ndp n-        (f,p,pf,fd,c) = t !! i-        e = case j of-              0 -> nm_f i-              1 -> dp f-              2 -> pitch_pp p-              3 -> dp pf-              4 -> dp fd-              5 -> dp c-              _ -> undefined+hs_r_cell :: (p -> String) -> Int -> (Int -> String) -> [HS_R p] -> (Int,Int) -> G.Table_Cell+hs_r_cell pp n nm_f t (i,j) =+    let t' = nm_f i : hs_r_pp pp n (t !! i)+        e = t' !! j     in ([],[H.cdata e])++hs_r_pitch_cell :: Int -> (Int -> String) -> [HS_R Pitch] -> (Int,Int) -> G.Table_Cell+hs_r_pitch_cell = hs_r_cell pitch_pp 

@@ -5,9 +5,9 @@  [cairo]: http://cairographics.org/ [html5]: http://www.w3.org/html5-[hmt]: http://rd.slavepianos.org/?t=hmt+[hmt]: http://rd.slavepianos.org/t/hmt -© [rohan drape][rd], 2006-2013, [gpl]+© [rohan drape][rd], 2006-2014, [gpl]  [rd]: http://rd.slavepianos.org/ [gpl]: http://gnu.org/copyleft/

@@ -1,29 +1,30 @@ Name:              hmt-diagrams-Version:           0.14+Version:           0.15 Synopsis:          Haskell Music Theory Diagrams Description:       Haskell Music Theory Diagrams License:           GPL Category:          Music-Copyright:         Rohan Drape, 2006-2013+Copyright:         Rohan Drape, 2006-2014 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental-Homepage:          http://rd.slavepianos.org/?t=hmt-diagrams-Tested-With:       GHC == 7.0.4+Homepage:          http://rd.slavepianos.org/t/hmt-diagrams+Tested-With:       GHC == 7.8.2 Build-Type:        Simple Cabal-Version:     >= 1.8  Data-files:        README  Library-  Build-Depends:   base==4.*,+  Build-Depends:   base == 4.*,                    cairo,                    colour,-                   hcg-minus==0.14.*,-                   hcg-minus-cairo==0.14.*,-                   hmt==0.14.*,-                   html-minimalist==0.14.*,+                   hcg-minus == 0.15.*,+                   hcg-minus-cairo == 0.15.*,+                   hmt == 0.15.*,+                   html-minimalist == 0.15.*,                    filepath,+                   process,                    xml   GHC-Options:     -Wall -fwarn-tabs   Exposed-modules: Music.Theory.Diagram.Grid@@ -31,7 +32,9 @@                    Music.Theory.Diagram.Render.Circular                    Music.Theory.Diagram.Render.Contour.WT                    Music.Theory.Diagram.Render.Grid+                   Music.Theory.Diagram.Render.Hinton                    Music.Theory.Diagram.Render.Path+                   Music.Theory.Diagram.Sequencer                    Music.Theory.Tuning.Table  Source-Repository  head