Map Widget Demo Code

mw-demo.rkt

#lang racket
(require racket/gui
         map-widget
         json
         "gpx.rkt"
         mrlib/snip-canvas plot)

;; This bit of code intercepts messages logged by the map widget and prints
;; them out.  Might be helpful during debugging.
(define (make-dbglog-sink . loggers)
  (define sources (for/list ([logger loggers])
                    (make-log-receiver logger 'info)))
  (define (do-logging)
    (let* ((log-item (apply sync sources))
           (level (vector-ref log-item 0))
           (message (vector-ref log-item 1)))
      (printf "~a: ~a" level message))
    (do-logging))
  (thread do-logging)
  (void))

(make-dbglog-sink map-widget-logger)

(define toplevel (new frame% [label "Map Demo"] [width 600] [height 400]))
(define map (new map-widget% [parent toplevel]))
(send toplevel show #t)

(define (add-track-to-map track-points map)
  (send map add-track track-points #f)
  (send map center-map))

(define (add-mile-markers track-points map)
  (define total-distance (gpx-total-distance track-points))
  (define marker-color (make-color 0 135 36))
  (let loop ((mile 0))
    (when (< (* mile 1609) total-distance)
      (let ((p (gpx-lookup-position track-points (* mile 1609))))
        (send map add-marker p
              (if (zero? mile) "Start" (format "Mile ~a" mile)) 1 marker-color))
      (loop (add1 mile)))))
          
(define (make-elevation-profile-plot track-points map)

  (send map track-current-location #t)
  
  (define (plot-callback snip event x y)
    (if (and x y (eq? (send event get-event-type) 'motion))
        (let ((elevation (gpx-lookup-elevation track-points x))
              (position (gpx-lookup-position track-points x)))
          (define overlays
            (list (vrule x #:style 'long-dash)
                  (point-label (vector x y)
                               (format "~a miles, height: ~a meters"
                                       (~r (/ x 1609) #:precision 2)
                                       (~r elevation #:precision 1))
                               #:anchor 'auto)))
          (send snip set-overlay-renderers overlays)
          (send map current-location position))
        (begin
          (send snip set-overlay-renderers '())
          (send map current-location #f))))
  
  (define elevation
    (for/list ([p track-points])
      (match-define (vector lat lon dst ele ts) p)
      (vector dst ele)))
  (define (make-snip width height)
    (parameterize ([plot-x-label "Distance (miles)"]
                   [plot-y-label "Elevation (meters)"]
                   [plot-x-ticks
                    (ticks (linear-ticks-layout)
                           (lambda (min max pre-ticks)
                             (for/list ([pt pre-ticks])
                               (~a (exact-truncate (/ (pre-tick-value pt) 1609))))))])
      (define snip (plot-snip (lines elevation) #:width width #:height height))
      (send snip set-mouse-event-callback plot-callback)
      snip))
  (define frame (new frame% [label "Elevation Plot"] [width 600] [height 300]))
  (define canvas (new snip-canvas% [parent frame] [make-snip make-snip]))
  (send frame show #t)
  frame)