toSVG :: Array (Int,Int) (Cell Char) -> SVG
toSVG table =
    let (_, (m,n)) = bounds table
        -- square edge width
        sqmeasure  = 50.0 :: Float
        rmeasure   =  5.0
        -- stroke line width:
        smeasure   =  1.0
        width      = sqmeasure * fromIntegral m
        height     = sqmeasure * fromIntegral n
        valmaxf    = fromIntegral $ maximum (map val (elems table))
        palette    = cycle [red, yello, green, cyan, blu, purpl]
        s_path     = S.toList (successpath table)
    in
      SVG $ 
      mkTag "svg"
       [("xmlns","http://www.w3.org/2000/svg"), ("width", show width), ("height", show height)
       ,("viewBox", show (-0.5*sqmeasure) ++ " " ++ show (-0.5*sqmeasure) ++ " " ++ show (width + 1*sqmeasure) ++ " " ++ show (height + 1*sqmeasure))
       ]
       $
       -- white background
       [ Left (mkTag "rect" [("x", show $ -0.5*sqmeasure),
                             ("y", show $ -0.5*sqmeasure),
                             ("width", show $ width + 1*sqmeasure),
                             ("height", show $ height + 1*sqmeasure),
                             ("fill", "white")
                            ] [])]
       ++
       -- horizontal lettering
       [ Left (mkTag "text"
               [("x", show x), ("y", show (-sqmeasure/4)),
                ("fill", rgb 0.0 0.0 0.0)
               ]
               [Right $ XMLString c])
       | i <- [1..m]
       , let c = case reasons (table ! (i, 0)) of [X c] -> [c] ; _ -> ""
       , let x = fromIntegral i * sqmeasure - 0.5 * sqmeasure ]
       ++
       -- vertical lettering
       [ Left (mkTag "text"
               [("y", show y), ("x", show (-sqmeasure/4)),
                ("fill", rgb 0.0 0.0 0.0)
               ]
               [Right $ XMLString c])
       | j <- [1..n]
       , let c = case reasons (table ! (0, j)) of [Y c] -> [c] ; _ -> ""
       , let y = fromIntegral j * sqmeasure - 0.5 * sqmeasure ]
       ++
       -- little square tiles
       [ Left (mkTag "rect"
               [("x", show rx), ("y", show ry),
                ("width", show sqmeasure),
                ("height", show sqmeasure),
                ("fill", color),
                ("fill-opacity", show 1.0),
                ("stroke", color),
                ("stroke-width", show smeasure)
               ] [])
       | i <- [0..m-1], j <- [0..n-1]
       , let rx = fromIntegral i * sqmeasure
       , let ry = fromIntegral j * sqmeasure
       , let vf = fromIntegral $ val (table ! (i+1,j+1))
       , let shade = vf / valmaxf
       , let color = rgb shade shade shade ]
       ++
       -- highlight successful path(s)
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | ((i',j'), (i,j)) <- s_path
       -- a nice possibility: draw a thicker line first
       , let s'measure = 5.0
       , let x1 = fromIntegral i' * sqmeasure
       , let y1 = fromIntegral j' * sqmeasure
       , let x2 = fromIntegral i  * sqmeasure
       , let y2 = fromIntegral j  * sqmeasure
       , let color = rgb 0.0 0.0 1.0 ]
       ++
       -- dashed lines for same letter
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)
               ,("stroke-dasharray", show 5)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Eq _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       -- horizontal
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral (j+1) * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (X _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       -- vertical
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral (i+1) * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Y _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j))]
       ++
       -- diagonal, different letter
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Neq _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       [ Left (mkTag "circle"
               [("cx", show cx), ("cy", show cy), ("r", show rmeasure),
                ("fill", rgb 0.0 0.0 (vf / valmaxf)),
                ("fill-opacity", show 1)
               ] [])
       | i <- [0..m], j <- [0..n]
       , let cx = fromIntegral i * sqmeasure
       , let cy = fromIntegral j * sqmeasure
       , let vf = fromIntegral $ val (table ! (i,j)) ]
