Ticket #1848: test.scm

(import scheme)
(import (chicken base))
(import (chicken process-context))
(import cairo)

(define width 256)
(define height 128)

(define (paint-rectangle! ctx x y w h)
  (cairo-new-path ctx)
  (cairo-rectangle ctx x y w h)
  (cairo-fill ctx))

(define (paint-outline! ctx x y w h)
  (cairo-new-path ctx)
  (cairo-rectangle ctx x y w h)
  (cairo-stroke ctx))

(define-record pen r g b)

(define black-pen (make-pen 0 0 0))
(define white-pen (make-pen 1 1 1))

(define (select-pen! ctx pen)
  (cairo-set-source-rgb ctx (pen-r pen) (pen-g pen) (pen-b pen)))

(define (paint-text! ctx x y text)
  (cairo-move-to ctx x y)
  (cairo-show-text ctx text))

(define (paint-text-in-rectangle! ctx x y w h text)
  (select-pen! ctx black-pen)
  (paint-rectangle! ctx x y w h)
  (select-pen! ctx white-pen)
  (paint-text! ctx x y text))

(define (paint-text-in-outline! ctx x y w h text)
  (select-pen! ctx black-pen)
  (paint-outline! ctx x y w h)
  (paint-text! ctx x y text))

(define font-matrix (make-cairo-matrix-type))

(define (setup-cairo! ctx)
  (select-pen! ctx white-pen)
  (paint-rectangle! ctx 0 0 width height)

  (select-pen! ctx black-pen)
  (cairo-set-line-width ctx 2)

  (cairo-select-font-face ctx
                          "sans-serif"
                          CAIRO_FONT_SLANT_NORMAL
                          CAIRO_FONT_WEIGHT_NORMAL)
  (cairo-set-font-size ctx 16)

  ;; HACK: if you draw text and a rectangle at the same x/y
  ;; coordinate, the text is drawn above and the rectangle below, so
  ;; obtain the font matrix and translate it to land inside the
  ;; rectangle (move x by 1/8 of the font size and y by 9/8)
  (cairo-get-font-matrix ctx font-matrix)
  (cairo-matrix-translate font-matrix 0.125 1.125)
  (cairo-set-font-matrix ctx font-matrix))

(define (paint-scene! ctx)
  (paint-text-in-rectangle! ctx 24 24 128 24 "Hello")
  (paint-text-in-outline! ctx 72 56 128 24 "world"))

(define (preview-image! path)
  (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_RGB24
                                              width
                                              height))
         (ctx (cairo-create surface)))
    (setup-cairo! ctx)
    (paint-scene! ctx)
    (cairo-surface-write-to-png surface path)))

(preview-image! (car (command-line-arguments)))