guile-charting/charting/draw.scm

;; guile-charting
;; Copyright (C) 2007, 2012, 2014, 2019 Andy Wingo <wingo at pobox dot com>

;; This library 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.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, see
;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; 
;;
;;; Code:

(define-module (charting draw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (cairo)
  #:use-module (charting util)
  #:export (draw-legend
            draw-bar
            draw-axis-label
            draw-bar-group
            draw-perf-test
            draw-annotations
            draw-perf-series
            draw-page-map
            draw-bar-legend
            draw-point
            draw-decorator
            draw-ticks
            draw-tick-labels
            draw-grid
            draw-title
            draw-chart-area
            draw-background
            reset-colors!
            ))

(define *pi* 3.141592653589793)

(define-syntax-rule (with-cairo cr body ...)
  (begin
    (cairo-save cr)
    (call-with-values (lambda () body ...)
      (lambda vals
        (cairo-restore cr)
        (apply values vals)))))

(define-syntax-rule (with-rgb cr r g b body ...)
  (with-cairo cr 
    (cairo-set-source-rgb cr r g b)
    body ...))

(define-syntax-rule (with-rgba cr r g b a body ...)
  (with-cairo cr 
    (cairo-set-source-rgba cr r g b a)
    body ...))

(define-syntax-rule (with-line-width cr w body ...)
  (with-cairo cr 
    (cairo-set-line-width cr w)
    body ...))

(define-syntax-rule (with-font-size cr s body ...)
  (with-cairo cr 
    (cairo-set-font-size cr s)
    body ...))

(define-syntax-rule (with-y-inverted cr body ...)
  (with-cairo cr 
    (cairo-scale cr 1 -1)
    body ...))

(define-syntax-rule (with-rotate cr degrees body ...)
  (with-cairo cr 
    (cairo-rotate cr (* 2 *pi* (/ degrees 360)))
    body ...))

(define-syntax-rule (with-color cr color body ...)
  (with-cairo cr
    (apply cairo-set-source-rgb cr
           (map 
            (lambda (x) (/ x 255.0))
            (let ((c color))
              (assoc-ref *palette* c))))
    body ...))

(define-syntax-rule (with-color-for-series cr series body ...)
  (with-color cr (color-for-series series)
              body ...))

(define-syntax-rule (with-current-point cr x y body ...)
  (call-with-values (lambda () (cairo-get-current-point cr))
    (lambda (x y) body ...)))

