diff --git a/Music/Theory/Diagram/Grid.hs b/Music/Theory/Diagram/Grid.hs --- a/Music/Theory/Diagram/Grid.hs +++ b/Music/Theory/Diagram/Grid.hs @@ -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 diff --git a/Music/Theory/Diagram/Render/Grid.hs b/Music/Theory/Diagram/Render/Grid.hs --- a/Music/Theory/Diagram/Render/Grid.hs +++ b/Music/Theory/Diagram/Render/Grid.hs @@ -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 diff --git a/Music/Theory/Diagram/Render/Hinton.hs b/Music/Theory/Diagram/Render/Hinton.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Diagram/Render/Hinton.hs @@ -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 diff --git a/Music/Theory/Diagram/Sequencer.hs b/Music/Theory/Diagram/Sequencer.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Diagram/Sequencer.hs @@ -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 diff --git a/Music/Theory/Tuning/Table.hs b/Music/Theory/Tuning/Table.hs --- a/Music/Theory/Tuning/Table.hs +++ b/Music/Theory/Tuning/Table.hs @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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/ diff --git a/hmt-diagrams.cabal b/hmt-diagrams.cabal --- a/hmt-diagrams.cabal +++ b/hmt-diagrams.cabal @@ -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