Changeset 34506 in project


Ignore:
Timestamp:
09/04/17 00:48:49 (3 months ago)
Author:
kon
Message:

add types, ? for preds

Location:
release/4/geo-utils/trunk
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • release/4/geo-utils/trunk/geo-dms.scm

    r34462 r34506  
    11;;;; geo-dms.scm
    22;;;; Kon Lovett, May '17
     3;;;; Kon Lovett, Sep '17
    34
    45(module geo-dms
     
    89  dms->degree degree->dms
    910  dms->string dms->string*
    10   string-dms->degree )
     11  string-dms->degree
     12  ;
     13  degree->string string->degree )
    1114
    1215(import scheme)
     
    4043;;
    4144
     45(: degree-minute-second-text (#!optional (list string string string) -> (list string string string)))
    4246(define degree-minute-second-text
    4347  (make-parameter
     
    5458; fixnum fixnum fixnum #!optional boolean boolean string -> string
    5559; the degree argument maybe negative
     60(: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
    5661(define (dms->string d m s #!optional lat? leading-dir? (pad ""))
    5762  (if (and (fx= d 0) (fx= m 0) (fx= s 0))
     
    7176; -122°45'10"W => 122.752777777778 even though W
    7277;
     78(: string-dms->degree (string #!optional boolean --> number))
    7379(define (string-dms->degree str #!optional lat?)
    7480  (let ((match (irregex-match +dms-regex+ str)))
     
    99105        (dms->degree d m s) ) ) ) )
    100106
     107;
     108(define string->degree string-dms->degree)
     109
     110;
     111(: degree->string (float #!optional boolean boolean string --> string))
     112(define (degree->string deg #!optional lat? leading-dir? (pad ""))
     113  (receive (d m s) (degree->dms deg)
     114    (dms->string d m s lat? leading-dir? pad) ) )
     115
    101116;;
    102117
    103118; fixnum fixnum fixnum -> flonum
    104119; the degree argument maybe negative
     120(: dms->degree (fixnum fixnum fixnum --> float))
    105121(define (dms->degree d m s)
    106122  (let* (
     
    116132
    117133; flonum -> fixnum fixnum fixnum
     134(: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
    118135(define (degree->dms deg)
    119136  (let* ((deg (exact->inexact deg))
     
    127144        (values (if neg? (fxneg ideg) ideg) imin isec) ) ) ) )
    128145
     146(: dms->string* (number number number #!optional string --> string))
    129147(define (dms->string* d m s #!optional (pad ""))
    130148  (string-append
  • release/4/geo-utils/trunk/geo-utils.scm

    r34419 r34506  
    11;;;; geo-utils.scm
    22;;;; Kon Lovett, May '17
     3;;;; Kon Lovett, Sep '17
    34
    45(module geo-utils
     
    4142;;
    4243
     44(: pythagorean-distance (number number number number --> number))
    4345(define (pythagorean-distance lat1 lon1 lat2 lon2)
    4446  (sqrt (pythagorean-distance* lat1 lon1 lat2 lon2)) )
    4547
     48(: pythagorean-distance* (number number number number --> number))
    4649(define (pythagorean-distance* lat1 lon1 lat2 lon2)
    4750  (let ((a (- lat1 lat2))
     
    5154;;
    5255
     56(: spherical-surface-distance (float float float float #!optional float --> float))
    5357(define (spherical-surface-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-MILES))
    5458  ;haversine formula : https://en.wikipedia.org/wiki/Haversine_formula
     
    6872;;
    6973
     74(: great-circle-distance (float float float float #!optional float --> float))
    7075(define (great-circle-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-MILES))
    7176  (let ((lat1 (fpdegree->radian lat1))
     
    7681
    7782; https://en.wikipedia.org/wiki/Great-circle_distance
     83(: great-circle-distance-radians (float float float float #!optional float --> float))
    7884(define (great-circle-distance-radians lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-MILES))
    7985  (let ((d
     
    9399;;
    94100
     101(: straight-line-distance (float float float float float float #!optional float --> float))
    95102(define (straight-line-distance lat1 lon1 h1 lat2 lon2 h2 #!optional (R EARTH-RADIUS-MILES))
    96103  ;filler
     
    99106;;
    100107
     108(: approximate-ellipsoid-distance (float float float float #!optional float --> float))
    101109(define (approximate-ellipsoid-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-MILES))
    102110  (let ((lat1 (fpdegree->radian lat1))
     
    135143;;
    136144
     145(: great-circle-azimuth (float float float float #!optional (or fixnum float) --> float))
    137146(define (great-circle-azimuth lat1 lon1 lat2 lon2 #!optional (prec 5))
    138147  ;
     
    186195;;
    187196
     197(: great-circle-position (float float float float #!optional float --> float float))
    188198(define (great-circle-position lat lon dis azi #!optional (R EARTH-RADIUS-MILES))
    189199  (let ((dlat (fpdegree->radian (fp- 90.0 lat)))
  • release/4/geo-utils/trunk/geo-utils.setup

    r34455 r34506  
    55(verify-extension-name "geo-utils")
    66
    7 (setup-shared+static-extension-module 'geopoint (extension-version "0.2.0")
     7(setup-shared+static-extension-module 'geopoint (extension-version "0.3.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    1111
    12 (setup-shared+static-extension-module 'geobox (extension-version "0.2.0")
     12(setup-shared+static-extension-module 'geobox (extension-version "0.3.0")
    1313  #:inline? #t
    1414  #:types? #t
    1515  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    1616
    17 (setup-shared+static-extension-module 'geopolygon (extension-version "0.2.0")
     17(setup-shared+static-extension-module 'geopolygon (extension-version "0.3.0")
    1818  #:inline? #t
    1919  #:types? #t
    2020  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    2121
    22 (setup-shared+static-extension-module 'geopoint-utils (extension-version "0.2.0")
     22(setup-shared+static-extension-module 'geopoint-utils (extension-version "0.3.0")
    2323  #:inline? #t
    2424  #:types? #t
    2525  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    2626
    27 (setup-shared+static-extension-module (extension-name) (extension-version "0.2.0")
     27(setup-shared+static-extension-module (extension-name) (extension-version "0.3.0")
    2828  #:inline? #t
    2929  #:types? #t
    3030  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    3131
    32 (setup-shared+static-extension-module 'geo-dms (extension-version "0.2.0")
     32(setup-shared+static-extension-module 'geo-dms (extension-version "0.3.0")
    3333  #:inline? #t
    3434  #:types? #t
  • release/4/geo-utils/trunk/geobox.scm

    r34496 r34506  
    99  geobox-minimum geobox-maximum
    1010  geobox= geobox< geobox> geobox<= geobox>=
    11   geopoint-within-box )
     11  geopoint-within-box? )
    1212
    1313(import scheme chicken)
     
    2121;;
    2222
    23 (define *make-geobox cons)
    24 (define *geobox-minimum car)
    25 (define *geobox-maximum cdr)
     23(: *make-geobox ((struct geopoint) (struct geopoint) --> (struct geobox)))
     24(: geobox? (* --> boolean))
     25(: *geobox-minimum ((struct geobox) --> (struct geopoint)))
     26(: *geobox-maximum ((struct geobox) --> (struct geopoint)))
     27(define-record-type geobox
     28  (*make-geobox min max)
     29  geobox?
     30  (min *geobox-minimum)
     31  (max *geobox-maximum) )
    2632
    27 ;;;
    28 
    29 ;;
    30 
     33;(: make-geobox (or ((struct geopoint) (struct geopoint) --> (struct geobox)) (number number number number --> (struct geobox))))
    3134(define make-geobox
    3235  (case-lambda
     
    3740        (make-geopoint minLat minLon) (make-geopoint maxLat maxLon)) ) ) )
    3841
     42(: make-geobox* (symbol (struct geopoint) (struct geopoint) --> (struct geobox)))
    3943(define (make-geobox* loc min-pnt max-pnt)
    4044  (check-geopoint loc min-pnt)
     
    4246  (unless
    4347    (and
    44       (geopoint-above min-pnt max-pnt)
    45       (geopoint-left min-pnt max-pnt) )
     48      (geopoint-above? min-pnt max-pnt)
     49      (geopoint-left? min-pnt max-pnt) )
    4650    (error loc "minimum-geopoint > maximum-geopoint" min-pnt max-pnt) )
    4751  (*make-geobox min-pnt max-pnt) )
    4852
    49 (define (geobox? obj)
    50   (and
    51     (pair? obj)
    52     (geopoint? (car obj))
    53     (geopoint? (cdr obj))) )
    54 
    5553(define-check+error-type geobox)
    5654
     55(: geobox-minimum ((struct geobox) --> (struct geopoint)))
    5756(define (geobox-minimum gb)
    5857  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
    5958
     59(: geobox-maximum ((struct geobox) --> (struct geopoint)))
    6060(define (geobox-maximum gb)
    6161  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
     
    6363;;
    6464
     65(: geobox= ((struct geobox) (struct geobox) --> boolean))
    6566(define (geobox= gb1 gb2)
    6667  (check-geobox 'geobox= gb1)
     
    7071    (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    7172
     73(: geobox< ((struct geobox) (struct geobox) --> boolean))
    7274(define (geobox< gb1 gb2)
    7375  (check-geobox 'geobox< gb1)
     
    7779    (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    7880
     81(: geobox> ((struct geobox) (struct geobox) --> boolean))
    7982(define (geobox> gb1 gb2)
    8083  (check-geobox 'geobox> gb1)
     
    8487    (geopoint> (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    8588
     89(: geobox<= ((struct geobox) (struct geobox) --> boolean))
    8690(define (geobox<= gb1 gb2)
    8791  (check-geobox 'geobox<= gb1)
     
    9195    (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    9296
     97(: geobox>= ((struct geobox) (struct geobox) --> boolean))
    9398(define (geobox>= gb1 gb2)
    9499  (check-geobox 'geobox>= gb1)
     
    98103    (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    99104
    100 (define (geopoint-within-box gp gb)
     105(: geopoint-within-box? ((struct geobox) (struct geobox) --> boolean))
     106(define (geopoint-within-box? gp gb)
    101107  (and
    102108    (geopoint<= (*geobox-minimum gb) gp)
  • release/4/geo-utils/trunk/geopoint-utils.scm

    r34455 r34506  
    2121;;;
    2222
     23(define-type geopolygon (or (list-of (struct geopoint)) (vector-of (struct geopoint))))
     24
    2325;;
    2426
    2527;https://github.com/substack/point-in-polygon
     28;(: geopoint-in-closed-polygon? ((struct geopoint) geopolygon #!optional ((struct geopoint) (struct geopoint) number number --> boolean) --> boolean))
     29(: geopoint-in-closed-polygon? ((struct geopoint) geopolygon #!optional procedure --> boolean))
    2630(define (geopoint-in-closed-polygon? gp gpoly #!optional (intersects? intersects?-pnp))
    2731        ;test for intersection of ray with every segment of the polygon
     
    4852;; Ray-casting algorithm (http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html)
    4953;; (https://github.com/substack/point-in-polygon)
     54(: intersects?-pnp ((struct geopoint) (struct geopoint) number number --> boolean))
    5055(define (intersects?-pnp pi pj lat lon)
    5156  (let ((lati (geopoint-latitude pi))
     
    5964;; Ray-casting algorithm (http://en.wikipedia.org/wiki/Point_in_polygon)
    6065;; (http://alienryderflex.com/polygon/)
     66(: intersects?-pip ((struct geopoint) (struct geopoint) number number --> boolean))
    6167(define (intersects?-pip pi pj lat lon)
    6268  (let ((lati (geopoint-latitude pi))
  • release/4/geo-utils/trunk/geopoint.scm

    r34496 r34506  
    88  geopoint? check-geopoint error-geopoint
    99  geopoint-latitude geopoint-longitude
    10   geopoint-strictly-above geopoint-above geopoint-strictly-below geopoint-below
    11   geopoint-strictly-left geopoint-left geopoint-strictly-right geopoint-right
     10  ;
     11  geopoint-strictly-above? geopoint-above? geopoint-strictly-below? geopoint-below?
     12  geopoint-strictly-left? geopoint-left? geopoint-strictly-right? geopoint-right?
     13  ;
    1214  geopoint= geopoint< geopoint> geopoint<= geopoint>=
    1315  ;
     
    2426;;
    2527
    26 (define *make-geopoint cons)
    27 (define *geopoint-latitude car)
    28 (define *geopoint-longitude cdr)
     28(: *make-geopoint (number number --> (struct geopoint)))
     29(: geopoint? (* --> boolean))
     30(: *geopoint-latitude ((struct geopoint) --> number))
     31(: *geopoint-longitude ((struct geopoint) --> number))
     32(define-record-type geopoint
     33  (*make-geopoint lat lon)
     34  geopoint?
     35  (lat *geopoint-latitude)
     36  (lon *geopoint-longitude) )
    2937
    30 ;;;
    31 
    32 ;;
    33 
     38(: make-geopoint (number number --> (struct geopoint)))
    3439(define (make-geopoint lat lon)
    3540  (*make-geopoint
    36     (check-real 'make-geopoint lat "lat")
    37     (check-real 'make-geopoint lon "lon")) )
    38 
    39 (define (geopoint? obj)
    40   (and
    41     (pair? obj)
    42     (real? (car obj))
    43     (real? (cdr obj))) )
     41    (check-real 'make-geopoint lat 'lat)
     42    (check-real 'make-geopoint lon 'lon)) )
    4443
    4544(define-check+error-type geopoint)
    4645
     46(: geopoint-latitude ((struct geopoint) --> number))
    4747(define (geopoint-latitude gp)
    4848  (*geopoint-latitude (check-geopoint 'geopoint-latitude gp)) )
    4949
     50(: geopoint-longitude ((struct geopoint) --> number))
    5051(define (geopoint-longitude gp)
    5152  (*geopoint-longitude (check-geopoint 'geopoint-longitude gp)) )
     
    5354;;
    5455
    55 (define (geopoint-strictly-above gp1 gp2)
     56(: geopoint-strictly-above? ((struct geopoint) (struct geopoint) --> boolean))
     57(define (geopoint-strictly-above? gp1 gp2)
    5658  (check-geopoint 'geopoint-strictly-above gp1)
    5759  (check-geopoint 'geopoint-strictly-above gp2)
    5860  (< (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
    5961
    60 (define (geopoint-above gp1 gp2)
     62(: geopoint-above? ((struct geopoint) (struct geopoint) --> boolean))
     63(define (geopoint-above? gp1 gp2)
    6164  (check-geopoint 'geopoint-above gp1)
    6265  (check-geopoint 'geopoint-above gp2)
    6366  (<= (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
    6467
    65 (define (geopoint-strictly-below gp1 gp2)
     68(: geopoint-strictly-below? ((struct geopoint) (struct geopoint) --> boolean))
     69(define (geopoint-strictly-below? gp1 gp2)
    6670  (check-geopoint 'geopoint-strictly-below gp1)
    6771  (check-geopoint 'geopoint-strictly-below gp2)
    6872  (> (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
    6973
    70 (define (geopoint-below gp1 gp2)
     74(: geopoint-below? ((struct geopoint) (struct geopoint) --> boolean))
     75(define (geopoint-below? gp1 gp2)
    7176  (check-geopoint 'geopoint-below gp1)
    7277  (check-geopoint 'geopoint-below gp2)
    7378  (>= (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
    7479
    75 (define (geopoint-strictly-left gp1 gp2)
     80(: geopoint-strictly-left? ((struct geopoint) (struct geopoint) --> boolean))
     81(define (geopoint-strictly-left? gp1 gp2)
    7682  (check-geopoint 'geopoint-strictly-left gp1)
    7783  (check-geopoint 'geopoint-strictly-left gp2)
    7884  (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
    7985
    80 (define (geopoint-left gp1 gp2)
     86(: geopoint-left? ((struct geopoint) (struct geopoint) --> boolean))
     87(define (geopoint-left? gp1 gp2)
    8188  (check-geopoint 'geopoint-left gp1)
    8289  (check-geopoint 'geopoint-left gp2)
    8390  (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
    8491
    85 (define (geopoint-strictly-right gp1 gp2)
     92(: geopoint-strictly-right? ((struct geopoint) (struct geopoint) --> boolean))
     93(define (geopoint-strictly-right? gp1 gp2)
    8694  (check-geopoint 'geopoint-strictly-right gp1)
    8795  (check-geopoint 'geopoint-strictly-right gp2)
    8896  (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
    8997
    90 (define (geopoint-right gp1 gp2)
     98(: geopoint-right? ((struct geopoint) (struct geopoint) --> boolean))
     99(define (geopoint-right? gp1 gp2)
    91100  (check-geopoint 'geopoint-right gp1)
    92101  (check-geopoint 'geopoint-right gp2)
    93102  (>= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
    94103
     104;;
     105
     106(: geopoint= ((struct geopoint) (struct geopoint) --> boolean))
    95107(define (geopoint= gp1 gp2)
    96108  (check-geopoint 'geopoint= gp1)
     
    100112    (= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    101113
     114(: geopoint< ((struct geopoint) (struct geopoint) --> boolean))
    102115(define (geopoint< gp1 gp2)
    103116  (check-geopoint 'geopoint< gp1)
     
    107120    (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    108121
     122(: geopoint> ((struct geopoint) (struct geopoint) --> boolean))
    109123(define (geopoint> gp1 gp2)
    110124  (check-geopoint 'geopoint> gp1)
     
    114128    (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    115129
     130(: geopoint<= ((struct geopoint) (struct geopoint) --> boolean))
    116131(define (geopoint<= gp1 gp2)
    117132  (check-geopoint 'geopoint<= gp1)
     
    121136    (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    122137
     138(: geopoint>= ((struct geopoint) (struct geopoint) --> boolean))
    123139(define (geopoint>= gp1 gp2)
    124140  (check-geopoint 'geopoint>= gp1)
  • release/4/geo-utils/trunk/geopolygon.scm

    r34455 r34506  
    2424;;;
    2525
     26(define-type geopolygon (or (list-of (struct geopoint)) (vector-of (struct geopoint))))
     27
    2628;not strict
    2729(define make-geopolygon
     
    3739      (make-geopolygon rest) ) ) )
    3840
     41(: geopolygon? (* --> boolean))
    3942(define (geopolygon? obj)
    4043  (and
     
    4851
    4952; explicitly closed means [0] = [n-1]
     53(: geopolygon-closed? (geopolygon --> boolean))
    5054(define (geopolygon-closed? gpoly)
    5155        (let* ((gpoly (if (list? gpoly) (list->vector gpoly) gpoly))
     
    5660
    5761; explicitly open means [0] != [n-1]
     62(: geopolygon-open? (geopolygon --> boolean))
    5863(define (geopolygon-open? gpoly)
    5964        (not (geopolygon-closed? gpoly)) )
     
    6166;;
    6267
     68(: geopolygon-bounding-box (geopolygon --> (struct geobox)))
    6369(define (geopolygon-bounding-box gpoly)
    6470        (let ((gpoly (if (list? gpoly) (list->vector gpoly) gpoly)))
  • release/4/geo-utils/trunk/tests/run.scm

    r34455 r34506  
     1;;;; test-geo-utils.scm
     2;;;; Kon Lovett, May '17
     3;;;; Kon Lovett, Sep '17
    14
    25(use test)
     
    47(use fp-utils)
    58
    6 ;;
     9;;;
    710
    811(use geo-utils)
     
    3033    (test-assert (fp~= lon2 lon 0.009)) ) )
    3134
    32 ;;
     35;;;
    3336
    3437(use geo-dms)
     
    4346(test -10.3416666666667 (string-dms->degree "W10° 20'30\"" #t))
    4447
    45 ;;
     48;;;
    4649
    4750(use geopoint)
     
    5356  (test lon1 (geopoint-longitude gp1))
    5457
    55   (test-assert (not (geopoint-left gp1 gp2)))
    56   (test-assert (geopoint-right gp1 gp2))
    57   (test-assert (geopoint-above gp1 gp2))
    58   (test-assert (not (geopoint-below gp1 gp2)))
     58  (test-assert (not (geopoint-left? gp1 gp2)))
     59  (test-assert (geopoint-right? gp1 gp2))
     60  (test-assert (geopoint-above? gp1 gp2))
     61  (test-assert (not (geopoint-below? gp1 gp2)))
    5962)
    6063
    61 ;;
     64;;;
    6265
    6366(use geobox)
     
    9295)
    9396
     97;;;
     98
    9499(test-exit)
    95100
Note: See TracChangeset for help on using the changeset viewer.