(module progress mzscheme
  (require (all-except (lib "list.ss" "srfi" "1") any)
           (lib "mred.ss" "mred")
           (lib "include-bitmap.ss" "mrlib")
           (lib "class.ss")
           (lib "contract.ss"))

  (define nw (include-bitmap "bitmaps/nw.bmp"))
  (define sw (include-bitmap "bitmaps/sw.bmp"))
  (define ne (include-bitmap "bitmaps/ne.bmp"))
  (define se (include-bitmap "bitmaps/se.bmp"))

  (define tick/small (include-bitmap "bitmaps/tick-small.bmp"))
  (define tick/medium (include-bitmap "bitmaps/tick-medium.bmp"))
  (define tick/large (include-bitmap "bitmaps/tick-large.bmp"))

  ;; A percent? is a number between 0.0 (inclusive) and 1.0 (inclusive).

  ;; percent? : any -> boolean
  (define (percent? n)
    (and (number? n)
         (<= 0.0 n 1.0)))

  (define progress-meter<%>
    (interface ()
      update-progress ; percent? -> void
      ))

  (define dark-gray (make-object color% 104 104 104))
  (define light-gray (make-object color% 190 190 190))

  ;; (new progress-meter% (parent (union frame% dialog% panel% pane%))
  ;;                      [(width size-integer?)]
  ;;                      [(enabled boolean?)]
  ;;                      [(vert-margin size-integer?)]
  ;;                      [(horiz-margin size-integer?)]
  ;;                      [(stretchable-width boolean?)]
  ;;                      [(progress percent?)]
  ;;                      [(tick bitmap%)])
  (define progress-meter%
    (class* canvas% (progress-meter<%> canvas<%>)
      (init parent
            (width 256)
            (enabled #t)
            (vert-margin 0)
            (horiz-margin 0)
            (stretchable-width #f)
            (progress 0.0)
            (tick tick/medium))
      (inherit get-dc refresh)

      (define (get-tick-count)
        (let* ([bar-width (- current-width 4)]
               [target-width (ceiling (* bar-width current-progress))])
          (ceiling (/ target-width effective-tick-width))))

      (define/public (update-progress progress)
        (set! current-progress progress)
        (refresh))

      (define/override (on-size w h)
        (set! current-width w)
        (set! current-height h)
        (refresh))

      (define/override (on-paint)
        (let* ([dc (get-dc)]
               [east-x (- current-width 3)]
               [south-y (- current-height 3)]
               [bottom (- current-height 1)]
               [right (- current-width 1)]
               [bar-end (- current-width 1)]
               [bar-width (- current-width 4)])
          (send dc set-smoothing 'unsmoothed)
          ;; Draw the corners.
          (send dc draw-bitmap nw 0 0)
          (send dc draw-bitmap sw 0 south-y)
          (send dc draw-bitmap ne east-x 0)
          (send dc draw-bitmap se east-x south-y)
          ;; Draw the borders.
          (send dc set-pen dark-gray 1 'solid)
          (send dc draw-line 0 3 0 south-y)
          (send dc draw-line 3 0 east-x 0)
          (send dc draw-line 3 bottom east-x bottom)
          (send dc draw-line right 3 right south-y)
          ;; Draw the border shading.
          (send dc set-pen light-gray 1 'solid)
          (send dc draw-line 1 3 1 south-y)
          (send dc draw-line 3 1 east-x 1)
          ;; Draw the ticks.
          (for-each (lambda (x)
                      (let* ([left (+ x tick-margin)]
                             [expected-end (+ left tick-width)])
                        (if (> expected-end bar-end)
                            (send dc draw-bitmap-section
                              tick-bitmap left 3
                              0 0 (- bar-end left) tick-height)
                            (send dc draw-bitmap tick-bitmap left 3))))
                    (iota (get-tick-count) 3 effective-tick-width))))

      (define tick-bitmap tick)
      (define tick-margin 1)
      (define tick-width (send tick-bitmap get-width))
      (define effective-tick-width (+ tick-margin tick-width tick-margin))
      (define tick-height (send tick-bitmap get-height))
      (define current-width width)
      (define current-height (+ tick-height 6))
      (define current-progress progress)

      (super-new (parent parent)
                 (enabled enabled)
                 (min-width current-width)
                 (min-height current-height)
                 (vert-margin vert-margin)
                 (horiz-margin horiz-margin)
                 (stretchable-width stretchable-width)
                 (stretchable-height #f))))

  (provide/contract
    [tick/small (is-a?/c bitmap%)]
    [tick/medium (is-a?/c bitmap%)]
    [tick/large (is-a?/c bitmap%)]
    [percent? (any/c . -> . boolean?)]
    [progress-meter<%> interface?]
    [progress-meter% (and/c (implementation?/c progress-meter<%>)
                            (implementation?/c canvas<%>))]))