Diagrams.hs

{-# LANGUAGE NoMonomorphismRestriction, TypeFamilies, FlexibleContexts #-}

module Music.Graphics.Diagrams (
        draw,
        writeGraphic,
        openGraphic
) where

import Music.Score
import Music.Pitch
import Diagrams.Prelude hiding (Time, Duration)
import qualified Diagrams.Backend.SVG as SVG

-- test       
import Music.Prelude.Basic
import Control.Lens
import System.Process
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
import qualified Data.ByteString.Lazy as ByteString


timeToDouble :: Time -> Double
timeToDouble = realToFrac . (.-. origin)
durationToDouble :: Duration -> Double
durationToDouble = realToFrac
pitchToDouble :: Music.Pitch.Pitch -> Double
pitchToDouble = realToFrac . semitones . (.-. c)

draw :: (Renderable (Path R2) b, Real a) => Score a -> Diagram b R2
draw = bg whitesmoke . scaleX 20{-TODO-} . mconcat . fmap drawNote . fmap (map1 timeToDouble . map2 durationToDouble . map3 realToFrac) . (^. events)
    where
        map1 f (a,b,c) = (f a,b,c)
        map2 f (a,b,c) = (a,f b,c)
        map3 f (a,b,c) = (a,b,f c)
        drawNote (t,d,x) = translateY x $ translateX (t.+^(d^/2)) $ scaleX d $ noteShape
        noteShape = lcA transparent $ fcA (blue  `withOpacity` 0.5) $ square 1

writeGraphic :: FilePath -> Score Double -> IO ()
writeGraphic path x = do
    let dia = draw x
    let svg = renderDia SVG.SVG (SVG.SVGOptions (Dims 1800 (1800/20)) Nothing) dia
    let bs  = renderSvg svg
    ByteString.writeFile path bs
        
openGraphic :: Score Double -> IO ()
openGraphic x = do
    writeGraphic "test.svg" x
    -- FIXME find best reader
    system "open -a Firefox test.svg"
    return ()

-- drawScores
--     :: (Integral p, p ~ Pitch b, HasPitch b, Voice b ~ NotePart, HasVoice b)
--     => Score b -> Score c -> Diagram SVG R2
-- drawScores notes cmds = notes1D <> notes2D <> cmdsD <> middleLines <> crossLines
--     where
--         notes1 = mfilter (\x -> getPartGroup (getVoice x) == 1) notes
--         notes2 = mfilter (\x -> getPartGroup (getVoice x) == 2) notes
-- 
--         notes1D     = mconcat $ fmap (drawNote 1) $ perform notes1
--         notes2D     = mconcat $ fmap (drawNote 2) $ perform notes2
--         cmdsD       = mconcat $ fmap drawCmd $ perform cmds
--         middleLines = translateX ((/ 2) $ totalDur) (hrule $ totalDur)
--         crossLines  = mconcat $ fmap (\n -> translateX ((totalDur/5) * n) (vrule 100)) $ [0..5]
-- 
--         drawNote n (t,d,x) = translateY (getP x + off n) $ translateX (getT (t.+^(d^/2))) $ scaleX (getD d) $ noteShape n
--         off 1 = 50
--         off 2 = (-50)
--         drawCmd (t,d,x) = translateY 0 $ translateX (getT t) $ cmdShape
-- 
--         noteShape 1 = lcA transparent $ fcA (blue  `withOpacity` 0.3) $ square 1
--         noteShape 2 = lcA transparent $ fcA (green `withOpacity` 0.3) $ square 1
--         cmdShape = lcA (red `withOpacity` 0.3) $ vrule (200)
-- 
--         totalDur = getD $ duration notes
--         getT = fromRational . toRational
--         getD = fromRational . toRational
--         getP = (subtract 60) . fromIntegral . getPitch