;;;; geo-dms.scm
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Sep '17

(module geo-dms

(;export
  degree-minute-second-text
  dms->degree degree->dms
  dms->string dms->string*
  string-dms->degree
  ;
  degree->string string->degree )

(import scheme)

(import chicken)

(use irregex mathh fp-utils)

;;;

(define-constant DEGREE-TEXT "°")
(define-constant MINUTE-TEXT "'")
(define-constant SECOND-TEXT "\"")

(define +dms-regex+
  (sre->irregex
    '(:
      (* space)
      (? ($ ("NSEWnsew")))            ;Direction maybe here
      (* space)
      ($ (? #\-) (+ num)) (~ num)     ;shouldn't be neg, should be °
      (* space)
      ($ (+ num)) (~ num)             ;should be a '
      (* space)
      ($ (+ (or num #\.))) (~ num)    ;should be "
      (* space)
      (? ($ ("NSEWnsew")))            ;Direction maybe here; 0,0 has no dir
      (* space))
    'utf8 'fast))

;;

(: degree-minute-second-text (#!optional (list string string string) -> (list string string string)))
(define degree-minute-second-text
  (make-parameter
    `(,DEGREE-TEXT ,MINUTE-TEXT ,SECOND-TEXT)
    (lambda (x)
      (if (and (list? x) (= 3 (length x)))
        x
        (begin
          (warning 'degree-minute-second-text "improper DMS text" x)
          (degree-minute-second-text))))))

;;

; fixnum fixnum fixnum #!optional boolean boolean string -> string
; the degree argument maybe negative
(: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
(define (dms->string d m s #!optional lat? leading-dir? (pad ""))
  (if (and (fx= d 0) (fx= m 0) (fx= s 0))
    ;so 0
    (dms0)
    ;construct DMS N/S/E/W
    (let* ((neg? (fx< d 0))
           (d (if neg? (fxneg d) d))
           (str (dms->string* d m s pad))
           (dir  (if lat? (if neg? "S" "N") (if neg? "W" "E")) ) )
      (if leading-dir?
        (string-append dir pad str)
        (string-append str pad dir) ) ) ) )

; string #!optional boolean -> flonum
; -122°45'10"E => -122.752777777778 even though E
; -122°45'10"W => 122.752777777778 even though W
;
(: string-dms->degree (string #!optional boolean --> number))
(define (string-dms->degree str #!optional lat?)
  (let ((match (irregex-match +dms-regex+ str)))
    (unless match
      (error 'string-dms->degree "improper DMS form" str) )
    (let* (
        (leading-dir (irregex-match-substring match 1) )
        (leading-dir (and leading-dir (string-ref leading-dir 0)) )
        (d (string->number (irregex-match-substring match 2)) )
        (m (string->number (irregex-match-substring match 3)) )
        (s (string->number (irregex-match-substring match 4)) )
        (trailing-dir (irregex-match-substring match 5) )
        (trailing-dir (and trailing-dir (string-ref trailing-dir 0)) )
        (dir (or leading-dir trailing-dir) )
        ; input string overrides parameters
        (lat? (or (ns-dir? dir) lat?) )
        (neg? (sw-dir? dir) ) )
      (when (and dir (negative? d))
        (error 'string-dms->degree "improper DMS sign with direction" str) )
      (let ((d (if neg? (- d) d)))
        (unless (and
                  (if lat?
                    (and (<= -90 d) (<= d 90))
                    (and (<= -180 d) (<= d 180)))
                  (and (<= 0 m) (<= m 59))
                  (and (<= 0 s) (<= s 59)) )
          (error 'string-dms->degree "improper DMS value" str) )
        (dms->degree d m s) ) ) ) )

;
(define string->degree string-dms->degree)

;
(: degree->string (float #!optional boolean boolean string --> string))
(define (degree->string deg #!optional lat? leading-dir? (pad ""))
  (receive (d m s) (degree->dms deg)
    (dms->string d m s lat? leading-dir? pad) ) )

;;

; fixnum fixnum fixnum -> flonum
; the degree argument maybe negative
(: dms->degree (fixnum fixnum fixnum --> float))
(define (dms->degree d m s)
  (let* (
      (neg? (fx< d 0) )
      (d (if neg? (fxneg d) d) )
      (deg
        (fp+
          (exact->inexact d)
          (fp+
            (fp/ (exact->inexact m) 60.0)
            (fp/ (exact->inexact s) 3600.0))) ) )
    (if neg? (fpneg deg) deg) ) )

; flonum -> fixnum fixnum fixnum
(: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
(define (degree->dms deg)
  (let* ((deg (exact->inexact deg))
         (neg? (fp< deg 0.0)) )
    (let*-values (((sint sflt) (modf (fpabs deg)))
                  ((dint dflt) (modf (fp* sflt 60.0)))
                  ((mint mflt) (modf (fp* dflt 60.0))) )
      (let ((ideg (inexact->exact dint))
            (isec (inexact->exact (fpround (fp+ sint (fp* mflt 60.0)))))
            (imin (inexact->exact mint)) )
        (values (if neg? (fxneg ideg) ideg) imin isec) ) ) ) )

(: dms->string* (number number number #!optional string --> string))
(define (dms->string* d m s #!optional (pad ""))
  (string-append
    (number->string d) (degree-char)
    pad
    (number->string m) (minute-char)
    pad
    (number->string s) (second-char)) )

;;

(define (dms0)
  (string-append "0" (degree-char) "0" (minute-char) "0" (second-char)) )

(define (degree-char)
  (car (degree-minute-second-text)) )

(define (minute-char)
  (cadr (degree-minute-second-text)) )

(define (second-char)
  (caddr (degree-minute-second-text)) )

;;

(define (ns-dir? dir)
  (or (n-dir? dir) (s-dir? dir)) )

(define (sw-dir? dir)
  (or (s-dir? dir) (w-dir? dir)) )

(define (w-dir? dir)
  (case dir
    ((#\W #\w)  #t )
    (else       #f ) ) )

(define (e-dir? dir)
  (case dir
    ((#\E #\e)  #t )
    (else       #f ) ) )

(define (n-dir? dir)
  (case dir
    ((#\N #\n)  #t )
    (else       #f ) ) )

(define (s-dir? dir)
  (case dir
    ((#\S #\s)  #t )
    (else       #f ) ) )

) ;module geo-dms