feat(onomastics-ng): add server
This commit is contained in:
33
onomastics-ng/lib/Onomap/Stoepel.hs
Normal file
33
onomastics-ng/lib/Onomap/Stoepel.hs
Normal file
@@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Onomap.Stoepel (districts, districtStatistics, states, stateStatistics, runStoepel) where
|
||||
|
||||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Client (Manager)
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Onomap.Types (Area, ByArea)
|
||||
|
||||
type StoepelAPI =
|
||||
"content" :> "de" :> "districts.json" :> Get '[JSON] [Area]
|
||||
:<|> "api" :> "clusters" :> "district" :> QueryParam "name" Text :> Get '[JSON] (ByArea Int)
|
||||
:<|> "content" :> "de" :> "states.json" :> Get '[JSON] [Area]
|
||||
:<|> "api" :> "clusters" :> "state" :> QueryParam "name" Text :> Get '[JSON] (ByArea Int)
|
||||
|
||||
stoepelApi :: Proxy StoepelAPI
|
||||
stoepelApi = Proxy
|
||||
|
||||
districts :: ClientM [Area]
|
||||
states :: ClientM [Area]
|
||||
districtStatistics :: Maybe Text -> ClientM (ByArea Int)
|
||||
stateStatistics :: Maybe Text -> ClientM (ByArea Int)
|
||||
districts :<|> districtStatistics :<|> states :<|> stateStatistics = client stoepelApi
|
||||
|
||||
runStoepel :: Manager -> ClientM a -> IO a
|
||||
runStoepel manager' c = do
|
||||
x <- runClientM c (mkClientEnv manager' (BaseUrl Https "geogen.stoepel.net" 443 ""))
|
||||
case x of
|
||||
Left err -> error $ show err
|
||||
Right a -> return a
|
||||
82
onomastics-ng/lib/Onomap/Svg.hs
Normal file
82
onomastics-ng/lib/Onomap/Svg.hs
Normal file
@@ -0,0 +1,82 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Onomap.Svg (drawMap, renderMap) where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import qualified Data.Text as Text
|
||||
import Graphics.Svg
|
||||
import Text.Printf (printf)
|
||||
import Onomap.Types (Area (..), ByArea (..))
|
||||
|
||||
renderMap :: Text -> [Area] -> ByArea Double -> Text
|
||||
renderMap fillColor areas statistics = toStrict $ prettyText $ drawMap fillColor areas statistics
|
||||
|
||||
drawMap :: Text -> [Area] -> ByArea 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
|
||||
97
onomastics-ng/lib/Onomap/Types.hs
Normal file
97
onomastics-ng/lib/Onomap/Types.hs
Normal file
@@ -0,0 +1,97 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Onomap.Types (Area (..), AreaKind (..), ByArea (..), relativeCount, absoluteCount, computeAreaStatistics, Mode(..)) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.Aeson
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Data.Foldable (toList)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Vector ((!))
|
||||
import GHC.Generics
|
||||
import Servant.API
|
||||
|
||||
data Mode = Relative | Absolute
|
||||
|
||||
instance FromHttpApiData Mode where
|
||||
parseUrlPiece = \case
|
||||
"relative" -> Right Relative
|
||||
"absolute" -> Right Absolute
|
||||
x -> Left x
|
||||
|
||||
data AreaKind = District | State
|
||||
|
||||
instance FromHttpApiData AreaKind where
|
||||
parseUrlPiece = \case
|
||||
"district" -> Right District
|
||||
"state" -> Right State
|
||||
x -> Left x
|
||||
|
||||
data Area = Area
|
||||
{ name :: Text
|
||||
, key :: Text
|
||||
, population :: Int
|
||||
, path :: Text
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance FromJSON Area
|
||||
instance ToJSON Area
|
||||
|
||||
newtype ByArea n = ByArea {getByArea :: Map Text n}
|
||||
deriving (Show)
|
||||
|
||||
instance ToJSON a => ToJSON (ByArea a) where
|
||||
toJSON = toJSON . getByArea
|
||||
|
||||
instance (Integral a, FromJSON a) => FromJSON (ByArea a) where
|
||||
parseJSON =
|
||||
withObject "Statistics" $ \o -> do
|
||||
clusterers <- o .: "clusterers"
|
||||
clusterer <- clusterers .: "DistrictClusterer" <|> clusterers .: "StateClusterer"
|
||||
data_ <- clusterer .: "Data"
|
||||
withArray
|
||||
"Clusters"
|
||||
( \a ->
|
||||
ByArea . Map.fromList . toList
|
||||
<$> mapM
|
||||
( withArray
|
||||
"Cluster"
|
||||
( \kv ->
|
||||
withText
|
||||
"Key"
|
||||
( \k ->
|
||||
withScientific
|
||||
"Value"
|
||||
(\v -> return (k, truncate v))
|
||||
(kv ! 1)
|
||||
)
|
||||
(kv ! 0)
|
||||
)
|
||||
)
|
||||
a
|
||||
)
|
||||
data_
|
||||
|
||||
computeAreaStatistics :: (Area -> Int -> a) -> [Area] -> ByArea Int -> ByArea a
|
||||
computeAreaStatistics f areas nameCounts =
|
||||
ByArea . Map.fromList $ map (key &&& areaCount) areas
|
||||
where
|
||||
areaCount area =
|
||||
let nameCount = fromMaybe 0 (Map.lookup (key area) (getByArea nameCounts))
|
||||
in f area nameCount
|
||||
|
||||
absoluteCount, relativeCount :: Area -> Int -> Double
|
||||
absoluteCount _ count = fromIntegral count
|
||||
relativeCount area count = million * (fromIntegral count / fromIntegral (population area))
|
||||
where
|
||||
million = 10 ** 6
|
||||
Reference in New Issue
Block a user