module Data.GPS.Gps2HtmlReport.DrawOsm where
import Prelude
import Data.GPS
import Graphics.Transform.Magick.Types hiding (Image, minimum, maximum)
import Network.HTTP.Enumerator
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Control.Monad
import Data.Bits
import Graphics.GD
import Data.Maybe
import Data.GPS.Gps2HtmlReport.JourneyStats
baseurl = "http://tile.openstreetmap.org"
tilesprefix = "tile"
tilesourcename = "osmrender"
data TileCoords = TileCoords { minX :: Int
, maxX :: Int
, minY :: Int
, maxY :: Int
}
tileNumbers :: Double -> Double -> Int -> [(Int,Int)]
tileNumbers latitude longitude zoom =
let xtile = ((longitude+180) / 360) * fromInteger (shift (1::Integer) zoom)
tmp = log (tan (latitude*pi / 180) + secant (latitude * pi / 180))
ytile = ((1tmp / pi) / 2.0) * fromInteger (shift (1::Integer) zoom)
bounds x = [ceiling x, floor x]
in [(xt,yt) | xt <- bounds xtile, yt <- bounds ytile]
maxTile :: [(Int,Int)] -> (Int,Int)
maxTile [] = error "There is no max tile of an empty list"
maxTile (x:xs) = go x xs
where
go a [] = a
go a (y:ys) = if fst y >= fst a && snd y >= snd a then go y ys else go a ys
secant :: Floating a => a -> a
secant a = 1 / cos a
initCoords :: TileCoords
initCoords = TileCoords {minX = 1000000, maxX = 1000, minY = 1000000, maxY = 1000}
determineTiles :: [WptType] -> TileCoords -> Int -> TileCoords
determineTiles [] _ _ = initCoords
determineTiles [wpt] tCoords zoom =
let curMinX = minX tCoords
curMaxX = maxX tCoords
curMinY = minY tCoords
curMaxY = maxY tCoords
tiles = tileNumbers (value (lat wpt)) (value (lon wpt)) zoom
newMaxX = maximum $ curMaxX : map fst tiles
newMinX = minimum $ curMinX : map fst tiles
newMaxY = maximum $ curMaxY : map snd tiles
newMinY = minimum $ curMinY : map snd tiles
in tCoords {minX = newMinX, maxX = newMaxX, minY = newMinY, maxY = newMaxY}
determineTiles (wpt:wpts) tCoords zoom =
let tileScope = determineTiles [wpt] tCoords zoom
in determineTiles wpts tileScope zoom
deltaLat :: TileCoords -> Int
deltaLat tCoords = maxX tCoords minX tCoords
deltaLong :: TileCoords -> Int
deltaLong tCoords = maxY tCoords minY tCoords
maxNumAutoTiles = 32
zoom :: TileCoords -> Int
zoom = zoomCalc
zoomCalc :: TileCoords -> Int
zoomCalc tCoords =
let numxtiles = maxX tCoords minX tCoords + 1
numytiles = maxY tCoords minY tCoords + 1
div = getZoomDiv numxtiles numytiles 0
in 16 div
getZoomDiv x y i
| (x+1)*(y+1) > maxNumAutoTiles = getZoomDiv (shiftR x 1) (shiftR y 1) (i+1)
| otherwise = i
selectedTiles :: TileCoords -> [(Int,Int)]
selectedTiles tCoords =
let minx = minX tCoords
maxx = maxX tCoords
miny = minY tCoords
maxy = maxY tCoords
in [(i,j) | i <- [minx..maxx], j <- [miny..maxy]]
filenameStr :: (Show a, Show a1) => a -> a1 -> String
filenameStr xTile yTile = tilesprefix ++ tilesourcename ++ "-z"++show zoom++"-x"++show xTile++"-y"++show yTile++".png"
urlStr xTile yTile zoom = baseurl ++"/"++show zoom++"/"++show xTile++"/"++show yTile++".png"
rectangle :: Int -> Int -> Graphics.Transform.Magick.Types.Rectangle
rectangle x' y' = Rectangle {width=256, height=256, x = x'*256, y = y'*256}
downloadFile :: String -> IO Image
downloadFile url = do
response <- liftM (B.concat . L.toChunks) (simpleHttp url)
loadPngByteString response
makeOSMLayer :: TileCoords -> Int -> IO Image
makeOSMLayer tCoords zoom = do
backgroundImg <- newImage (((maxX tCoords minX tCoords)+1)*256,((maxY tCoords minY tCoords)+1)*256)
mapM_ (\(a,b) -> placeTile a b backgroundImg tCoords zoom) (selectedTiles tCoords)
return backgroundImg
placeTile :: Int -> Int -> Graphics.GD.Image -> TileCoords -> Int -> IO ()
placeTile x y backgroundImg tCoords zoom = do
img <- downloadFile $ urlStr x y zoom
copyRegion (0,0) (256,256) img (256*(xminX tCoords),256*(yminY tCoords)) backgroundImg
projectMercToLat :: Floating a => a -> a
projectMercToLat rely = (180 / pi) * atan (sinh rely)
project :: Int -> Int -> Int -> (Double,Double,Double,Double)
project x y zoom =
let unit = 1.0 / (2.0 ** fromIntegral zoom)
rely1 = fromIntegral y * unit
rely2 = rely1 + unit
limity = pi
rangey = 2.0 * limity
rely1' = limity rangey * rely1
rely2' = limity rangey * rely2
lat1 = projectMercToLat rely1'
lat2 = projectMercToLat rely2'
unit' = 360.0 / (2.0 ** fromIntegral zoom)
long1 = (180.0) + fromIntegral x * unit'
in (lat2,long1,lat1,long1+unit')
pixelPosForCoord :: (Lon a, Lat a, Integral t, Integral t1) => [a] -> TileCoords -> Int -> (t, t1)
pixelPosForCoord [] _ _ = (0,0)
pixelPosForCoord [wpt] tCoord zoom =
let lat' = value $ lat wpt
lon' = value $ lon wpt
tile = maxTile $ tileNumbers lat' lon' zoom
xoffset = (fst tile minX tCoord) * 256
yoffset = (snd tile minY tCoord) * 256
(south,west,north,east) = (uncurry project tile zoom)
x = round $ (lon' west) * 256.0 / (east west) + fromIntegral xoffset
y = round $ (lat' north) * 256.0 / (south north) + fromIntegral yoffset
in (x,y)
drawLines :: [WptType] -> TileCoords -> Image -> Int -> IO Image
drawLines [] _ img _ = return img
drawLines [_] _ img _ = return img
drawLines (wpt:wpts) tCoord img zoom = do
let start = pixelPosForCoord [wpt] tCoord zoom
end = pixelPosForCoord [head wpts] tCoord zoom
minEle = fromMaybe 0 $ fmap snd $ findPoint wpts wpt ele (<)
maxEle = fromMaybe 0 $ fmap snd $ findPoint wpts wpt ele (>)
drawLine' start end img (minEle,fromMaybe 0 $ ele wpt,maxEle) 0
drawLines wpts tCoord img zoom
drawLine' :: Point -> Point -> Image -> (Double,Double,Double) -> Int -> IO ()
drawLine' start end img (minEle,ele',maxEle) i
| i < 4 = do
drawLine (fst start+(i2),snd start(i2)) (fst end+(i2),snd end(i2)) color' img
drawLine (fst start+(i+2),snd start(i2)) (fst end+(i+2),snd end(i2)) color' img
drawLine (fst start+(i+2),snd start(i+2)) (fst end+(i+2),snd end(i+2)) color' img
drawLine (fst start+(i2),snd start(i+2)) (fst end+(i2),snd end(i+2)) color' img
drawLine' start end img (minEle,ele',maxEle) (i+1)
| otherwise = return ()
where range = maxEle minEle
x' = ele' minEle
x'' = x' / range
color' = lineColor $ round $ 255.0*x''
lineColor :: Int -> Graphics.GD.Color
lineColor redVal = rgb redVal 255 0
addCopyright :: Graphics.GD.Image -> IO (Graphics.GD.Point, Graphics.GD.Point, Graphics.GD.Point, Graphics.GD.Point)
addCopyright img = do
size <- imageSize img
let copyrightS = "Tile images © OpenStreetMap (and) contributors, CC-BY-SA"
pos = (10,snd size10)
black = rgb 0 0 0
useFontConfig True
drawString "monospace" 6.0 0.0 pos copyrightS black img
fitToWidth :: Image -> IO Image
fitToWidth img = do
dimensions <- imageSize img
let width = fst dimensions
if width > 800 then resizeImg img dimensions else return img
resizeImg :: Image -> (Int,Int) -> IO Image
resizeImg img dimensions = do
let resizeRatio = fromIntegral (fst dimensions) / 800.0
height = round (fromIntegral (snd dimensions) / resizeRatio)
resizeImage 800 height img
generateOsmMap :: String -> [WptType] -> IO ()
generateOsmMap webDir points = do
let tiles = determineTiles points initCoords 16
zoom = zoomCalc tiles
tiles' = determineTiles points initCoords zoom
backgroundImg <- makeOSMLayer tiles' zoom
imgWithLines <- drawLines points tiles' backgroundImg zoom
resizedImg <- fitToWidth imgWithLines
addCopyright resizedImg
savePngFile (webDir++"/osm.png") resizedImg