79 lines
2.7 KiB
Haskell
79 lines
2.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Svg (drawMap) where
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import Graphics.Svg
|
|
import Text.Printf (printf)
|
|
import Types (Area (..), ByArea (..))
|
|
|
|
drawMap :: Text -> [Area t] -> ByArea t Double -> Element
|
|
drawMap fillColor areas statistics =
|
|
doctype <> with (svg11_ content) [Version_ <<- "1.1", Width_ <<- "650", Height_ <<- "900"]
|
|
where
|
|
theMaximum = maximum $ getByArea statistics
|
|
localize = Text.replace "." "," . Text.dropWhileEnd (== '.') . Text.dropWhileEnd (== '0')
|
|
showRounded = Text.pack . printf "%.2f"
|
|
frameColor = "grey"
|
|
areaPaths =
|
|
foldMap
|
|
( \area ->
|
|
let count = fromMaybe 0 (Map.lookup (key area) (getByArea statistics))
|
|
in path_
|
|
[ Stroke_ <<- frameColor
|
|
, Fill_ <<- fillColor
|
|
, Fill_opacity_ <<- showRounded (if count == 0 then 0 else count / theMaximum)
|
|
, D_ <<- path area
|
|
]
|
|
( title_
|
|
[]
|
|
( toElement $
|
|
name area <> ": " <> localize (showRounded count)
|
|
)
|
|
)
|
|
)
|
|
areas
|
|
content =
|
|
defs_
|
|
[]
|
|
( linearGradient_
|
|
[ Id_ <<- "legend"
|
|
, X1_ <<- "0"
|
|
, X2_ <<- "1"
|
|
, Y1_ <<- "0"
|
|
, Y2_ <<- "0"
|
|
]
|
|
( stop_ [Offset_ <<- "0%", Stop_color_ <<- "white"]
|
|
<> stop_ [Offset_ <<- "100%", Stop_color_ <<- fillColor]
|
|
)
|
|
)
|
|
<> g_
|
|
[]
|
|
( rect_
|
|
[ X_ <<- "150"
|
|
, Y_ <<- "880"
|
|
, Stroke_ <<- frameColor
|
|
, Width_ <<- "350"
|
|
, Height_ <<- "10"
|
|
, Fill_ <<- "url(#legend)"
|
|
]
|
|
<> text_
|
|
[ X_ <<- "135"
|
|
, Y_ <<- "890"
|
|
, Font_size_ <<- "18"
|
|
, Fill_ <<- "black"
|
|
]
|
|
"0"
|
|
<> text_
|
|
[ X_ <<- "510"
|
|
, Y_ <<- "890"
|
|
, Font_size_ <<- "18"
|
|
, Fill_ <<- "black"
|
|
]
|
|
(toElement $ localize $ showRounded theMaximum)
|
|
)
|
|
<> g_ [] areaPaths
|