feat(onomastics-ng): init
This commit is contained in:
53
onomastics-ng/app/Main.hs
Normal file
53
onomastics-ng/app/Main.hs
Normal file
@@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Client.TLS (newTlsManager)
|
||||
import Options.Applicative
|
||||
import Stoepel
|
||||
import Svg
|
||||
import Types
|
||||
|
||||
data Mode = Relative | Absolute
|
||||
|
||||
data Options = Options
|
||||
{ mode :: Mode
|
||||
, surname :: Text
|
||||
, fillColor :: Maybe Text
|
||||
, areaMode :: AreaKind
|
||||
}
|
||||
|
||||
parseOptions :: Parser Options
|
||||
parseOptions =
|
||||
Options
|
||||
<$> flag Absolute Relative (long "relative" <> help "Relative numbers (instead of absolute)")
|
||||
<*> strArgument (metavar "SURNAME" <> help "Surname")
|
||||
<*> optional (strOption (long "color" <> metavar "COLOR" <> help "Color of the SVG"))
|
||||
<*> flag District State (long "states" <> help "Analyze by state (instead of district)")
|
||||
|
||||
opts :: ParserInfo Options
|
||||
opts = info (parseOptions <**> helper) (fullDesc <> progDesc "Map your German surname")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
options <- execParser opts
|
||||
manager' <- newTlsManager
|
||||
let computeFunction =
|
||||
case mode options of
|
||||
Relative -> relativeCount
|
||||
Absolute -> absoluteCount
|
||||
color = fromMaybe "black" $ fillColor options
|
||||
res <- runStoepel manager' $ do
|
||||
case areaMode options of
|
||||
State -> do
|
||||
ds <- states
|
||||
stats <- computeAreaStatistics computeFunction ds <$> stateStatistics (Just $ surname options)
|
||||
return $ drawMap color ds stats
|
||||
District -> do
|
||||
ds <- districts
|
||||
stats <- computeAreaStatistics computeFunction ds <$> districtStatistics (Just $ surname options)
|
||||
return $ drawMap color ds stats
|
||||
print res
|
||||
33
onomastics-ng/app/Stoepel.hs
Normal file
33
onomastics-ng/app/Stoepel.hs
Normal file
@@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module 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 Types (Area, AreaKind (..), ByArea)
|
||||
|
||||
type StoepelAPI =
|
||||
"content" :> "de" :> "districts.json" :> Get '[JSON] [Area 'District]
|
||||
:<|> "api" :> "clusters" :> "district" :> QueryParam "name" Text :> Get '[JSON] (ByArea 'District Int)
|
||||
:<|> "content" :> "de" :> "states.json" :> Get '[JSON] [Area 'State]
|
||||
:<|> "api" :> "clusters" :> "state" :> QueryParam "name" Text :> Get '[JSON] (ByArea 'State Int)
|
||||
|
||||
stoepelApi :: Proxy StoepelAPI
|
||||
stoepelApi = Proxy
|
||||
|
||||
districts :: ClientM [Area 'District]
|
||||
states :: ClientM [Area 'State]
|
||||
districtStatistics :: Maybe Text -> ClientM (ByArea 'District Int)
|
||||
stateStatistics :: Maybe Text -> ClientM (ByArea 'State 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
|
||||
78
onomastics-ng/app/Svg.hs
Normal file
78
onomastics-ng/app/Svg.hs
Normal file
@@ -0,0 +1,78 @@
|
||||
{-# 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
|
||||
85
onomastics-ng/app/Types.hs
Normal file
85
onomastics-ng/app/Types.hs
Normal file
@@ -0,0 +1,85 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Types (Area (..), AreaKind (..), ByArea (..), relativeCount, absoluteCount, computeAreaStatistics) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types (Parser)
|
||||
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
|
||||
|
||||
data AreaKind = District | State
|
||||
|
||||
newtype Key (t :: AreaKind) = Key {getKey :: Text}
|
||||
deriving (Show, Generic, Eq, Ord)
|
||||
|
||||
instance FromJSON (Key t) where
|
||||
parseJSON = withText "Area key" (pure . Key)
|
||||
|
||||
data Area (t :: AreaKind) = Area
|
||||
{ name :: Text
|
||||
, key :: Key t
|
||||
, population :: Int
|
||||
, path :: Text
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance FromJSON (Area t)
|
||||
|
||||
newtype ByArea (t :: AreaKind) n = ByArea {getByArea :: Map (Key t) n}
|
||||
deriving (Show)
|
||||
|
||||
instance FromJSON (ByArea 'District Int) where
|
||||
parseJSON = parseClusters "DistrictClusterer"
|
||||
|
||||
instance FromJSON (ByArea 'State Int) where
|
||||
parseJSON = parseClusters "StateClusterer"
|
||||
|
||||
parseClusters :: Text -> Value -> Parser (ByArea t Int)
|
||||
parseClusters clusterType =
|
||||
withObject "Statistics" $ \o ->
|
||||
((o .: "clusterers") >>= (.: clusterType) >>= (.: "Data"))
|
||||
>>= withArray
|
||||
"Clusters"
|
||||
( \a ->
|
||||
ByArea . Map.fromList . toList
|
||||
<$> mapM
|
||||
( withArray
|
||||
"Cluster"
|
||||
( \kv ->
|
||||
withText
|
||||
"Key"
|
||||
( \k ->
|
||||
withScientific
|
||||
"Value"
|
||||
(\v -> return (Key k, truncate v))
|
||||
(kv ! 1)
|
||||
)
|
||||
(kv ! 0)
|
||||
)
|
||||
)
|
||||
a
|
||||
)
|
||||
|
||||
computeAreaStatistics :: (Area t -> Int -> a) -> [Area t] -> ByArea t Int -> ByArea t 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 t -> Int -> Double
|
||||
absoluteCount _ count = fromIntegral count
|
||||
relativeCount area count = million * (fromIntegral count / fromIntegral (population area))
|
||||
where
|
||||
million = 10 ** 6
|
||||
25
onomastics-ng/onomap.cabal
Normal file
25
onomastics-ng/onomap.cabal
Normal file
@@ -0,0 +1,25 @@
|
||||
cabal-version: 2.4
|
||||
name: onomap
|
||||
version: 0.1.0
|
||||
author: Kierán Meinhardt
|
||||
maintainer: kmein@posteo.de
|
||||
|
||||
executable onomap
|
||||
main-is: Main.hs
|
||||
build-depends: base ^>=4.14.3.0
|
||||
, aeson
|
||||
, containers
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, optparse-applicative
|
||||
, servant
|
||||
, servant-client
|
||||
, svg-builder
|
||||
, text
|
||||
, vector
|
||||
other-modules: Stoepel
|
||||
, Types
|
||||
, Svg
|
||||
hs-source-dirs: app
|
||||
default-language: Haskell2010
|
||||
ghc-options: -O2 -Wall -threaded
|
||||
11
onomastics-ng/shell.nix
Normal file
11
onomastics-ng/shell.nix
Normal file
@@ -0,0 +1,11 @@
|
||||
{ pkgs ? import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/d2caa9377539e3b5ff1272ac3aa2d15f3081069f.tar.gz") {} }:
|
||||
with pkgs;
|
||||
haskellPackages.developPackage {
|
||||
root = ./.;
|
||||
modifier = drv: haskell.lib.addBuildTools drv (with haskellPackages; [
|
||||
cabal-install
|
||||
ghcid
|
||||
(hoogleLocal { packages = drv.propagatedBuildInputs; })
|
||||
fourmolu
|
||||
]);
|
||||
}
|
||||
Reference in New Issue
Block a user