shapefiles: implement save-shapes.

diff --git a/extra/shapefiles/shapefiles.factor b/extra/shapefiles/shapefiles.factor
index 3a1b02273304cc62de1fb7a226fcb20c6b5d1611..ba5a5b98ad74e3a85fc4621c5b69c7e0be190af1 100644 (file)
--- a/extra/shapefiles/shapefiles.factor
+++ b/extra/shapefiles/shapefiles.factor
@@ -1,8 +1,10 @@
 ! Copyright (C) 2018 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: accessors combinators io io.binary io.encodings.binary
-io.files kernel math sequences ;
+USING: accessors byte-arrays classes combinators io
+io.binary.fast io.encodings.binary io.files
+io.streams.byte-array kernel locals math math.order
+math.statistics sequences sets ;
 
 IN: shapefiles
 
@@ -166,7 +168,216 @@ TUPLE: index offset content-length ;
         2 * seek-absolute seek-input read-record
     ] with-file-reader ;
 
+: write-int ( n -- )
+    4 >le write ;
+
+: write-double ( n -- )
+    double>bits 8 >le write ;
+
+: write-point ( point -- )
+    [ x>> ] [ y>> ] bi [ write-double ] bi@ ;
+
+:: update-box ( header shape -- header )
+    header shape points>> :> points
+    points [ x>> ] map minmax :> ( x-min x-max )
+    points [ y>> ] map minmax :> ( y-min y-max )
+    [ x-min [ or ] keep min ] change-x-min
+    [ x-max [ or ] keep max ] change-x-max
+    [ y-min [ or ] keep min ] change-y-min
+    [ y-max [ or ] keep max ] change-y-max
+    { x-min y-min x-max y-max } shape box<< ;
+
+:: update-z-range ( header shape -- header )
+    header shape z-array>> minmax :> ( z-min z-max )
+    [ z-min [ or ] keep min ] change-z-min
+    [ z-max [ or ] keep max ] change-z-max
+    { z-min z-max } shape z-range<< ;
+
+:: update-m-range ( header shape -- header )
+    header shape m-array>> minmax :> ( m-min m-max )
+    [ m-min [ or ] keep min ] change-m-min
+    [ m-max [ or ] keep max ] change-m-max
+    { m-min m-max } shape m-range<< ;
+
+GENERIC: update-bounds ( header shape -- header )
+
+M: object update-bounds drop ;
+
+M: polyline update-bounds update-box ;
+
+M: polygon update-bounds update-box ;
+
+M: multipoint update-bounds update-box ;
+
+M: polyline-z update-bounds
+    [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
+
+M: polygon-z update-bounds
+    [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
+
+M: multipoint-z update-bounds
+    [ call-next-method ] [ update-z-range ] [ update-m-range ] tri ;
+
+M: polyline-m update-bounds
+    [ call-next-method ] [ update-m-range ] bi ;
+
+M: polygon-m update-bounds
+    [ call-next-method ] [ update-m-range ] bi ;
+
+M: multipoint-m update-bounds
+    [ call-next-method ] [ update-m-range ] bi ;
+
+M: multipatch update-bounds
+    [ update-box ] [ update-z-range ] [ update-m-range ] tri ;
+
+GENERIC: (write-shape) ( shape -- )
+
+M: null-shape (write-shape) drop ;
+
+M: point (write-shape) write-point ;
+
+: write-poly ( poly -- )
+    {
+        [ box>> [ write-double ] each ]
+        [ parts>> length write-int ]
+        [ points>> length write-int ]
+        [ parts>> [ write-int ] each ]
+        [ points>> [ write-point ] each ]
+    } cleave ; inline
+
+M: polyline (write-shape) write-poly ;
+
+M: polygon (write-shape) write-poly ;
+
+M: multipoint (write-shape)
+    {
+        [ box>> [ write-double ] each ]
+        [ points>> length write-int ]
+        [ points>> [ write-point ] each ]
+    } cleave ;
+
+M: point-z (write-shape)
+    [ call-next-method ] [ z>> ] [ m>> ] tri [ write-double ] bi@ ;
+
+: write-z ( shape -- )
+    [ z-range>> ] [ z-array>> ] bi [ [ write-double ] each ] bi@ ; inline
+
+: write-m ( shape -- )
+    [ m-range>> ] [ m-array>> ] bi [ [ write-double ] each ] bi@ ; inline
+
+: write-poly-z ( poly -- )
+    [ write-poly ] [ write-z ] [ write-m ] tri ; inline
+
+M: polyline-z (write-shape) write-poly-z ;
+
+M: polygon-z (write-shape) write-poly-z ;
+
+M: multipoint-z (write-shape)
+    [ call-next-method ] [ write-z ] [ write-m ] tri ;
+
+M: point-m (write-shape)
+    [ call-next-method ] [ m>> write-double ] bi ;
+
+: write-poly-m ( poly -- )
+    [ write-poly ] [ write-m ] bi ; inline
+
+M: polyline-m (write-shape) write-poly-m ;
+
+M: polygon-m (write-shape) write-poly-m ;
+
+M: multipoint-m (write-shape)
+    [ call-next-method ] [ write-m ] bi ;
+
+M: multipatch (write-shape)
+    {
+        [ box>> [ write-double ] each ]
+        [ parts>> length write-int ]
+        [ points>> length write-int ]
+        [ parts>> [ write-int ] each ]
+        [ part-types>> [ write-int ] each ]
+        [ points>> [ write-point ] each ]
+        [ write-z ]
+        [ write-m ]
+    } cleave ;
+
+GENERIC: shape-type ( shape -- shape-type )
+M: null-shape shape-type drop 0 ;
+M: point shape-type drop 1 ;
+M: polyline shape-type drop 3 ;
+M: polygon shape-type drop 5 ;
+M: multipoint shape-type drop 8 ;
+M: point-z shape-type drop 11 ;
+M: polyline-z shape-type drop 13 ;
+M: polygon-z shape-type drop 15 ;
+M: multipoint-z shape-type drop 18 ;
+M: point-m shape-type drop 21 ;
+M: polyline-m shape-type drop 23 ;
+M: polygon-m shape-type drop 25 ;
+M: multipoint-m shape-type drop 28 ;
+M: multipatch shape-type drop 31 ;
+
+: write-shape ( shape -- )
+    [ shape-type write-int ] [ (write-shape) ] bi ;
+
+: write-header ( header -- )
+    {
+        [ file-code>> 4 >be write ]
+        [ drop 20 <byte-array> write ] ! unused
+        [ file-length>> 4 >be write ]
+        [ version>> write-int ]
+        [ shape-type>> write-int ]
+        [ x-min>> 0.0 or write-double ]
+        [ y-min>> 0.0 or write-double ]
+        [ x-max>> 0.0 or write-double ]
+        [ y-max>> 0.0 or write-double ]
+        [ z-min>> 0.0 or write-double ]
+        [ z-max>> 0.0 or write-double ]
+        [ m-min>> 0.0 or write-double ]
+        [ m-max>> 0.0 or write-double ]
+    } cleave ;
+
+: write-record ( shape index -- )
+    1 + 4 >be write
+    binary [ write-shape ] with-byte-writer
+    [ length 2/ 4 >be write ] [ write ] bi ;
+
+ERROR: non-null-shapes-must-be-same-type shape-types ;
+
+: non-null-shape-types ( shapes -- shape-types )
+    [ null-shape? ] reject [ class-of ] map members ;
+
+: check-shape-types ( shapes -- )
+    non-null-shape-types dup length 1 >
+    [ non-null-shapes-must-be-same-type ] [ drop ] if ;
+
+: write-shp ( shapes -- header indices )
+    [ header new ] dip {
+        [ check-shape-types ]
+        [ first shape-type >>shape-type ]
+        [ [ update-bounds ] each ]
+        [ ]
+    } cleave binary [
+        [
+            [ tell-output 100 + 2/ ] 2dip write-record
+            tell-output 100 + 8 - 2/ over - index boa
+        ] map-index
+    ] with-byte-writer swap [
+        [ length 100 + 2/ >>file-length [ write-header ] keep ]
+        [ write ] bi
+    ] dip ;
+
+: write-index ( index -- )
+    [ offset>> ] [ content-length>> ] bi [ 4 >be write ] bi@ ;
+
+: write-shx ( header indices -- )
+    [ length 8 * 100 + 2/ >>file-length write-header ]
+    [ [ write-index ] each ] bi ;
+
 PRIVATE>
 
 : load-shapes ( path -- shapes )
     ".shp" append file>shp nip [ shape>> ] map ;
+
+: save-shapes ( shapes path -- )
+    [ ".shp" append binary [ write-shp ] with-file-writer ]
+    [ ".shx" append binary [ write-shx ] with-file-writer ] bi ;