diff options
Diffstat (limited to 'simpleSVG')
| -rw-r--r-- | simpleSVG/SimpleSvg.hs | 158 | ||||
| -rw-r--r-- | simpleSVG/TestSvg.hs | 16 |
2 files changed, 174 insertions, 0 deletions
diff --git a/simpleSVG/SimpleSvg.hs b/simpleSVG/SimpleSvg.hs new file mode 100644 index 0000000..80fdf1b --- /dev/null +++ b/simpleSVG/SimpleSvg.hs @@ -0,0 +1,158 @@ +-- +-- 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++"\" " diff --git a/simpleSVG/TestSvg.hs b/simpleSVG/TestSvg.hs new file mode 100644 index 0000000..cb075d1 --- /dev/null +++ b/simpleSVG/TestSvg.hs @@ -0,0 +1,16 @@ +-- can be run simply via: stack runghc TestSvg.hs > example1.svg + +import SimpleSvg + +svgExample1 = svgAddList (svgEmpty (svgShGray 200) 300 200) $ + [ svgRedLine (0,0) (200,200) + ,svgRedLine (300,0) (100,200) + ,svgBluePoint (33,133) + ,svgBluePoint (33,22) + ,svgBluePoint (66,25) + ,svgFilledTriangle svgBlack svgWhite (20,20) (100,100) (10,90) + ,svgFilledCircle svgWhite svgGreen (150,120) 30 + ]++ + map (svgBluePoint . (,) 250) [50,60..150] + +main = putStr $ svgGenerate svgExample1 |