--
-- Miguel's Simple SVG Generator 
-- 
-- Author:      Michal Idziorek <m.i@gmx.at>
-- Last Update: May 11th, 2018
--

{-# LANGUAGE ExistentialQuantification #-}

module SimpleSvg (

            svgGenerate    -- canvas to svg

            ,svgEmpty       -- empty canvas
            ,svgAdd         -- add to canvas (single)
            ,svgAddList     -- add to canvas (list)
            
            ,svgCircle      -- circle
            ,svgLine        -- line
            ,svgTriangle    -- trianvle

            ,svgFilledCircle      -- filled circle
            ,svgFilledLine        -- filled line
            ,svgFilledTriangle    -- filled trianvle

            ,svgColor             -- colors and shades of gray
            ,svgRed
            ,svgGreen
            ,svgBlue
            ,svgWhite
            ,svgBlack
            ,svgShGray


            ,svgRedLine           -- red line
            ,svgBluePoint         -- small blue circle
            ,svgGreenTriangle     -- green triangle


        ) where

-- CONFIG --

svgStrokeWidth = 2

-- SHAPES --

-- A few predefined shapes easing a quickstart as well as serving as an
-- example, for how to define them in your own code.

svgRedLine       = svgLine svgRed
svgBluePoint pos = svgCircle svgBlue pos 2
svgGreenTriangle = svgTriangle svgGreen

-- Shape construction

svgLine c (x1,y1) (x2,y2) = 
    svgShape c (SvgLine (svgCoord x1 y1) (svgCoord x2 y2))

svgCircle c (x,y) r = 
    svgShape c (SvgCircle (svgCoord x y) r)

svgTriangle c (x1,y1) (x2,y2) (x3,y3)=
    svgShape c (SvgTriangle (svgCoord x1 y1) (svgCoord x2 y2) (svgCoord x3 y3))

svgFilledLine c1 c2 (x1,y1) (x2,y2) =
    svgFilledShape c1 c2 (SvgLine (svgCoord x1 y1) (svgCoord x2 y2))

svgFilledCircle c1 c2 (x,y) r = 
    svgFilledShape c1 c2 (SvgCircle (svgCoord x y) r)

svgFilledTriangle c1 c2 (x1,y1) (x2,y2) (x3,y3)= 
    svgFilledShape c1 c2 (SvgTriangle (svgCoord x1 y1) (svgCoord x2 y2) (svgCoord x3 y3))

svgShape c1 = SvgPrim c1 (svgNoFill)
svgFilledShape c1 c2 = SvgPrim c1 (svgFill c2)

-- CANVAS --

data SvgCanvas = SvgCanvas SvgColor Int Int [SvgPrim]

svgEmpty   c w h                   = SvgCanvas c w h []
svgAdd     (SvgCanvas c w h xs) x  = SvgCanvas c w h (x:xs)
svgAddList (SvgCanvas c w h xs) ys = SvgCanvas c w h (reverse ys++xs)

svgGenerate (SvgCanvas col width height prims) = 
            xml_enc "svg" [("height",show height),("width", show width),
                           ("style","background-color:"++svgGenColor col)] 
                           body
            where body = foldl f "" prims
                  f a x = primToSvg x++a

-- COLORS --

-- color type along with a few predefined colors to work with

newtype SvgColor = SvgColor     (Int,Int,Int)
svgColor r g b   = SvgColor     (r,g,b)
svgRed           = svgColor     255 0   0 
svgBlue          = svgColor     0   0   255
svgGreen         = svgColor     0   255 0 
svgShGray v      = svgColor     v   v   v 
svgBlack         = svgShGray    0
svgWhite         = svgShGray    255

svgGenColor (SvgColor (r,g,b)) = "rgb("++show r++","++show g++","++show b++")"

-- the fill color is wrapped inside a Maybe type, since it is optional

newtype SvgFill = SvgFill (Maybe SvgColor)
svgFill col     = SvgFill (Just col)
svgNoFill       = SvgFill Nothing

-- SHAPES --

-- A class for shapes that we want to transform into SVG
-- We define instances for circle, line and triangle
-- The 2D coordinates are wrapped inside a newtype SvgCoord

newtype SvgCoord = SvgCoord (Double,Double)
svgCoord x y = SvgCoord (x,y)

data SvgPrim = forall a.SvgPrimClass a => SvgPrim SvgColor SvgFill a 

class SvgPrimClass a where
      getSvg :: a->(String,[(String,String)])

data SvgCircle = SvgCircle SvgCoord Double
instance SvgPrimClass SvgCircle where 
    getSvg (SvgCircle (SvgCoord (x,y)) r) = 
                    ("circle", [("cx",show x),("cy",show y),("r",show r)])
                                    
data SvgLine = SvgLine SvgCoord SvgCoord
instance SvgPrimClass SvgLine where
    getSvg (SvgLine (SvgCoord (x1,y1)) (SvgCoord (x2,y2))) = 
                   ("line", [("x1",show x1),("y1",show y1),
                             ("x2",show x2),("y2",show y2)])

data SvgTriangle = SvgTriangle SvgCoord SvgCoord SvgCoord
instance SvgPrimClass SvgTriangle where
    getSvg (SvgTriangle (SvgCoord (x1,y1)) (SvgCoord (x2,y2)) (SvgCoord (x3,y3))) = 
                   ("polygon", [("points",pts)])
                   where pts=show x1++","++show y1++" "++
                             show x2++","++show y2++" "++
                             show x3++","++show y3

-- transform single primitve to SVG
primToSvg (SvgPrim col (SvgFill fill) prim) = xml_enc tag (attrs++attrs2) ""
                        where (tag, attrs)=getSvg prim
                              attrs2=[ ("fill",maybe "none" svgGenColor fill)
                                      ,("stroke",svgGenColor col)
                                      ,("stroke-width",show svgStrokeWidth)]

-- XML ENCODER --
 
xml_enc tag attrs body = "<"++tag++" "++xml_attrs++">"++body++"</"++tag++">"
                  where xml_attrs = unlines $ map xml_attr attrs
                        xml_attr (a,v) = a++"=\""++v++"\" "