-
Notifications
You must be signed in to change notification settings - Fork 2
/
DrawOsm.hs
242 lines (206 loc) · 9.66 KB
/
DrawOsm.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
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"
-- zoom = 16::Int
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 = ((1-tmp / 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}
-- | Determines the minimum and maximum of the X and Y tiles
-- to be downloaded from OSM
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
-- | Takes the boundaries of the OSM tiles, and generates
-- [(Int,Int)] containing a list of all OSM tiles that
-- need downloading
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]]
-- | Formats the filename string
filenameStr :: (Show a, Show a1) => a -> a1 -> String
filenameStr xTile yTile = tilesprefix ++ tilesourcename ++ "-z"++show zoom++"-x"++show xTile++"-y"++show yTile++".png"
-- | Formats the URL string
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}
-- | Takes the URL of a given OSM tile and uses curl to download it
downloadFile :: String -> IO Image
downloadFile url = do
response <- liftM (B.concat . L.toChunks) (simpleHttp url)
loadPngByteString response
-- | Takes the boundaries of the OSM tiles covering the
-- the 'Trail', uses 'placeTile' to download the tile
-- and to place each tile on the background layer
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
-- | Used to create a mosaic of all downloaded OSM tiles to generate
-- the background layer for plotting the 'Trail' onto the 'Image'
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*(x-minX tCoords),256*(y-minY tCoords)) backgroundImg
projectMercToLat :: Floating a => a -> a
projectMercToLat rely = (180 / pi) * atan (sinh rely)
-- | Used by @pixelPosForCoord@ for N,S,E,W coordinates for (x,y) values
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') -- S,W,N,E
-- | Takes a WptType, and the OSM tile boundaries
-- and generates (x,y) points to be placed on the 'Image'
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)
-- | Takes the 'WptType' and draws lines between every
-- point to point connection in the 'Trail'
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,fromJust $ ele wpt,maxEle) 0
drawLines wpts tCoord img zoom
-- | This is a fix on the fact that the 'drawLine' function
-- provided by the GD bindings do not provid a `width' parameter
drawLine' :: Point -> Point -> Image -> (Double,Double,Double) -> Int -> IO ()
drawLine' start end img (minEle,ele',maxEle) i
| i < 4 = do
drawLine (fst start+(i-2),snd start-(i-2)) (fst end+(i-2),snd end-(i-2)) color' img
drawLine (fst start+(i+2),snd start-(i-2)) (fst end+(i+2),snd end-(i-2)) color' img
drawLine (fst start+(i+2),snd start-(i+2)) (fst end+(i+2),snd end-(i+2)) color' img
drawLine (fst start+(i-2),snd start-(i+2)) (fst end+(i-2),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''
-- | Uses a sliding scale for the red value in the RGB Color
-- to show a sliding color from green to yellow in accordance
-- with the relative elevation of a given WptType in the Trail
lineColor :: Int -> Graphics.GD.Color
lineColor redVal = rgb redVal 255 0
-- | Adds the copyright text in accordance with
-- http://wiki.openstreetmap.org/wiki/Legal_FAQ
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 size-10)
black = rgb 0 0 0
useFontConfig True
drawString "monospace" 6.0 0.0 pos copyrightS black img
-- | If the generated OSM image has a greater width than 800 pixels, it is scaled to have a width of 800 pixels.
fitToWidth :: Image -> IO Image
fitToWidth img = do
dimensions <- imageSize img
let width = fst dimensions
if width > 800 then resizeImg img dimensions else return img
-- | Uses the GraphicsMagick bindings the resize the image
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
-- | Takes the destination directory for the web content,
-- the (Trail WptType), and uses the DrawOsm functions
-- to generate an `osm.png' file showing the trail.
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