packages feed

hmt-diagrams (empty) → 0.14

raw patch · 10 files changed

+729/−0 lines, 10 filesdep +basedep +cairodep +coloursetup-changed

Dependencies added: base, cairo, colour, filepath, hcg-minus, hcg-minus-cairo, hmt, html-minimalist, xml

Files

+ Music/Theory/Diagram/Grid.hs view
@@ -0,0 +1,123 @@+-- | Functions for drawing grid and table structure common in music+-- theory and in compositions such as Morton Feldman's durational+-- /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 qualified Text.XML.Light as X {- xml -}++-- * Grid++-- | Real number, synonym for 'Double'.+type R = Double++-- | Point given as pair of 'R'.+type P = (R,R)++-- | Red, green and blue colour triple.+type C = (R,R,R)++-- | Cell location as row and column indices.+type L = (Int,Int)++-- | Cell+type Cell = (L,C,String)++-- | Grid+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+-- 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 (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++-- | Variant on 'grid' that constructs a single point.+--+-- > map (grid_pt (10,10) (50,10)) [(0,0),(1,1)] == [(10,10),(60,20)]+grid_pt :: (R,R) -> (R,R) -> L -> P+grid_pt (x,y) (w,h) (r,c) =+    let r' = fromIntegral r+        c' = fromIntegral c+    in (x + c' * w,y + r' * h)++-- | Displace 'P' (pointwise addition).+--+-- > displace (2,3) (1,1) == (3,4)+displace :: (R,R) -> P -> P+displace (dx,dy) (x,y) = (x+dx,y+dy)++-- | Make a bounding box from /row/ and /column/ dimensions.+mk_bbox :: (Int,Int) -> (R,R)+mk_bbox (r,c) =+    let f n = (fromIntegral n + 2) * 10+    in (f c,f r)++-- * Table++-- | A table cell is an 'X.Attr' and 'X.Content' duple.+type Table_Cell = ([X.Attr],[X.Content])++type Caption = [X.Content]++-- | Table of row order 'Table_Cell's.+type Table = (Caption,[[Table_Cell]])++-- | Construct a 'Table' with one 'X.Content' per cell.+simple_table :: Caption -> [[X.Content]] -> 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 c z = (c,map (map (\(nm,x) -> ([H.class' nm],[x]))) z)++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_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 c (m,n) f = build_table_m c (m,n) (Just . f)++-- | Render 'Table' as @HTML@ table.+table :: 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)++-- | A set of related tables.+type Table_Set = [Table]++-- | Render a 'Table_Set's in a @div@ with class @table-set@.+table_set :: 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 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']+        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 o_fn css = writeFile o_fn . page css
+ Music/Theory/Diagram/Path.hs view
@@ -0,0 +1,193 @@+-- | Functions to make /path diagrams/ such as those in Fig. VIII-11+-- on I.Xenakis /Formalized Music/.+module Music.Theory.Diagram.Path where++import Data.CG.Minus {- hcg-minus -}+import Data.Function+import Data.List+import Data.Maybe++-- * Genera++-- | Set of all /(pre,element,post)/ triples of a sequence.+--+-- > parts "abc" == [("",'a',"bc"),("a",'b',"c"),("ab",'c',"")]+parts :: [a] -> [([a],a,[a])]+parts inp =+    let f p i q = let r = (p,i,q)+                  in case q of+                       [] -> [r]+                       (q':q'') -> r : f (p ++ [i]) q' q''+    in case inp of+         (x:xs) -> f [] x xs+         [] -> []++-- | All /(element,remainder)/ pairs for a sequence.+--+-- > parts' "abc" == [('a',"bc"),('b',"ac"),('c',"ab")]+parts' :: [a] -> [(a,[a])]+parts' = let f (p,i,q) = (i,p++q) in map f . parts++-- | Gather elements with equal keys.+--+-- > gather (zip "abcba" [0..]) == [('a',[0,4]),('b',[1,3]),('c',[2])]+gather :: (Ord a) => [(a,i)] -> [(a,[i])]+gather =+    let f xs = (fst (head xs),map snd xs)+    in map f . groupBy ((==) `on` fst) . sortBy (compare `on` fst)++-- * Geometry++-- | Does either endpoint of the /lhs/ 'Ln' lie on the /rhs/ 'Ln'.+--+-- > ln_on (ln' (1/2,1/2) (1/2,1)) (ln' (0,0) (1,1)) == True+-- > ln_on (ln' (1/2,0) (1/2,1)) (ln' (0,0) (1,1)) == False+ln_on :: Ln R -> Ln R -> Bool+ln_on (Ln p q) l = pt_on_line l p || pt_on_line l q++-- | Do 'Ln's overlap in the particular sense of being 'ln_parallel'+-- and at least one endpoint of one line lying on the other.+overlap :: Ln R -> Ln R -> Bool+overlap p q = ln_parallel p q && (ln_on p q || ln_on q p)++-- | Do both points of the /rhs/ 'Ln' lie on the /lhs/ 'Ln'.+includes :: Ln R -> Ln R -> Bool+includes l (Ln p q) =+    let f = pt_on_line l+    in f p && f q++-- | 'flip' 'includes'.+is_included :: Ln R -> Ln R -> Bool+is_included = flip includes++-- | Apply /f/ to /x/ and /y/ duple of 'Pt'.+pt_fn :: ((a,a) -> b) -> Pt a -> b+pt_fn f (Pt x y) = f (x,y)++-- | Apply /f/ to /start/ and /end/ 'Pt' duple of 'Ln'.+ln_fn :: (Num a,Eq a) => ((Pt a,Pt a) -> b) -> Ln a -> b+ln_fn f (Ln p q) = f (p,q)++-- | Apply /f/ to /start/ and /end/ 'Pt's of 'Ln' and construct 'Ln'.+ln_pt_fn :: (Num a,Eq a,Num b,Eq b) => (Pt a -> Pt b) -> Ln a -> Ln b+ln_pt_fn f = ln_fn (\(p,q) -> Ln (f p) (f q))++-- | Scale set of 'Ln' to lie in area given by /(0,n)/.+to_unit :: R -> [Ln R] -> [Ln R]+to_unit m p =+    let p' = concatMap (ln_fn (\(i,j) -> [i,j])) p+        x = maximum (map pt_x p')+        y = maximum (map pt_y p')+        f n = pt_fn (\(i,j) -> Pt (i*m/n) (m - (j*m/n)))+        g n = ln_pt_fn (f n)+    in map (g (max x y)) p++-- * Orientation++-- | Enumeration of 'Vertical', 'Horizontal' and 'Diagonal'.+data Orientation a = Vertical | Horizontal | Diagonal a+                     deriving (Eq,Show)++-- | Calculate 'Orientation' of 'Ln'.+--+-- > orientation (ln' (0,0) (0,1)) == Vertical+-- > orientation (ln' (0,0) (1,0)) == Horizontal+-- > orientation (ln' (0,0) (1,1)) == Diagonal 1+orientation :: (Fractional a,Eq a) => Ln a -> Orientation a+orientation l =+    case ln_slope l of+      Nothing -> Vertical+      Just m -> if m == 0 then Horizontal else Diagonal m++-- * Shift Map++-- | A table 'Pt' and 'Orientation' set pairs.+type Shift_Map a = [(Pt a,[Orientation a])]++-- | Construct a 'Shift_Map' from a set of 'Ln's.+mk_shift_map :: [Ln R] -> Shift_Map R+mk_shift_map =+    let f i l = if overlap i l then Just (i,orientation l) else Nothing+        g (x,i,_) = mapMaybe (f i) x+        h (l0,o) = let (p,q) = ln_pt l0 in [(p,o),(q,o)]+    in gather . concatMap h . concatMap g . parts++-- | Apply 'Shift_Map' to a 'Pt'.+shift_map_pt :: Shift_Map R -> Pt R -> Pt R+shift_map_pt tbl i =+    let n = 0.1+        Pt x y = i+        g o = let x' = if Vertical `elem` o then x+n else x+                  y' = if Horizontal `elem` o then y+n else y+              in Pt x' y'+    in maybe i g (lookup i tbl)++-- | Apply 'Shift_Map' to a 'Ln'.+shift_map_ln :: Shift_Map R -> Ln R -> Ln R+shift_map_ln tbl = ln_pt_fn (shift_map_pt tbl)++-- * Shift table++-- | A table of 'Pt' pairs.+type Shift_Table a = [(Pt a,Pt a)]++-- | Make element of 'Shift_Table'.+mk_shift_tbl_m :: (Ln R,Bool) -> Maybe (Shift_Table R)+mk_shift_tbl_m (Ln p1 p2,occ) =+    if occ+    then let Pt x1 y1 = p1+             Pt x2 y2 = p2+             n = 0.1+         in if x1 == x2+            then let x = x1 + n in Just [(p1,Pt x y1),(p2,Pt x y2)]+            else let y = y1 + n in Just [(p1,Pt x1 y),(p2,Pt x2 y)]+    else Nothing++-- | Make complete 'Shift_Table'.+mk_shift_tbl :: Collision_Table -> Shift_Table R+mk_shift_tbl = concat . mapMaybe mk_shift_tbl_m++-- | Apply 'Shift_Table' to 'Ln'.+shift_table_ln :: Shift_Table R -> Ln R -> Ln R+shift_table_ln tbl =+    let f i = fromMaybe i (lookup i tbl)+    in ln_fn (\(p,q) -> Ln (f p) (f q))++-- * Collision table++-- | Table of 'Ln's indicating collisions.+type Collision_Table = [(Ln R,Bool)]++-- | Construct 'Collision_Table' for a set of 'Ln'.+mk_collision_table :: [Ln R] -> Collision_Table+mk_collision_table =+    let f (x,xs) = (x,any (is_included x) xs)+    in map f . parts'++-- | Construct 'Shift_Table' from 'Collision_Table' and shift all 'Ln'.+collision_table_rewrite :: Collision_Table -> [Ln R]+collision_table_rewrite xs =+    let tbl = mk_shift_tbl xs+    in map (shift_table_ln tbl . fst) xs++-- * Path diagram++-- | A diagram given as a set of 'Int' pairs.+type Path_Diagram = [(Int,Int)]++-- | Construct set of 'Ln' from 'Path_Diagram'.+path_diagram_ln :: Path_Diagram -> [Ln R]+path_diagram_ln xs =+    let xs' = map (pt_from_i . uncurry Pt) xs+    in zipWith Ln xs' (tail xs')++-- | 'Collision_Table' based resolution of 'Path_Diagram'.+mk_path_ct :: Path_Diagram -> [Ln R]+mk_path_ct = collision_table_rewrite . mk_collision_table . path_diagram_ln++-- | 'Shift_Map' variant of 'mk_path_ct'.+mk_path_sm :: Path_Diagram -> [Ln R]+mk_path_sm p =+    let p' = path_diagram_ln p+    in map (shift_map_ln (mk_shift_map p')) p'+
+ Music/Theory/Diagram/Render/Circular.hs view
@@ -0,0 +1,90 @@+-- | Functions for circular representations of Zn structures.+module Music.Theory.Diagram.Render.Circular where++import Data.CG.Minus {- hcg-minus -}+import Data.CG.Minus.Colour+import Data.Colour {- colour -}+import qualified Graphics.Rendering.Cairo as C {- cairo -}+import Render.CG.Minus {- hcg-minus-cairo -}++type P = Pt R++lw :: R+lw = 0.25++circle_s :: Ca -> P -> R -> C.Render ()+circle_s c i j = circle i j >> pen lw c >> C.stroke++-- > marks (2 * pi) 12+marks :: R -> Int -> [R]+marks m n =+    let i = m / fromIntegral n+    in [0,i .. m - i]++-- > marks_p 100 (2 * pi) 12+marks_p :: R -> R -> Int -> [P]+marks_p r m n =+    let f i = pt_from_polar (Pt r (i - (pi/2)))+    in map f (marks m n)++type Text_F = Maybe (Int -> String)++-- | Frame, circle at @(0,0)@ with radius /r/ and /n/ marks.+frame :: R -> Int -> Text_F -> C.Render ()+frame r n t_fn = do+  let g = 0.15+      c = toCa (g,g,g,1)+      p = marks_p r (2 * pi) n+      p' = marks_p (r * 1.1) (2 * pi) n+      t_fn' = maybe (const "") id t_fn+  circle_s c (Pt 0 0) r+  mapM_ (\i -> circle_s c i 1) p+  mapM_ (\(i,j) -> text c i 4 j) (zip p' (map t_fn' [0..n-1]))+  text c (Pt 0 0) 4 (show n)++circle_polygon :: R -> Int -> Ca -> [Int] -> C.Render ()+circle_polygon r n c x = do+  let p = marks_p r (2 * pi) n+      p' = map (p !!) x+  polygon p'+  pen lw c+  C.stroke++circle_marks :: R -> Int -> Ca -> [Int] -> C.Render ()+circle_marks r n c x = do+  let p = marks_p r (2 * pi) n+      p' = map (p !!) x+  mapM_ (\i -> circle_s c i 2) p'++circle_diagram_set :: Int -> Text_F -> [[Int]] -> C.Render ()+circle_diagram_set n t pp = do+  frame 100 n t+  let cc = [venetianRed+           ,swedishAzureBlue+           ,candlelightYellow+           ,fernGreen+           ,sepiaBrown]+      f (p,c) = do circle_polygon 100 n c p+                   circle_marks 100 n c p+  mapM_ f (zip pp (cycle (map opaque cc)))++circle_diagram :: Int -> Text_F -> [Int] -> C.Render ()+circle_diagram n t p = circle_diagram_set n t [p]++-- | Variant of 'render_to_file'.+--+-- > let s = [[0..11],[0,2..10],[0,3..9],[0,4,8]+-- >         ,[0,5,10,3,8,1,6,11,4,9,2,7]]+-- > in to_file F_SVG "/tmp/circular" (circle_diagram_set 12 (Just show) s)+--+-- > let s = [[0,5,6,7],[1,2,3,8],[4,9,10,11]]+-- > in to_file F_SVG "/tmp/circular" (circle_diagram_set 12 (Just show) s)+--+-- > let {s = [0,1,5,6,12,25,29,36,42,48,49,53]+-- >     ;t = [0,8,16,18,26,34]+-- >     ;z = map (\i -> map ((`mod` 72) . (+ i)) s) t}+-- > in to_file F_SVG "/tmp/circular" (circle_diagram_set 72 (Just show) z)+to_file :: File_Type -> FilePath -> C.Render () -> IO ()+to_file ty nm f =+  let f' = C.translate 125 125 >> f+  in render_to_file ty (250,250) nm f'
+ Music/Theory/Diagram/Render/Contour/WT.hs view
@@ -0,0 +1,94 @@+-- | Contour contact sheets.+module Music.Theory.Diagram.Render.Contour.WT where++import Control.Monad {- base -}+import Data.CG.Minus {- hcg-minus -}+import qualified Graphics.Rendering.Cairo as C {- cairo -}+import Render.CG.Minus {- hcg-minus-cairo -}+import System.FilePath {- filepath -}++data Setup = Setup {wt_nc :: Int+                   ,wt_dimensions :: (Int,Int)+                   ,wt_spacers :: (R,R)+                   ,wt_scalar :: R}++type CN = [(Bool,[Int])]+type PP = [CN]++fi :: Integral a => a -> R+fi = fromIntegral++ipt :: Integral a => a -> a -> Pt R+ipt x y = Pt (fi x) (fi y)++-- | Generate grid points.+-- l=left, u=upper, r=rows, c=columns, w=width, h=height+grid :: (R,R) -> (Int,Int) -> (R,R) -> (R,R) -> [Pt R]+grid (l,u) (r,c) (w,h) (dx,dy) =+    let xs = take r [l,l + w + dx ..]+        ys = take c [u,u + h + dy ..]+    in concatMap (\y -> zipWith Pt xs (repeat y)) ys++-- | Calculate number of rows (nr) given number of columns (nc) and+-- number of entries (ne).+calc_nr :: Integral t => t -> t -> t+calc_nr nc ne =+    let (a,b) = ne `divMod` nc+    in a + if b == 0 then 0 else 1++-- | Cairo co-ordinates are /y/ descending.+invert :: (Num a) => a -> [a] -> [a]+invert n = map (\x -> n - x)++draw_contour :: Pt R -> Bool -> [Int] -> C.Render ()+draw_contour (Pt x y) c ys = do+  let (r,g,b) = if c then (1,0,0) else (0,0,0)+      p = zipWith ipt [0..] ys+  C.save+  C.setSourceRGBA r g b 0.75+  C.setLineWidth 0.05+  C.translate x y+  line p+  C.stroke+  C.restore++draw_border :: Pt R -> (Int,Int) -> C.Render ()+draw_border (Pt x y) (w,h) = do+  let g = 0.75+  C.save+  C.setSourceRGBA g g g 0.75+  C.setLineWidth 0.05+  C.translate x y+  C.rectangle 0 0 (fi w) (fi h)+  C.stroke+  C.restore++draw_img :: Pt R -> (Int,Int) -> CN -> C.Render ()+draw_img p (w,h) xs = do+  draw_border p (w,h)+  mapM_ (\(c,ys) -> draw_contour p c (invert h ys)) xs++draw_wt :: Setup -> PP -> C.Render ()+draw_wt (Setup nc (w,h) sp sc) dd = do+  let nr = calc_nr nc (length dd)+      g = grid (1,1) (nc,nr) (fi w,fi h) sp+  C.save+  C.scale sc sc+  zipWithM_ (\d p -> draw_img p (w,h) d) dd g+  C.showPage+  C.restore++-- | Select format from extension (ie. @.pdf@ or @.svg@).+draw :: FilePath -> Setup -> [PP] -> IO ()+draw o_fn wt_f ddd = do+  let (Setup nc (w,h) (dx,dy) sc) = wt_f+      nr = calc_nr nc (maximum (map length ddd))+      w' = fi nc * (fi w + dx) + dx+      h' = fi nr * (fi h + dy) + dy+      f s = C.renderWith s (mapM_ (draw_wt wt_f) ddd)+      wr = case takeExtension o_fn of+             ".pdf" -> C.withPDFSurface+             ".svg" -> C.withSVGSurface+             _ -> undefined+  wr o_fn (w' * sc) (h' * sc) f+
+ Music/Theory/Diagram/Render/Grid.hs view
@@ -0,0 +1,30 @@+-- | Functions for drawing grid and table structure common in music+-- theory and in compositions such as Morton Feldman's durational+-- /grid/ music of the 1950's.+module Music.Theory.Diagram.Render.Grid where++import Data.CG.Minus+import Data.CG.Minus.Colour+import Data.Colour {- colour -}+import qualified Graphics.Rendering.Cairo as C {- cairo -}+import qualified Music.Theory.Diagram.Grid as T {- hmt -}+import Render.CG.Minus++-- | Render 'Grid' of /(rows,columns)/ with displacement /(dx,dy)/ in+-- indicated font size.+mk_grid :: (Int,Int) -> (R,R) -> R -> T.Grid -> C.Render ()+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_ (\(l,clr,i) -> text (opaque (toC clr)) (grid_pt' l) fs i) xs+  C.showPage++-- | Run render to @PDF@ file.+--+-- > let g = [((0,0),(1,0,0),"a"),((2,2),(0,0,1),"b")]+-- > in to_pdf "/tmp/grid.pdf" (60,60) (mk_grid (4,4) (2,8) 9 g)+to_pdf :: FilePath -> (R,R) -> C.Render () -> IO ()+to_pdf nm (w,h) f = do+  let g s = C.renderWith s f+  C.withPDFSurface nm w h g
+ Music/Theory/Diagram/Render/Path.hs view
@@ -0,0 +1,41 @@+-- | Functions to make /path diagrams/ such as those in Fig. VIII-11+-- on I.Xenakis /Formalized Music/.+module Music.Theory.Diagram.Render.Path where++import Data.CG.Minus {- hcg-minus -}+import Data.CG.Minus.Colour+import Data.Colour {- colour -}+import qualified Graphics.Rendering.Cairo as C {- cairo -}+import Music.Theory.Diagram.Path+import Render.CG.Minus.Arrow++-- * Drawing++-- | A set of 'Ca' and 'Ls' pairs.+type Path = [(Ca,Ls R)]++-- | Draw 'Path' with mid-point arrows.+draw_path :: Path -> C.Render ()+draw_path xs = do+  mapM_ (uncurry (arrows_mp 0.1 (pi/9))) xs+  C.showPage++-- | 'mapM_' 'draw_path'.+draw_paths :: [Path] -> C.Render ()+draw_paths = mapM_ draw_path++-- | 'draw_paths' to named @PDF@ file.+write_pdf :: FilePath -> [Path] -> IO ()+write_pdf fn xs = do+  let f s = C.renderWith s (C.translate 10 100 >>+                            C.scale 100 100 >>+                            draw_paths xs)+  C.withPDFSurface fn 500 500 f++-- * Path diagram++-- | Write @PDF@ of a set of 'Path_Diagram's to named file.+path_diagram :: FilePath -> [Path_Diagram] -> IO ()+path_diagram fn =+    let f (i,j) = (opaque black,[i,j])+    in write_pdf fn . map (map (ln_fn f) . to_unit 4 . mk_path_sm)
+ Music/Theory/Tuning/Table.hs view
@@ -0,0 +1,103 @@+-- | 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++nearest_24et_tone :: Double -> HS_R+nearest_24et_tone = nearest_et_table_tone tbl_24et++-- * 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+    in ([],[H.cdata e])+
+ README view
@@ -0,0 +1,13 @@+hmt-diagrams+------------++[cairo][cairo] & [html][html5] rendering of [hmt][hmt] related diagrams.++[cairo]: http://cairographics.org/+[html5]: http://www.w3.org/html5+[hmt]: http://rd.slavepianos.org/?t=hmt++© [rohan drape][rd], 2006-2013, [gpl]++[rd]: http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ hmt-diagrams.cabal view
@@ -0,0 +1,39 @@+Name:              hmt-diagrams+Version:           0.14+Synopsis:          Haskell Music Theory Diagrams+Description:       Haskell Music Theory Diagrams+License:           GPL+Category:          Music+Copyright:         Rohan Drape, 2006-2013+Author:            Rohan Drape+Maintainer:        rd@slavepianos.org+Stability:         Experimental+Homepage:          http://rd.slavepianos.org/?t=hmt-diagrams+Tested-With:       GHC == 7.0.4+Build-Type:        Simple+Cabal-Version:     >= 1.8++Data-files:        README++Library+  Build-Depends:   base==4.*,+                   cairo,+                   colour,+                   hcg-minus==0.14.*,+                   hcg-minus-cairo==0.14.*,+                   hmt==0.14.*,+                   html-minimalist==0.14.*,+                   filepath,+                   xml+  GHC-Options:     -Wall -fwarn-tabs+  Exposed-modules: Music.Theory.Diagram.Grid+                   Music.Theory.Diagram.Path+                   Music.Theory.Diagram.Render.Circular+                   Music.Theory.Diagram.Render.Contour.WT+                   Music.Theory.Diagram.Render.Grid+                   Music.Theory.Diagram.Render.Path+                   Music.Theory.Tuning.Table++Source-Repository  head+  Type:            darcs+  Location:        http://rd.slavepianos.org/sw/hmt-diagrams