shapefiles: reorganize a bit, and add ``load-shapes``.

diff --git a/extra/shapefiles/shapefiles.factor b/extra/shapefiles/shapefiles.factor
index f8a3ad569fc9d7958094be3f9aeb43f78e6aa6d9..3a1b02273304cc62de1fb7a226fcb20c6b5d1611 100644 (file)
--- a/extra/shapefiles/shapefiles.factor
+++ b/extra/shapefiles/shapefiles.factor
@@ -1,11 +1,26 @@
 ! Copyright (C) 2018 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: arrays combinators io io.binary.fast io.encodings.binary
+USING: accessors combinators io io.binary io.encodings.binary
 io.files kernel math sequences ;
 
 IN: shapefiles
 
+SINGLETON: null-shape
+TUPLE: point x y ;
+TUPLE: multipoint box points ;
+TUPLE: polygon box parts points ;
+TUPLE: polyline box parts points ;
+TUPLE: point-z < point z m ;
+TUPLE: polyline-z < polyline z-range z-array m-range m-array ;
+TUPLE: polygon-z < polygon z-range z-array m-range m-array ;
+TUPLE: multipoint-z < multipoint z-range z-array m-range m-array ;
+TUPLE: point-m < point m ;
+TUPLE: polyline-m < polyline m-range m-array ;
+TUPLE: polygon-m < polygon m-range m-array ;
+TUPLE: multipoint-m < multipoint m-range m-array ;
+TUPLE: multipatch box parts part-types points z-range z-array m-range m-array ;
+
 <PRIVATE
 
 : read-int ( -- n )
@@ -26,114 +41,43 @@ IN: shapefiles
 : read-range ( -- range )
     2 read-doubles ;
 
-PRIVATE>
-
-TUPLE: header file-code file-length version shape-type x-min
-y-min x-max y-max z-min z-max m-min m-max ;
-
-: read-header ( -- header )
-    4 read be> dup 9994 assert=
-    20 read drop ! unused
-    4 read be>
-    read-int dup 1000 assert=
-    read-int
-    read-double
-    read-double
-    read-double
-    read-double
-    read-double
-    read-double
-    read-double
-    read-double
-    header boa ;
-
-SINGLETON: null-shape
-
-TUPLE: point x y ;
-
 : read-point ( -- point )
     read-double read-double point boa ;
 
 : read-points ( n -- points )
     [ read-point ] replicate ;
 
-TUPLE: multipoint box points ;
+: (read-multipoint) ( -- box points )
+    read-box read-int read-points ;
 
 : read-multipoint ( -- multipoint )
-    read-box read-int read-points multipoint boa ;
-
-TUPLE: polyline box parts points ;
+    (read-multipoint) multipoint boa ;
 
-: read-polyline ( -- polyline )
-    read-box read-int read-int [ read-ints ] dip
-    read-points polyline boa ;
-
-TUPLE: polygon box parts points ;
-
-: read-polygon ( -- polygon )
-    read-box read-int read-int [ read-ints ] dip
-    read-points polygon boa ;
-
-TUPLE: point-z x y z m ;
+: read-poly ( -- box parts points )
+    read-box read-int read-int [ read-ints ] dip read-points ;
 
 : read-point-z ( -- point-z )
     read-double read-double read-double read-double point-z boa ;
 
-TUPLE: polyline-z box parts points z-range z-array m-range
-m-array ;
-
-: read-polyline-z ( -- polyline-z )
-    read-box read-int read-int [ read-ints ] dip
-    [ read-points read-range ]
-    [ read-doubles read-range ]
-    [ read-doubles ] tri polyline-z boa ;
-
-TUPLE: polygon-z box parts points z-range z-array m-range
-m-array ;
-
-: read-polygon-z ( -- polygon-z )
-    read-box read-int read-int [ read-ints ] dip
-    [ read-points read-range ]
-    [ read-doubles read-range ]
-    [ read-doubles ] tri polygon-z boa ;
-
-TUPLE: multipoint-z box points z-range z-array m-range m-array ;
+: read-poly-z ( -- box parts points z-range z-array m-range m-array )
+    read-poly read-range over length
+    [ read-doubles read-range ] [ read-doubles ] bi ;
 
 : read-multipoint-z ( -- multipoint-z )
