extra/shapefiles/shapefiles.factor

   1 ! Copyright (C) 2018 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors byte-arrays classes combinators endian io
   5 io.encodings.binary io.files io.streams.byte-array kernel
   6 math math.order math.statistics sequences sequences.extras sets
   7 ;
   8
   9 IN: shapefiles
  10
  11 SINGLETON: null-shape
  12 TUPLE: point x y ;
  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 ;
  25
  26 <PRIVATE
  27
  28 : read-int ( -- n )
  29     4 read le> ;
  30
  31 : read-ints ( n -- parts )
  32     [ read-int ] replicate ;
  33
  34 : read-double ( -- n )
  35     8 read le> bits>double ;
  36
  37 : read-doubles ( n -- array )
  38     [ read-double ] replicate ;
  39
  40 : read-box ( -- box )
  41     4 read-doubles ;
  42
  43 : read-range ( -- range )
  44     2 read-doubles ;
  45
  46 : read-point ( -- point )
  47     read-double read-double point boa ;
  48
  49 : read-points ( n -- points )
  50     [ read-point ] replicate ;
  51
  52 : (read-multipoint) ( -- box points )
  53     read-box read-int read-points ;
  54
  55 : read-multipoint ( -- multipoint )
  56     (read-multipoint) multipoint boa ;
  57
  58 : read-poly ( -- box parts points )
  59     read-box read-int read-int [ read-ints ] dip read-points ;
  60
  61 : read-point-z ( -- point-z )
  62     read-double read-double read-double read-double point-z boa ;
  63
  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 ;
  67
  68 : read-multipoint-z ( -- multipoint-z )
  69     (read-multipoint) read-range over length
  70     [ read-doubles read-range ] [ read-doubles ] bi
  71     multipoint-z boa ;
  72
  73 : read-point-m ( -- point-m )
  74     read-double read-double read-double point-m boa ;
  75
  76 : read-poly-m ( -- box parts points m-range m-array )
  77     read-poly read-range over length read-doubles ;
  78
  79 : read-multipoint-m ( -- multipoint-m )
  80     (read-multipoint) read-range over length read-doubles
  81     multipoint-m boa ;
  82
  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 ;
  89
  90 : read-shape ( -- shape )
  91     read-int {
  92         { 0 [ null-shape ] }
  93         { 1 [ read-point ] }
  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 ] }
 106     } case ;
 107
 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 ;
 111
 112 : read-header ( -- header )
 113     4 read be> dup 9994 assert=
 114     20 read drop ! unused
 115     4 read be>
 116     read-int dup 1000 assert=
 117     read-int
 118     read-double
 119     read-double
 120     read-double
 121     read-double
 122     read-double
 123     read-double
 124     read-double
 125     read-double
 126     header boa ;
 127
 128 TUPLE: record number content-length shape ;
 129
 130 : read-record ( -- record/f )
 131     4 read [ be> 4 read be> read-shape record boa ] [ f ] if* ;
 132
 133 : read-records ( -- records )
 134     [ read-record ] loop>array ;
 135
 136 : read-shp ( -- header records )
 137     read-header read-records ;
 138
 139 : file>shp ( path -- header records )
 140     binary [ read-shp ] with-file-reader ;
 141
 142 TUPLE: index offset content-length ;
 143
 144 : read-index ( -- index/f )
 145     4 read [ be> 4 read be> index boa ] [ f ] if* ;
 146
 147 : read-indices ( -- indices )
 148     [ read-index ] loop>array ;
 149
 150 : read-shx ( -- header indices )
 151     read-header read-indices ;
 152
 153 : file>shx ( path -- header indices )
 154     binary [ read-shx ] with-file-reader ;
 155
 156 : num-records ( path -- n )
 157     ".shx" append binary [
 158         read-header file-length>> 2 * 100 - 8 /
 159     ] with-file-reader ;
 160
 161 : nth-index ( n path -- index )
 162     ".shx" append binary [
 163         8 * 100 + seek-absolute seek-input read-index
 164     ] with-file-reader ;
 165
 166 : nth-record ( n path -- record )
 167     [ nth-index offset>> ] keep ".shp" append binary [
 168         2 * seek-absolute seek-input read-record
 169     ] with-file-reader ;
 170
 171 : write-int ( n -- )
 172     4 >le write ;
 173
 174 : write-double ( n -- )
 175     double>bits 8 >le write ;
 176
 177 : write-point ( point -- )
 178     [ x>> ] [ y>> ] bi [ write-double ] bi@ ;
 179
 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<< ;
 189
 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<< ;
 195
 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<< ;
 201
 202 GENERIC: update-bounds ( header shape -- header )
 203
 204 M: object update-bounds drop ;
 205
 206 M: polyline update-bounds update-box ;
 207
 208 M: polygon update-bounds update-box ;
 209
 210 M: multipoint update-bounds update-box ;
 211
 212 M: polyline-z update-bounds
 213     [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
 214
 215 M: polygon-z update-bounds
 216     [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
 217
 218 M: multipoint-z update-bounds
 219     [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
 220
 221 M: polyline-m update-bounds
 222     [ call-next-method ] [ update-m-range ] bi ;
 223
 224 M: polygon-m update-bounds
 225     [ call-next-method ] [ update-m-range ] bi ;
 226
 227 M: multipoint-m update-bounds
 228     [ call-next-method ] [ update-m-range ] bi ;
 229
 230 M: multipatch update-bounds
 231     [ update-box ] [ update-z-range ] [ update-m-range ] tri ;
 232
 233 GENERIC: (write-shape) ( shape -- )
 234
 235 M: null-shape (write-shape) drop ;
 236
 237 M: point (write-shape) write-point ;
 238
 239 : write-poly ( poly -- )
 240     {
 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 ]
 246     } cleave ; inline
 247
 248 M: polyline (write-shape) write-poly ;
 249
 250 M: polygon (write-shape) write-poly ;
 251
 252 M: multipoint (write-shape)
 253     {
 254         [ box>> [ write-double ] each ]
 255         [ points>> length write-int ]
 256         [ points>> [ write-point ] each ]
 257     } cleave ;
 258
 259 M: point-z (write-shape)
 260     [ call-next-method ] [ z>> ] [ m>> ] tri [ write-double ] bi@ ;
 261
 262 : write-z ( shape -- )
 263     [ z-range>> ] [ z-array>> ] bi [ [ write-double ] each ] bi@ ; inline
 264
 265 : write-m ( shape -- )
 266     [ m-range>> ] [ m-array>> ] bi [ [ write-double ] each ] bi@ ; inline
 267
 268 : write-poly-z ( poly -- )
 269     [ write-poly ] [ write-z ] [ write-m ] tri ; inline
 270
 271 M: polyline-z (write-shape) write-poly-z ;
 272
 273 M: polygon-z (write-shape) write-poly-z ;
 274
 275 M: multipoint-z (write-shape)
 276     [ call-next-method ] [ write-z ] [ write-m ] tri ;
 277
 278 M: point-m (write-shape)
 279     [ call-next-method ] [ m>> write-double ] bi ;
 280
 281 : write-poly-m ( poly -- )
 282     [ write-poly ] [ write-m ] bi ; inline
 283
 284 M: polyline-m (write-shape) write-poly-m ;
 285
 286 M: polygon-m (write-shape) write-poly-m ;
 287
 288 M: multipoint-m (write-shape)
 289     [ call-next-method ] [ write-m ] bi ;
 290
 291 M: multipatch (write-shape)
 292     {
 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 ]
 299         [ write-z ]
 300         [ write-m ]
 301     } cleave ;
 302
 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 ;
 318
 319 : write-shape ( shape -- )
 320     [ shape-type write-int ] [ (write-shape) ] bi ;
 321
 322 : write-header ( header -- )
 323     {
 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 ]
 337     } cleave ;
 338
 339 : write-record ( shape index -- )
 340     1 + 4 >be write
 341     binary [ write-shape ] with-byte-writer
 342     [ length 2/ 4 >be write ] [ write ] bi ;
 343
 344 ERROR: non-null-shapes-must-be-same-type shape-types ;
 345
 346 : non-null-shape-types ( shapes -- shape-types )
 347     [ null-shape? ] reject [ class-of ] map members ;
 348
 349 : check-shape-types ( shapes -- )
 350     non-null-shape-types dup length 1 >
 351     [ non-null-shapes-must-be-same-type ] [ drop ] if ;
 352
 353 : write-shp ( shapes -- header indices )
 354     [ header new ] dip {
 355         [ check-shape-types ]
 356         [ first shape-type >>shape-type ]
 357         [ [ update-bounds ] each ]
 358         [ ]
 359     } cleave binary [
 360         [
 361             [ tell-output 100 + 2/ ] 2dip write-record
 362             tell-output 100 + 8 - 2/ over - index boa
 363         ] map-index
 364     ] with-byte-writer swap [
 365         [ length 100 + 2/ >>file-length [ write-header ] keep ]
 366         [ write ] bi
 367     ] dip ;
 368
 369 : write-index ( index -- )
 370     [ offset>> ] [ content-length>> ] bi [ 4 >be write ] bi@ ;
 371
 372 : write-shx ( header indices -- )
 373     [ length 8 * 100 + 2/ >>file-length write-header ]
 374     [ [ write-index ] each ] bi ;
 375
 376 PRIVATE>
 377
 378 : load-shapes ( path -- shapes )
 379     ".shp" append file>shp nip [ shape>> ] map ;
 380
 381 : save-shapes ( shapes path -- )
 382     [ ".shp" append binary [ write-shp ] with-file-writer ]
 383     [ ".shx" append binary [ write-shx ] with-file-writer ] bi ;