toSVG :: Array (Int,Int) (Cell Char) -> SVG
toSVG table =
    let (_, (m,n)) = bounds table
        -- square edge width
        sqmeasure  = 50.0 :: Float
        rmeasure   =  5.0
        -- stroke line width:
        smeasure   =  1.0
        width      = sqmeasure * fromIntegral m
        height     = sqmeasure * fromIntegral n
        valmaxf    = fromIntegral $ maximum (map val (elems table))
        palette    = cycle [red, yello, green, cyan, blu, purpl]
        s_path     = S.toList (successpath table)
    in
      SVG $ 
      mkTag "svg"
       [("xmlns","http://www.w3.org/2000/svg"), ("width", show width), ("height", show height)
       ,("viewBox", show (-0.5*sqmeasure) ++ " " ++ show (-0.5*sqmeasure) ++ " " ++ show (width + 1*sqmeasure) ++ " " ++ show (height + 1*sqmeasure))
       ]
       $
       -- white background
       [ Left (mkTag "rect" [("x", show $ -0.5*sqmeasure),
                             ("y", show $ -0.5*sqmeasure),
                             ("width", show $ width + 1*sqmeasure),
                             ("height", show $ height + 1*sqmeasure),
                             ("fill", "white")
                            ] [])]
       ++
       -- horizontal lettering
       [ Left (mkTag "text"
               [("x", show x), ("y", show (-sqmeasure/4)),
                ("fill", rgb 0.0 0.0 0.0)
               ]
               [Right $ XMLString c])
       | i <- [1..m]
       , let c = case reasons (table ! (i, 0)) of [X c] -> [c] ; _ -> ""
       , let x = fromIntegral i * sqmeasure - 0.5 * sqmeasure ]
       ++
       -- vertical lettering
       [ Left (mkTag "text"
               [("y", show y), ("x", show (-sqmeasure/4)),
                ("fill", rgb 0.0 0.0 0.0)
               ]
               [Right $ XMLString c])
       | j <- [1..n]
       , let c = case reasons (table ! (0, j)) of [Y c] -> [c] ; _ -> ""
       , let y = fromIntegral j * sqmeasure - 0.5 * sqmeasure ]
       ++
       -- little square tiles
       [ Left (mkTag "rect"
               [("x", show rx), ("y", show ry),
                ("width", show sqmeasure),
                ("height", show sqmeasure),
                ("fill", color),
                ("fill-opacity", show 1.0),
                ("stroke", color),
                ("stroke-width", show smeasure)
               ] [])
       | i <- [0..m-1], j <- [0..n-1]
       , let rx = fromIntegral i * sqmeasure
       , let ry = fromIntegral j * sqmeasure
       , let vf = fromIntegral $ val (table ! (i+1,j+1))
       , let shade = vf / valmaxf
       , let color = rgb shade shade shade ]
       ++
       -- highlight successful path(s)
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | ((i',j'), (i,j)) <- s_path
       -- a nice possibility: draw a thicker line first
       , let s'measure = 5.0
       , let x1 = fromIntegral i' * sqmeasure
       , let y1 = fromIntegral j' * sqmeasure
       , let x2 = fromIntegral i  * sqmeasure
       , let y2 = fromIntegral j  * sqmeasure
       , let color = rgb 0.0 0.0 1.0 ]
       ++
       -- dashed lines for same letter
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)
               ,("stroke-dasharray", show 5)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Eq _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       -- horizontal
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral (j+1) * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (X _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       -- vertical
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral (i+1) * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Y _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j))]
       ++
       -- diagonal, different letter
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Neq _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       [ Left (mkTag "circle"
               [("cx", show cx), ("cy", show cy), ("r", show rmeasure),
                ("fill", rgb 0.0 0.0 (vf / valmaxf)),
                ("fill-opacity", show 1)
               ] [])
       | i <- [0..m], j <- [0..n]
       , let cx = fromIntegral i * sqmeasure
       , let cy = fromIntegral j * sqmeasure
       , let vf = fromIntegral $ val (table ! (i,j)) ]
