1 ! Copyright (C) 2018 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors byte-arrays classes combinators io
5 io.binary.fast io.encodings.binary io.files
6 io.streams.byte-array kernel locals math math.order
7 math.statistics sequences sequences.extras sets ;
13 TUPLE: multipoint box points ;
14 TUPLE: polygon box parts points ;
15 TUPLE: polyline box parts points ;
16 TUPLE: point-z < point z m ;
17 TUPLE: polyline-z < polyline z-range z-array m-range m-array ;
18 TUPLE: polygon-z < polygon z-range z-array m-range m-array ;
19 TUPLE: multipoint-z < multipoint z-range z-array m-range m-array ;
20 TUPLE: point-m < point m ;
21 TUPLE: polyline-m < polyline m-range m-array ;
22 TUPLE: polygon-m < polygon m-range m-array ;
23 TUPLE: multipoint-m < multipoint m-range m-array ;
24 TUPLE: multipatch box parts part-types points z-range z-array m-range m-array ;
31 : read-ints ( n -- parts )
32 [ read-int ] replicate ;
34 : read-double ( -- n )
35 8 read le> bits>double ;
37 : read-doubles ( n -- array )
38 [ read-double ] replicate ;
43 : read-range ( -- range )
46 : read-point ( -- point )
47 read-double read-double point boa ;
49 : read-points ( n -- points )
50 [ read-point ] replicate ;
52 : (read-multipoint) ( -- box points )
53 read-box read-int read-points ;
55 : read-multipoint ( -- multipoint )
56 (read-multipoint) multipoint boa ;
58 : read-poly ( -- box parts points )
59 read-box read-int read-int [ read-ints ] dip read-points ;
61 : read-point-z ( -- point-z )
62 read-double read-double read-double read-double point-z boa ;
64 : read-poly-z ( -- box parts points z-range z-array m-range m-array )
65 read-poly read-range over length
66 [ read-doubles read-range ] [ read-doubles ] bi ;
68 : read-multipoint-z ( -- multipoint-z )
69 (read-multipoint) read-range over length
70 [ read-doubles read-range ] [ read-doubles ] bi
73 : read-point-m ( -- point-m )
74 read-double read-double read-double point-m boa ;
76 : read-poly-m ( -- box parts points m-range m-array )
77 read-poly read-range over length read-doubles ;
79 : read-multipoint-m ( -- multipoint-m )
80 (read-multipoint) read-range over length read-doubles
83 : read-multipatch ( -- multipatch )
84 read-box read-int read-int
85 [ [ read-ints ] [ read-ints ] bi ] dip
86 [ read-points read-range ]
87 [ read-doubles read-range ]
88 [ read-doubles ] tri multipatch boa ;
90 : read-shape ( -- shape )
94 { 3 [ read-poly polyline boa ] }
95 { 5 [ read-poly polygon boa ] }
96 { 8 [ read-multipoint ] }
97 { 11 [ read-point-z ] }
98 { 13 [ read-poly-z polyline-z boa ] }
99 { 15 [ read-poly-z polygon-z boa ] }
100 { 18 [ read-multipoint-z ] }
101 { 21 [ read-point-m ] }
102 { 23 [ read-poly-m polyline-m boa ] }
103 { 25 [ read-poly-m polygon-m boa ] }
104 { 28 [ read-multipoint-m ] }
105 { 31 [ read-multipatch ] }
108 TUPLE: header { file-code initial: 9994 } file-length
109 { version initial: 1000 } shape-type x-min y-min x-max y-max
110 z-min z-max m-min m-max ;
112 : read-header ( -- header )
113 4 read be> dup 9994 assert=
114 20 read drop ! unused
116 read-int dup 1000 assert=
128 TUPLE: record number content-length shape ;
130 : read-record ( -- record/f )
131 4 read [ be> 4 read be> read-shape record boa ] [ f ] if* ;
133 : read-records ( -- records )
134 [ read-record ] loop>array ;
136 : read-shp ( -- header records )
137 read-header read-records ;
139 : file>shp ( path -- header records )
140 binary [ read-shp ] with-file-reader ;
142 TUPLE: index offset content-length ;
144 : read-index ( -- index/f )
145 4 read [ be> 4 read be> index boa ] [ f ] if* ;
147 : read-indices ( -- indices )
148 [ read-index ] loop>array ;
150 : read-shx ( -- header indices )
151 read-header read-indices ;
153 : file>shx ( path -- header indices )
154 binary [ read-shx ] with-file-reader ;
156 : num-records ( path -- n )
157 ".shx" append binary [
158 read-header file-length>> 2 * 100 - 8 /
161 : nth-index ( n path -- index )
162 ".shx" append binary [
163 8 * 100 + seek-absolute seek-input read-index
166 : nth-record ( n path -- record )
167 [ nth-index offset>> ] keep ".shp" append binary [
168 2 * seek-absolute seek-input read-record
174 : write-double ( n -- )
175 double>bits 8 >le write ;
177 : write-point ( point -- )
178 [ x>> ] [ y>> ] bi [ write-double ] bi@ ;
180 :: update-box ( header shape -- header )
181 header shape points>> :> points
182 points [ x>> ] map minmax :> ( x-min x-max )
183 points [ y>> ] map minmax :> ( y-min y-max )
184 [ x-min [ or ] keep min ] change-x-min
185 [ x-max [ or ] keep max ] change-x-max
186 [ y-min [ or ] keep min ] change-y-min
187 [ y-max [ or ] keep max ] change-y-max
188 { x-min y-min x-max y-max } shape box<< ;
190 :: update-z-range ( header shape -- header )
191 header shape z-array>> minmax :> ( z-min z-max )
192 [ z-min [ or ] keep min ] change-z-min
193 [ z-max [ or ] keep max ] change-z-max
194 { z-min z-max } shape z-range<< ;
196 :: update-m-range ( header shape -- header )
197 header shape m-array>> minmax :> ( m-min m-max )
198 [ m-min [ or ] keep min ] change-m-min
199 [ m-max [ or ] keep max ] change-m-max
200 { m-min m-max } shape m-range<< ;
202 GENERIC: update-bounds ( header shape -- header )
204 M: object update-bounds drop ;
206 M: polyline update-bounds update-box ;
208 M: polygon update-bounds update-box ;
210 M: multipoint update-bounds update-box ;
212 M: polyline-z update-bounds
213 [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
215 M: polygon-z update-bounds
216 [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
218 M: multipoint-z update-bounds
219 [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
221 M: polyline-m update-bounds
222 [ call-next-method ] [ update-m-range ] bi ;
224 M: polygon-m update-bounds
225 [ call-next-method ] [ update-m-range ] bi ;
227 M: multipoint-m update-bounds
228 [ call-next-method ] [ update-m-range ] bi ;
230 M: multipatch update-bounds
231 [ update-box ] [ update-z-range ] [ update-m-range ] tri ;
233 GENERIC: (write-shape) ( shape -- )
235 M: null-shape (write-shape) drop ;
237 M: point (write-shape) write-point ;
239 : write-poly ( poly -- )
241 [ box>> [ write-double ] each ]
242 [ parts>> length write-int ]
243 [ points>> length write-int ]
244 [ parts>> [ write-int ] each ]
245 [ points>> [ write-point ] each ]
248 M: polyline (write-shape) write-poly ;
250 M: polygon (write-shape) write-poly ;
252 M: multipoint (write-shape)
254 [ box>> [ write-double ] each ]
255 [ points>> length write-int ]
256 [ points>> [ write-point ] each ]
259 M: point-z (write-shape)
260 [ call-next-method ] [ z>> ] [ m>> ] tri [ write-double ] bi@ ;
262 : write-z ( shape -- )
263 [ z-range>> ] [ z-array>> ] bi [ [ write-double ] each ] bi@ ; inline
265 : write-m ( shape -- )
266 [ m-range>> ] [ m-array>> ] bi [ [ write-double ] each ] bi@ ; inline
268 : write-poly-z ( poly -- )
269 [ write-poly ] [ write-z ] [ write-m ] tri ; inline
271 M: polyline-z (write-shape) write-poly-z ;
273 M: polygon-z (write-shape) write-poly-z ;
275 M: multipoint-z (write-shape)
276 [ call-next-method ] [ write-z ] [ write-m ] tri ;
278 M: point-m (write-shape)
279 [ call-next-method ] [ m>> write-double ] bi ;
281 : write-poly-m ( poly -- )
282 [ write-poly ] [ write-m ] bi ; inline
284 M: polyline-m (write-shape) write-poly-m ;
286 M: polygon-m (write-shape) write-poly-m ;
288 M: multipoint-m (write-shape)
289 [ call-next-method ] [ write-m ] bi ;
291 M: multipatch (write-shape)
293 [ box>> [ write-double ] each ]
294 [ parts>> length write-int ]
295 [ points>> length write-int ]
296 [ parts>> [ write-int ] each ]
297 [ part-types>> [ write-int ] each ]
298 [ points>> [ write-point ] each ]
303 GENERIC: shape-type ( shape -- shape-type )
304 M: null-shape shape-type drop 0 ;
305 M: point shape-type drop 1 ;
306 M: polyline shape-type drop 3 ;
307 M: polygon shape-type drop 5 ;
308 M: multipoint shape-type drop 8 ;
309 M: point-z shape-type drop 11 ;
310 M: polyline-z shape-type drop 13 ;
311 M: polygon-z shape-type drop 15 ;
312 M: multipoint-z shape-type drop 18 ;
313 M: point-m shape-type drop 21 ;
314 M: polyline-m shape-type drop 23 ;
315 M: polygon-m shape-type drop 25 ;
316 M: multipoint-m shape-type drop 28 ;
317 M: multipatch shape-type drop 31 ;
319 : write-shape ( shape -- )
320 [ shape-type write-int ] [ (write-shape) ] bi ;
322 : write-header ( header -- )
324 [ file-code>> 4 >be write ]
325 [ drop 20 <byte-array> write ] ! unused
326 [ file-length>> 4 >be write ]
327 [ version>> write-int ]
328 [ shape-type>> write-int ]
329 [ x-min>> 0.0 or write-double ]
330 [ y-min>> 0.0 or write-double ]
331 [ x-max>> 0.0 or write-double ]
332 [ y-max>> 0.0 or write-double ]
333 [ z-min>> 0.0 or write-double ]
334 [ z-max>> 0.0 or write-double ]
335 [ m-min>> 0.0 or write-double ]
336 [ m-max>> 0.0 or write-double ]
339 : write-record ( shape index -- )
341 binary [ write-shape ] with-byte-writer
342 [ length 2/ 4 >be write ] [ write ] bi ;
344 ERROR: non-null-shapes-must-be-same-type shape-types ;
346 : non-null-shape-types ( shapes -- shape-types )
347 [ null-shape? ] reject [ class-of ] map members ;
349 : check-shape-types ( shapes -- )
350 non-null-shape-types dup length 1 >
351 [ non-null-shapes-must-be-same-type ] [ drop ] if ;
353 : write-shp ( shapes -- header indices )
355 [ check-shape-types ]
356 [ first shape-type >>shape-type ]
357 [ [ update-bounds ] each ]
361 [ tell-output 100 + 2/ ] 2dip write-record
362 tell-output 100 + 8 - 2/ over - index boa
364 ] with-byte-writer swap [
365 [ length 100 + 2/ >>file-length [ write-header ] keep ]
369 : write-index ( index -- )
370 [ offset>> ] [ content-length>> ] bi [ 4 >be write ] bi@ ;
372 : write-shx ( header indices -- )
373 [ length 8 * 100 + 2/ >>file-length write-header ]
374 [ [ write-index ] each ] bi ;
378 : load-shapes ( path -- shapes )
379 ".shp" append file>shp nip [ shape>> ] map ;
381 : save-shapes ( shapes path -- )
382 [ ".shp" append binary [ write-shp ] with-file-writer ]
383 [ ".shx" append binary [ write-shx ] with-file-writer ] bi ;