added my simple haskell svg generator

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