Changeset 38967 in project


Ignore:
Timestamp:
08/30/20 22:42:15 (4 weeks ago)
Author:
Kon Lovett
Message:

add -strict-types, update test runner, fix geopoint-within-box? type

Location:
release/5/geo-utils/trunk
Files:
9 edited

Legend:

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

    r38475 r38967  
    2828(import (chicken flonum))
    2929(import (only mathh modf))
    30 ;moremacros
    3130(import type-checks)
    3231(import type-errors)
    3332(import geopoint)
    3433
    35 ;;;
     34;;
     35
     36(define-type dms-glyphs (list string string string))
     37
     38(: dms-glyphs (#!optional dms-glyphs -> dms-glyphs))
     39(: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
     40(: string-dms->degree (string #!optional boolean --> number))
     41(: string->degree (string #!optional boolean --> number))
     42(: degree->string (float #!optional boolean boolean string --> string))
     43(: dms->degree (fixnum fixnum fixnum --> float))
     44(: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
     45(: dms->string* (number number number #!optional string --> string))
     46(: set-compass-rose! (vector -> void))
     47(: degree->compass-rose (number -> symbol))
     48
     49;;
    3650
    3751(define (degree-latitude? d)
     
    106120;;
    107121
    108 (define-type dms-glyphs (list string string string))
    109 
    110122(define (dms-glyphs? x)
    111123  (and (list? x) (= 3 (length x))) )
     
    113125(define-check+error-type dms-glyphs)
    114126
    115 (: dms-glyphs (#!optional dms-glyphs -> dms-glyphs))
    116 ;
    117127(define dms-glyphs (make-parameter
    118128  `(,DEGREE-UNIT-GLYPH ,MINUTE-UNIT-GLYPH ,SECOND-UNIT-GLYPH)
     
    128138; fixnum fixnum fixnum #!optional boolean boolean string -> string
    129139; the degree argument maybe negative
    130 (: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
    131140;
    132141(define (dms->string d m s #!optional lat? leading-dir? (pad ""))
     
    148157; -122°45'10"E => -122.752777777778 even though E
    149158; -122°45'10"W => 122.752777777778 even though W
    150 ;
    151 (: string-dms->degree (string #!optional boolean --> number))
    152159;
    153160(define (string-dms->degree str #!optional lat?)
     
    173180      (dms->degree (if neg? (- d) d) m s) ) ) )
    174181
    175 ;
    176182(define string->degree string-dms->degree)
    177183
    178 ;
    179 (: degree->string (float #!optional boolean boolean string --> string))
    180 ;
    181184(define (degree->string deg #!optional lat? leading-dir? (pad ""))
    182185  (receive (d m s) (degree->dms deg)
     
    187190; fixnum fixnum fixnum -> flonum
    188191; the degree argument maybe negative
    189 (: dms->degree (fixnum fixnum fixnum --> float))
    190192;
    191193(define (dms->degree d m s)
     
    202204
    203205; flonum -> fixnum fixnum fixnum
    204 (: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
    205206;
    206207(define (degree->dms deg)
     
    221222        (values (if neg? (fxneg ideg) ideg) imin isec) ) ) ) )
    222223
    223 (: dms->string* (number number number #!optional string --> string))
    224 ;
    225224(define (dms->string* d m s #!optional (pad ""))
    226225  (string-append
     
    249248;;
    250249
    251 (: set-compass-rose! (vector -> void))
    252 (: degree->compass-rose (number -> symbol))
    253250(define set-compass-rose!)
    254251(define degree->compass-rose)
    255252(let (
    256   (+rose+ #f)
    257   (+rose-count+ #f)
    258   (+rose-slice+ #f)
    259   (+rose-slice/2+ #f) )
     253  (+rose+ #())
     254  (+rose-count+ 0)
     255  (+rose-slice+ 0)
     256  (+rose-slice/2+ 0) )
    260257  ;
    261258  (define (compass-rose-slice deg)
  • release/5/geo-utils/trunk/geo-globe.scm

    r38475 r38967  
    3131(define-type geopoint (struct geopoint))
    3232
    33 ;;
    34 
    3533(define-type globe (struct globe))
    36 
    37 ;FIXME define:-record-type
    3834
    3935(: *make-globe (number number --> globe))
     
    4137(: *globe-radius-kilometers (globe --> number))
    4238(: *globe-flattening-factor (globe --> number))
    43 ;
     39(: make-globe (number number --> globe))
     40(: globe-radius-kilometers (globe --> number))
     41(: globe-flattening-factor (globe --> number))
     42(: spherical-surface-distance (globe geopoint geopoint --> number))
     43(: approximate-ellipsoid-distance (globe geopoint geopoint --> number))
     44(: great-circle-distance (globe geopoint geopoint --> number))
     45(: great-circle-distance-radians (globe geopoint geopoint --> number))
     46(: great-circle-azimuth (geopoint geopoint #!rest (list (or fixnum float)) --> number))
     47(: great-circle-position (globe geopoint number number --> geopoint))
     48
     49;;
     50
    4451(define-record-type globe
    4552  (*make-globe rad flt)
     
    5057(define-check+error-type globe)
    5158
    52 (: make-globe (number number --> globe))
    53 ;
    5459(define (make-globe rad flt)
    5560  (*make-globe
     
    5762    (check-real 'make-globe flt 'falttening)) )
    5863
    59 (: globe-radius-kilometers (globe --> number))
    60 ;
    6164(define (globe-radius-kilometers glob)
    6265  (*globe-radius-kilometers (check-globe 'globe-radius-kilometers glob 'globe)))
    6366
    64 (: globe-flattening-factor (globe --> number))
    65 ;
    6667(define (globe-flattening-factor glob)
    6768  (*globe-flattening-factor (check-globe 'globe-flattening-factor glob 'globe)))
     
    6970;;
    7071
    71 (: spherical-surface-distance (globe geopoint geopoint --> number))
    72 ;
    7372(define (spherical-surface-distance glob gp1 gp2)
    7473  (check-geopoint 'spherical-surface-distance gp1)
     
    7978    (*globe-radius-kilometers (check-globe 'spherical-surface-distance glob 'globe))) )
    8079
    81 (: approximate-ellipsoid-distance (globe geopoint geopoint --> number))
    82 ;
    8380(define (approximate-ellipsoid-distance glob gp1 gp2)
    8481  (check-globe 'approximate-ellipsoid-distance glob 'globe)
     
    9188    (*globe-flattening-factor glob)) )
    9289
    93 (: great-circle-distance (globe geopoint geopoint --> number))
    94 ;
    9590(define (great-circle-distance glob gp1 gp2)
    9691  (check-geopoint 'great-circle-distance gp1)
     
    10196    (*globe-radius-kilometers (check-globe 'great-circle-distance glob 'globe))) )
    10297
    103 (: great-circle-distance-radians (globe geopoint geopoint --> number))
    104 ;
    10598(define (great-circle-distance-radians glob gp1 gp2)
    10699  (check-geopoint 'great-circle-distance-radians gp1)
     
    111104    (*globe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))) )
    112105
    113 (: great-circle-azimuth (geopoint geopoint #!rest (list (or fixnum float)) --> number))
    114 ;
    115106(define (great-circle-azimuth gp1 gp2 . args)
    116107  (check-geopoint 'great-circle-azimuth gp1)
     
    122113      (check-real 'great-circle-azimuth prec 'precision)) ) )
    123114
    124 (: great-circle-position (globe geopoint number number --> geopoint))
    125 ;
    126115(define (great-circle-position glob gp dis azi)
    127116  (check-geopoint 'great-circle-position gp)
  • release/5/geo-utils/trunk/geo-utils.egg

    r38475 r38967  
    33
    44((synopsis "Geographic Utilities")
    5  (version "1.0.1")
     5 (version "1.0.2")
    66 (category math)
    77 (author "[[kon lovett]]")
    88 (license "BSD")
    9  (dependencies
    10   (vector-lib "2.0")
    11   (mathh "4.0.0")
    12   (check-errors "3.1.0"))
     9 (dependencies vector-lib mathh check-errors)
    1310 (test-dependencies test)
    1411 (components
    1512  (extension geopoint
    16     #;(inline-file)
    1713    (types-file)
    18     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     14    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    1915  (extension geobox
    20     #;(inline-file)
    2116    (types-file)
    2217    (component-dependencies geopoint)
    23     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     18    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    2419  (extension geopolygon
    25     #;(inline-file)
    2620    (types-file)
    2721    (component-dependencies geopoint geobox)
    28     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     22    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    2923  (extension geopoint-utils
    30     #;(inline-file)
    3124    (types-file)
    3225    (component-dependencies geopoint geopolygon)
    33     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     26    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    3427  (extension geo-utils
    35     #;(inline-file)
    3628    (types-file)
    3729    (component-dependencies geopoint)
    38     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     30    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    3931  (extension geo-dms
    40     #;(inline-file)
    4132    (types-file)
    4233    (component-dependencies geopoint)
    43     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     34    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    4435  (extension geo-globe
    45     #;(inline-file)
    4636    (types-file)
    4737    (component-dependencies geopoint geo-utils)
    48     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") )
     38    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    4939  (extension geo-earth
    50     #;(inline-file)
    5140    (types-file)
    5241    (component-dependencies geo-globe)
    53     (csc-options "-O3" "-d1" "-no-procedure-checks-for-toplevel-bindings") ) ) )
     42    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
    5443
    5544#|
  • release/5/geo-utils/trunk/geo-utils.scm

    r38475 r38967  
    2525(import geopoint)
    2626
    27 ;;; FP Utils
    28 
    29 ;;
     27;;
     28
     29(: pythagorean-distance (number number number number --> number))
     30(: pythagorean-distance* (number number number number --> number))
     31(: spherical-surface-distance (float float float float #!optional float --> float))
     32(: great-circle-distance (float float float float #!optional float --> float))
     33(: great-circle-distance-radians (float float float float #!optional float --> float))
     34(: straight-line-distance (float float float float float float #!optional float --> float))
     35(: approximate-ellipsoid-distance (float float float float #!optional float float --> float))
     36(: great-circle-azimuth (float float float float #!optional (or fixnum float) --> float))
     37(: great-circle-position (float float float float #!optional float --> float float))
     38
     39;;(fp-tils)
    3040
    3141(: sqr (float --> float))
    32 ;
     42(: degree->radian (float --> float))
     43(: radian->degree (float --> float))
     44(: precision-factor ((or float fixnum) #!optional float --> float))
     45
    3346(define (sqr n) (* n n))
    3447
    35 ;;
    36 
    3748(define-constant DEGREE 0.0174532925199432957692369076848861271344) ;pi/180
    3849
    39 (: degree->radian (float --> float))
    40 ;
    41 (define (degree->radian deg)
    42   (* deg DEGREE) )
    43 
    44 (: radian->degree (float --> float))
    45 ;
    46 (define (radian->degree rad)
    47   (/ rad DEGREE) )
    48 
    49 ;;
    50 
    51 (: precision-factor ((or float fixnum) #!optional float --> float))
    52 ;
    53 (define (precision-factor p #!optional (base 10.0))
    54   (expt base (exact->inexact p)) )
    55 
    56 ;;;
     50(define (degree->radian deg) (* deg DEGREE))
     51(define (radian->degree rad) (/ rad DEGREE))
     52
     53(define (precision-factor p #!optional (base 10.0)) (expt base (exact->inexact p)))
     54
     55;;
    5756
    5857(include "geo-constants")
     
    6059;;
    6160
    62 (: pythagorean-distance (number number number number --> number))
    63 ;
    6461(define (pythagorean-distance lat1 lon1 lat2 lon2)
    6562  (sqrt (pythagorean-distance* lat1 lon1 lat2 lon2)) )
    6663
    67 (: pythagorean-distance* (number number number number --> number))
    68 ;
    6964(define (pythagorean-distance* lat1 lon1 lat2 lon2)
    7065  (let (
     
    7570;;
    7671
    77 (: spherical-surface-distance (float float float float #!optional float --> float))
    78 ;
    7972(define (spherical-surface-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-KILOMETERS))
    8073  ;haversine formula : https://en.wikipedia.org/wiki/Haversine_formula
     
    9790;;
    9891
    99 (: great-circle-distance (float float float float #!optional float --> float))
    100 ;
    10192(define (great-circle-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-KILOMETERS))
    10293  (let (
     
    10899
    109100; https://en.wikipedia.org/wiki/Great-circle_distance
    110 (: great-circle-distance-radians (float float float float #!optional float --> float))
    111101;
    112102(define (great-circle-distance-radians lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-KILOMETERS))
     
    128118;;
    129119
    130 (: straight-line-distance (float float float float float float #!optional float --> float))
    131 ;
    132120(define (straight-line-distance lat1 lon1 h1 lat2 lon2 h2 #!optional (R EARTH-RADIUS-KILOMETERS))
    133121  ;filler
     
    136124;;
    137125
    138 (: approximate-ellipsoid-distance (float float float float #!optional float float --> float))
    139 ;
    140126(define (approximate-ellipsoid-distance lat1 lon1 lat2 lon2
    141127          #!optional
     
    196182;;
    197183
    198 (: great-circle-azimuth (float float float float #!optional (or fixnum float) --> float))
    199 ;
    200184(define (great-circle-azimuth lat1 lon1 lat2 lon2 #!optional (prec 5))
    201185  ;
     
    257241;;
    258242
    259 (: great-circle-position (float float float float #!optional float --> float float))
    260 ;
    261243(define (great-circle-position lat lon dis azi #!optional (R EARTH-RADIUS-KILOMETERS))
    262244  (let (
  • release/5/geo-utils/trunk/geobox.scm

    r38475 r38967  
    2424(define-type geobox (struct geobox))
    2525
     26(: check-geopoint-above-left? (symbol * * --> boolean))
     27(: *make-geobox (geopoint geopoint --> geobox))
     28(: geobox? (* --> boolean))
     29(: *geobox-minimum (geobox --> geopoint))
     30(: *geobox-maximum (geobox --> geopoint))
     31;(: make-geobox (or (geopoint geopoint --> geobox) (number number number number --> geobox)))
     32(: geobox-minimum (geobox --> geopoint))
     33(: geobox-maximum (geobox --> geopoint))
     34(: geobox= (geobox geobox --> boolean))
     35(: geobox< (geobox geobox --> boolean))
     36(: geobox> (geobox geobox --> boolean))
     37(: geobox<= (geobox geobox --> boolean))
     38(: geobox>= (geobox geobox --> boolean))
     39(: geopoint-within-box? (geopoint geobox --> boolean))
     40
    2641;;
    2742
    28 (: check-geopoint-above-left? (symbol * * --> boolean))
    29 ;
    3043(define (check-geopoint-above-left? loc a b)
    3144  (check-geopoint loc a 'min)
     
    3548;;
    3649
    37 (: *make-geobox (geopoint geopoint --> geobox))
    38 (: geobox? (* --> boolean))
    39 (: *geobox-minimum (geobox --> geopoint))
    40 (: *geobox-maximum (geobox --> geopoint))
    41 ;
    4250(define-record-type geobox
    4351  (*make-geobox min max)
     
    4654  (max *geobox-maximum) )
    4755
    48 ;(: make-geobox (or (geopoint geopoint --> geobox) (number number number number --> geobox)))
    49 ;
    5056(define make-geobox
    5157  (case-lambda
     
    6773(define-check+error-type geobox)
    6874
    69 (: geobox-minimum (geobox --> geopoint))
    70 ;
    7175(define (geobox-minimum gb)
    7276  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
    7377
    74 (: geobox-maximum (geobox --> geopoint))
    75 ;
    7678(define (geobox-maximum gb)
    7779  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
     
    7981;;
    8082
    81 (: geobox= (geobox geobox --> boolean))
    82 ;
    8383(define (geobox= gb1 gb2)
    8484  (check-geobox 'geobox= gb1)
     
    8888    (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    8989
    90 (: geobox< (geobox geobox --> boolean))
    91 ;
    9290(define (geobox< gb1 gb2)
    9391  (check-geobox 'geobox< gb1)
     
    9795    (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    9896
    99 (: geobox> (geobox geobox --> boolean))
    100 ;
    10197(define (geobox> gb1 gb2)
    10298  (check-geobox 'geobox> gb1)
     
    106102    (geopoint> (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    107103
    108 (: geobox<= (geobox geobox --> boolean))
    109 ;
    110104(define (geobox<= gb1 gb2)
    111105  (check-geobox 'geobox<= gb1)
     
    115109    (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    116110
    117 (: geobox>= (geobox geobox --> boolean))
    118 ;
    119111(define (geobox>= gb1 gb2)
    120112  (check-geobox 'geobox>= gb1)
     
    124116    (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    125117
    126 (: geopoint-within-box? (geobox geobox --> boolean))
    127 ;
    128118(define (geopoint-within-box? gp gb)
    129119  (and
  • release/5/geo-utils/trunk/geopoint-utils.scm

    r38475 r38967  
    2020
    2121;WTF
    22 (define-type geopolygon
    23   (or (list-of (struct geopoint)) (vector-of (struct geopoint))))
     22(define-type geopolygon(or (list-of (struct geopoint)) (vector-of (struct geopoint))))
     23
     24;(: geopoint-in-closed-polygon? ((struct geopoint) geopolygon #!optional ((struct geopoint) (struct geopoint) number number --> boolean) --> boolean))
     25(: geopoint-in-closed-polygon? ((struct geopoint) geopolygon #!optional procedure --> boolean))
     26(: intersects?-pnp ((struct geopoint) (struct geopoint) number number --> boolean))
     27(: intersects?-pip ((struct geopoint) (struct geopoint) number number --> boolean))
    2428
    2529;;
    2630
    2731;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))
    3032;
    3133(define (geopoint-in-closed-polygon? gp gpoly #!optional (intersects? intersects?-pnp))
     
    5456;; Ray-casting algorithm (http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html)
    5557;; (https://github.com/substack/point-in-polygon)
    56 (: intersects?-pnp ((struct geopoint) (struct geopoint) number number --> boolean))
    5758;
    5859(define (intersects?-pnp pi pj lat lon)
     
    6869;; Ray-casting algorithm (http://en.wikipedia.org/wiki/Point_in_polygon)
    6970;; (http://alienryderflex.com/polygon/)
    70 (: intersects?-pip ((struct geopoint) (struct geopoint) number number --> boolean))
    7171;
    7272(define (intersects?-pip pi pj lat lon)
  • release/5/geo-utils/trunk/geopoint.scm

    r38475 r38967  
    2424(include "geo-constants")
    2525
    26 ;;;
    27 
    2826;;
    2927
     
    3432(: *geopoint-latitude (geopoint --> number))
    3533(: *geopoint-longitude (geopoint --> number))
    36 ;
     34(: make-geopoint (number number --> geopoint))
     35(: geopoint-latitude (geopoint --> number))
     36(: geopoint-longitude (geopoint --> number))
     37(: geopoint-strictly-above? (geopoint geopoint --> boolean))
     38(: geopoint-above? (geopoint geopoint --> boolean))
     39(: geopoint-strictly-below? (geopoint geopoint --> boolean))
     40(: geopoint-below? (geopoint geopoint --> boolean))
     41(: geopoint-strictly-left? (geopoint geopoint --> boolean))
     42(: geopoint-left? (geopoint geopoint --> boolean))
     43(: geopoint-strictly-right? (geopoint geopoint --> boolean))
     44(: geopoint-right? (geopoint geopoint --> boolean))
     45(: geopoint= (geopoint geopoint --> boolean))
     46(: geopoint< (geopoint geopoint --> boolean))
     47(: geopoint> (geopoint geopoint --> boolean))
     48(: geopoint<= (geopoint geopoint --> boolean))
     49(: geopoint>= (geopoint geopoint --> boolean))
     50
     51;;
     52
    3753(define-record-type geopoint
    3854  (*make-geopoint lat lon)
     
    4157  (lon *geopoint-longitude) )
    4258
    43 (: make-geopoint (number number --> geopoint))
    44 ;
    4559(define (make-geopoint lat lon)
    4660  (*make-geopoint
     
    5064(define-check+error-type geopoint)
    5165
    52 (: geopoint-latitude (geopoint --> number))
    53 ;
    5466(define (geopoint-latitude gp)
    5567  (*geopoint-latitude (check-geopoint 'geopoint-latitude gp)) )
    5668
    57 (: geopoint-longitude (geopoint --> number))
    58 ;
    5969(define (geopoint-longitude gp)
    6070  (*geopoint-longitude (check-geopoint 'geopoint-longitude gp)) )
     
    6979;;
    7080
    71 (: geopoint-strictly-above? (geopoint geopoint --> boolean))
    72 ;
    7381(define (geopoint-strictly-above? gp1 gp2)
    7482  (<
     
    7684    (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp2))) )
    7785
    78 (: geopoint-above? (geopoint geopoint --> boolean))
    79 ;
    8086(define (geopoint-above? gp1 gp2)
    8187  (<=
     
    8389    (*geopoint-latitude (check-geopoint 'geopoint-above gp2))) )
    8490
    85 (: geopoint-strictly-below? (geopoint geopoint --> boolean))
    86 ;
    8791(define (geopoint-strictly-below? gp1 gp2)
    8892  (>
     
    9094    (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp2))) )
    9195
    92 (: geopoint-below? (geopoint geopoint --> boolean))
    93 ;
    9496(define (geopoint-below? gp1 gp2)
    9597  (>=
     
    9799    (*geopoint-latitude (check-geopoint 'geopoint-below gp2))) )
    98100
    99 (: geopoint-strictly-left? (geopoint geopoint --> boolean))
    100 ;
    101101(define (geopoint-strictly-left? gp1 gp2)
    102102  (<
     
    104104    (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp2))) )
    105105
    106 (: geopoint-left? (geopoint geopoint --> boolean))
    107 ;
    108106(define (geopoint-left? gp1 gp2)
    109107  (<=
     
    111109    (*geopoint-longitude (check-geopoint 'geopoint-left gp2))) )
    112110
    113 (: geopoint-strictly-right? (geopoint geopoint --> boolean))
    114 ;
    115111(define (geopoint-strictly-right? gp1 gp2)
    116112  (>
     
    118114    (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp2))) )
    119115
    120 (: geopoint-right? (geopoint geopoint --> boolean))
    121 ;
    122116(define (geopoint-right? gp1 gp2)
    123117  (>=
     
    127121;;
    128122
    129 (: geopoint= (geopoint geopoint --> boolean))
    130 ;
    131123(define (geopoint= gp1 gp2)
    132124  (check-geopoint 'geopoint= gp1)
     
    136128    (= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    137129
    138 (: geopoint< (geopoint geopoint --> boolean))
    139 ;
    140130(define (geopoint< gp1 gp2)
    141131  (check-geopoint 'geopoint< gp1)
     
    145135    (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    146136
    147 (: geopoint> (geopoint geopoint --> boolean))
    148 ;
    149137(define (geopoint> gp1 gp2)
    150138  (check-geopoint 'geopoint> gp1)
     
    154142    (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    155143
    156 (: geopoint<= (geopoint geopoint --> boolean))
    157 ;
    158144(define (geopoint<= gp1 gp2)
    159145  (check-geopoint 'geopoint<= gp1)
     
    163149    (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    164150
    165 (: geopoint>= (geopoint geopoint --> boolean))
    166 ;
    167151(define (geopoint>= gp1 gp2)
    168152  (check-geopoint 'geopoint>= gp1)
  • release/5/geo-utils/trunk/geopolygon.scm

    r38475 r38967  
    2929;;;
    3030
    31 (define-type geopolygon
    32   (or
    33     (vector-of (struct geopoint))
    34     (list-of (struct geopoint))))
     31(define-type geopolygon (or (vector-of (struct geopoint)) (list-of (struct geopoint))))
     32
     33(: geopolygon? (* --> boolean))
     34(: geopolygon (#!rest --> geopolygon))
     35(: geopolygon-closed? (geopolygon --> boolean))
     36(: geopolygon-open? (geopolygon --> boolean))
     37(: geopolygon-bounding-box (geopolygon --> (struct geobox)))
    3538
    3639;;
     
    5255      (make-geopolygon rest) ) ) )
    5356
    54 (: geopolygon? (* --> boolean))
    55 ;
    5657(define (geopolygon? obj)
    5758  (and
     
    6162(define-check+error-type geopolygon)
    6263
    63 (: geopolygon (#!rest --> geopolygon))
    64 ;
    6564(define (geopolygon . gps)
    6665  (make-geopolygon gps) )
    6766
    6867; explicitly closed means [0] = [n-1]
    69 (: geopolygon-closed? (geopolygon --> boolean))
    7068;
    7169(define (geopolygon-closed? gpoly)
     
    7977
    8078; explicitly open means [0] != [n-1]
    81 (: geopolygon-open? (geopolygon --> boolean))
    8279;
    8380(define (geopolygon-open? gpoly)
     
    8683;;
    8784
    88 (: geopolygon-bounding-box (geopolygon --> (struct geobox)))
    89 ;
    9085(define (geopolygon-bounding-box gpoly)
    9186        (let* (
  • release/5/geo-utils/trunk/tests/run.scm

    r38475 r38967  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    16 (define (test-filename test-name)
    17   (string-append test-name "-test") )
     19(define *args* (argv))
    1820
    1921(define (egg-name args #!optional (def EGG-NAME))
    2022  (cond
    21     ((<= 4 (length *args*))
    22       (cadddr *args*) )
    23     (def
    24       def )
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
    2525    (else
    26       (error 'test "cannot determine egg-name") ) ) )
    27 
    28 ;;
    29 
    30 (define *args* (argv))
    31 (define *egg* (egg-name *args*))
    32 (define *tests* `(,*egg*))
     26      (error 'run "cannot determine egg-name") ) ) )
    3327
    3428(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
    3530
    3631;no -disable-interrupts or -no-lambda-info
    3732(define *csc-options* "-inline-global -local -inline \
    3833  -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    4036
    41 (define (run-test-evaluated test-name test-source)
    42   (format #t "*** ~A - csi ***~%" test-name)
    43   (system (string-append "csi -s " test-source)) )
     37(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
     38(define (test-filename name) (string-append name "-test"))
     39(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4440
    45 (define (run-test-compiled test-name test-source csc-options)
    46   (format #t "*** ~A - csc ~A ***~%" test-name csc-options)
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    4752  ;csc output is in current directory
    48   (system (string-append "csc" " " csc-options " " test-source))
    49   (system (make-pathname *current-directory* (test-filename test-name))) )
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5055
    5156;;;
    5257
    53 (define (run-test #!optional (test-name *egg*) (csc-options *csc-options*))
    54   (let ((test-source (make-pathname #f (test-filename test-name) "scm")))
    55     (run-test-evaluated test-name test-source)
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
    5664    (newline)
    57     (run-test-compiled test-name test-source csc-options) ) )
     65    (run-test-compiled source csc-options) ) )
    5866
    59 (define (run-tests #!optional (test-names *tests*) (csc-options *csc-options*))
    60   (for-each (cut run-test <> csc-options) test-names) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    6169
    6270;;; Do Test
Note: See TracChangeset for help on using the changeset viewer.