-    read-box read-int
-    [ read-points read-range ]
-    [ read-doubles read-range ]
-    [ read-doubles ] tri multipoint-z boa ;
-
-TUPLE: point-m x y m ;
+    (read-multipoint) read-range over length
+    [ read-doubles read-range ] [ read-doubles ] bi
+    multipoint-z boa ;
 
 : read-point-m ( -- point-m )
     read-double read-double read-double point-m boa ;
 
-TUPLE: polyline-m box parts points m-range m-array ;
-
-: read-polyline-m ( -- polyline-m )
-    read-box read-int read-int [ read-ints ] dip
-    [ read-points read-range ] [ read-doubles ] bi
-    polyline-m boa ;
-
-TUPLE: polygon-m box parts points m-range m-array ;
-
-: read-polygon-m ( -- polygon-m )
-    read-box read-int read-int [ read-ints ] dip
-    [ read-points read-range ] [ read-doubles ] bi
-    polygon-m boa ;
-
-TUPLE: multipoint-m box points m-range m-array ;
+: read-poly-m ( -- box parts points m-range m-array )
+    read-poly read-range over length read-doubles ;
 
 : read-multipoint-m ( -- multipoint-m )
-    read-box read-int
-    [ read-points read-range ] [ read-doubles ] bi
+    (read-multipoint) read-range over length read-doubles
     multipoint-m boa ;
 
-TUPLE: multipatch box parts part-types points z-range z-array
-m-range m-array ;
-
 : read-multipatch ( -- multipatch )
     read-box read-int read-int
     [ [ read-ints ] [ read-ints ] bi ] dip
@@ -145,20 +89,40 @@ m-range m-array ;
     read-int {
         { 0 [ null-shape ] }
         { 1 [ read-point ] }
-        { 3 [ read-polyline ] }
-        { 5 [ read-polygon ] }
+        { 3 [ read-poly polyline boa ] }
+        { 5 [ read-poly polygon boa ] }
         { 8 [ read-multipoint ] }
         { 11 [ read-point-z ] }
-        { 13 [ read-polyline-z ] }
-        { 15 [ read-polygon-z ] }
+        { 13 [ read-poly-z polyline-z boa ] }
+        { 15 [ read-poly-z polygon-z boa ] }
         { 18 [ read-multipoint-z ] }
         { 21 [ read-point-m ] }
-        { 23 [ read-polyline-m ] }
-        { 25 [ read-polygon-m ] }
+        { 23 [ read-poly-m polyline-m boa ] }
+        { 25 [ read-poly-m polygon-m boa ] }
         { 28 [ read-multipoint-m ] }
         { 31 [ read-multipatch ] }
     } case ;
 
+TUPLE: header { file-code initial: 9994 } file-length
+{ version initial: 1000 } shape-type x-min y-min x-max y-max
+z-min z-max m-min m-max ;
+
+: read-header ( -- header )
+    4 read be> dup 9994 assert=
+    20 read drop ! unused
+    4 read be>
+    read-int dup 1000 assert=
+    read-int
+    read-double
+    read-double
+    read-double
+    read-double
+    read-double
+    read-double
+    read-double
+    read-double
+    header boa ;
+
 TUPLE: record number content-length shape ;
 
 : read-record ( -- record/f )
@@ -186,3 +150,23 @@ TUPLE: index offset content-length ;
 
 : file>shx ( path -- header indices )
     binary [ read-shx ] with-file-reader ;
+
+: num-records ( path -- n )
+    ".shx" append binary [
+        read-header file-length>> 2 * 100 - 8 /
+    ] with-file-reader ;
+
+: nth-index ( n path -- index )
+    ".shx" append binary [
+        8 * 100 + seek-absolute seek-input read-index
+    ] with-file-reader ;
+
+: nth-record ( n path -- record )
+    [ nth-index offset>> ] keep ".shp" append binary [
+        2 * seek-absolute seek-input read-record
+    ] with-file-reader ;
+
+PRIVATE>
+
+: load-shapes ( path -- shapes )
+    ".shp" append file>shp nip [ shape>> ] map ;