;; the 2014 material design palette, mixed up a bit
(define *palette*
  '(("Light Blue 500" 3 169 244)
    ("Teal 500" 0 150 136)
    ("Orange 500" 255 152 0)
    ("Yellow 500" 255 235 59)
    ("Light Green 500" 139 195 74)
    ("Amber 500" 255 193 7)
    ("Indigo 500" 63 81 181)
    ("Red 500" 244 67 54)
    ("Cyan 500" 0 188 212)
    ("Deep Orange 500" 255 87 34)
    ("Lime 500" 205 220 57)
    ("Brown 500" 121 85 72)
    ("Blue 500" 33 150 243)
    ("Blue Gray 500" 96 125 139)
    ("Purple 500" 156 39 176)
    ("Deep purple 500" 103 58 183)
    ("Pink 500" 233 30 99)
    ("Green 500" 76 175 80)
    ("Gray 100" #xf5 #xf5 #xf5)
    ("Gray 200" #xee #xee #xee)
    ("Gray 300" #xe0 #xe0 #xe0)
    ("Gray 800" #x42 #x42 #x42)))

(define *series-colors* '())
(define *available-colors* *palette*)
  
(define (reset-colors!)
  (set! *series-colors* '())
  (set! *available-colors* *palette*))

(define (color-for-series series)
  (cond
   ((assoc-ref *series-colors* series))
   ((pair? *available-colors*)
    (set! *series-colors*
          (acons series (caar *available-colors*)
                 *series-colors*))
    (set! *available-colors*
          (cdr *available-colors*))
    (pk series (cdar *series-colors*)))
   (else
    (let ((color-name (string-append "tmp-" series))
          (color (list (random 256) (random 256) (random 256))))
      (set! *series-colors* (acons series color-name *series-colors*))
      (set! *palette* (acons color-name color *palette*))
      color-name))))
  
(define (rel-rectangle cr width height)
  (cairo-rel-line-to cr width 0)
  (cairo-rel-line-to cr 0 height)
  (cairo-rel-line-to cr (- width) 0)
  (cairo-rel-line-to cr 0 (- height)))

(define (filled-rectangle cr width height stroke fill)
  (rel-rectangle cr width height)
  (with-color cr fill
              (cairo-fill-preserve cr))
  (with-color cr stroke
              (cairo-stroke cr)))

(define (filled-rectangle/1 cr width height stroke fill)
  (let ((line-width (cairo-get-line-width cr)))
    (cairo-rel-move-to cr (/ line-width 2) (/ line-width 2))
    (filled-rectangle cr (- width line-width)
                      (- height line-width)
                      stroke fill)))

(define (show-text cr text justification)
  (with-cairo cr
              (let ((width (cairo-text-extents:width
                            (cairo-text-extents cr text))))
                (cairo-rel-move-to
                 cr
                 (case justification
                   ((left) 0)
                   ((right) (- width))
                   ((center) (- (/ width 2)))
                   (else
                    (error "unknown justification" justification)))
                 0)
                (cairo-scale cr 1 -1)
                (cairo-show-text cr text))))

(define-with-kwargs (draw-legend cr expand-right? expand-down?
                                 measure-only? (text-height 12)
                                 (draw-outlines? #t)
                                 (draw-background? #t)
                                 (text-measurer
                                  (lambda (size)
                                    (lambda (text)
                                      (with-cairo cr
                                        (cairo-set-font-size
                                         cr (or size text-height))
                                        (cairo-text-width cr text)))))
                                 (series-list '()))
  "Draw a legend.

@var{series-list} is expected to be a list of series names. The
@var{cr} is expected to be positioned at one of the corners of
the legend; @var{expand-right?} and @var{expand-down?} control which way
the legend will be rendered."
  (let* ((box-width text-height)
         (padding 5)
         (spacing (/ text-height 2))
         (text-width (apply max (map (text-measurer text-height)
                                     series-list)))
         (total-width (+ (* 2 padding) box-width spacing text-width))
         (num-series (length series-list))
         (total-height (+ (* 2 padding) (* (- num-series 1) spacing)
                          (* num-series text-height))))
    (cond
     (measure-only?
      (values total-width total-height))
     (else
      (with-current-point
       cr basex basey
       (cairo-rel-move-to cr (if expand-right? 0 (- total-width))
                          (if expand-down? (- total-height) 0))
       (when draw-background?
         (filled-rectangle/1 cr total-width total-height
                               "Gray 800" "Gray 100"))
       (let lp ((x (+ basex (if expand-right?
                                padding
                                (- (- total-width padding)))))
                (y (+ basey (if expand-down?
                                (- padding)
                                (- total-height padding))))
                (series-list series-list))
         (cond
          ((not (null? series-list))
           (cairo-move-to cr x (- y box-width))
           (if draw-outlines?
               (filled-rectangle/1 cr box-width box-width
                                   "Gray 800"
                                   (color-for-series (car series-list)))
               (begin
                 (rel-rectangle cr box-width box-width)
                 (with-color cr (color-for-series (car series-list))
                             (cairo-fill cr))))
           (cairo-move-to cr (+ x box-width spacing) (- y text-height))
           (with-font-size cr text-height
                           (show-text cr (car series-list) 'left))
           (lp x (- y text-height spacing) (cdr series-list))))))))))

(define-with-kwargs (draw-decorator cr scale label y+-bracket y--bracket
                                    y-bracket)
  "Draw a decorator.

A decorator is something drawn around a point, such as error
bars. This function currently supports drawing error bars in the
Y direction, which are specified individually as @var{y+-bracket}
and @var{y--bracket}."
  (define (make-bracket x y mx my len)
    (cairo-move-to cr x y)
    (cairo-rel-line-to cr (* mx len) (* my len))
    (cairo-rel-line-to cr (* my -5) (* mx 0))
    (cairo-rel-line-to cr (* my 10) (* mx 0))
    (with-color cr "Gray 800" (cairo-stroke cr)))
  (with-current-point
   cr x y
   (if (or y+-bracket y-bracket)
       (make-bracket x y 0 1 (* (or y+-bracket y-bracket) scale)))
   (if label
       (begin
         (cairo-move-to cr x (+ y 4))
         (show-text cr label 'center)))
   (if (or y--bracket y-bracket)
       (make-bracket x y 0 -1 (* (or y--bracket y-bracket) scale)))))

(define-with-kwargs (draw-bar cr height scale bar-width bar-value-formatter
                              series (decorator '()))
  "Draw a single bar.

@var{cr} is expected to have been placed at the lower left corner
of where the bar should be. @var{decorator} is a property list
that can be passed to @ref{charting draw draw-decorator}."
  (with-current-point
   cr x y
   (filled-rectangle/1 cr bar-width (* height scale)
                       "Gray 800"
                       (color-for-series series))
   (cairo-move-to cr (+ x (/ bar-width 2)) (+ y (* height scale)))
   (apply draw-decorator cr scale
          #:label (and bar-value-formatter (bar-value-formatter height))
          decorator)))

(define-with-kwargs (draw-bar-group cr data bar-width scale bar-value-formatter)
  "Draw a group of bars.

@var{data} is a property list suitable for passing to
@ref{charting draw draw-bar}. @var{cr} is expected to have been positioned
along the x axis in the center of where the bar group should be
displayed."
  (cairo-rel-move-to cr (- (/ (* (length data) bar-width) 2)) 0)
  (with-current-point
   cr basex basey
   (let lp ((data data) (n 0))
     (cond
      ((not (null? data))
       (cairo-move-to cr (+ basex (* n bar-width)) basey)
       (apply draw-bar cr (caar data) scale bar-width bar-value-formatter
              (cdar data))
       (lp (cdr data) (1+ n)))))))
    
(define-with-kwargs (draw-bar-legend cr data width
                                     (text-height 10)
                                     (font-family "Bitstream Vera Sans")
                                     (horizontal-spacing 10)
                                     (vertical-spacing 2))
  "Draw a \"bar legend\".

A bar legend is meant to show what categories exist, as well as
indicating their contribution to a graph.  Use a bar legend if it would
be confusing to label some other chart in which the pixel count of a
category is proportional to its magnitude, but you want to make sure to
label all categories, even those with small magnitudes.

@var{data} is as in @ref{charting draw draw-page-map}.  The legend will
be written below the current position of @var{cr}."
  (with-current-point
   cr x0 y0
   (with-cairo
    cr
    (cairo-select-font-face cr font-family 'normal 'normal)
    (cairo-set-font-size cr text-height)
    (match data
      (((section-names . (starts . sizes)) ...)
       (let ((max-size (apply max sizes))
             (labels-width (apply max (map (lambda (name)
                                             (cairo-text-extents:width
                                              (cairo-text-extents cr name)))
                                           section-names))))
         (let lp ((y0 y0)
                  (labels section-names)
                  (sizes sizes))
           (match (cons labels sizes)
             ((() . ()) #t)
             (((label . labels) . (size . sizes))
              (let ((y0 (- y0 text-height)))
                (cairo-move-to cr (+ x0 labels-width) y0)
                (show-text cr label 'right)
                (cairo-move-to cr (+ labels-width horizontal-spacing) y0)
                (with-color-for-series
                 cr label
                 (rel-rectangle
                  cr
                  (* (- width labels-width horizontal-spacing)
                     (/ size max-size))
                  text-height)
                 (cairo-fill cr))
                (cairo-move-to cr width y0)
                (show-text cr (format #f "~a" size) 'right)
                (lp (- y0 vertical-spacing) labels sizes)))))))))))

(define (draw-box-background cr width color x bottom top)
  (cairo-move-to cr x bottom)
  (rel-rectangle cr width top)
  (with-color cr color (cairo-fill cr)))

(define (draw-box-tick cr width color line-width x y)
  (cairo-move-to cr x y)
  (with-line-width cr (* (cairo-get-line-width cr) line-width)
                   (cairo-rel-line-to cr width 0)
                   (with-color cr color
                               (cairo-stroke cr))))

(define (draw-box-range cr width color x min max)
  (cairo-move-to cr (+ x (/ width 2)) min)
  (cairo-rel-line-to cr 0 (- max min))
  (with-color cr color (cairo-stroke cr)))

(define-with-kwargs (draw-box-plot cr data translate-y
                                   box-width box-value-formatter)
  "Draw a single box plot.

 data := (series point ...)

@var{cr} is expected to have been placed at the lower left corner of
where the box-plot should be."
  (let* ((series (car data))
         (color (color-for-series (car data)))
         (ordered (list->vector (sort (cdr data) <)))
         (len (vector-length ordered)))
    (define (percentile p)
      (vector-ref ordered (min (floor/ (* p len) 100) (1- len))))
    (unless (zero? len)
      (with-current-point
       cr x y
       (let ((median (if (even? len)
                         (/ (+ (vector-ref ordered (/ len 2))
                               (vector-ref ordered (1- (/ len 2))))
                            2)
                         (vector-ref ordered (/ (1- len) 2)))))
         (draw-box-background cr box-width color x
                              (translate-y (percentile 25))
                              (translate-y (percentile 75)))
         (draw-box-range cr box-width color x
                         (translate-y (percentile 0))
                         (translate-y (percentile 100)))
         (for-each
          (lambda (tick)
            (match tick
              ((p width thickness)
               (draw-box-tick cr (* box-width width) color thickness
                              (+ x
                                 (/ (* (- 1.0 width) box-width) 2))
                              (translate-y (percentile p))))))
          '((5 0.5 1)
            (95 0.5 1)))
         (draw-box-tick cr (/ box-width 2) "Gray 800" 2
                        (+ x (/ box-width 4)) (translate-y median))
         (when box-value-formatter
           (cairo-move-to cr (+ x (/ box-width 2))
                          (+ y 4 (translate-y (vector-ref ordered (1- len)))))
           (with-font-size cr 10
                           (show-text cr (box-value-formatter median) 'center))))))))

(define (compute-histogram ordered translate-y)
  (let* ((len (vector-length ordered))
         (base (floor (translate-y (vector-ref ordered 0)))))
    (define (bucket-for n)
      (inexact->exact (floor (- (translate-y (vector-ref ordered n)) base))))
    (let ((ret (make-vector (1+ (bucket-for (1- len))) 0)))
      (let lp ((n 0))
        (when (< n len)
          (let ((bucket (bucket-for n)))
            (vector-set! ret bucket (1+ (vector-ref ret bucket)))
            (lp (1+ n)))))
      (values base ret))))

(define (draw-histogram cr x base buckets len box-width color)
  (let ((x (+ x (/ box-width 2)))
        (x-scale (/ (* box-width 1.5) len)))
    (cairo-move-to cr x base)
    (let lp ((n 0) (prev 0))
      (when (< n (vector-length buckets))
        (let ((next (* (vector-ref buckets n) x-scale)))
          (cairo-rel-line-to cr (- next prev) 0)
          (cairo-rel-line-to cr 0 1)
          (lp (1+ n) next))))
    (cairo-line-to cr x (+ base (vector-length buckets)))
    (let lp ((n (1- (vector-length buckets))) (prev 0))
      (when (>= n 0)
        (let ((next (* (vector-ref buckets n) x-scale)))
          (cairo-rel-line-to cr (- prev next) 0)
          (cairo-rel-line-to cr 0 -1)
          (lp (1- n) next))))
    (cairo-close-path cr)
    (with-color cr color
                (cairo-fill cr))))

(define (draw-histogram* cr x base buckets len width color)
  (let ((x-scale (/ (* width 3) len)))
    (cairo-move-to cr x base)
    (let lp ((n 0) (prev 0))
      (when (< n (vector-length buckets))
        (let ((next (* (vector-ref buckets n) x-scale)))
          (cairo-rel-line-to cr (- next prev) 0)
          (cairo-rel-line-to cr 0 1)
          (lp (1+ n) next))))
    (cairo-line-to cr x (+ base (vector-length buckets)))
    (let lp ((n (1- (vector-length buckets))) (prev 0))
      (when (>= n 0)
        (let ((next (* (vector-ref buckets n) x-scale)))
          (cairo-rel-line-to cr (- prev next) 0)
          (cairo-rel-line-to cr 0 -1)
          (lp (1- n) next))))
    (cairo-close-path cr)
    (with-color cr color
                (cairo-fill cr))))

(define-with-kwargs (draw-histo-plot cr series points box-width label-offset
                                     translate-y box-value-formatter
                                     label-height vertical-label? baseline)
  "Draw a histogram of @var{points} as part of a larger chart of data.

@var{cr} is expected to have been placed at the lower left corner of
where the histo-plot should be."
  (let* ((color (color-for-series series))
         (ordered (list->vector (sort points <)))
         (len (vector-length ordered))
         (median (and (> len 0)
                      (if (even? len)
                          (/ (+ (vector-ref ordered (/ len 2))
                                (vector-ref ordered (1- (/ len 2))))
                             2)
                          (vector-ref ordered (/ (1- len) 2))))))
    (define (percentile p)
      (vector-ref ordered (min (floor/ (* p len) 100) (1- len))))
    (unless (zero? len)
      (with-current-point
       cr x y
       (when baseline
         (cairo-rel-move-to cr 0 (translate-y baseline)))
       (rel-rectangle cr box-width (- (translate-y median)
                                      (if baseline
                                          (translate-y baseline)
                                          0)))
       (with-color cr color (cairo-fill cr))
       (call-with-values (lambda () (compute-histogram ordered translate-y))
         (lambda (base buckets)
           (draw-histogram cr x base buckets len box-width "Gray 800")))
       (with-line-width cr (/ (cairo-get-line-width cr) 2)
         (draw-box-range cr box-width "Gray 800" x
                         (translate-y (percentile 0))
                         (translate-y (percentile 100))))
       (when box-value-formatter
         (call-with-values (lambda ()
                             (cond
                              ((not baseline)
                               (values median 1.0))
                              ((< median baseline)
                               (values baseline 1.0))
                              (else
                               (values baseline -1.0))))
           (lambda (val direction)
             (cairo-move-to cr (+ x (/ box-width 2))
                            (+ y (translate-y val)
                               (* direction label-offset)))
             (with-font-size
              cr label-height
              (let ((label (box-value-formatter median)))
                (if vertical-label?
                    (begin
                      (cairo-rel-move-to cr (* label-height 0.5) 0)
                      (with-rotate
                       cr 90
                       (show-text cr label
                                  (if (negative? direction) 'right 'left))))
                    (show-text cr label 'center)))))))))))

(define-with-kwargs (draw-perf-test cr data box-width box-spacing
                                    translate-y box-value-formatter
                                    box-label-height vertical-box-labels?
                                    baseline)
  "Draw a group of boxes corresponding to runs of one benchmark in
different scenarios.

Each scenario corresponds to a series.  The format of @var{data} is
@code{((@var{series} @var{point} ...) ...)}, where the series is a
string, and the points are numbers.  @var{cr} is expected to have been
positioned along the x axis in the center of where the data for the test
should be displayed."
  (define (avg l)
    (if (null? l)
        0.0
        (/ (apply + l) 1.0 (length l))))
  (define (variance l)
    (let* ((mean (avg l)))
      (avg (map (lambda (x) (expt (- x mean) 2)) l))))
  (define (translated-variance l)
    (variance (map translate-y l)))
  (let* ((sqrt-avg-translated-variance
          (sqrt (avg (map translated-variance (map cdr data)))))
         (label-offset (if baseline
                           box-label-height
                           (+ 6 (* sqrt-avg-translated-variance 2)))))
    (cairo-rel-move-to cr
                       (- (/ (* (length data) (+ box-width box-spacing)) 2))
                       0)
    (with-current-point
     cr basex basey
     (let lp ((data data) (n 0))
       (match data
         (() #t)
         (((series . points) . data)
          (cairo-move-to cr
                         (+ basex (* n (+ box-width box-spacing))
                                  (/ box-spacing 2)
                                  0.5)
                         basey)
          (unless (null? points)
            (draw-histo-plot cr series points box-width label-offset
                             translate-y box-value-formatter
                             box-label-height vertical-box-labels?
                             baseline))
          (lp data (1+ n))))))))

(define (draw-background-shape cr ordered xticks box-width box-spacing
                               translate-y range color)
  (define (percentile ordered p)
    (vector-ref ordered (min (floor/ (* p (vector-length ordered)) 100) (1- (vector-length ordered)))))
  (cairo-move-to cr (car xticks) (translate-y (percentile (car ordered) (+ 50 range))))
  (for-each (lambda (x ordered)
              (cairo-line-to cr x (translate-y (percentile ordered (+ 50 range)))))
            xticks ordered)
  (for-each (lambda (x ordered)
              (cairo-line-to cr x (translate-y (percentile ordered (- 50 range)))))
            (reverse xticks) (reverse ordered))
  (cairo-close-path cr)
  (with-color cr color
              (cairo-fill cr)))

(define-with-kwargs (draw-histo-plots cr ordered xticks box-width box-spacing
                                      translate-y)
  (for-each
   (lambda (x ordered)
     (define (percentile p)
       (vector-ref ordered (min (floor/ (* p (vector-length ordered)) 100) (1- (vector-length ordered)))))
     (call-with-values (lambda () (compute-histogram ordered translate-y))
       (lambda (base buckets)
         (draw-histogram* cr x base buckets (vector-length ordered) (* (+ box-width box-spacing) 3) "Gray 800")))
     (with-line-width cr (/ (cairo-get-line-width cr) 2)
        (draw-box-range cr 0 "Gray 800" x
                        (translate-y (percentile 0))
                        (translate-y (percentile 100))))
     #;
     (when box-value-formatter
       (cairo-move-to cr (+ x (/ box-width 2))
                      (+ y 25 (translate-y median)))
       (with-font-size cr 10
         (show-text cr (box-value-formatter median) 'center))))
   xticks ordered))

(define (draw-median-labels cr median xticks translate-y box-value-formatter)
  (for-each (lambda (x y)
              (cairo-move-to cr (+ x 5) (- (translate-y y) 5))
              (with-font-size cr 10
                (show-text cr (box-value-formatter y) 'left)))
            xticks median))

(define-with-kwargs (draw-annotations cr annotations xticks width height)
  (define (translate-x x)
    (let lp ((ticks xticks))
      (match ticks
        (((before-from . before-to) (after-from . after-to) . _)
         (if (<= before-from x after-from)
             (+ before-to
                (* (- x before-from)
                   (/ (- after-to before-to) (- after-from before-from))))
             (lp (cdr ticks)))))))
  (for-each (lambda (x)
              (cairo-move-to cr x 0)
              (cairo-line-to cr x height)
              (with-color cr "Gray 800" (cairo-stroke cr)))
            (map translate-x annotations)))

(define-with-kwargs (draw-perf-series cr data xticks box-width box-spacing
                                      translate-y box-value-formatter
                                      vertical-labels?)
  "Draw a group of boxes corresponding to runs of one benchmark in
different scenarios.

@var{data} := @code{(@var{x} @var{point} ...) ...)}

, where the series is a
string, and the points are numbers.  @var{cr} is expected to have been
positioned along the x axis in the center of where the data for the test
should be displayed."
  (let* ((ordered (map (lambda (data) (list->vector (sort (cdr data) <)))
                       data))
         (median (map (lambda (ordered)
                        (let ((len (vector-length ordered)))
                          (and (> len 0)
                               (if (even? len)
                                   (/ (+ (vector-ref ordered (/ len 2))
                                         (vector-ref ordered (1- (/ len 2))))
                                      2)
                                   (vector-ref ordered (/ (1- len) 2))))))
                      ordered)))
    (with-cairo
     cr
     (draw-background-shape cr ordered xticks box-width box-spacing translate-y
                            45 "Orange 1")
     (draw-background-shape cr ordered xticks box-width box-spacing translate-y
                            25 "Orange 2")
     (draw-background-shape cr ordered xticks box-width box-spacing translate-y
                            15 "Scarlet Red 1")
     (draw-background-shape cr ordered xticks box-width box-spacing translate-y
                            5 "Scarlet Red 2")
     (draw-histo-plots cr ordered xticks box-width box-spacing translate-y)
     (draw-median-labels cr median xticks translate-y box-value-formatter))))

(define-with-kwargs (draw-point cr x y label)
  "Draw a point at the current position."
  ; (cairo-rel-move-to cr 2 0)
  (with-color-for-series
   cr label
   (cairo-new-path cr)
   (cairo-arc cr x y 2 0 (* 2 *pi*))
   (cairo-close-path cr)
   (cairo-stroke cr)))

(define-with-kwargs (draw-page-map cr data chart-width chart-height
                                   (page-size 4096)
                                   (page-height 2)
                                   (page-spacing 1))
  "Draw a page map for the given data set.

@var{data} := @code{(@var{label} . (@var{start} . @var{size})) ...)}

@var{label} is a string, and @var{start} and @var{size} are numbers.
@var{cr} is expected to have been positioned at the lower-left corner of the chart area."
  (for-each
   (match-lambda
    ((label . (start . size))
     (let lp ((start start)
              (size size))
       (unless (zero? size)
         (call-with-values (lambda () (floor/ start page-size))
           (lambda (page offset)
             (let* ((offset-fraction (/ offset page-size))
                    (inc (min (- page-size offset) size))
                    (inc-fraction (/ inc page-size)))
               (cairo-move-to cr (+ (* offset-fraction chart-width))
                              (- chart-height
                                 (* page (+ page-height page-spacing))
                                 page-height))
               (with-color-for-series
                cr label
                (rel-rectangle cr (* inc-fraction chart-width) page-height)
                (cairo-fill cr))
               (lp (+ start inc) (- size inc)))))))))
   data))

(define-with-kwargs (draw-ticks cr ticks tick-size vertical?)
  "Draw ticks on an axis.

@var{ticks} is a list of positions in the current cairo
coordinate system."
  (for-each
   (lambda (pos)
     (cond
      (vertical?
       (cairo-move-to cr 0 pos)
       (cairo-rel-line-to cr (- (* 2/3 tick-size)) 0))
      (else
       (cairo-move-to cr pos 0)
       (cairo-rel-line-to cr 0 (- (* 2/3 tick-size))))))
   ticks)
  (with-color cr "Gray 200"
              (cairo-stroke cr)))

(define-with-kwargs (draw-tick-labels cr tick-labels tick-size
                                      vertical-axis?
                                      vertical-text?
                                      text-height)
  "Draw tick labels on an axis.

@var{tick-labels} is an alist of label-position pairs, where
position is in the current cairo coordinate system, along one
axis."
  (for-each
   (lambda (pair)
     (let ((text (if (string? (car pair))
                     (car pair)
                     (object->string (car pair)))))
       (cond
        (vertical-axis?
         (cairo-move-to cr (- tick-size) (- (cdr pair) (/ text-height 2)))
         (with-font-size
          cr text-height
          (show-text cr text 'right)))
        (vertical-text?
         (cairo-move-to cr (+ (cdr pair) (/ text-height 2)) (- tick-size))
         (with-rotate
          cr 90
          (with-font-size
           cr text-height
           (show-text cr text 'right))))
        (else
         (cairo-move-to cr (cdr pair) (- (+ text-height tick-size)))
         (with-font-size
          cr text-height
          (show-text cr text 'center))))))
   tick-labels))

(define-with-kwargs (draw-grid cr ticks width vertical?)
  "Draw grid lines.

@var{ticks} is a list of positions in the current cairo coordinate
system.  @var{width} is the that the grid lines should be: the chart
width of @var{vertical?}, and the height otherwise."
  (for-each
   (lambda (pos)
     (cond
      (vertical?
       (cairo-move-to cr 0 pos)
       (cairo-rel-line-to cr width 0))
      (else
       (cairo-move-to cr pos 0)
       (cairo-rel-line-to cr 0 width))))
   ticks)
  (with-rgb cr 1 1 1
            (cairo-stroke cr)))

(define-with-kwargs (draw-axis-label cr text text-height axis-length vertical?)
  "Draw an axis label.

The label will be drawn such that the current position of
@var{cr} is the closest corner of the label's bounding box."
  (cond
   (vertical?
    (with-rotate
     cr 90
     (with-font-size
      cr text-height
      (cairo-rel-move-to cr (/ axis-length 2) 0)
      (show-text cr text 'center))))
   (else
    (with-font-size
     cr text-height
     (cairo-rel-move-to cr (/ axis-length 2) (- text-height))
     (show-text cr text 'center)))))
                                 
(define-with-kwargs (draw-title cr text font-size)
  "Draw a title.

@var{cr} is expected to have been positioned at the lower
boundary of where the title should be written, in the center."
  (with-font-size
   cr font-size
   (with-color cr "Gray 800" (show-text cr text 'center))))

(define-with-kwargs (draw-chart-area cr width height)
  "Draw the actual box for the chart background.

@var{cr} is expected to have been positioned at the origin."
  (with-line-width cr (* 2 (cairo-get-line-width cr))
                   (rel-rectangle cr width height)
                   (with-color cr "Gray 300"
                               (cairo-fill cr))))

(define-with-kwargs (draw-background cr)
  "Draw the background."
  (with-rgb cr 1 1 1
            (cairo-paint cr)))