Changeset 35004 in project


Ignore:
Timestamp:
01/11/18 07:58:59 (8 months ago)
Author:
kon
Message:

earth on it's own , ocd

Location:
release/4/geo-utils/trunk
Files:
1 added
1 deleted
12 edited

Legend:

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

    r34786 r35004  
    11;;;; geo-constants.scm
    22
    3 (define-constant EARTH-FLATTENING 0.00335281066474748) ;1.0/298.257223563 (WGS '84)
     3;1.0/298.257223563 (WGS '84)
     4(define-constant EARTH-FLATTENING 0.00335281066474748)
    45
    56(define-constant EARTH-RADIUS-MILES 3963.188)
  • release/4/geo-utils/trunk/geo-dms.scm

    r34786 r35004  
    1313  degree->string string->degree )
    1414
    15 (import scheme)
    16 
    17 (import chicken)
    18 
    19 (use irregex mathh fp-utils moremacros type-checks type-errors)
    20 (use geopoint)
     15(import scheme chicken)
     16(use
     17  irregex
     18  mathh
     19  fp-utils
     20  moremacros
     21  type-checks
     22  type-errors
     23  geopoint)
    2124
    2225;;;
     
    181184;;
    182185
     186(define (degree-char)
     187  (car (degree-minute-second-text)) )
     188
     189(define (minute-char)
     190  (cadr (degree-minute-second-text)) )
     191
     192(define (second-char)
     193  (caddr (degree-minute-second-text)) )
     194
     195;;
     196
    183197(define (dms0)
    184198  (string-append "0" (degree-char) "0" (minute-char) "0" (second-char)) )
    185199
    186 (define (degree-char)
    187   (car (degree-minute-second-text)) )
    188 
    189 (define (minute-char)
    190   (cadr (degree-minute-second-text)) )
    191 
    192 (define (second-char)
    193   (caddr (degree-minute-second-text)) )
    194 
    195 ;;
     200;;
     201
     202(define (w-dir? dir)
     203  (case dir
     204    ((#\W #\w)  #t )
     205    (else       #f ) ) )
     206
     207(define (e-dir? dir)
     208  (case dir
     209    ((#\E #\e)  #t )
     210    (else       #f ) ) )
     211
     212(define (n-dir? dir)
     213  (case dir
     214    ((#\N #\n)  #t )
     215    (else       #f ) ) )
     216
     217(define (s-dir? dir)
     218  (case dir
     219    ((#\S #\s)  #t )
     220    (else       #f ) ) )
    196221
    197222(define (ns-dir? dir)
     
    201226  (or (s-dir? dir) (w-dir? dir)) )
    202227
    203 (define (w-dir? dir)
    204   (case dir
    205     ((#\W #\w)  #t )
    206     (else       #f ) ) )
    207 
    208 (define (e-dir? dir)
    209   (case dir
    210     ((#\E #\e)  #t )
    211     (else       #f ) ) )
    212 
    213 (define (n-dir? dir)
    214   (case dir
    215     ((#\N #\n)  #t )
    216     (else       #f ) ) )
    217 
    218 (define (s-dir? dir)
    219   (case dir
    220     ((#\S #\s)  #t )
    221     (else       #f ) ) )
    222 
    223228) ;module geo-dms
  • release/4/geo-utils/trunk/geo-globe.scm

    r34796 r35004  
    1111  globe-flattening-factor
    1212  ;
    13   make-earth
    14   ;
    1513  spherical-surface-distance
    1614  great-circle-distance great-circle-distance-radians
     
    1917  great-circle-azimuth
    2018  ;
    21   great-circle-position
    22 )
     19  great-circle-position)
    2320
    24 (import scheme)
    25 
    26 (import chicken)
    27 
    28 (use numbers)
    29 (use type-checks)
    30 (use geopoint)
    31 
    32 (import (prefix geo-utils utility-))
    33 (require-library geo-utils)
    34 
    35 (use typed-define)
    36 
    37 (include "geo-constants")
     21(import scheme chicken)
     22(use
     23  numbers
     24  type-checks
     25  geopoint
     26  (prefix geo-utils utility-)
     27  typed-define)
    3828
    3929;;
     
    6959(define: (globe-flattening-factor (glob globe)) --> number
    7060  (*globe-flattening-factor (check-globe 'globe-flattening-factor glob 'globe)))
    71 
    72 ;;
    73 
    74 (define: (make-earth) --> globe
    75   (*make-globe EARTH-RADIUS-KILOMETERS EARTH-FLATTENING) )
    7661
    7762;;
  • release/4/geo-utils/trunk/geo-utils.meta

    r34796 r35004  
    2323 "geo-dms.scm"
    2424 "geopoint-utils.scm"
    25  "geo-globe.scm"
     25 "geo-globe.scm" "geo-earth.scm"
    2626 "tests/run.scm" "tests/geo-utils-test.scm") )
  • release/4/geo-utils/trunk/geo-utils.scm

    r34786 r35004  
    66
    77(;export
    8   ;
    9   *earth-flattening*
    10   *earth-radius-miles* *earth-radius-kilometers*
    118  ;
    129  pythagorean-distance pythagorean-distance*
     
    2017  great-circle-position )
    2118
    22 (import scheme)
    23 
    24 (import chicken)
    25 
    26 (use numbers)
    27 
    28 (use fp-utils)
    29 
    30 (use geopoint)
     19(import scheme chicken)
     20(use
     21  numbers
     22  fp-utils
     23  geopoint)
    3124
    3225(include "geo-constants")
    33 
    34 ;;
    35 
    36 (define *earth-flattening* EARTH-FLATTENING)
    37 
    38 (define *earth-radius-miles* EARTH-RADIUS-MILES)
    39 (define *earth-radius-kilometers* EARTH-RADIUS-KILOMETERS)
    4026
    4127;;
  • release/4/geo-utils/trunk/geo-utils.setup

    r34786 r35004  
    55(verify-extension-name "geo-utils")
    66
    7 (setup-shared+static-extension-module 'geopoint (extension-version "0.4.0")
     7(setup-shared+static-extension-module 'geopoint (extension-version "0.4.1")
    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.4.0")
     12(setup-shared+static-extension-module 'geobox (extension-version "0.4.1")
    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.4.0")
     17(setup-shared+static-extension-module 'geopolygon (extension-version "0.4.1")
    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.4.0")
     22(setup-shared+static-extension-module 'geopoint-utils (extension-version "0.4.1")
    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.4.0")
     27(setup-shared+static-extension-module (extension-name) (extension-version "0.4.1")
    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.4.0")
     32(setup-shared+static-extension-module 'geo-dms (extension-version "0.4.1")
    3333  #:inline? #t
    3434  #:types? #t
     
    3636  #:compile-options `(-scrutinize -optimize-level 2 -debug-level 1 -no-procedure-checks))
    3737
    38 (setup-shared+static-extension-module 'geo-globe (extension-version "0.4.0")
     38(setup-shared+static-extension-module 'geo-globe (extension-version "0.4.1")
     39  #:inline? #t
     40  #:types? #t
     41  #:compile-options `(-scrutinize -optimize-level 2 -debug-level 1 -no-procedure-checks))
     42
     43(setup-shared+static-extension-module 'geo-earth (extension-version "0.4.1")
    3944  #:inline? #t
    4045  #:types? #t
  • release/4/geo-utils/trunk/geobox.scm

    r34786 r35004  
    1212
    1313(import scheme chicken)
    14 
    15 (use type-checks)
    16 
    17 (use geopoint)
     14(use
     15  type-checks
     16  geopoint)
    1817
    1918;;;
     
    2221
    2322(define-type geobox (struct geobox))
     23
     24;;
     25
     26(define (check-geopoint-above-left? loc a b)
     27  (check-geopoint loc a 'min)
     28  (check-geopoint loc b 'max)
     29  (and (geopoint-above? a b) (geopoint-left? a b)) )
    2430
    2531;;
     
    3844(define make-geobox
    3945  (case-lambda
     46    ;
    4047    ((min-pnt max-pnt)
    41       (make-geobox* 'make-geobox min-pnt max-pnt) )
    42     ((minLat minLon maxLat maxLon)
    43       (make-geobox* 'make-geobox
    44         (make-geopoint minLat minLon)
    45         (make-geopoint maxLat maxLon)) ) ) )
    46 
    47 (: make-geobox* (symbol geopoint geopoint --> geobox))
    48 (define (make-geobox* loc min-pnt max-pnt)
    49   (check-geopoint loc min-pnt)
    50   (check-geopoint loc max-pnt)
    51   (unless
    52     (and
    53       (geopoint-above? min-pnt max-pnt)
    54       (geopoint-left? min-pnt max-pnt) )
    55     (error loc "minimum-geopoint > maximum-geopoint" min-pnt max-pnt) )
    56   (*make-geobox min-pnt max-pnt) )
     48      (unless (check-geopoint-above-left? 'make-geobox min-pnt max-pnt)
     49        (error 'make-geobox "min geopoint > max geopoint" min-pnt max-pnt) )
     50      (*make-geobox min-pnt max-pnt) )
     51    ;
     52    ((min-lat min-lon max-lat max-lon)
     53      (make-geobox
     54        (make-geopoint
     55          (check-real 'make-geobox min-lat)
     56          (check-real 'make-geobox min-lon))
     57        (make-geopoint
     58          (check-real 'make-geobox max-lat)
     59          (check-real 'make-geobox max-lon))) ) ) )
    5760
    5861(define-check+error-type geobox)
  • release/4/geo-utils/trunk/geopoint-utils.scm

    r34774 r35004  
    99  intersects?-pnp intersects?-pip)
    1010
    11 (import scheme)
    12 
    13 (import chicken)
    14 
    15 (use numbers)
    16 
    17 (use geopoint geopolygon)
    18 
    19 (use type-checks)
     11(import scheme chicken)
     12(use
     13  numbers
     14  geopoint
     15  geopolygon
     16  type-checks)
    2017
    2118;;;
    2219
    23 (define-type geopolygon (or (list-of (struct geopoint)) (vector-of (struct geopoint))))
     20;WTF
     21(define-type geopolygon
     22  (or (list-of (struct geopoint)) (vector-of (struct geopoint))))
    2423
    2524;;
     
    3938      ;assumes an open-poly is "closed" so a closed-poly must be treated as "open"
    4039      (let ((len (if (geopolygon-closed? gpoly) (fx- len 1) len)))
    41         (let loop ((i 0) (j (fx- len 1)) (poly? #f))
     40        (let loop (
     41          (i 0)
     42          (j (fx- len 1))
     43          (poly? #f) )
     44          ;
    4245          (if (fx= i len)
    4346            poly?
     
    4750              (if (intersects? (vector-ref gpoly i) (vector-ref gpoly j) lat lon)
    4851                (not poly?)
    49                 poly?)) ) ) ) ) ) )
     52                poly? ) ) ) ) ) ) ) )
    5053
    5154;;
  • release/4/geo-utils/trunk/geopoint.scm

    r34786 r35004  
    1717  )
    1818
    19 (import scheme)
    20 
    21 (import chicken)
    22 
    23 (use numbers)
    24 (use type-checks)
     19(import scheme chicken)
     20(use
     21  numbers
     22  type-checks)
    2523
    2624(include "geo-constants")
  • release/4/geo-utils/trunk/geopolygon.scm

    r34786 r35004  
    1212  geopolygon-bounding-box )
    1313
    14 (import scheme)
    15 
    16 (import chicken)
    17 
    18 (use vector-lib)
    19 
    20 (use type-checks)
    21 
    22 (use geopoint geobox)
     14(import scheme chicken)
     15(use
     16  vector-lib
     17  type-checks
     18  geopoint
     19  geobox)
    2320
    2421(include "geo-constants")
     
    2623;;;
    2724
    28 (define-type geopolygon (or (list-of (struct geopoint)) (vector-of (struct geopoint))))
     25(define (ensure-vector gps)
     26  (if (list? gps) (list->vector gps) gps) )
     27
     28;;;
     29
     30(define-type geopolygon
     31  (or
     32    (vector-of (struct geopoint))
     33    (list-of (struct geopoint))))
     34
     35;;
    2936
    3037;not strict
     
    3340    ((gps)
    3441      (cond
    35         ((vector? gps)  gps )
    36         ((list? gps)    (list->vector gps) )
     42        ((vector? gps)
     43          (and
     44            (vector-every geopoint? gps)
     45            gps ) )
     46        ((list? gps)
     47          (make-geopolygon (ensure-vector gps)) )
    3748        (else
    38           (warning 'make-geopolygon "unrecognized as geopolygon" gps)
    39           gps ) ) )
     49          (error 'make-geopolygon "unrecognized as geopolygon" gps) ) ) )
    4050    (rest
    4151      (make-geopolygon rest) ) ) )
     
    5767(define (geopolygon-closed? gpoly)
    5868        (let* (
    59           (gpoly (if (list? gpoly) (list->vector gpoly) gpoly) )
     69          (gpoly (ensure-vector gpoly) )
    6070    (len (vector-length gpoly) ) )
    6171    ;
     
    7484(define (geopolygon-bounding-box gpoly)
    7585        (let* (
    76           (gpoly (if (list? gpoly) (list->vector gpoly) gpoly) )
     86          (gpoly (ensure-vector gpoly) )
    7787    (len (vector-length (check-geopolygon 'geopolygon-bounding-box gpoly)) ) )
    7888    ;
     
    93103          (loop
    94104            (fx+ i 1)
    95             (min lat minLat)
    96             (max lat maxLat)
    97             (min lon minLon)
    98             (max lon maxLon)) ) ) ) ) )
     105            (min lat minLat) (max lat maxLat)
     106            (min lon minLon) (max lon maxLon)) ) ) ) ) )
    99107
    100108) ;geopolygon
  • release/4/geo-utils/trunk/tests/geo-utils-test.scm

    r34796 r35004  
    118118;;
    119119
    120 (import (prefix geo-globe globe-))
    121 (require-library geo-globe)
     120(use (prefix geo-globe globe:) geo-earth)
    122121
    123122(test-group "geo-globe"
     
    126125    (azi (great-circle-azimuth lat1 lon1 lat2 lon2) )
    127126    ;
    128     (earth (globe-make-earth) )
     127    (earth (make-earth) )
    129128    (gp1 (make-geopoint lat1 lon1) )
    130129    (gp2 (make-geopoint lat2 lon2) ) )
    131130    ;
    132     (test dis (globe-great-circle-distance earth gp1 gp2))
    133     (test azi (globe-great-circle-azimuth gp1 gp2))
    134     (test (approximate-ellipsoid-distance lat1 lon1 lat2 lon2) (globe-approximate-ellipsoid-distance earth gp1 gp2))
    135     (test (spherical-surface-distance lat1 lon1 lat2 lon2) (globe-spherical-surface-distance earth gp1 gp2))
     131    (test dis (globe:great-circle-distance earth gp1 gp2))
     132    (test azi (globe:great-circle-azimuth gp1 gp2))
     133    (test
     134      (approximate-ellipsoid-distance lat1 lon1 lat2 lon2)
     135      (globe:approximate-ellipsoid-distance earth gp1 gp2))
     136    (test
     137      (spherical-surface-distance lat1 lon1 lat2 lon2)
     138      (globe:spherical-surface-distance earth gp1 gp2))
    136139    (let-values (((ulat ulon) (great-circle-position lat1 lon1 dis azi)))
    137       (let ((globe-pos (globe-great-circle-position earth gp1 dis azi)))
    138         (test ulat (geopoint-latitude globe-pos))
    139         (test ulon (geopoint-longitude globe-pos)) ) ) )
     140      (let ((pos (globe:great-circle-position earth gp1 dis azi)))
     141        (test "great-circle-position latitude" ulat (geopoint-latitude pos))
     142        (test "great-circle-position longitude" ulon (geopoint-longitude pos)) ) ) )
    140143)
    141144
  • release/4/geo-utils/trunk/tests/run.scm

    r34849 r35004  
     1
     2(define EGG-NAME "geo-utils")
    13
    24;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    3 
    4 (define *egg-name* "geo-utils")
    55
    66(use files)
     
    1111(define *args* (argv))
    1212
    13 (define (test-name #!optional (eggnam *egg-name*))
     13(define (test-name #!optional (eggnam EGG-NAME))
    1414  (string-append eggnam "-test") )
    1515
    16 (define (egg-name #!optional (def *egg-name*))
     16(define (egg-name #!optional (def EGG-NAME))
    1717  (cond
    1818    ((<= 4 (length *args*))
     
    2525;;;
    2626
    27 (set! *egg-name* (egg-name))
     27(set! EGG-NAME (egg-name))
    2828
    29 (define (run-test #!optional (eggnam *egg-name*) (cscopts *csc-options*))
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    3030  (let ((tstnam (test-name eggnam)))
    3131    (print "*** csi ***")
     
    3636    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    3737
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
    3841;;;
    3942
Note: See TracChangeset for help on using the changeset viewer.