diff --git a/Justfile b/Justfile deleted file mode 100644 --- a/Justfile +++ /dev/null @@ -1,8 +0,0 @@ -clean: - rm test/testmap.* - sn c . - -upload: - rm -rf dist/ - cabal sdist - cabal upload --publish $(fd '\.tar\.gz$') diff --git a/LICENSE-readshp b/LICENSE-readshp deleted file mode 100644 --- a/LICENSE-readshp +++ /dev/null @@ -1,20 +0,0 @@ -Copyright (c) 2015 Sam van Herwaarden - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/cabal.project.local b/cabal.project.local --- a/cabal.project.local +++ b/cabal.project.local @@ -1,5 +1,5 @@ -with-compiler: ghc-8.2.1 +constraints: hgis +development +with-compiler: ghc-8.2.2 optimization: 2 -documentation: True -haddock-hoogle: True -haddock-internal: True +documentation: true +tests: true diff --git a/hgis.cabal b/hgis.cabal --- a/hgis.cabal +++ b/hgis.cabal @@ -1,88 +1,123 @@ -name: hgis -version: 0.1.3.7 -synopsis: Package and command-line for GIS with Haskell -description: Package containting functions to make graphs, read - shapefiles, and compute areas/perimeters of - geographic features. -homepage: https://github.com/vmchale/hgis#readme -license: BSD3 -license-file: LICENSE -author: Vanessa McHale -maintainer: tmchale@wisc.edu -copyright: Copyright: (c) 2016 Vanessa McHale -category: Web -build-type: Simple -extra-source-files: README.md, cabal.project.local, docs/manual.tex, src/depends/readshp/LICENSE, LICENSE-readshp, Justfile -cabal-version: >=1.10 +cabal-version: 1.18 +name: hgis +version: 0.1.3.8 +license: BSD3 +license-file: LICENSE +copyright: Copyright: (c) 2016-2018 Vanessa McHale +maintainer: vamchale@gmail.com +author: Vanessa McHale +synopsis: Package and command-line for GIS with Haskell +description: + Package containting functions to make graphs, read + shapefiles, and compute areas/perimeters of + geographic features. +category: Web +build-type: Simple +extra-source-files: + cabal.project.local + stack.yaml +extra-doc-files: README.md + docs/manual.tex + src/depends/readshp/LICENSE -Flag llvm-fast { - Description: Enable build with llvm backend - Default: False -} +source-repository head + type: git + location: https://github.com/vmchale/hgis +flag llvm-fast + description: + Enable build with llvm backend + default: False + +flag development + description: + Turn on '-Werror' + default: False + manual: True + library - hs-source-dirs: src, src/depends/readshp - exposed-modules: GIS.Exe.Opt - , GIS.Exe.OptCairo - , GIS.Math.Spherical - , GIS.Graphics.PlotPNG - , GIS.Graphics.PlotSVG - , GIS.Hylo - , GIS.Math.Projections - other-modules: GIS.Math.Utils - , GIS.Utils - , GIS.Graphics.Plot - , GIS.Graphics.Types - , GIS.Types - , GIS.Exe.Parser - , Geometry.Shapefile - , Geometry.Shapefile.MergeShpDbf - , Geometry.Shapefile.ReadDbf - , Geometry.Shapefile.ReadShp - , Geometry.Shapefile.Types - , Geometry.Shapefile.Internal - build-depends: base >= 4.7 && < 5 - , optparse-applicative - , Chart - , Chart-cairo - , Chart-diagrams - , lens - , composition - , ansi-wl-pprint - , transformers - , directory - , colour - , data-default - , binary - , bytestring - , data-binary-ieee754 - , filepath - , monad-loops - default-language: Haskell2010 - default-extensions: DeriveGeneric - , OverloadedStrings + exposed-modules: + GIS.Exe.Opt + GIS.Exe.OptCairo + GIS.Math.Spherical + GIS.Graphics.PlotPNG + GIS.Graphics.PlotSVG + GIS.Hylo + GIS.Math.Projections + hs-source-dirs: src src/depends/readshp + other-modules: + GIS.Math.Utils + GIS.Utils + GIS.Graphics.Plot + GIS.Graphics.Types + GIS.Types + GIS.Exe.Parser + Geometry.Shapefile + Geometry.Shapefile.MergeShpDbf + Geometry.Shapefile.ReadDbf + Geometry.Shapefile.ReadShp + Geometry.Shapefile.Types + Geometry.Shapefile.Internal + default-language: Haskell2010 + default-extensions: DeriveGeneric OverloadedStrings + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + optparse-applicative -any, + Chart -any, + Chart-cairo -any, + Chart-diagrams -any, + lens -any, + composition-prelude >=1.1.0.1, + ansi-wl-pprint -any, + directory -any, + colour -any, + data-default -any, + binary -any, + bytestring -any, + data-binary-ieee754 -any, + filepath -any, + monad-loops -any + + if flag(development) + ghc-options: -Werror + + if impl(ghc >=8.0) + ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates executable hgis - hs-source-dirs: app - main-is: MainPng.hs - if flag(llvm-fast) - ghc-options: -threaded -rtsopts -with-rtsopts=-N -fllvm -optlo-O3 -O3 - else - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base > 4.9 && < 5 - , hgis - default-language: Haskell2010 + main-is: MainPng.hs + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >4.9 && <5, + hgis -any + + if flag(llvm-fast) + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fllvm -optlo-O3 + else + ghc-options: -threaded -rtsopts -with-rtsopts=-N + + if flag(development) + ghc-options: -Werror + + if impl(ghc >=8.0) + ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates test-suite hgis-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - build-depends: base - , hgis - , hspec - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/vmchale/hgis + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base -any, + hgis -any, + hspec -any + + if flag(development) + ghc-options: -Werror + + if impl(ghc >=8.0) + ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates diff --git a/src/GIS/Exe/Opt.hs b/src/GIS/Exe/Opt.hs --- a/src/GIS/Exe/Opt.hs +++ b/src/GIS/Exe/Opt.hs @@ -1,28 +1,22 @@ module GIS.Exe.Opt where -import GIS.Hylo -import Control.Monad -import Control.Lens hiding (argument) -import Options.Applicative -import Control.Monad.IO.Class -import Data.Monoid hiding (getAll) -import System.Directory --- -import GIS.Utils -import GIS.Math.Projections -import GIS.Math.Spherical -import GIS.Graphics.PlotSVG -import GIS.Types -import GIS.Exe.Parser -import GIS.Graphics.Types +import Control.Lens +import Data.Semigroup +import GIS.Exe.Parser hiding (projection) +import GIS.Graphics.PlotSVG +import GIS.Graphics.Types hiding (projection) +import GIS.Hylo +import Options.Applicative +import System.Directory pick :: Program -> IO () pick (Program (MapMaker outfile False projection) infile) = let p = pickProjection projection in - mkMapSVG outfile =<< districtToMapP p <$> getDistricts infile -pick (Program (MapMaker outfile True projection) infile) = let p = pickProjection projection in + mkMapSVG outfile =<< districtToMapP p <$> getDistricts infile +pick (Program (MapMaker _ True projection) infile) = let p = pickProjection projection in makeFoldersSVG =<< districtToMapFilesP p <$> getDistricts infile pick (Program (MapLabel outfile False projection lensName) infile) = let p = pickProjection projection in mkMapSVG outfile =<< districtToMapLensP p (pickLens lensName) <$> getDistricts infile -- FIXME make it work with -a (generate-all) +pick _ = error "not yet implemented." exec :: IO () exec = pick =<< execParser helpDisplay @@ -30,4 +24,4 @@ makeFoldersSVG :: [Map] -> IO () makeFoldersSVG maps = do createDirectoryIfMissing False "maps" - mapM_ (\m -> mkMapSVG ("maps/" <> (view title m) <> ".svg") m) maps + mapM_ (\m -> mkMapSVG ("maps/" <> view title m <> ".svg") m) maps diff --git a/src/GIS/Exe/OptCairo.hs b/src/GIS/Exe/OptCairo.hs --- a/src/GIS/Exe/OptCairo.hs +++ b/src/GIS/Exe/OptCairo.hs @@ -7,23 +7,14 @@ , exec ) where -import GIS.Hylo -import Control.Lens -import Control.Monad -import Options.Applicative -import Control.Monad.IO.Class -import Data.Monoid hiding (getAll) -import System.Directory --- -import GIS.Utils -import GIS.Math.Projections -import GIS.Math.Spherical -import GIS.Graphics.PlotSVG -import GIS.Graphics.PlotPNG -import GIS.Types -import GIS.Exe.Opt hiding (exec, pick) -import GIS.Exe.Parser -import GIS.Graphics.Types +import Control.Lens +import Data.Semigroup +import GIS.Exe.Parser hiding (projection) +import GIS.Graphics.PlotPNG +import GIS.Graphics.Types hiding (projection) +import GIS.Hylo +import Options.Applicative +import System.Directory -- | Main executable; parses command line options and runs program exec :: IO () @@ -33,19 +24,20 @@ pick :: Program -> IO () pick (Program (MapMaker outfile False projection) infile) = let p = pickProjection projection in mkMap outfile =<< districtToMapP p <$> getDistricts infile -- svg now idk? -pick (Program (MapMaker outfile True projection) infile) = let p = pickProjection projection in +pick (Program (MapMaker _ True projection) infile) = let p = pickProjection projection in makeFoldersPng =<< districtToMapFilesP p <$> getDistricts infile -- TODO fix this -pick (Program (Computation comp Nothing) infile) = --slightly wrong but eh. +pick (Program (Computation comp Nothing) infile) = --slightly wrong but eh. case comp of "perimeter" -> putStrLn =<< districtPerimeter <$> getDistricts infile "area" -> putStrLn =<< districtArea <$> getDistricts infile "compactness" -> putStrLn =<< districtCompactness <$> getDistricts infile _ -> putStrLn "computation not recognized" -pick (Program (MapLabel outfile False projection lensName) infile) = let p = pickProjection projection in +pick (Program (MapLabel outfile False _ lensName) infile) = mkLensMap "" outfile (pickLens lensName) =<< getDistricts infile -- FIXME make it work with -a (generate-all) and make it not bind things together?? +pick _ = error "not yet supported." -- | Make maps as png files. makeFoldersPng :: [Map] -> IO () makeFoldersPng maps = do createDirectoryIfMissing False "maps" - mapM_ (\m -> mkMapPng ("maps/" <> (view title m) <> ".png") m) maps + mapM_ (\m -> mkMapPng ("maps/" <> view title m <> ".png") m) maps diff --git a/src/GIS/Exe/Parser.hs b/src/GIS/Exe/Parser.hs --- a/src/GIS/Exe/Parser.hs +++ b/src/GIS/Exe/Parser.hs @@ -2,33 +2,33 @@ -- | This module contains the parser for the command-line options module GIS.Exe.Parser where -import Options.Applicative -import GIS.Types -import GIS.Math.Projections -import Control.Lens hiding (argument) -import Data.Monoid +import Control.Lens hiding (argument) +import Data.Monoid +import GIS.Math.Projections +import GIS.Types +import Options.Applicative -- | Data type for one run of the program -data Program = Program { com :: Command +data Program = Program { com :: Command , file :: FilePath -- "Path to dbf file" - } + } -- | Data type for the appropriate subcommand -data Command = Computation { computation :: String , outputM :: Maybe FilePath } +data Command = Computation { computation :: String , outputM :: Maybe FilePath } | MapMaker { output :: FilePath , generateAll :: Bool , projection :: Maybe String } | MapLabel { output :: FilePath , generateAll :: Bool , projection :: Maybe String , computatation :: String } -- | Parses the `Program` data type program :: Parser Program -program = Program +program = Program <$> hsubparser ( command "compute" (info computationP ( progDesc "Compute perimeter, area, etc. of map" )) <> command "map" (info mapMaker ( progDesc "Make a map from a shapefile database." )) <> command "labelmap" (info mapLabelMaker ( progDesc "Make a map from a shapefile database, and label areas with relevant info" ))) - <*> ( argument str - (metavar "SHAPEFILE" + <*> argument str + (metavar "SHAPEFILE" <> help "Path to .shp file" - <> completer (bashCompleter "file -X '!*.shp' -o plusdirs"))) + <> completer (bashCompleter "file -X '!*.shp' -o plusdirs")) -- | Parses the `Command` datatype into a Computation computationP :: Parser Command @@ -36,11 +36,11 @@ <$> argument str ( metavar "COMPUTATION" <> help "which computation to perform, e.g. area, perimeter, etc." ) - <*> ( optional $ strOption -- because it's a maybe filepath + <*> optional (strOption -- because it's a maybe filepath ( long "output" <> short 'o' <> metavar "OUTPUT" - <> help "Where to write output" ) ) + <> help "Where to write output" )) -- | Parses the `Command` datatype into a map mapLabelMaker :: Parser Command @@ -54,14 +54,14 @@ (long "generate-all" <> short 'a' <> help "Whether to generate a separate file for each object in the shapefile" ) - <*> ( optional $ strOption + <*> optional (strOption (long "projection" <> short 'p' - <> help "Which projection to use, e.g. mercator etc.") ) - <*> ( strOption + <> help "Which projection to use, e.g. mercator etc.")) + <*> strOption (long "label" <> short 'p' - <> help "What aspect to label (area, perimeter, compactness)") ) + <> help "What aspect to label (area, perimeter, compactness)") -- | Parses the `Command` datatype into a map mapMaker :: Parser Command @@ -75,14 +75,15 @@ (long "generate-all" <> short 'a' <> help "Whether to generate a separate file for each object in the shapefile" ) - <*> ( optional $ strOption + <*> optional (strOption (long "projection" <> short 'p' - <> help "Which projection to use, e.g. mercator etc.") ) + <> help "Which projection to use, e.g. mercator etc.")) -- | display help if user enters e.g. -- -- > hgis --help wrongcommand +helpDisplay :: ParserInfo Program helpDisplay = info ( program <**> helper) ( fullDesc <> progDesc "GIS for Haskell. Can make maps, compute areas/perimeters for shapefiles." @@ -90,15 +91,17 @@ pickLens :: String -> Lens' District Double pickLens "compactness" = compactness -pickLens "perimeter" = perimeter +pickLens "perimeter" = perimeter +pickLens _ = error "must be one of 'compactness', 'perimeter'" -- | Parse a `Maybe String` into the appropriate `Projection`, doing nothing for -- a `Nothing` pickProjection :: Maybe String -> Projection -pickProjection str = case str of +pickProjection s = case s of Just "mercator" -> mercator - Just "bonne" -> bonne - Just "albers" -> albers washingtonDC - Just "winkel3" -> winkel3 - Just "littow" -> littow - Nothing -> id + Just "bonne" -> bonne + Just "albers" -> albers washingtonDC + Just "winkel3" -> winkel3 + Just "littow" -> littow + Just _ -> error "unknown projection. try one of 'mercator', 'bonne', 'albers', 'winkel3', or 'littow'" + Nothing -> id diff --git a/src/GIS/Graphics/Plot.hs b/src/GIS/Graphics/Plot.hs --- a/src/GIS/Graphics/Plot.hs +++ b/src/GIS/Graphics/Plot.hs @@ -3,21 +3,18 @@ -- | Module containing renderable objects and plots for our maps module GIS.Graphics.Plot where -import GIS.Types -import Graphics.Rendering.Chart -import Graphics.Rendering.Chart.Easy -import GIS.Math.Spherical -import GIS.Utils -import Data.Colour.Names -import GIS.Graphics.Types -import GIS.Math.Projections +import Data.Colour.Names +import GIS.Graphics.Types hiding (title) +import GIS.Math.Spherical +import GIS.Types +import GIS.Utils +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Easy hiding (lens, points) -- | Given a map, return a `Renderable ()` for use with the --- """Graphics.Rendering.Char""" module. +-- """Graphics.Rendering.Char""" module. mkMapR :: Map -> Renderable () -mkMapR (Map { _projection = p , _title = tit , _labelEntities = le , _labelledDistricts = points }) = case le of - True -> mkRenderableLabelled tit points - False -> mkRenderableLabelled tit $ fmap (over _2 (const "")) points +mkMapR Map { _title = tit , _labelEntities = le , _labelledDistricts = points } = if le then mkRenderableLabelled tit points else mkRenderableLabelled tit $ fmap (over _2 (pure "")) points mkRenderablePlots :: String -> [Plot Double Double] -> Renderable () mkRenderablePlots title plots = toRenderable $ @@ -27,23 +24,23 @@ mkRenderableLens lens districts title = mkRenderableLabelled title (labelByLens lens districts) mkRenderableLabelled :: String -> [([Polygon], String)] -> Renderable () -mkRenderableLabelled title points = mkRenderablePlots title [ plotDataPoints (concat . (fmap fst) $ points), plotLabels points ] +mkRenderableLabelled title points = mkRenderablePlots title [ plotDataPoints (fst =<< points), plotLabels points ] -- | Helper function to plot data points as appropriate for a map, i.e. using --- contiguous lines. +-- contiguous lines. plotDataPoints :: [Polygon] -> Plot Double Double plotDataPoints points = toPlot $ plot_lines_values .~ points $ plot_lines_style . line_color .~ opaque blue $ plot_lines_title .~ "Border" $ def -- | Set labels via a lens field. labelByLens :: (Show a) => Lens' District a -> [District] -> [([Polygon], String)] -labelByLens lens districts = zip (fmap (view shape) districts) (fmap (show . (view lens)) districts) +labelByLens lens districts = zip (fmap (view shape) districts) (fmap (show . view lens) districts) -- | Helper function to plot labels on a map. The ordinate will be plotted at -- the centroid of the abscissa, which may be outside the polygon if it is --- concave. +-- concave. plotLabels :: [([Polygon], String)] -> Plot Double Double plotLabels points = toPlot texts - where pairs = fmap (flatten . (over _1 (shittyCentroid . concat))) points + where pairs = fmap (flatten . over _1 (shittyCentroid . concat)) points fontStyle = font_size .~ 15 $ font_weight .~ FontWeightBold $ def texts = plot_annotation_values .~ pairs $ plot_annotation_style .~ fontStyle $ def diff --git a/src/GIS/Graphics/PlotPNG.hs b/src/GIS/Graphics/PlotPNG.hs --- a/src/GIS/Graphics/PlotPNG.hs +++ b/src/GIS/Graphics/PlotPNG.hs @@ -3,34 +3,29 @@ -- | Module to generate PNGs from shapefiles module GIS.Graphics.PlotPNG where -import Graphics.Rendering.Chart -import Graphics.Rendering.Chart.Easy -import Graphics.Rendering.Chart.Backend.Cairo -import GIS.Types -import Data.Monoid -import Control.Monad -import GIS.Hylo -import GIS.Math.Projections -import Control.Lens -import Control.Lens.Tuple --- -import GIS.Math.Spherical -import GIS.Utils -import GIS.Graphics.Plot -import GIS.Graphics.Types -import GIS.Graphics.PlotSVG hiding (fileOptions) +import Control.Lens hiding (lens) +import Data.Semigroup +import GIS.Graphics.Plot +import GIS.Graphics.PlotSVG hiding (fileOptions) +import GIS.Graphics.Types hiding (title) +import GIS.Types +import GIS.Utils +import Graphics.Rendering.Chart.Backend.Cairo +import Graphics.Rendering.Chart.Easy hiding (lens) -- | Default file options: PNG output and 1920x1080. To change the file size, -- you can do e.g. -- > fo_size .~ (640,480) $ fileOptions +fileOptions :: FileOptions fileOptions = def { _fo_size = (1920, 1080) , _fo_format = PNG } -- | Given a `Map` write it to file, where the format is determined by the -- extension. mkMap :: FilePath -> Map -> IO () -mkMap filepath map = case getExt filepath of - "png" -> mkMapPng filepath map - "svg" -> mkMapSVG filepath map +mkMap filepath map' = case getExt filepath of + "png" -> mkMapPng filepath map' + "svg" -> mkMapSVG filepath map' + _ -> error "file extension must be one of: .svg, .png" -- | Given a `Map` write it to file, where the format is determined by the -- extension. @@ -38,19 +33,15 @@ mkLensMap title filepath lens districts = case getExt filepath of "png" -> makeLensMapPng title filepath lens districts "svg" -> makeLensMapSVG title filepath lens districts + _ -> error "file extension must be one of: .svg, .png" --- | Given a `Map`, write it to file. +-- | Given a `Map`, write it to file. mkMapPng :: FilePath -> Map -> IO () -mkMapPng path map = do - renderableToFile fileOptions path $ mkMapR map +mkMapPng path map' = + renderableToFile fileOptions path (mkMapR map') >> putStrLn ("...output written to " <> path) makeLensMapPng :: (Show a) => String -> FilePath -> Lens' District a -> [District] -> IO () -makeLensMapPng title filepath lens districts = do - renderableToFile fileOptions filepath $ mkRenderableLens lens districts title +makeLensMapPng title filepath lens districts = + renderableToFile fileOptions filepath (mkRenderableLens lens districts title) >> putStrLn ("...output written to " <> filepath) - -{-- -makeMapPng' :: String -> FilePath -> [Polygon] -> IO () -makeMapPng' = (flip zip (forever $ "")) -.** makeLabelledMapPng ---} diff --git a/src/GIS/Graphics/PlotSVG.hs b/src/GIS/Graphics/PlotSVG.hs --- a/src/GIS/Graphics/PlotSVG.hs +++ b/src/GIS/Graphics/PlotSVG.hs @@ -3,28 +3,26 @@ -- | Module to generate SVGs from shapefiles. module GIS.Graphics.PlotSVG where -import Graphics.Rendering.Chart.Easy -import Graphics.Rendering.Chart.Backend.Diagrams -import Control.Monad -import GIS.Hylo -import GIS.Types -import Data.Monoid -import GIS.Math.Projections -import GIS.Graphics.Plot -import GIS.Graphics.Types +import Data.Semigroup +import GIS.Graphics.Plot +import GIS.Graphics.Types hiding (title) +import GIS.Types +import Graphics.Rendering.Chart.Backend.Diagrams +import Graphics.Rendering.Chart.Easy hiding (lens) -- | Default file options: PNG output and 1920x1080. To change the file size, -- you can do e.g. -- > fo_size .~ (640,480) $ fileOptions +fileOptions :: FileOptions fileOptions = def { _fo_size = (1920, 1080) , _fo_format = SVG } -- | Given a `Map`, write it to file as an SVG. mkMapSVG :: FilePath -> Map -> IO () -mkMapSVG path map = do - renderableToFile fileOptions path $ mkMapR map +mkMapSVG path map' = + renderableToFile fileOptions path (mkMapR map') >> putStrLn ("...output written to " <> path) makeLensMapSVG :: (Show a) => String -> FilePath -> Lens' District a -> [District] -> IO () -makeLensMapSVG title filepath lens districts = do - renderableToFile fileOptions filepath $ mkRenderableLens lens districts title +makeLensMapSVG title filepath lens districts = + renderableToFile fileOptions filepath (mkRenderableLens lens districts title) >> putStrLn ("...output written to " <> filepath) diff --git a/src/GIS/Hylo.hs b/src/GIS/Hylo.hs --- a/src/GIS/Hylo.hs +++ b/src/GIS/Hylo.hs @@ -2,38 +2,34 @@ -- | Module to transform shapefiles. module GIS.Hylo where -import Control.Lens -import Control.Lens.Tuple -import Control.Monad -import Data.Char -import Data.Composition +import Control.Lens hiding (lens) import Data.Default import Data.List import Data.Maybe -import Data.Monoid +import Data.Semigroup import Geometry.Shapefile.MergeShpDbf import Geometry.Shapefile.ReadShp import Geometry.Shapefile.Types import GIS.Graphics.Types import GIS.Math.Projections import GIS.Math.Spherical -import GIS.Types +import GIS.Types hiding (area, perimeter) import GIS.Utils import System.Directory -- | Get the areas of various objects and return a string suitable for printing districtArea :: [District] -> String -districtArea districts = concat . intercalate (pure "\n") $ map (pure . show . distA) districts +districtArea districts = concat . intercalate (pure "\n") $ fmap (pure . show . distA) districts where distA (District _ label _ area _) = (label, sum area) -- TODO figure out which one is the correct one -- | Get the perimeters of various objects and return a string suitable for printing districtPerimeter :: [District] -> String -districtPerimeter districts = concat . intercalate (pure "\n") $ map (pure . show . distP) districts +districtPerimeter districts = concat . intercalate (pure "\n") $ fmap (pure . show . distP) districts where distP (District _ label perimeter _ _) = (label, perimeter) -- | Label with relative compactness districtCompactness :: [District] -> String -districtCompactness districts = concat . intercalate (pure "\n") $ map (pure . show . distC) districts +districtCompactness districts = concat . intercalate (pure "\n") $ fmap (pure . show . distC) districts where distC (District _ label _ _ compacticity) = (label, compacticity) -- | Given a projection and lists of districts, draw a map. @@ -59,7 +55,8 @@ -- | Given a list of districts, return a list of maps. districtToMapFiles :: [District] -> [Map] -districtToMapFiles = fmap (\(District polygons label _ area _) -> title .~ label ++ "-" ++ (show . sum $ area) $ labelledDistricts .~ pure (polygons,"") $ def) +districtToMapFiles = fmap g where + g (District polygons label _ area' _) = title .~ label <> "-" <> (show . sum $ area') $ labelledDistricts .~ pure (polygons,"") $ def -- | Given the path to a shapefile, return a list of districts getDistricts :: FilePath -> IO [District] @@ -75,6 +72,7 @@ -- | Helper function for extracting from shapefiles. getPolygon :: RecContents -> [Polygon] -getPolygon RecPolygon{ recPolPoints = pt } = pt -getPolygon RecPolygonM{ recPolMPoints = pt } = pt -getPolygon RecPolygonZ{ recPolZPoints = pt } = pt +getPolygon RecPolygon { recPolPoints = pt } = pt +getPolygon RecPolygonM { recPolMPoints = pt } = pt +getPolygon RecPolygonZ { recPolZPoints = pt } = pt +getPolygon _ = error "shapefile contents not supported. please ensure the shapefile contains a list of polygons." diff --git a/src/GIS/Math/Projections.hs b/src/GIS/Math/Projections.hs --- a/src/GIS/Math/Projections.hs +++ b/src/GIS/Math/Projections.hs @@ -1,11 +1,10 @@ -- | Module containing several useful projections for generating maps. module GIS.Math.Projections where -import Control.Lens -import Control.Lens.Tuple -import GIS.Types -import GIS.Math.Utils -import GIS.Graphics.Types +import Control.Lens +import GIS.Graphics.Types +import GIS.Math.Utils +import GIS.Types -- | For use as a reference point in certain projections. washingtonDC :: Point @@ -17,7 +16,7 @@ -- | Littow retroazimuthal + conformal projection littow :: Projection -littow (long, lat) = ((sin(long - referenceLong)/(cos lat)), (cos (long - referenceLong) * (tan lat))) +littow (long, lat) = (sin(long - referenceLong)/cos lat, cos (long - referenceLong) * tan lat) where referenceLong = radians 0 -- | Craig retroazimuthal projection @@ -25,29 +24,29 @@ craig :: Point -> Projection craig referencePoint (long, lat) = (long - referenceLong, y) where (referenceLong, referenceLat) = referencePoint - y = if long - referenceLong == 0 then expr else (long - referenceLong)/(sin(long - referenceLong)) * expr - expr = ((sin lat) * (cos (long - referenceLong)) - (tan referenceLat) * (cos lat)) + y = if long - referenceLong == 0 then expr else (long - referenceLong)/sin(long - referenceLong) * expr + expr = sin lat * cos (long - referenceLong) - tan referenceLat * cos lat --- | Winkel Tripel projection (standard for the National Geographic Society since +-- | Winkel Tripel projection (standard for the National Geographic Society since winkel3 :: Projection -winkel3 (long, lat) = ((lambda * (cos phi1) + (2 * cos lat * sin (lambda/2)/(sinc alpha)))/2, (lat + (sin lat)/(sinc alpha))/2) +winkel3 (long, lat) = ((lambda * cos phi1 + (2 * cos lat * sin (lambda/2)/sinc alpha))/2, (lat + sin lat/sinc alpha)/2) where lambda = long - lambda0 phi1 = acos $ 2 / pi - alpha = acos $ cos lat * (cos (lambda/2)) + alpha = acos $ cos lat * cos (lambda/2) lambda0 = radians (-77.0369) -- | Mercator projection. mercator :: Projection -mercator (long, lat) = (long - meridian, asinh(tan(lat))) +mercator (long, lat) = (long - meridian, asinh (tan lat)) where meridian = radians (-98.5795) -- | Bonne projection with standard parallel at 45 N and central meridian -- centered at Washington DC bonne :: Projection -bonne (long, lat) = (rho * (sin e), (cot phi1 - rho * (cos e))) - where rho = (cot phi1) + phi1 - lat - e = (long - meridian) * (cos lat) / rho - phi1 = radians 45 -- standard parallel @ 45 N +bonne (long, lat) = (rho * sin e, cot phi1 - rho * cos e) + where rho = cot phi1 + phi1 - lat + e = (long - meridian) * cos lat / rho + phi1 = radians 45 -- standard parallel @ 45 N meridian = radians (-77.0369) -- central meridian @ dc cot = (1/) . tan @@ -55,15 +54,15 @@ -- use -- > ablers washingtonDC albers :: Point -> Projection -albers referencePoint (long, lat) = (rho * (sin theta), rho' - rho * (cos theta)) +albers referencePoint (long, lat) = (rho * sin theta, rho' - rho * cos theta) where n = (sin phi1 + sin phi2)/2 theta = n * (long - referenceLong) - c = (cos phi1)^2 + 2 * n * (sin phi1) - rho = sqrt (c - 2 * n * (sin lat)) / n - rho' = sqrt (c - 2 * n * (sin referenceLat)) / n - phi1 = (radians 20) -- standard parallels @ 20, 50 degrees - phi2 = (radians 50) - (referenceLong, referenceLat) = referencePoint + c = cos phi1^(2 :: Int) + 2 * n * sin phi1 + rho = sqrt (c - 2 * n * sin lat) / n + rho' = sqrt (c - 2 * n * sin referenceLat) / n + phi1 = radians 20 -- standard parallels @ 20, 50 degrees + phi2 = radians 50 + (referenceLong, referenceLat) = referencePoint -- | Helper to project given a `Polygon`. project :: Projection -> Polygon -> Polygon @@ -71,4 +70,4 @@ -- | Helper to apply a projection given a `Map`. projectMap :: Projection -> Map -> Map -projectMap p = over (labelledDistricts) (fmap (over _1 (fmap (project p)))) +projectMap p = over labelledDistricts (fmap (over _1 (fmap (project p)))) diff --git a/src/GIS/Math/Spherical.hs b/src/GIS/Math/Spherical.hs --- a/src/GIS/Math/Spherical.hs +++ b/src/GIS/Math/Spherical.hs @@ -1,18 +1,15 @@ -- | Utilities to compute area, perimeterPolygon, etc. on the surface of a sphere. module GIS.Math.Spherical where -import Control.Lens -import Control.Lens.Tuple -import Data.Function -import Data.List -import GIS.Types -import Data.Composition -import GIS.Math.Projections -import GIS.Math.Utils +import Control.Composition +import Control.Lens +import GIS.Math.Projections +import GIS.Math.Utils +import GIS.Types -- | averages the coördinates of a polygon, returning a point. shittyCentroid :: Polygon -> Point -shittyCentroid poly = (avg $ map fst poly, avg $ map snd poly) +shittyCentroid poly = (avg $ fmap fst poly, avg $ fmap snd poly) -- | Average over a foldable container avg :: (RealFrac a, Foldable t) => t a -> a @@ -20,7 +17,7 @@ -- | Compute the area of a triangle using L'Huillier's formula areaTriangle :: Point -> Point -> Point -> Double -areaTriangle x1 x2 x3 = r^2 * e +areaTriangle x1 x2 x3 = r^(2 :: Int) * e where r = 6371 e = 4 * atan(sqrt(tan(s/2) * tan((s - a)/2) * tan((s - b)/2) * tan((s - c)/2))) s = (a + b + c) / 2 @@ -29,24 +26,25 @@ c = distanceRad x2 x3 distanceRad = on centralAngle toRadians --- TODO mandelbrot/fractal dimension? --- consider "area of largest circumscribable circle" as well. +-- TODO mandelbrot/fractal dimension? +-- consider "area of largest circumscribable circle" as well. -- | Relative compactness, i.e. compactness divided by the compactness of a Euclidean circle relativeCompactness :: Polygon -> Double relativeCompactness = (*scale) . compactness1 - where scale = (1/4*pi) + where scale = 1/4*pi -- | Take the area of the polygon and divide by the perimeter squared. This is a dimensionless measurement. -compactness1 :: Polygon -> Double -compactness1 p = (areaPolygon p)/(perimeterPolygon p)^2 +compactness1 :: Polygon -> Double +compactness1 p = areaPolygon p/perimeterPolygon p^(2 :: Int) -- | Compute the area of a convex polygon on the surface of a sphere. areaConvex :: Polygon -> Double -areaConvex (base1:base2:pts) = (view _1) $ foldr stepArea (0,base2) pts - where stepArea point (sum, base) = (sum + (areaTriangle base1 base point), point) +areaConvex (base1:base2:pts) = view _1 $ foldr stepArea (0,base2) pts + where stepArea point (sum', base) = (sum' + areaTriangle base1 base point, point) +areaConvex _ = error "attempted to take area of polygon with < 3 points" --- | Uses areal projection; then finds area of the polygon. +-- | Uses areal projection; then finds area of the polygon. -- Result is in km^2 areaPolygon :: Polygon -> Double areaPolygon = (*factor) . areaPolyRectangular . fmap (bonne . toRadians) @@ -54,22 +52,24 @@ -- | Given a list of polygons, return the total area. totalPerimeter :: [Polygon] -> Double -totalPerimeter lines = sum $ fmap perimeterPolygon lines +totalPerimeter ps = sum $ fmap perimeterPolygon ps +perimeterPolygon :: Polygon -> Double perimeterPolygon [x1, x2] = distance x1 x2 perimeterPolygon (x1:x2:points) = perimeterPolygon (x2:points) + distance x1 x2 +perimeterPolygon _ = error "Attempted to take area of polygon with no points" --- | Find the area of a polygon with rectangular coördinates given. +-- | Find the area of a polygon with rectangular coördinates given. areaPolyRectangular :: Polygon -> Double -areaPolyRectangular (pt:pts) = abs . (*0.5) . fst $ (foldl' areaPolyCalc (0,pt) pts) - where areaPolyCalc (sum,(x1,y1)) (x2, y2) = (sum + (x1 * y2 - x2 * y1),(x2,y2)) - ((x1, y1),(xn, yn)) = (pt, last pts) +areaPolyRectangular (pt:pts) = abs . (*0.5) . fst $ foldr areaPolyCalc (0,pt) pts + where areaPolyCalc (x2, y2) (sum',(x1,y1)) = (sum' + (x1 * y2 - x2 * y1),(x2,y2)) +areaPolyRectangular _ = error "Attempted to take area of polygon with no points" --- | Distance in kilometers between two points given in degrees. +-- | Distance in kilometers between two points given in degrees. distance :: (Double, Double) -> (Double, Double) -> Double -distance = (*6371) .* (on centralAngle toRadians) +distance = (*6371) .* on centralAngle toRadians -- | Compute central angle from points given in radians centralAngle :: (Double, Double) -> (Double, Double) -> Double -centralAngle (long1, lat1) (long2, lat2) = centralAngle - where centralAngle = acos $ (sin lat1) * (sin lat2) + (cos lat1) * (cos lat2) * (cos (long1 - long2)) +centralAngle (long1, lat1) (long2, lat2) = + acos $ sin lat1 * sin lat2 + cos lat1 * cos lat2 * cos (long1 - long2) diff --git a/src/GIS/Math/Utils.hs b/src/GIS/Math/Utils.hs --- a/src/GIS/Math/Utils.hs +++ b/src/GIS/Math/Utils.hs @@ -1,15 +1,16 @@ -- | Miscellaneous utils for math module GIS.Math.Utils where -import GIS.Types -import Control.Lens -import Control.Lens.Tuple +import Control.Lens +import GIS.Types +sinc :: Floating a => a -> a sinc x = sin x / x -- | Convert a `Double` from degrees to radians. +radians :: Double -> Double radians = (*(pi/180)) -- | Convert both coördinates to radians. toRadians :: Point -> Point -toRadians = (over _1 radians) . (over _2 radians) +toRadians = over _1 radians . over _2 radians diff --git a/src/GIS/Types.hs b/src/GIS/Types.hs --- a/src/GIS/Types.hs +++ b/src/GIS/Types.hs @@ -1,19 +1,19 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} --- | Module containing types for various geometrical objects. Lenses included. +-- | Module containing types for various geometrical objects. Lenses included. module GIS.Types where -import Text.PrettyPrint.ANSI.Leijen -import GHC.Generics -import Control.Lens +import Control.Lens +import GHC.Generics +import Text.PrettyPrint.ANSI.Leijen type Point = (Double, Double) type Polygon = [Point] type Projection = (Double, Double) -> (Double, Double) -- | Data type for one record in a shape file, also capable of storing basic --- information about the district. +-- information about the district. data District = District { _shape :: [Polygon] , _districtLabel :: String , _perimeter :: Double @@ -23,9 +23,8 @@ makeLenses ''District --- possibly get rid of this idk data DbfReadError = NotAPolygon | ShpNull instance Show DbfReadError where - show NotAPolygon = show $ red (text "Error: ") <> (text "Shape not a polygon! Are you sure you're opening a district?") - show ShpNull = show $ red (text "Error: ") <> (text "") + show NotAPolygon = show $ red (text "Error: ") <> text "Shape not a polygon! Are you sure you're opening a district?" + show ShpNull = show $ red (text "Error: ") <> text "" diff --git a/src/GIS/Utils.hs b/src/GIS/Utils.hs --- a/src/GIS/Utils.hs +++ b/src/GIS/Utils.hs @@ -1,7 +1,8 @@ -- | Miscellaneous utils and helper functions. module GIS.Utils where -import Data.Char +import Control.Composition +import Data.Char -- | Strip extension from a filepath stripExt :: String -> String @@ -9,11 +10,11 @@ -- | Get extension given a filepath getExt :: String -> String -getExt = fmap toLower . reverse . (takeWhile (/='.')) . reverse +getExt = fmap toLower . reverse . takeWhile (/='.') . reverse -- | Make sure labels on shapefile objects are suitable for human reading. labels :: (Show a) => [[a]] -> [String] -labels = map ((filter (/=' ')) . (take 35) . (drop 11) . show . (!!3)) +labels = fmap (thread [filter (/=' '), take 35, drop 11] . show . (!!3)) -- | Flatten a nested tuple. flatten :: ((a,b),c) -> (a,b,c) diff --git a/src/depends/readshp/Geometry/Shapefile/Internal.hs b/src/depends/readshp/Geometry/Shapefile/Internal.hs --- a/src/depends/readshp/Geometry/Shapefile/Internal.hs +++ b/src/depends/readshp/Geometry/Shapefile/Internal.hs @@ -6,9 +6,9 @@ module Geometry.Shapefile.Internal where -import Control.Monad ( replicateM ) -import Data.Binary.Get -import Data.Binary.IEEE754 ( getFloat64le ) +import Control.Monad (replicateM) +import Data.Binary.Get +import Data.Binary.IEEE754 (getFloat64le) import qualified Data.ByteString.Char8 as C -- | 8-bit Int value @@ -43,14 +43,12 @@ -- | Two doubles making up a point with two coordinates getPoint :: Get Point -getPoint = do x <- getFloat64le - y <- getFloat64le - return (x, y) +getPoint = (,) <$> getFloat64le <*> getFloat64le -- | Get the increments between list values steps :: Num a => [a] -> [a] steps [] = [] -steps (_:[]) = [] +steps [_] = [] steps (x1:x2:xs) = x2 - x1 : steps (x2:xs) -- | List of points of length `numPoints` diff --git a/src/depends/readshp/Geometry/Shapefile/MergeShpDbf.hs b/src/depends/readshp/Geometry/Shapefile/MergeShpDbf.hs --- a/src/depends/readshp/Geometry/Shapefile/MergeShpDbf.hs +++ b/src/depends/readshp/Geometry/Shapefile/MergeShpDbf.hs @@ -6,25 +6,24 @@ module Geometry.Shapefile.MergeShpDbf ( readShpWithDbf ) where -import System.FilePath - -import qualified Data.ByteString.Lazy as BL - -import Geometry.Shapefile.ReadDbf -import Geometry.Shapefile.ReadShp -import Geometry.Shapefile.Types +import qualified Data.ByteString.Lazy as BL +import Data.Semigroup +import Geometry.Shapefile.ReadDbf +import Geometry.Shapefile.ReadShp +import Geometry.Shapefile.Types +import System.FilePath -- | Read a shp-file from `fp`, and a dbf file from the same path but with -- modified extension. readShpWithDbf :: String -> IO ShpData readShpWithDbf fp = do shpData <- readShpData <$> BL.readFile fp - let dbfPath = dropExtension fp ++ ".dbf" + let dbfPath = dropExtension fp <> ".dbf" dbfData <- readDbfData <$> BL.readFile dbfPath - return shpData { + pure shpData { dbfFieldDescs = Just $ dbfFields dbfData, shpRecs = zipWith addRecLabel (shpRecs shpData) (dbfRecords dbfData) } addRecLabel :: ShpRec -> [DbfRecord] -> ShpRec -addRecLabel sr labels = sr { shpRecLabel = Just (labels) } -- FIXME add field name as string +addRecLabel sr labels = sr { shpRecLabel = Just labels } -- FIXME add field name as string diff --git a/src/depends/readshp/Geometry/Shapefile/ReadDbf.hs b/src/depends/readshp/Geometry/Shapefile/ReadDbf.hs --- a/src/depends/readshp/Geometry/Shapefile/ReadDbf.hs +++ b/src/depends/readshp/Geometry/Shapefile/ReadDbf.hs @@ -10,14 +10,14 @@ readDbfData ) where -import Control.Monad ( replicateM ) -import Control.Monad.Loops ( whileM ) -import Data.Binary.Get hiding (getInt8) +import Control.Monad (replicateM) +import Control.Monad.Loops (whileM) +import Data.Binary.Get hiding (getInt8) -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BL -import Geometry.Shapefile.Internal -import Geometry.Shapefile.Types +import Geometry.Shapefile.Internal +import Geometry.Shapefile.Types -- | Read dbf file at `fp` into resident data format `DbfData` readDbfFile :: String -> IO DbfData @@ -37,7 +37,7 @@ -- Records recs <- replicateM numRecs (getWord8 >> mapM getDbfRecord fields) -- Everything together - return DbfData { dbfNumRecs = numRecs, + pure DbfData { dbfNumRecs = numRecs, dbfFields = fields, dbfRecords = recs } @@ -49,7 +49,7 @@ _ <- getIntLE -- Field displacement (?) len <- getInt8 -- Field length _ <- getByteString 15 -- Num decimal/field flags/autoincrement - return DbfFieldDesc { fieldName = name, + pure DbfFieldDesc { fieldName = name, fieldType = fieldT, fieldLen = len } diff --git a/src/depends/readshp/Geometry/Shapefile/ReadShp.hs b/src/depends/readshp/Geometry/Shapefile/ReadShp.hs --- a/src/depends/readshp/Geometry/Shapefile/ReadShp.hs +++ b/src/depends/readshp/Geometry/Shapefile/ReadShp.hs @@ -9,15 +9,16 @@ readShpData, ) where -import Control.Monad ( replicateM, when ) -import Control.Monad.Loops ( whileM ) -import Data.Binary.Get -import Data.Binary.IEEE754 ( getFloat64le ) +import Control.Monad (replicateM, replicateM_, when) +import Control.Monad.Loops (whileM) +import Data.Binary.Get +import Data.Binary.IEEE754 (getFloat64le) +import Data.Semigroup -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BL -import Geometry.Shapefile.Internal -import Geometry.Shapefile.Types +import Geometry.Shapefile.Internal +import Geometry.Shapefile.Types -- | Read shapefile at `fp` to resident data structure `ShpData` readShpFile :: String -> IO ShpData @@ -28,7 +29,7 @@ readShpData = runGet $ do shpH <- getShpHeader shpRs <- whileM (not <$> isEmpty) getShpRec - return ShpData { shpHeader = shpH, + pure ShpData { shpHeader = shpH, dbfFieldDescs = Nothing, -- fill using readDbfData shpRecs = shpRs } @@ -37,12 +38,12 @@ getShpHeader = do fc <- getIntBE -- File code when (fc /= 9994) (error "getShpHeader: Input file is not a SHP file") - _ <- replicateM 5 getWord32be -- Unused data + _ <- replicateM_ 5 getWord32be -- Unused data shpLen <- getIntBE -- File length shpV <- getIntLE -- Version (little-endian!) shpT <- getShpType -- Shape type shpbb <- getShpBBox shpT -- Bounding box - return ShpHeader { shpFileLength = shpLen, + pure ShpHeader { shpFileLength = shpLen, shpVersion = shpV, shpType = shpT, shpBB = shpbb } @@ -58,13 +59,13 @@ [xMin, yMin, xMax, yMax] <- replicateM 4 getFloat64le [zMin, zMax] <- let ds = replicateM 2 getFloat64le in if t `elem` zTypes - then map Just <$> ds - else ds >> return [Nothing, Nothing] + then fmap Just <$> ds + else ds >> pure [Nothing, Nothing] [mMin, mMax] <- let ds = replicateM 2 getFloat64le in if t `elem` mTypes - then map Just <$> ds - else ds >> return [Nothing, Nothing] - return ShpBBox { shpXMin = xMin, + then fmap Just <$> ds + else ds >> pure [Nothing, Nothing] + pure ShpBBox { shpXMin = xMin, shpXMax = xMax, shpYMin = yMin, shpYMax = yMax, @@ -80,84 +81,82 @@ recLen <- getIntBE -- Record length recType <- getShpType -- Shape type recContents <- if recType == ShpNull -- Record contents - then return Nothing + then pure Nothing else Just <$> getRecContents recType - return ShpRec { shpRecNum = recNum, - shpRecLen = recLen, - shpRecContents = recContents, - shpRecLabel = Nothing, - shpRecType = recType } + pure ShpRec { shpRecNum = recNum, + shpRecLen = recLen, + shpRecContents = recContents, + shpRecLabel = Nothing, + shpRecType = recType } -- | Get record contents for record of given type getRecContents :: ShpType -> Get RecContents getRecContents t = case t of - ShpPoint -> do - p <- getPoint - return $ RecPoint p + ShpPoint -> RecPoint <$> getPoint ShpPointM -> do p <- getPoint m <- getFloat64le - return $ RecPointM { pmPoint = p, pmM = m } + pure RecPointM { pmPoint = p, pmM = m } ShpPointZ -> do p <- getPoint z <- getFloat64le m <- getFloat64le - return $ RecPointZ { pzPoint = p, pzZ = z, pzM = m } + pure RecPointZ { pzPoint = p, pzZ = z, pzM = m } ShpMultiPoint -> do (bb, nPoints, points) <- getPointsData - return RecMultiPoint { recMPBBox = bb, - recMPNumPoints = nPoints, - recMPPoints = points } + pure RecMultiPoint { recMPBBox = bb, + recMPNumPoints = nPoints, + recMPPoints = points } ShpMultiPointM -> do (bb, nPoints, points) <- getPointsData (mMin, mMax, ms) <- getMData nPoints - return RecMultiPointM { recMPMBBox = bb, - recMPMNumPoints = nPoints, - recMPMPoints = points, - recMPMMRange = (mMin, mMax), - recMPMMs = ms} + pure RecMultiPointM { recMPMBBox = bb, + recMPMNumPoints = nPoints, + recMPMPoints = points, + recMPMMRange = (mMin, mMax), + recMPMMs = ms} ShpMultiPointZ -> do (bb, nPoints, points) <- getPointsData (zMin, zMax, zs) <- getZData nPoints (mMin, mMax, ms) <- getMData nPoints - return RecMultiPointZ { recMPZBBox = bb, - recMPZNumPoints = nPoints, - recMPZPoints = points, - recMPZZRange = (zMin, zMax), - recMPZZs = zs, - recMPZMRange = (mMin, mMax), - recMPZMs = ms } + pure RecMultiPointZ { recMPZBBox = bb, + recMPZNumPoints = nPoints, + recMPZPoints = points, + recMPZZRange = (zMin, zMax), + recMPZZs = zs, + recMPZMRange = (mMin, mMax), + recMPZMs = ms } ShpPolyLine -> do (bb, nParts, nPoints, partLengths, pntLists) <- getPolyData - return RecPolyLine { recPolLBBox = bb, - recPolLNumParts = nParts, - recPolLNumPoints = nPoints, - recPolLPartLengths = partLengths, - recPolLPoints = pntLists } + pure RecPolyLine { recPolLBBox = bb, + recPolLNumParts = nParts, + recPolLNumPoints = nPoints, + recPolLPartLengths = partLengths, + recPolLPoints = pntLists } ShpPolyLineM -> do (bb, nParts, nPoints, partLengths, pntLists) <- getPolyData (mMin, mMax, ms) <- getMData nPoints - return RecPolyLineM { recPolLMBBox = bb, - recPolLMNumParts = nParts, - recPolLMNumPoints = nPoints, - recPolLMPartLengths = partLengths, - recPolLMPoints = pntLists, - recPolLMMRange = (mMin, mMax), - recPolLMMs = ms } + pure RecPolyLineM { recPolLMBBox = bb, + recPolLMNumParts = nParts, + recPolLMNumPoints = nPoints, + recPolLMPartLengths = partLengths, + recPolLMPoints = pntLists, + recPolLMMRange = (mMin, mMax), + recPolLMMs = ms } ShpPolyLineZ -> do (bb, nParts, nPoints, partLengths, pntLists) <- getPolyData (zMin, zMax, zs) <- getZData nPoints (mMin, mMax, ms) <- getMData nPoints - return RecPolyLineZ { recPolLZBBox = bb, + pure RecPolyLineZ { recPolLZBBox = bb, recPolLZNumParts = nParts, recPolLZNumPoints = nPoints, recPolLZPartLengths = partLengths, @@ -169,7 +168,7 @@ ShpPolygon -> do (bb, nParts, nPoints, partLengths, pntLists) <- getPolyData - return RecPolygon { recPolBBox = bb, + pure RecPolygon { recPolBBox = bb, recPolNumParts = nParts, recPolNumPoints = nPoints, recPolPartLengths = partLengths, @@ -178,7 +177,7 @@ ShpPolygonM -> do (bb, nParts, nPoints, partLengths, pntLists) <- getPolyData (mMin, mMax, ms) <- getMData nPoints - return RecPolygonM { recPolMBBox = bb, + pure RecPolygonM { recPolMBBox = bb, recPolMNumParts = nParts, recPolMNumPoints = nPoints, recPolMPartLengths = partLengths, @@ -190,7 +189,7 @@ (bb, nParts, nPoints, partLengths, pntLists) <- getPolyData (zMin, zMax, zs) <- getZData nPoints (mMin, mMax, ms) <- getMData nPoints - return RecPolygonZ { recPolZBBox = bb, + pure RecPolygonZ { recPolZBBox = bb, recPolZNumParts = nParts, recPolZNumPoints = nPoints, recPolZPartLengths = partLengths, @@ -201,7 +200,7 @@ recPolZMs = ms } ShpNull -> - return RecNull + pure RecNull ShpMultiPatch -> error "getShpRec: MultiPatch type is not supported, sorry!" @@ -212,7 +211,7 @@ bb <- getRecBBox nPoints <- getIntLE points <- replicateM nPoints getPoint - return (bb, nPoints, points) + pure (bb, nPoints, points) -- | Recurring pattern of a bounding box with polygon data getPolyData :: Get (RecBBox, Int, Int, [Int], [[Point]]) @@ -221,16 +220,16 @@ nParts <- getIntLE nPoints <- getIntLE partIndices <- replicateM nParts getIntLE - let partLengths = steps $ partIndices ++ [nPoints] + let partLengths = steps $ partIndices <> [nPoints] pntLists <- mapM getPointList partLengths - return (bb, nParts, nPoints, partLengths, pntLists) + pure (bb, nParts, nPoints, partLengths, pntLists) -- | Recurring pattern of M-valued data getMData :: Int -> Get (Double, Double, [Double]) getMData nPoints = do [mMin, mMax] <- replicateM 2 getFloat64le ms <- replicateM nPoints getFloat64le - return (mMin, mMax, ms) + pure (mMin, mMax, ms) -- | Recurring pattern of Z-valued data (same structure as M-valued data) getZData :: Int -> Get (Double, Double, [Double]) @@ -240,7 +239,7 @@ getRecBBox :: Get RecBBox getRecBBox = do [xMin, yMin, xMax, yMax] <- replicateM 4 getFloat64le - return RecBBox { recXMin = xMin, + pure RecBBox { recXMin = xMin, recXMax = xMax, recYMin = yMin, recYMax = yMax } diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,14 @@ +--- +resolver: lts-11.3 +extra-deps: + - Chart-diagrams-1.8.3 + - composition-prelude-1.3.0.8 + - SVGFonts-1.6.0.3 + - diagrams-core-1.4.0.1 + - diagrams-lib-1.4.2 + - diagrams-postscript-1.4 + - diagrams-svg-1.4.1.1 + - diagrams-solve-0.1.1 + - dual-tree-0.2.1.1 + - lens-4.15.4 + - free-4.12.4 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,12 +7,12 @@ main :: IO () main = hspec $ do - describe "distance" $ do - it "computes distances along geodesics" $ do - distance ((-74.0059), 40.7128) ((-118.2347), 34.0522) `shouldBe` 3934.997673163554 - describe "mercatorFullPng" $ do - it "Reads a map and writes a .png with the mercator projection" $ do - (mkMapPng "test/testmap.png" =<< districtToMapP bonne <$> getDistricts "test/data/worldmap/TM_WORLD_BORDERS-0.3.shp") >>= (`shouldBe` ()) - describe "mercatorFullSVG" $ do - it "Reads a map and writes a .svg with the mercator projection" $ do - (mkMapSVG "test/testmap.svg" =<< districtToMapP bonne <$> getDistricts "test/data/worldmap/TM_WORLD_BORDERS-0.3.shp") >>= (`shouldBe` ()) + describe "distance" $ + it "computes distances along geodesics" $ + distance (-74.0059, 40.7128) (-118.2347, 34.0522) `shouldBe` 3934.997673163554 + describe "mercatorFullPng" $ + it "Reads a map and writes a .png with the mercator projection" $ + (mkMapPng "test/testmap.png" =<< districtToMapP bonne <$> getDistricts "test/data/worldmap/TM_WORLD_BORDERS-0.3.shp") >>= (`shouldBe` ()) + describe "mercatorFullSVG" $ + it "Reads a map and writes a .svg with the mercator projection" $ + (mkMapSVG "test/testmap.svg" =<< districtToMapP bonne <$> getDistricts "test/data/worldmap/TM_WORLD_BORDERS-0.3.shp") >>= (`shouldBe` ())