{-|
  This module produces simple representations of Pitch Class Sets
  suitable for use in Scalable Vector Graphics.  By default it
  does not generate the files -- instead, it generates a printable
  string, which can be captured to standard output or directed to
  a file at your discretion.
-}
module Data.PcSets.Svg
  (
    -- * Simple Usage
      pcSvg
    , pcSvgAx
    -- * Advanced Usage
    , pcSvg'
    , pcSvgAx'
    -- * Rendering Style
    , Rendering (Rendering, pxSize, lnColor, psColor, csColor,
                 axColor, relMain, relElem, relAxis)
    -- ** Default Rendering Values
    , stdRen
  )
where

import qualified Data.PcSets as P

-- | The basic idea: generate SVG data for an input pitch class set.
pcSvg :: (P.PcSet a) => a -> String
pcSvg = pcSvg' stdRen

-- | Same as 'pcSvg', but includes an /invertXY/ style axis.
pcSvgAx :: (P.PcSet a) => a -> (Int,Int) -> String
pcSvgAx = pcSvgAx' stdRen

-- | Same as 'pcSvg' but allows a custom 'Rendering'.
pcSvg' :: (P.PcSet a) => Rendering -> a -> String
pcSvg' ren ps = svgHeader ++ show (toSvg ren ps parts)
  where parts = [psFrame,psCircle]

-- | Same as 'pcSvgAx', but allows a custom 'Rendering'.
pcSvgAx' :: (P.PcSet a) => Rendering -> a -> (Int,Int) -> String
pcSvgAx' ren ps invAx = svgHeader ++ show (toSvg ren ps parts)
  where parts = [psFrame, psAxis invAx ps, psCircle]

-- | Stores the rendering information for the SVG file.
data Rendering = Rendering
  {
    pxSize  :: Int,    -- ^ sets the (square) image dimensions
    lnColor :: String, -- ^ line color for the main structures
    psColor :: String, -- ^ pitch class set color
    csColor :: String, -- ^ complementary set color
    axColor :: String, -- ^ axis color
    relMain :: Float,  -- ^ proportion of main circle compared to image
    relElem :: Float,  -- ^ proportion of elements compared to main circle
    relAxis :: Float   -- ^ proportion of axis (if any) compared to image
  }

{-|
  The Standard 'Rendering' is a 500x500 image using black lines, with
  elements of the set in red, the complement in black, and any axis in
  blue.  The pitch class set circle is 80% of the frame, each element
  is 10% of the main circle's size, and any axis is 95% frame size.
-}
stdRen :: Rendering
stdRen = Rendering
  {
    pxSize = 500,
    lnColor = "black",
    psColor = "red",
    csColor = "black",
    axColor = "blue",
    relMain = 0.80,
    relElem = 0.10,
    relAxis = 0.95
  }

data Attr = Attr String String

instance Show Attr where
  show (Attr n v) = n ++ "=\"" ++ v ++ "\""

attrs :: [Attr] -> String
attrs as = unwords [show a | a <- as]

nattr :: String -> Int -> Attr
nattr s = Attr s . show -- 'numerical attributes'

data Tag = Tag String [Attr]

instance Show Tag where
  show (Tag n as) = "<" ++ n ++ " " ++ attrs as ++ "/>"

data PTag = PTag String [Attr] [Tag]

instance Show PTag where
  show (PTag n as ts) = "<" ++ n ++ " " ++ attrs as
      ++ ">\n" ++ tags ++ "</" ++ n ++ ">"
    where tags = unlines [show t | t <- ts]

circle :: (Int,Int) -> Int -> String -> Int -> String -> Tag
circle (cx,cy) r s sw f =
  Tag "circle" [nattr "cx" cx, nattr "cy" cy, nattr "r" r,
    Attr "stroke" s, nattr "stroke-width" sw, Attr "fill" f]

line :: (Int,Int) -> (Int,Int) -> String -> Int -> String -> Tag
line (x1,y1) (x2,y2) s sw sd =
  Tag "line" [nattr "x1" x1, nattr "y1" y1,
             nattr "x2" x2, nattr "y2" y2,
             Attr "stroke" s, nattr "stroke-width" sw,
             Attr "stroke-dasharray" sd]

rect :: (Int,Int) -> (Int,Int) -> String -> Int -> String -> Tag
rect (x,y) (w,h) s sw f =
  Tag "rect" [nattr "x" x, nattr "y" y,
             nattr "width" w, nattr "height" h,
             Attr "stroke" s, nattr "stroke-width" sw,
             Attr "fill" f]

svgHeader :: String
svgHeader = "<?xml version=\"1.0\" standalone=\"no\"?>\n" ++
            "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\" " ++
            "\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">\n"

svg :: (Int,Int) -> [Tag] -> PTag
svg (w,h) ts =
  PTag "svg" stdatt ts
    where
      stdatt = [nattr "width" w,
               nattr "height" h,
               Attr "version" "1.1",
               Attr "xmlns" "http://www.w3.org/2000/svg"]

ctr :: Rendering -> Int
ctr ren = pxSize ren `div` 2

ctrxy :: Rendering -> (Int,Int)
ctrxy ren = (ctr ren, ctr ren)

frameSize :: Rendering -> (Int,Int)
frameSize ren = (p,p)
  where p = pxSize ren

mainRad :: Rendering -> Float
mainRad ren = relMain ren * fromIntegral (pxSize ren) / 2

axisRad :: Rendering -> Float
axisRad ren = relAxis ren * fromIntegral (pxSize ren) / 2

elemRad :: Rendering -> Float
elemRad ren = relElem ren * mainRad ren

phase :: Int -> Int -> Float
phase t m = 2 * pi * fromIntegral t / fromIntegral m

pos :: Int -> Int -> Rendering -> (Rendering -> Float) -> (Int,Int)
pos t m ren radf = (x,y)
  where
    r = radf ren
    x = ctr ren + round (r * sin (phase t m))
    y = ctr ren - round (r * cos (phase t m))

psFrame :: Rendering -> Tag
psFrame ren = rect (1,1) (frameSize ren) "none" 1 "none"

psCircle :: Rendering -> Tag
psCircle ren = circle (ctrxy ren) (round r) (lnColor ren) 2 "none"
  where r = mainRad ren

psElements :: (P.PcSet a) => a -> Rendering -> [Tag]
psElements ps ren = if m == 0 then [] else map f [0..(m-1)]
  where
    m = P.modulus ps
    es = P.elements ps
    f t = circle (p t) (round r) (lnColor ren) 1 (onOff t ren)
    p t = pos t m ren mainRad
    r = elemRad ren
    onOff t = if t `elem` es then psColor else csColor

psAxis :: (P.PcSet a) => (Int,Int) -> a -> Rendering -> Tag
psAxis (x,y) ps ren =
    line (p t1) (p t2) (axColor ren) 1 "9, 3, 3, 3"
  where
    m = P.modulus ps
    p t = pos t (m * 2) ren axisRad
    t1 = x + y
    t2 = x + y + m

toSvg :: (P.PcSet a) => Rendering -> a -> [(Rendering -> Tag)] -> PTag
toSvg ren ps parts = svg (frameSize ren) tags
  where
    tags = map ($ ren) parts ++ psElements ps ren