Hinton.hs

-- | 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