#lang racket
;;; Science Collection
;;; plot-histogram-2d.rkt
;;; Copyright (c) 2004-2011 M. Douglas Williams
;;;
;;; This file is part of the Science Collection.
;;;
;;; The Science Collection is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the License
;;; or (at your option) any later version.
;;;
;;; The Science Collection is distributed in the hope that it will be useful,
;;; but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with the Science Collection.  If not, see
;;; <http://www.gnu.org/licenses/>.
;;;
;;; -------------------------------------------------------------------
;;;
;;; This module implements 2d histogram in the PLoT Scheme package.
;;;
;;; Version  Date      Description
;;; 1.0.0    09/28/04  Marked as ready for Release 1.0.  (Doug
;;;                    Williams)
;;; 2.0.0.   06/07/08  More V4.0 changes.  (Doug Williams)
;;; 4.0.0    08/16/11  Changed the header and restructured the code. (MDW)

(require plot/plot-extend)

;;; Draw a column given the widths (x and y)
(define (draw-column-given-widths
         x x-width y y-width width-factor z view)
  (let* ((half-x-whitespace (/ (* x-width (- 1.0 width-factor)) 2.0))
         (x1 (+ x half-x-whitespace))
         (x2 (- (+ x x-width) half-x-whitespace))
         (half-y-whitespace (/ (* y-width (- 1.0 width-factor)) 2.0))
         (y1 (+ y half-y-whitespace))
         (y2 (- (+ y y-width) half-y-whitespace)))
    ;; Draw bottom
    (send view plot-polygon
          `(,x1 ,x2 ,x2 ,x1 ,x1)
          `(,y1 ,y1 ,y2 ,y2 ,y1)
          '(0 0 0 0 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 1
    (send view plot-polygon
          `(,x1 ,x2 ,x2 ,x1 ,x1)
          `(,y1 ,y1, y1 ,y1 ,y1)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 2
    (send view plot-polygon
          `(,x2 ,x2 ,x2 ,x2 ,x2)
          `(,y1 ,y2 ,y2 ,y1 ,y1)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 3
    (send view plot-polygon
          `(,x2 ,x1 ,x1 ,x2 ,x2)
          `(,y2 ,y2 ,y2 ,y2 ,y2)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 4
    (send view plot-polygon
          `(,x1 ,x1 ,x1 ,x1 ,x1)
          `(,y2 ,y1 ,y1 ,y2 ,y2)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw top
    (send view plot-polygon
          `(,x1 ,x2 ,x2 ,x1 ,x1)
          `(,y1 ,y1 ,y2 ,y2 ,y1)
          `(,z ,z ,z ,z ,z)
          '(1 1 1 1 1)
          1)))

;;; Draw a column
(define (draw-column x1 x2 y1 y2 width-factor z view)
  (let* ((half-x-whitespace (/ (* (- x2 x1) (- 1.0 width-factor)) 2.0))
         (half-y-whitespace (/ (* (- y2 y1) (- 1.0 width-factor)) 2.0)))
    (set! x1 (+ x1 half-x-whitespace))
    (set! x2 (- x2 half-x-whitespace))
    (set! y1 (+ y1 half-y-whitespace))
    (set! y2 (- y2 half-y-whitespace))
    ;; Draw bottom
    (send view plot-polygon
          `(,x1 ,x2 ,x2 ,x1 ,x1)
          `(,y1 ,y1 ,y2 ,y2 ,y1)
          '(0 0 0 0 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 1
    (send view plot-polygon
          `(,x1 ,x2 ,x2 ,x1 ,x1)
          `(,y1 ,y1, y1 ,y1 ,y1)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 2
    (send view plot-polygon
          `(,x2 ,x2 ,x2 ,x2 ,x2)
          `(,y1 ,y2 ,y2 ,y1 ,y1)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 3
    (send view plot-polygon
          `(,x2 ,x1 ,x1 ,x2 ,x2)
          `(,y2 ,y2 ,y2 ,y2 ,y2)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw face 4
    (send view plot-polygon
          `(,x1 ,x1 ,x1 ,x1 ,x1)
          `(,y2 ,y1 ,y1 ,y2 ,y2)
          `(0 0 ,z ,z 0)
          '(1 1 1 1 1)
          1)
    ;; Draw top
    (send view plot-polygon
          `(,x1 ,x2 ,x2 ,x1 ,x1)
          `(,y1 ,y1 ,y2 ,y2 ,y1)
          `(,z ,z ,z ,z ,z)
          '(1 1 1 1 1)
          1)))

;;; Draw a histogram-2d with specified ranges (x and y)
(define (draw-histogram-2d 
         bins x-ranges y-ranges width-factor view)
  (let ((nx (- (vector-length x-ranges) 1))
        (ny (- (vector-length y-ranges) 1)))
    (do ((i 0 (+ i 1)))
        ((= i nx) (void))
      (do ((j 0 (+ j 1)))
          ((= j ny) (void))
        (let ((bin (+ (* i ny) j)))
          (draw-column (vector-ref x-ranges i)
                       (vector-ref x-ranges (+ i 1))
                       (vector-ref y-ranges j)
                       (vector-ref y-ranges (+ j 1))
                       width-factor
                       (vector-ref bins bin)
                       view))))))

;;; Define histogram-2d plot type
(define-plot-type histogram-2d
  data 3dview (x-min x-max y-min y-max) ((color 'black) (width 1.0))
  (begin
    (send 3dview set-line-color color)
    (set! width (max width 0.0))
    (set! width (min width 1.0))
    (draw-histogram-2d (car data)
                       (cadr data)
                       (caddr data)
                       width
                       3dview)))

;;; Module Contracts

(provide
 histogram-2d)