From c766346dfa25d801611ae20c7f64eceb513ecf56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Sun, 17 Apr 2022 21:04:13 +0200 Subject: [PATCH] feat(onomastics-ng): init --- onomastics-ng/app/Main.hs | 53 ++++++++++++++++++++++ onomastics-ng/app/Stoepel.hs | 33 ++++++++++++++ onomastics-ng/app/Svg.hs | 78 +++++++++++++++++++++++++++++++++ onomastics-ng/app/Types.hs | 85 ++++++++++++++++++++++++++++++++++++ onomastics-ng/onomap.cabal | 25 +++++++++++ onomastics-ng/shell.nix | 11 +++++ 6 files changed, 285 insertions(+) create mode 100644 onomastics-ng/app/Main.hs create mode 100644 onomastics-ng/app/Stoepel.hs create mode 100644 onomastics-ng/app/Svg.hs create mode 100644 onomastics-ng/app/Types.hs create mode 100644 onomastics-ng/onomap.cabal create mode 100644 onomastics-ng/shell.nix diff --git a/onomastics-ng/app/Main.hs b/onomastics-ng/app/Main.hs new file mode 100644 index 0000000..46ea0f1 --- /dev/null +++ b/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 diff --git a/onomastics-ng/app/Stoepel.hs b/onomastics-ng/app/Stoepel.hs new file mode 100644 index 0000000..f030e31 --- /dev/null +++ b/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 diff --git a/onomastics-ng/app/Svg.hs b/onomastics-ng/app/Svg.hs new file mode 100644 index 0000000..e863c35 --- /dev/null +++ b/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 diff --git a/onomastics-ng/app/Types.hs b/onomastics-ng/app/Types.hs new file mode 100644 index 0000000..349e646 --- /dev/null +++ b/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 diff --git a/onomastics-ng/onomap.cabal b/onomastics-ng/onomap.cabal new file mode 100644 index 0000000..5844661 --- /dev/null +++ b/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 diff --git a/onomastics-ng/shell.nix b/onomastics-ng/shell.nix new file mode 100644 index 0000000..fa6b4b8 --- /dev/null +++ b/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 + ]); +}