root/trunk/thirdparty/cl-pdf/chart.lisp

;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html

(in-package #:pdf)

;;WARNING this part of cl-pdf is an alpha version. Use with care!

;; Basic charts: histogram, pie and plot-xy
;; (Thanks to Carlos Ungil <Carlos.Ungil@cern.ch> for plot-xy)


;; the pre and post draw functions must have this signature:
;; (defun pre-draw-chart (object dx dy x-scale y-scale x-min y-min x-max y-max) ...)

(defvar *default-chart-font* (get-font))

(defclass chart-item ()
  ((x :accessor x :initform 0 :initarg :x)
   (y :accessor y :initform 0 :initarg :y)
   (width :accessor width :initform 0 :initarg :width)
   (height :accessor height :initform 0 :initarg :height)
   (background-color :accessor background-color :initform '(1 1 1) :initarg :background-color)
   (title :accessor title :initform "" :initarg :title)
   (title-font :accessor title-font :initform *default-chart-font* :initarg :title-font)
   (title-font-size :accessor title-font-size :initform 12 :initarg :title-font-size)
   (title-color :accessor title-color :initform '(0 0 0) :initarg :title-color)
   (line-width :accessor line-width :initform 0.5 :initarg :line-width)
   (line-color :accessor line-color :initform '(0 0 0) :initarg :line-color)
   (pre-draw-chart-fn :accessor pre-draw-chart-fn :initform nil :initarg :pre-draw-chart-fn)
   (post-draw-chart-fn :accessor post-draw-chart-fn :initform nil :initarg :post-draw-chart-fn)
   ))

(defclass axis (chart-item)
  ((label-font :accessor label-font :initform *default-chart-font* :initarg :label-font)
   (label-font-size :accessor label-font-size :initform 10.0 :initarg :label-font-size)
   (label-position :accessor label-position :initform :center :initarg :label-position)
   (label-rotation :accessor label-rotation :initform 0 :initarg :label-rotation)
   (label-color :accessor label-color :initform '(0 0 0) :initarg :label-color)
   (tick-length :accessor tick-length :initform 6 :initarg :tick-length)
   (tick-width :accessor tick-width :initform 0.25 :initarg :tick-width)
   (ticks-positions :accessor ticks-positions)
   (ticks-separation :accessor ticks-separation)
   ))

(defclass value-axis (axis)
  ((min-value :accessor min-value :initform 0 :initarg :min-value)
   (max-value :accessor max-value :initform 100 :initarg :max-value)
   (locked-values :accessor locked-values :initform nil :initarg :locked-values)
   (subtick-length :accessor subtick-length :initform 2 :initarg :subtick-length)
   (subtick-width :accessor subtick-width :initform 0.25 :initarg :subtick-width)
   (integer-tick :accessor integer-tick :initform nil :initarg :integer-tick)
   (nb-ticks :accessor nb-ticks :initform 10 :initarg :nb-ticks)
   (tick-value :accessor tick-value)
   (axis-scale :accessor axis-scale)
   (axis-min :accessor axis-min)
   (axis-max :accessor axis-max)
   (nb-subticks :accessor nb-subticks)
   (format-string :accessor format-string :initform nil :initarg :format-string)
   ))

(defmethod initialize-instance :after ((axis value-axis) &rest init-options &key &allow-other-keys)
  (declare (ignore init-options))
  (compute-scale axis))

(defclass histo-axis (axis)
  ((label-names :accessor label-names :initform nil :initarg :label-names)
   ))

(defclass vertical-value-axis (value-axis)
  ())

(defclass horizontal-value-axis (value-axis)
  ())

(defclass vertical-histo-axis (histo-axis)
  ())

(defclass horizontal-histo-axis (histo-axis)
  ())

(defmethod axis-size (axis)
  (width axis))

(defmethod axis-size ((axis vertical-value-axis))
  (height axis))

(defmethod axis-size ((axis vertical-histo-axis))
  (height axis))

(defmethod draw-object (obj)
  (declare (ignore obj)))

(defun nice-number (n approx integer-p)
  (let* ((n10 (expt 10 (floor (log n 10))))
         (nf (/ n n10))
         (value 
          (loop for (max val) in (if approx '((1.5 1)(3 2)(7 5)(15 10)) '((1 1)(2 2)(5 5)(15 10)))
                when (<= nf max) do (return (* val n10)))))
    (if integer-p
        (max 1 (round value))
        value)))

(defun compute-scale (axis)
  (let* ((min (min-value axis))
         (max (max-value axis))
         d nfrac)
    (when (= min max)
      (if (zerop min)
        (setf max 1.0)
        (if (plusp max)
          (setf min 0.0 max (* max 1.01))
          (setf min (* min 1.01) max 0.0))))
    (setf d (nice-number (/ (nice-number (- max min) nil (integer-tick axis)) (nb-ticks axis))
                         t (integer-tick axis)))
    (setf nfrac (max (- (floor (log d 10))) 0))
    (setf (tick-value axis) d
          (axis-min axis) (* d (floor min d))
          (axis-max axis) (* d (ceiling max d))
          (nb-ticks axis) (1+ (ceiling (- (axis-max axis)(axis-min axis)) d))
          (axis-scale axis) (/ (axis-size axis)(- (axis-max axis) (axis-min axis)))
          (ticks-separation axis)(/ (axis-size axis) (1- (nb-ticks axis)))
          (format-string axis)
          (or (format-string axis)
              (if (integer-tick axis)
                  "~d"
                  (format nil "~~,~df" nfrac)))
          (ticks-positions axis) (make-array (nb-ticks axis)))
    (loop for tick from 0 below (nb-ticks axis)
          for pos from 0 by (ticks-separation axis) do
          (setf (aref (ticks-positions axis) tick) pos))))

(defmethod draw-object ((axis horizontal-histo-axis))
  (with-saved-state
    (set-line-width (line-width axis))
    (apply #'set-rgb-stroke (line-color axis))
    (translate (x axis) (y axis))
    (move-to 0 0)
    (line-to (width axis) 0)
    (stroke)
    (set-line-width (tick-width axis))
    (move-to 0 0)
    (line-to 0 (- (tick-length axis)))
    (stroke)
    (apply #'set-rgb-fill (label-color axis))
    (loop with nb = (length (label-names axis))
          with d  = (/ (width axis) nb)
          with l = (- (tick-length axis))
          with font-size = (label-font-size axis)
          with max-width = (- d (* 0.6 font-size))
          with text-y = (* -1.25 font-size)
          for name in (label-names axis)
          for tx from d by d
          for text-x from (* 0.5 d) by d do
          (move-to tx 0)
          (line-to tx l)
          (stroke)
          (draw-centered-text text-x text-y name (label-font axis) font-size max-width))))

(defmethod draw-object ((axis vertical-value-axis))
  (with-saved-state
    (set-line-width (line-width axis))
    (apply #'set-rgb-stroke (line-color axis))
    (translate (x axis) (y axis))
    (move-to 0 0)
    (line-to 0 (height axis))
    (stroke)
    (set-line-width (tick-width axis))
    (move-to 0 0)
    (line-to (- (tick-length axis)) 0)
    (stroke)
    (apply #'set-rgb-fill (label-color axis))
    (loop with nb = (nb-ticks axis)
          with d  = (ticks-separation axis)
          with l = (- (tick-length axis))
          with font-size = (label-font-size axis)
          with text-x = (* l 1.25)
          with format = (format-string axis)
          repeat nb
          for value from (axis-min axis) by (tick-value axis)
          for y from 0 by d
          for text-y from (* -0.35 font-size) by d do
          (move-to 0 y)
          (line-to l y)
          (stroke)
          (when (integer-tick axis) (setf value (round value)))
          (draw-left-text text-x text-y (format nil format value) (label-font axis) font-size))))

(defclass legend (chart-item)
  ((label-font :accessor label-font :initform *default-chart-font* :initarg :label-font)
   (label-font-size :accessor label-font-size :initform 10.0 :initarg :label-font-size)
   (label-color :accessor label-color :initform '(0 0 0) :initarg :label-color)
   (labels&colors :accessor labels&colors :initform () :initarg :labels&colors)
   ))

(defmethod draw-object ((obj legend))
  (let* ((nb (length (labels&colors obj)))
         (font-size (label-font-size obj))
         (space (* 0.2 font-size))
         (line-height (+ space font-size))
         (height (+ (* nb line-height) space))
         (width (+ (* 3 space) font-size
                   (reduce 'max (labels&colors obj)
                           :key #'(lambda (lc) (text-width (first lc) (label-font obj)font-size))))))
    (with-saved-state
      (set-line-width (line-width obj))
      (apply #'set-rgb-stroke (line-color obj))
      (apply #'set-rgb-fill (background-color obj))
      (translate (x obj) (+ (y obj)(* 0.5 (- (height obj) height))))
      (basic-rect 0 0 width height)
      (fill-and-stroke)
      (basic-rect 0 0 width height)
      (clip-path)
      (end-path-no-op)
      (loop with dx = font-size
            with dy = font-size
            with text-x = (+ dx (* 2 space))
            for (name color) in (labels&colors obj)
            for y downfrom (- height line-height) by line-height do
            (apply #'set-rgb-fill color)
            (basic-rect space y dx dy)
            (fill-and-stroke)
            (apply #'set-rgb-fill (label-color obj))
            (in-text-mode
             (move-text text-x y)
             (set-font (label-font obj) font-size)
             (show-text name))
            ))))

(defclass histogram (chart-item)
  ((label-names :accessor label-names :initform nil :initarg :label-names)
   (series :accessor series :initform () :initarg :series)
   (stacked-series :accessor stacked-series :initform () :initarg :stacked-series)
   (labels&colors :accessor labels&colors :initform () :initarg :labels&colors)
   (h-lines-width :accessor h-lines-width :initform 0.2 :initarg :h-lines-width)
   (h-lines-color :accessor h-lines-color :initform '(0.5 0.5 0.5) :initarg :h-lines-color)
   (groups-spacing :accessor groups-spacing :initform 0.2 :initarg :groups-spacing)
   (x-axis :accessor x-axis)
   (y-axis :accessor y-axis)
   (legend :accessor legend :initform nil)
   ))

(defmethod initialize-instance :after ((histo histogram) &rest init-options &key
                                       x-axis-options y-axis-options legend-options &allow-other-keys)
  (declare (ignore init-options))
  (setf (y-axis histo)
        (apply #'make-instance 'vertical-value-axis
               :x (x histo) :y (y histo) :height (height histo)
               (append y-axis-options
                       (list
                        :min-value (if (stacked-series histo)
                                       0.0
                                       (reduce #'min (mapcar #'(lambda (values)
                                                                 (reduce #'min values))
                                                             (series histo))))
                        :max-value (reduce #'max
                                           (if (stacked-series histo)
                                               (apply 'mapcar #'(lambda (&rest values)
                                                                  (apply '+ values))
                                                      (series histo))
                                               (mapcar #'(lambda (values)
                                                           (reduce #'max values))
                                                       (series histo))))))))
  (setf (x-axis histo)
        (apply #'make-instance 'horizontal-histo-axis
               :x (x histo) :y (y histo) :width (width histo)
               :label-names (label-names histo)
               x-axis-options))
  (when (> (length (series histo)) 1)
    (setf (legend histo)
        (apply #'make-instance 'legend
               :x (+ (x histo) (width histo) 10) :y (y histo) :width 60 :height (height histo)
               :labels&colors (labels&colors histo)
               legend-options))))

(defmethod draw-object ((obj histogram))
  (let* ((nb-series (if (stacked-series obj) 1 (length (series obj))))
         (nb-values (length (first (series obj))))
         (width (width obj))
         (group-width (/ width nb-values))
         (spacing (* (groups-spacing obj) group-width))
         (bar-width (/ (- group-width spacing) nb-series))
         (min-value (axis-min (y-axis obj)))
         (scale (axis-scale (y-axis obj))))
    (with-saved-state
        (translate (x obj)(y obj))
      (set-line-width (line-width obj))
      (apply #'set-rgb-stroke (line-color obj))
      (apply #'set-rgb-fill (background-color obj))
      (basic-rect 0 0 width (height obj))
      (fill-and-stroke)
      (set-line-width (h-lines-width obj))
      (apply #'set-rgb-stroke (h-lines-color obj))
      (loop for tick-y across (ticks-positions (y-axis obj)) do
            (move-to 0 tick-y)
            (line-to width tick-y)
            (stroke))
      (set-line-width (line-width obj))
      (apply #'set-rgb-stroke (line-color obj))
      (if (stacked-series obj)
          (loop for values in (apply 'mapcar 'list (series obj))
                for gx from (* 0.5 spacing) by bar-width
                for bx from gx by group-width do
                (loop for y = 0.0 then (+ y dy)
                      for value in values
                      for (nil color) in (labels&colors obj)
                      for dy = (* value scale) do
                      (apply #'set-rgb-fill color)
                      (basic-rect bx y bar-width dy)
                      (fill-and-stroke)))
          (loop for serie in (series obj)
                for gx from (* 0.5 spacing) by bar-width
                for (nil color) in (labels&colors obj) do
                (apply #'set-rgb-fill color)
                (loop for value in serie
                      for dy = (* (- value min-value) scale)
                      for bx from gx by group-width do
                      (basic-rect bx 0 bar-width dy)
                      (fill-and-stroke))))))
  (draw-object (x-axis obj))
  (draw-object (y-axis obj))
  (draw-object (legend obj)))


(defclass pie-chart (chart-item)
  ((serie  :accessor serie  :initform () :initarg :serie)
   (labels&colors :accessor labels&colors :initform () :initarg :labels&colors)
   (legend :accessor legend :initform nil)
   ))

(defmethod initialize-instance :after ((obj pie-chart) &rest init-options &key no-legend
                                       legend-options &allow-other-keys)
  (declare (ignore init-options))
  (unless no-legend
    (setf (legend obj)
          (apply #'make-instance 'legend
                 :x (+ (x obj) (width obj) 10) :y (y obj) :width 60 :height (height obj)
                 :labels&colors (labels&colors obj)
                 legend-options))))

(defmethod draw-object ((obj pie-chart))
  (let* ((sum (reduce #'+ (serie obj)))
         (radius (* (width obj) 0.45))
         angles)
    (when (zerop sum) (setf sum 1))
    (setf angles (mapcar #'(lambda (v) (/ (* 2 pi v) sum)) (serie obj)))
    (with-saved-state
      (translate (+ (x obj)(* 0.5 (width obj)))(+ (y obj)(* 0.5 (height obj))))
      (set-line-width (line-width obj))
      (apply #'set-rgb-stroke (line-color obj))
      (apply #'set-rgb-fill (background-color obj))
      (fill-and-stroke)
      (loop for angle in angles
            for (nil color) in (labels&colors obj)
            for start = 0 then end
            for end = (+ start angle) do
            (apply #'set-rgb-fill color)
            (pie 0 0 radius start angle)
            (fill-and-stroke))))
  (draw-object (legend obj)))


(defmethod draw-object ((axis horizontal-value-axis))
  (with-saved-state
    (set-line-width (line-width axis))
    (apply #'set-rgb-stroke (line-color axis))
    (translate (x axis) (y axis))
    (move-to 0 0)
    (line-to (width axis) 0)
    (stroke)
    (set-line-width (tick-width axis))
    (move-to 0 0)
    (line-to 0 (- (tick-length axis)))
    (stroke)
    (apply #'set-rgb-fill (label-color axis))
    (loop with nb = (nb-ticks axis)
          with d  = (ticks-separation axis)
          with l = (- (tick-length axis))
          with font-size = (label-font-size axis)
          with text-y = (+ (* l 1.25) (* -1 font-size))
          with format = (format-string axis)
          repeat nb
          for value from (axis-min axis) by (tick-value axis)
          for x from 0 by d
          for text-x from (* -0.35 font-size) by d do
          (move-to x 0)
          (line-to x l)
          (stroke)
          (draw-centered-text text-x text-y (format nil format value) (label-font axis) font-size d))))

(defclass plot-xy (chart-item)
  ((series :accessor series :initform () :initarg :series)
   (labels&colors :accessor labels&colors :initform () :initarg :labels&colors)
   (h-lines-width :accessor h-lines-width :initform 0.2 :initarg :h-lines-width)
   (h-lines-color :accessor h-lines-color :initform '(0.5 0.5 0.5) :initarg :h-lines-color)
   (point-radius :accessor point-radius :initform 2 :initarg :point-radius)
   (x-axis :accessor x-axis)
   (y-axis :accessor y-axis)
   (legend :accessor legend :initform nil)
   ))

(defmethod initialize-instance :after ((plot plot-xy) &rest init-options &key
                                       x-axis-options y-axis-options legend-options &allow-other-keys)
  (declare (ignore init-options))
  (setf (y-axis plot)
        (apply #'make-instance 'vertical-value-axis
               :x (x plot) :y (y plot) :height (height plot)
               (append y-axis-options
                       (list
                        :min-value
                        (reduce #'min
                                (mapcar #'(lambda (values)
                                            (reduce #'min
                                                    (remove nil (mapcar #'second values))))
                                        (series plot)))
                        :max-value
                        (reduce #'max
                                (mapcar #'(lambda (values)
                                            (reduce #'max
                                                    (remove nil (mapcar #'second values))))
                                        (series plot)))))))
  (setf (x-axis plot)
        (apply #'make-instance 'horizontal-value-axis
               :x (x plot) :y (y plot) :width (width plot)
               (append x-axis-options
                       (list
                        :min-value
                        (reduce #'min
                                (mapcar #'(lambda (values)
                                            (reduce #'min
                                                    (remove nil (mapcar #'first values))))
                                        (series plot)))
                        :max-value
                        (reduce #'max
                                (mapcar #'(lambda (values)
                                            (reduce #'max
                                                    (remove nil (mapcar #'first values))))
                                        (series plot)))))))
  (when (labels&colors plot)
    (setf (legend plot)
        (apply #'make-instance 'legend
               :x (or (getf legend-options :x) (+ (x plot) (width plot) 10))
               :y (or (getf legend-options :y) (y plot))
               :width 60 :height (height plot)
               :labels&colors (labels&colors plot)
               legend-options))))


(defmethod draw-object ((obj plot-xy))
  (let* ((width (width obj))
         (height (height obj))
         (min-value-y (axis-min (y-axis obj)))
         (min-value-x (axis-min (x-axis obj)))
         (max-value-y (axis-max (y-axis obj)))
         (max-value-x (axis-max (x-axis obj)))
         (scale-y (axis-scale (y-axis obj)))
         (scale-x (axis-scale (x-axis obj))))
    (with-saved-state
        (translate (x obj)(y obj))
      (set-line-width (line-width obj))
      (apply #'set-rgb-stroke (line-color obj))
      (apply #'set-rgb-fill (background-color obj))
      (basic-rect 0 0 width height)
      (fill-and-stroke)
      (when (pre-draw-chart-fn obj)
        (funcall (pre-draw-chart-fn obj) obj width height scale-x scale-y 
                 min-value-x min-value-y max-value-x max-value-y))
      (set-line-width (h-lines-width obj))
      (apply #'set-rgb-stroke (h-lines-color obj))
      (loop for tick-y across (ticks-positions (y-axis obj)) do
           (move-to 0 tick-y)
           (line-to width tick-y)
           (stroke))
      (loop for tick-x across (ticks-positions (x-axis obj)) do
           (move-to tick-x 0)
           (line-to tick-x height)
           (stroke))
      (set-line-width (line-width obj))
      (set-line-join 2)
      (loop for serie in (series obj)
            for (nil color) in (labels&colors obj) do
           (apply #'set-rgb-stroke color)
           (apply #'set-rgb-fill color)
           (let ((points '())
                 (all-points '()))
             (loop for (xx yy) in serie
                for x = (when xx (* (- xx min-value-x) scale-x))
                for y = (when yy (* (- yy min-value-y) scale-y))
                do
                  (if (and x y)
                      (progn
                        (push (list x y) points)
                        (unless (zerop (point-radius obj))
                          (circle x y (point-radius obj))
                          (fill-and-stroke)))
                      (when points
                        (push points all-points)
                        (setf points '()))))
             (when points (push points all-points))
             (map nil 'polyline all-points)
             (stroke)))
      (when (post-draw-chart-fn obj)
        (funcall (post-draw-chart-fn obj) obj width height scale-x scale-y 
                 min-value-x min-value-y max-value-x max-value-y))))
  (draw-object (x-axis obj))
  (draw-object (y-axis obj))
  (draw-object (legend obj)))