diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ + +Copyright (c) 2013, Hans Höglund +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/music-graphics.cabal b/music-graphics.cabal new file mode 100644 --- /dev/null +++ b/music-graphics.cabal @@ -0,0 +1,41 @@ + +name: music-graphics +version: 1.6 +cabal-version: >= 1.10 +author: Hans Hoglund +maintainer: Hans Hoglund +license: BSD3 +license-file: COPYING +synopsis: Diagrams-based visualization of musical data structures. +category: +tested-with: GHC +build-type: Simple + +description: + To be written. + +source-repository head + type: git + location: git://github.com/music-suite/music-graphics.git + +library + build-depends: + base >= 4 && < 5, + music-score == 1.6, + music-pitch == 1.6, + diagrams-core >= 0.6, + diagrams-svg >= 0.6, + bytestring, + blaze-svg, + process, + lens, + + -- DEBUG + music-preludes == 1.6, + + diagrams-lib >= 0.6 + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Music.Graphics + Music.Graphics.Diagrams diff --git a/src/Music/Graphics.hs b/src/Music/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Music/Graphics.hs @@ -0,0 +1,6 @@ + +module Music.Graphics ( + module Music.Graphics.Diagrams +) where + +import Music.Graphics.Diagrams diff --git a/src/Music/Graphics/Diagrams.hs b/src/Music/Graphics/Diagrams.hs new file mode 100644 --- /dev/null +++ b/src/Music/Graphics/Diagrams.hs @@ -0,0 +1,79 @@ + +{-# 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