feat(onomastics-ng): init

onomastics-ng/app/Main.hs

@@ -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

onomastics-ng/app/Stoepel.hs

@@ -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

onomastics-ng/app/Svg.hs

@@ -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

onomastics-ng/app/Types.hs

@@ -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

onomastics-ng/onomap.cabal

@@ -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

onomastics-ng/shell.nix

@@ -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
+  ]);
+}