;;;; geo-dms.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Sep '17
;;;; Kon Lovett, May '17

(module geo-dms

(;export
  degree-latitude? degree-longitude?
  degree? minute? second?
  w-dir? e-dir? n-dir? s-dir?
  ;
  dms-glyphs
  dms->degree degree->dms
  dms->string dms->string*
  string-dms->degree
  ;
  degree->string string->degree
  ;
  degree->compass-rose
  set-compass-rose!)

(import scheme
  (chicken base)
  (chicken irregex)
  (chicken type)
  (chicken fixnum)
  (chicken flonum)
  (only mathh modf)
  type-checks
  type-errors
  geopoint)

;;

(define-type real (or integer ratnum float))

(define-type dms-glyphs (list string string string))

(: dms-glyphs (#!optional dms-glyphs -> dms-glyphs))
(: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
(: string-dms->degree (string #!optional boolean --> number))
(: string->degree (string #!optional boolean --> number))
(: degree->string (real #!optional boolean boolean string --> string))
(: dms->degree (fixnum fixnum fixnum --> real))
(: degree->dms (real --> fixnum fixnum fixnum))
(: dms->string* (number number number #!optional string --> string))
(: set-compass-rose! (vector -> void))
(: degree->compass-rose (number -> symbol))

;;

(define (degree-latitude? d) (<= -90 d 90))

(define (degree-longitude? d) (<= -180 d 180))

(define (degree? d #!optional lat?)
  (if lat? (degree-latitude? d)
    (degree-longitude? d)) )

(define (minute? m) (<= 0 m 59))

(define (second? s) (<= 0 s 59))

;;

(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 ) ) )

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

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

;DMS output tags
;
(define-constant DEGREE-UNIT-GLYPH "°")
(define-constant MINUTE-UNIT-GLYPH "'")
(define-constant SECOND-UNIT-GLYPH "\"")

;degree-minute-second text form

(define +dms-sre+
  '(:
    (* 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)))

(define +dms-regex+ (sre->irregex +dms-sre+ 'utf8 'fast))

;;

(define (dms-glyphs? x)
  (and (list? x) (= 3 (length x))) )

(define-check+error-type dms-glyphs)

(define dms-glyphs (make-parameter
  `(,DEGREE-UNIT-GLYPH ,MINUTE-UNIT-GLYPH ,SECOND-UNIT-GLYPH)
  (lambda (x)
    (if (dms-glyphs? x)
      x
      (begin
        (warning 'dms-glyphs "not a dms-glyphs" x)
        (dms-glyphs))))))

;;

; fixnum fixnum fixnum #!optional boolean boolean string -> string
; the degree argument maybe negative
;
(define (dms->string d m s #!optional lat? leading-dir? (pad ""))
  (if (and (= d 0) (= m 0) (= s 0))
    ;so 0
    (dms0 pad)
    ;construct DMS N/S/E/W
    (let* (
      (neg? (negative? d))
      (d (if neg? (- 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
;
(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) )
      (unless (and (degree? d lat?) (minute? m) (second? s))
        (error 'string-dms->degree "improper DMS value" str) )
      (dms->degree (if neg? (- d) d) m s) ) ) )

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

(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
;
(define (dms->degree d m s)
  (let* (
    (neg? (negative? d))
    (d    (if neg? (- d) d))
    (deg  (+ d (/ m 60) (/ s 3600))) )
    (if neg? (- deg) deg) ) )

; flonum -> fixnum fixnum fixnum
;
(define (degree->dms deg)
  (let (
    (neg? (negative? deg)) )
    ;
    (let*-values (
      ((sint sflt) (modf (abs deg)))
      ((dint dflt) (modf (* sflt 60)))
      ((mint mflt) (modf (* dflt 60))) )
      ;
      (let (
        (ideg (inexact->exact dint))
        (imin (inexact->exact mint))
        (isec (inexact->exact (round (+ sint (* mflt 60))))) )
        ;
        (values (if neg? (- ideg) ideg) imin isec) ) ) ) )

(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 (degree-char)
  (car (dms-glyphs)) )

(define (minute-char)
  (cadr (dms-glyphs)) )

(define (second-char)
  (caddr (dms-glyphs)) )

;;

(define (dms0 #!optional (pad ""))
  (dms->string* 0 0 0 pad) )

;;

(define set-compass-rose!)
(define degree->compass-rose)
(let (
  (+rose+ #())
  (+rose-count+ 0)
  (+rose-slice+ 0)
  (+rose-slice/2+ 0) )
  ;
  (define (compass-rose-slice deg)
    (inexact->exact (floor (/ (+ deg +rose-slice/2+) +rose-slice+))) )
  ;
  (set! set-compass-rose! (lambda (vec)
    (set! +rose+ (check-vector 'set-compass-rose! vec))
    (set! +rose-count+ (vector-length +rose+))
    (set! +rose-slice+ (/ 360 +rose-count+))
    (set! +rose-slice/2+ (/ +rose-slice+ 2)) ) )
  ;
  (set! degree->compass-rose (lambda (deg)
    ;0 <= deg < 360
    (vector-ref +rose+ (modulo (compass-rose-slice deg) +rose-count+)) ) ) )

;;;Module Init

(set-compass-rose! '#(N NNE NE ENE E ESE SE SSE S SSW SW WSW W WNW NW NNW))

) ;module geo-dms