toSVG table =
    let (_, (m,n)) = bounds table
        -- square edge width
        sqmeasure  = 50.0 :: Float
        rmeasure   =  5.0
        -- stroke line width:
        smeasure   =  1.0
        width      = sqmeasure * fromIntegral m
        height     = sqmeasure * fromIntegral n
        valmaxf    = fromIntegral $ maximum (map val (elems table))
        palette    = cycle [red, yello, green, cyan, blu, purpl]
        s_path     = S.toList (successpath table)
    in
      SVG $ 
      mkTag "svg"
       [("xmlns","http://www.w3.org/2000/svg"), ("width", show width), ("height", show height)
       ,("viewBox", show (-0.5*sqmeasure) ++ " " ++ show (-0.5*sqmeasure) ++ " " ++ show (width + 1*sqmeasure) ++ " " ++ show (height + 1*sqmeasure))
       ]
       $
       -- white background
       [ Left (mkTag "rect" [("x", show $ -0.5*sqmeasure),
                             ("y", show $ -0.5*sqmeasure),
                             ("width", show $ width + 1*sqmeasure),
                             ("height", show $ height + 1*sqmeasure),
                             ("fill", "white")
                            ] [])]
       ++
       -- horizontal lettering
       [ Left (mkTag "text"
               [("x", show x), ("y", show (-sqmeasure/4)),
                ("fill", rgb 0.0 0.0 0.0)
               ]
               [Right $ XMLString c])
       | i <- [1..m]
       , let c = case reasons (table ! (i, 0)) of [X c] -> [c] ; _ -> ""
       , let x = fromIntegral i * sqmeasure - 0.5 * sqmeasure ]
       ++
       -- vertical lettering
       [ Left (mkTag "text"
               [("y", show y), ("x", show (-sqmeasure/4)),
                ("fill", rgb 0.0 0.0 0.0)
               ]
               [Right $ XMLString c])
       | j <- [1..n]
       , let c = case reasons (table ! (0, j)) of [Y c] -> [c] ; _ -> ""
       , let y = fromIntegral j * sqmeasure - 0.5 * sqmeasure ]
       ++
       -- little square tiles
       [ Left (mkTag "rect"
               [("x", show rx), ("y", show ry),
                ("width", show sqmeasure),
                ("height", show sqmeasure),
                ("fill", color),
                ("fill-opacity", show 1.0),
                ("stroke", color),
                ("stroke-width", show smeasure)
               ] [])
       | i <- [0..m-1], j <- [0..n-1]
       , let rx = fromIntegral i * sqmeasure
       , let ry = fromIntegral j * sqmeasure
       , let vf = fromIntegral $ val (table ! (i+1,j+1))
       , let shade = vf / valmaxf
       , let color = rgb shade shade shade ]
       ++
       -- highlight successful path(s)
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | ((i',j'), (i,j)) <- s_path
       -- a nice possibility: draw a thicker line first
       , let s'measure = 5.0
       , let x1 = fromIntegral i' * sqmeasure
       , let y1 = fromIntegral j' * sqmeasure
       , let x2 = fromIntegral i  * sqmeasure
       , let y2 = fromIntegral j  * sqmeasure
       , let color = rgb 0.0 0.0 1.0 ]
       ++
       -- dashed lines for same letter
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)
               ,("stroke-dasharray", show 5)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Eq _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       -- horizontal
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral (j+1) * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (X _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       -- vertical
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral (i+1) * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Y _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j))]
       ++
       -- diagonal, different letter
       [ Left (mkTag "line"
               [("x1", show x1)
               ,("y1", show y1)
               ,("x2", show x2)
               ,("y2", show y2)
               ,("stroke", color)
               ,("stroke-width", show s'measure)]
               [])
       | i <- [0..m-1], j <- [0..n-1]
       , let s'measure = smeasure
       , let x1 = fromIntegral i * sqmeasure
       , let y1 = fromIntegral j * sqmeasure
       , let x2 = fromIntegral (i+1) * sqmeasure
       , let y2 = fromIntegral (j+1) * sqmeasure
       , let rr = reasons (table ! (i+1,j+1))
       , any (\x -> case x of (Neq _) -> True ; _ -> False) rr
       , let color = palette !! val (table ! (i, j)) ]
       ++
       [ Left (mkTag "circle"
               [("cx", show cx), ("cy", show cy), ("r", show rmeasure),
                ("fill", rgb 0.0 0.0 (vf / valmaxf)),
                ("fill-opacity", show 1)
               ] [])
       | i <- [0..m], j <- [0..n]
       , let cx = fromIntegral i * sqmeasure
       , let cy = fromIntegral j * sqmeasure
       , let vf = fromIntegral $ val (table ! (i,j)) ]