#lang racket/gui
;;; histogram-widget.rkt
;;; Copyright (c) 2007-2010 M. Douglas Williams
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;
;; ------------------------------------------------------------------------------
;;;
;;; Version  Date      Description
;;; 2.0.0    06/01/10  Updated for Racket. (MDW)

(require (planet williams/animated-canvas/animated-canvas)
         (planet williams/science/histogram))

(define histogram-widget%
  (class vertical-panel%
    ;; Init parameters
    (init-field label)
    (init-field n)
    (init-field min-range)
    (init-field max-range)
    (init parent)
    (init (font normal-control-font))
    ;; Instantiate superclass
    (super-instantiate (parent))
    ;; Create graphical subelements
    (define message
      (instantiate message%
        (label this)))
    (define canvas 
      (instantiate animated-canvas%
        (this)
        (style '(border))))
    ;; Recompute sizes and positions
    (send this reflow-container)
    ;; Create histogram vector
    (define histogram
      (make-histogram-with-ranges-uniform n min-range max-range))
    ;; Draw histogram
    (define (draw-histogram (scale 1))
      (let* ((dc (send canvas get-dc))
             (width (exact->inexact (send canvas get-width)))
             (height (exact->inexact (send canvas get-height)))
             (bin-width (/ width n))
             (bin-delta (/ (exact->inexact (- max-range min-range)) n))
             (half-bin-delta (/ bin-delta 2))
             (max-value (histogram-max histogram))
             (sum-value (histogram-sum histogram))
             (mean (histogram-mean histogram))
             (sigma (histogram-sigma histogram))
             (cum-value 0))
        (when (> sum-value 0.0)
          (send dc set-pen "White" 1 'solid)
          (for ((i (in-range n)))
            (let ((bin-center (+ min-range (* i bin-delta) half-bin-delta))
                  (bin-value (histogram-get histogram i)))
              (set! cum-value (+ cum-value bin-value))
              (unless (= bin-value 0)
                (let ((x1 (* i bin-width))
                      (bin-height (* scale (/  bin-value max-value) height))
                      (color
                       (cond ((<= bin-center (- mean (* 2.0 sigma))) "Red")
                             ((<= bin-center (- mean sigma)) "Yellow")
                             ((< bin-center (+ mean sigma)) "Green")
                             ((< bin-center (+ mean (* 2.0 sigma))) "Yellow")
                             (else "Red"))))
                  (send dc set-brush color 'solid)
                  (send dc draw-rectangle
                        x1 (- height bin-height)
                        bin-width height)))))
          (send dc set-pen "Blue" 1 'solid)
          (let ((x (* (/ (- mean min-range) (- max-range min-range)) width)))
            (send dc draw-line x 0.0 x height)))
        (send canvas swap-bitmaps)))
    ;; Reset method
    (define/public (reset)
      (set! histogram
            (make-histogram-with-ranges-uniform n min-range max-range))
      (draw-histogram))
    ;; Set value method
    (define/public (set-value value)
      (histogram-increment! histogram value)
      (draw-histogram))))

;;; Module Contracts

(provide (all-defined-out))