Example usages of guile-cairo

Example usages of guile-cairo

[Panicz Maciej Godek]

Hi,
I've been trying to cooperate with guile-cairo. However, the documentation
serves as a reference rather than a tutorial, and I've been trying to agree
the tutorial from the Cairo website with guile bindings, to no avail.

After evaluating the following code, the svg (or pdf) file gets generated,
but it is (in both cases) completely blank. The textual content of the svg
and pdf files suggests that the drawing commands have indeed been issued,
but apparently something's wrong.

(cairo-version) reports 11406.

So, here comes the code (based on the first snippet in the "Drawing with
Cairo" section from https://cairographics.org/tutorial/).

Note (BUG) by the way, that the order of arguments to
cairo-*-surface-create is reversed compared to the documentation, which
claims that the output file name should come first.


(use-modules (cairo))


(define s (cairo-svg-surface-create 200 300 "test.svg"))


;;(define s (cairo-pdf-surface-create  300.0 200.0 "test.pdf"))


(define c (cairo-create s))


(cairo-set-source-rgb c 0 0 0)


(cairo-move-to c 0 0)


(cairo-line-to c 1 1)


(cairo-move-to c 1 0)


(cairo-line-to c 0 1)


(cairo-set-line-width c 0.2)


(cairo-stroke c)


(cairo-rectangle c 0 0 0.5 0.5)


(cairo-set-source-rgba c 1 0 0 0.80)


(cairo-fill c)


(cairo-rectangle c 0 0.5 0.5 0.5)


(cairo-set-source-rgba c 0 1 0 0.60)


(cairo-fill c)


(cairo-rectangle c 0.5 0 0.5 0.5)


(cairo-set-source-rgba c 0 0 1 0.40)


(cairo-fill c)


(cairo-surface-finish s)

Re: Example usages of guile-cairo

[Vladimir Zhbanov]

Hi Panicz,

Have you solved your issue?

If not, I would recommend to look at README in your guile-cairo
distribution, it contains some example code. BTW, I have also
prototyped some C code to make a grid pattern using guile-cairo
and gnome-gtk and have a little scheme example that I could
publish if you're still interested.

-- 
  Vladimir

Re: Example usages of guile-cairo

[Panicz Maciej Godek]

Hi,
thanks for your reply -- I think I have solved it (although I took a
slightly different approach*) -- the problem was probably that the scale
was too small for anything to be visible, and it was sufficient to enlarge
the values of points.

Of course, if you publish your examples, as it is always a pleasure to read
other people's ideas :)

*the approach was to write my own bindings to cairo, as I intended to
integrate it with my SDL-based framework anyway, so I wrote a module
inspired by cairosdl, with a slightly more scheme-style API, i.e. instead
of passing the cairo context explicitly to each function, one uses the
notion of current drawing context (like there is the notion of current
output port for the display; the difference is that I didn't reify the
drawing context yet), e.g.

(let ((image (make-image 320 200)))
  (with-output-to-surface image
    (lambda ()
      (set-source-rgb! 0 0 0)
      (move-to! 0 0)
      (line-to! 320 240)
      (move-to! 320 0)
      (line-to! 0 240)
      (set-line-width! 2)
      (stroke!)
      image)))

The code is far from complete and far from perfect, but it is available in
the SLAYER repository, in case anybody wanted to check it:
https://bitbucket.org/panicz/slayer/src/ae322e1a1ad21564c4aba3b662ba3d5861eea026/src/drawing.c?at=2-vector-graphics&fileviewer=file-view-default


2016-07-15 22:19 GMT+02:00 Vladimir Zhbanov <vzhbanov@gmail.com>:

> Hi Panicz,
>
> Have you solved your issue?
>
> If not, I would recommend to look at README in your guile-cairo
> distribution, it contains some example code. BTW, I have also
> prototyped some C code to make a grid pattern using guile-cairo
> and gnome-gtk and have a little scheme example that I could
> publish if you're still interested.
>
> --
>   Vladimir
>
>

Re: Example usages of guile-cairo

[Vladimir Zhbanov]

[-- Attachment #1: Type: text/plain, Size: 1992 bytes --]

On Sat, Jul 16, 2016 at 10:05:45AM +0200, Panicz Maciej Godek wrote:
> Hi,
> thanks for your reply -- I think I have solved it (although I took a
> slightly different approach*) -- the problem was probably that the scale
> was too small for anything to be visible, and it was sufficient to enlarge
> the values of points.
> 
> Of course, if you publish your examples, as it is always a pleasure to read
> other people's ideas :)

I don't think they have anything valuable Scheme-wise. Anyways,
the code is attached. It uses gtk and cairo, and repeating
patterns which I used to prototype custom grids on my
canvas. Probably it could be useful for someone. Working on the
code I've learned hard way gtk is not thread save and how to avoid
this issue working in the Emacs Geiser environment. Basically, it
is something like
  (gdk-threads-init) ; only once
  ; and then
  (and (gdk-threads-enter)
       (your-function)
       (gdk-threads-leave))

Other attempts always lead me to crashes due to non-thread-safe
underground libraries (I cannot recall all, though one of which is
libpango which bugged me not long ago when I worked on another
issue). Even using (begin ...) instead of (and ...) lead to
crashes. Now I suspect the procedures in the (begin ...) body while
are executed one by one, nobody waits until any of them finishes,
which leads to race conditions in the gtk case. Probably I'm
wrong, don't know.

Further investigation has showed me that the standard external
REPL server (I still use the stock version of guile in Debian
stable which is 2.0.11) doesn't even use after-eval-hook so I
cannot try to automate those two calls without using work-arounds
in my code. I've found the rework of REPL in the Sly (previously
guile-2d) code by David Thompson which solves this for his
library. Hope to see something like this in the future releases of
guile.

BTW, thank you for your pamphlet against R. It has given me many
new ideas wrt the code I'm now working on.

-- 
  Vladimir

[-- Attachment #2: grid.scm --]
[-- Type: text/plain, Size: 5410 bytes --]

(use-modules (srfi srfi-1)
             (oop goops)
             (cairo)
             (gnome-2)
             (gnome gobject)
             (gnome gtk))

;;; The following commands may sometimes be very useful:
;;;   (gtype-class-get-signal-names <gtk-drawing-area>)
;;;   (get-property-names <gtk-drawing-area>)

;;; 3.1415926
(define pi (* 4 (atan 1)))

(define (draw-sample cr width height)
  (let ((radius 3)
        (x (/ width 2))
        (y (/ height 2)))
    ;; Use (cairo-antialias-get-values) to define the value of the
    ;; type <cairo-antialias-t> you need.
    (cairo-set-antialias cr 'none)

    ;; Set background color
    (cairo-set-source-rgba cr 0 .7 .4 .5)
    ;; Paint all area with it
    (cairo-paint cr)

    ;; paint a circle
    (cairo-set-source-rgba cr 1 1 0 1)
    (cairo-arc cr x y radius 0 (* 2 pi))
    ;; set background color and fill it
    (cairo-fill-preserve cr)
    ;; set margin color and stroke it
    (cairo-set-source-rgb cr 0 0 0)
    (cairo-set-line-width cr 1)
    (cairo-stroke cr)
    ))

(define (create-sample-surface-similar-to global-cr size scale)
  (let* ((width (* size scale))
         (height width)
         ;; create a new local surface that is as compatible as possible
         ;; with an existing one for the global context;
         ;; (cairo-get-target) gets the cairo surface for the given
         ;; cairo context
         (surface (cairo-surface-create-similar
                   (cairo-get-target global-cr)
                   ;; Use (cairo-content-get-values) to define the
                   ;; value of the type <cairo-content-t> you need.
                   'color-alpha
                   width
                   height))
         ;; create a new cairo context for the new surface
         (cr (cairo-create surface)))

    ;; This sample will become the pattern repeated over the canvas
    (draw-sample cr width height)
    surface))

(define (dots-pattern global-cr size scale)
  ;; next, create a pattern for the local surface we have
  (let ((pattern (cairo-pattern-create-for-surface
                  (create-sample-surface-similar-to global-cr
                                                    size
                                                    scale))))
    ;; Adjust the pattern to make it be repeated.
    ;; Use (cairo-extend-get-values) to define the value of the
    ;; type <cairo-extend-t> you need.
    (cairo-pattern-set-extend pattern 'repeat)
    pattern))

(define (draw cr width height size scale)
  (let ((halfway (/ (* size scale) 2))
        (pattern (dots-pattern cr size scale)))
    (cairo-translate cr halfway halfway)
    ;; set the pattern as a source for the global context
    (cairo-set-source cr pattern)
    (cairo-translate cr (- halfway) (- halfway))
    ;; create a path in the global cairo context (I use the whole
    ;; area)
    (cairo-rectangle cr 0 0 width height)
    ;; and fill it with the pattern
    (cairo-fill cr)
    ))

;;; Get size of GDK-WINDOW
;;; We could use something like
;;;   (event-coord-info (vector->list
;;;                      (fourth
;;;                       (vector->list
;;;                        (gdk-event->vector event)))))
;;; However there is a more specialized way.
;;; The function gdk-drawable-get-size used here is deprecated in
;;; new gtk+ versions, but I use it since guile-cairo on my Debian
;;; system is slightly old and doesn't support its replacements
;;; gdk-window-get-width and gdk-window-get-height.
(define (get-size gdk-window)
  (call-with-values
      (lambda () (gdk-drawable-get-size gdk-window))
    (lambda (a b) (cons a b))))


(define (grid-pattern-expose widget event)
  (let* ((size 15)
         (scale 3)
         (gdk-window (get widget 'window))
         ;; get cairo context for gtk widget
         (cr (gdk-cairo-create gdk-window))
         (window-size (get-size gdk-window))
         (width (car window-size))
         (height (cdr window-size)))
    (apply draw cr `(,width ,height ,size ,scale))
    #f))

(define-class <grid-pattern> (<gtk-drawing-area>)
  #:gsignal '(hi #f))
(define-method (grid-pattern:hi (entry <grid-pattern>))
  (format #t "Hi, all! I'm here! My name is ~A\n" entry))

(define (make-widget)
  (let ((widget (make <grid-pattern>)))
    (connect widget 'expose-event grid-pattern-expose)
    widget))


(define (make-window)
  (let* ((window (make <gtk-window> #:type 'toplevel #:title "Guile Cairo"))
	 ;;;; (button (make <gtk-button> #:label "Hello, World!"))
         )

    (set window 'border-width 10)
    ;;;; (add window button)

    ;;;; (gtype-instance-signal-connect button 'clicked (lambda (b) (gtk-main-quit)))
    (connect window 'destroy (lambda (b) (gtk-main-quit)))

    window))


;;; Make a window and a widget for it.
(define w (make-window))
(define widget (make-widget))
(add w widget)

(show-all w)
(emit widget 'hi)

;;; Threading
(gdk-threads-init)
;;; The above command (gdk-threads-init) is not sufficient to
;;; prevent crashes in multy-threaded environment.  The following
;;; pair of commands must be used in the Guile REPL to prevent
;;; crashes while working in Geiser (using a socket):
;;;   (gdk-threads-enter)
;;;   (gdk-threads-leave)
;;; Convenience procedures
(define -> (gdk-threads-enter))
(define <- (gdk-threads-leave))
;;; Use the following sequence:
;;; -> (your-command) <-

;;; Run main gtk loop yourself if you're working in Geiser
(gtk-main)

Re: Example usages of guile-cairo

[Andy Wingo]

[-- Attachment #1: Type: text/plain, Size: 461 bytes --]

On Wed 06 Jul 2016 22:01, Panicz Maciej Godek <godek.maciek@gmail.com> writes:

> I've been trying to cooperate with guile-cairo. However, the documentation
> serves as a reference rather than a tutorial, and I've been trying to agree
> the tutorial from the Cairo website with guile bindings, to no avail.

Attached is a part of guile-present that uses cairo to render slides.  I
think I need to find guile-present a new home, as gitorious went away...

Andy


[-- Attachment #2: cairo.scm --]
[-- Type: text/plain, Size: 24058 bytes --]

;; guile-present
;; Copyright (C) 2007, 2009, 2010, 2011, 2012, 2014 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:
;;
;; Routines to render SXML documents from the presentation vocabulary
;; using the Cairo graphics library.
;;
;;; Code:

(define-module (present cairo)
  #:use-module (cairo)
  #:use-module (present fold)
  #:use-module (ice-9 match)
  #:export (presentation-render-cairo))

(define rsvg-handle-render-cairo #f)
(define rsvg-handle-new-from-file #f)
(define rsvg-handle-get-dimensions #f)

(cond
 ((resolve-module '(rsvg) #:ensure #f)
  => (lambda (mod)
       (set! rsvg-handle-render-cairo
             (module-ref mod 'rsvg-handle-render-cairo))
       (set! rsvg-handle-new-from-file
             (module-ref mod 'rsvg-handle-new-from-file))
       (set! rsvg-handle-get-dimensions
             (module-ref mod 'rsvg-handle-get-dimensions))))
 (else
  (let ()
    (define (no-rsvg . args)
      (warn "SVG support not available.  Install guile-rsvg."))
    (set! rsvg-handle-render-cairo no-rsvg)
    (set! rsvg-handle-new-from-file no-rsvg)
    (set! rsvg-handle-get-dimensions no-rsvg))))

(define jpeg-dimensions #f)
(define jpeg->rgb #f)
(define interleaved-image-buffer #f)

(cond
 ((resolve-module '(jpeg) #:ensure #f)
  => (lambda (mod)
       (set! jpeg-dimensions (eval 'jpeg-dimensions mod))
       (set! jpeg->rgb (eval 'jpeg->rgb mod))
       (set! interleaved-image-buffer (eval 'interleaved-image-buffer mod))))
 (else
  (let ()
    (define (no-jpeg . args)
      (warn "JPEG support not available.  Install guile-jpeg."))
    (set! jpeg-dimensions no-jpeg)
    (set! jpeg->rgb no-jpeg)
    (set! interleaved-image-buffer no-jpeg))))

(define (fold-cairo cr tree bindings params layout stylesheet)
  (define (munge-bindings bindings)
    (define (munge-post-proc p)
      (lambda (tag params layout klayout kids)
        (values (p cr tag params layout klayout)
                (if (null? (car params))
                    (cons tag kids)
                    (cons* tag (cons '@ (car params)) kids)))))
    (define (munge-pre-layout-proc p)
      (lambda (tag params layout)
        (p cr tag params layout)))
    (define (munge-text-proc p)
      (lambda (text params layout)
        (values (p cr text params layout)
                text)))
    (define (munge-handler h)
      (case (car h)
        ((post) (cons 'post (munge-post-proc (cdr h))))
        ((pre-layout) (cons 'pre-layout (munge-pre-layout-proc (cdr h))))
        ((bindings) (cons 'bindings (munge-bindings (cdr h))))
        (else h)))
    (define (munge-binding b)
      (case (car b)
        ((*text*) (cons '*text* (munge-text-proc (cdr b))))
        (else (cons (car b) (map munge-handler (cdr b))))))
    (map munge-binding bindings))
  (call-with-values
      (lambda () (fold-layout tree (munge-bindings bindings)
                              params layout stylesheet))
    (lambda (ret layout)
      layout)))

;; Probably, more of this could be public.

(define* (lookup params key
                 #:optional (default-thunk
                              (lambda ()
                                (error "unbound param" key))))
  (cond ((null? params) (default-thunk))
        ((assq key (car params)) => cadr)
        (else (lookup (cdr params) key default-thunk))))

(define-syntax let-params
  (syntax-rules ()
    ((_ (param-exp ...) (k ...) b b* ...)
     (let ((p (param-exp ...)))
       (let-params p (k ...) b b* ...)))
    ((_ params () b b* ...)
     (begin b b* ...))
    ((_ params ((k default) k* ...) b b* ...)
     (let ((k (lookup params 'k (lambda () default))))
       (let-params params (k* ...) b b* ...)))
    ((_ params (k k* ...) b b* ...)
     (let ((k (lookup params 'k)))
       (let-params params (k* ...) b b* ...)))))

(define* (make-layout left top x line-height #:optional (space 0))
  (vector left top x line-height space))

(define (layout-left layout)
  (vector-ref layout 0))

(define (layout-top layout)
  (vector-ref layout 1))

(define (layout-x layout)
  (vector-ref layout 2))

(define (layout-line-height layout)
  (vector-ref layout 3))

(define (layout-space layout)
  (vector-ref layout 4))

(define (layout-beginning-of-line? layout)
  (= (layout-x layout) (layout-left layout)))

(define (layout-indent layout indent)
  (make-layout (+ (layout-left layout) indent) (layout-top layout)
               (+ (layout-left layout) indent) (layout-line-height layout)))

(define (layout-scroll layout scroll)
  (make-layout (layout-left layout) (+ (layout-top layout) scroll)
               (layout-left layout) (layout-line-height layout)))

(define (layout-next-line layout line-spacing)
  (layout-scroll layout (* (layout-line-height layout) line-spacing)))

(define (layout-enter layout line-height)
  (make-layout (layout-left layout) (layout-top layout)
               (layout-left layout) line-height))

(define (layout-return layout block-spacing line-spacing)
  (if (layout-beginning-of-line? layout)
      layout
      (layout-next-line layout (* block-spacing line-spacing))))

(define* (layout-advance layout dx #:optional (space 0))
  (make-layout (layout-left layout) (layout-top layout)
               (+ (layout-x layout) dx) (layout-line-height layout)
               space))

(define (layout-ensure-space layout space)
  (if (layout-beginning-of-line? layout)
      layout
      (layout-advance layout 0 (max (layout-space layout) space))))

(define (layout-apply-space layout)
  (layout-advance layout (layout-space layout)))

(define (default-pre-layout cr tree params layout)
  (let-params params (inline? absolute? margin-left margin-top
                              text-height text-scaling)
    (cond
     (inline? layout)
     (absolute? (make-layout margin-left margin-top margin-left
                             (* text-height text-scaling)))
     (else (and layout (layout-enter layout (* text-height text-scaling)))))))

(define (default-post cr tag params old-layout layout)
  (let-params params (inline? absolute? block-spacing line-spacing)
    (cond
     (inline? layout)
     (absolute? old-layout)
     (else (layout-return layout block-spacing line-spacing)))))

(define (specialize-param params k v)
  (cons (list (list k v)) params))

(define (text-x-advance cr text)
  (cairo-text-extents:x-advance (cairo-text-extents cr text)))

(define *punctuation*
  '(("``" . "“")
    ("''" . "”")
    ("`" . "‘")
    ("'" . "’")
    ("---" . "—")
    ("--" . "–")))

(define (prettify-punctuation word)
  (let lp ((word word) (punctuation *punctuation*))
    (match punctuation
      (() word)
      (((needle . replacement) . punctuation)
       (cond
        ((string-contains word needle)
         => (lambda (pos)
              (lp (string-append
                   (substring word 0 pos)
                   replacement
                   (substring word (+ pos (string-length needle))))
                  punctuation)))
        (else (lp word punctuation)))))))

(define *subword-charset* (char-set #\/ #\- ))

(define (find-subword-right word end)
  (let ((tail (string-index-right word
                                  (char-set-complement *subword-charset*)
                                  0 end)))
    (and tail
         (and=> (string-index-right word *subword-charset* 0 tail)
                1+))))

(define* (next-subword cr word available #:optional (end (string-length word)))
  (let* ((subword-end (find-subword-right word end))
         (end (or subword-end end)))
    (let* ((subword (substring word 0 end))
           (width (text-x-advance cr subword)))
      (if (or (< width available) (not subword-end))
          (values subword width)
          (next-subword cr word available end)))))

(define (terminal? word)
  (case (string-ref word (1- (string-length word)))
    ((#\. #\! #\?) #t)
    (else #f)))

(define (flow-text cr params layout text)
  (let-params params (text-height text-scaling font-family line-spacing width
                      margin-right font-weight font-slant pretty-punctuation?
                      can-end-sentence?)
    (define (maybe-prettify word)
      (if pretty-punctuation?
          (prettify-punctuation word)
          word))
    (cairo-select-font-face cr font-family font-slant font-weight)
    (cairo-set-font-size cr (* text-height text-scaling))
    (let ((space-width (text-x-advance cr " ")))
      (let render ((text text)
                   (layout layout))
        (cond
         ((string-null? text)
          ;; Done.
          layout)
         ((char-whitespace? (string-ref text 0))
          ;; Interword space.
          (render (substring text 1) (layout-ensure-space layout space-width)))
         ;; Print a word at a time.  Ignore whitespace; interword spacing
         ;; is uniform, except a little bit more after a terminator (.?!).
         (else
          (let* ((word-end (or (string-index text char-whitespace?)
                               (string-length text)))
                 (word (maybe-prettify (substring text 0 word-end))))
            (let retry ((word word)
                        (subword? #f)
                        (text (substring text word-end))
                        (word-width (text-x-advance cr word))
                        (layout (layout-apply-space layout))
                        (force? #f))
              (cond
               ((and (> (+ (layout-x layout) word-width) (- width margin-right))
                     (not force?))
                ;; Word doesn't fit.
                (let ((available (- width margin-right (layout-x layout))))
                  (call-with-values (lambda ()
                                      (next-subword cr word available))
                    (lambda (subword subword-width)
                      (if (or (layout-beginning-of-line? layout)
                              (< subword-width available)
                              (string-every char-set:punctuation word))
                          (let ((tail (substring word (string-length subword))))
                            (retry subword #t (string-append tail text)
                                   subword-width layout #t))
                          (retry word subword? text word-width
                                 (layout-next-line layout line-spacing)
                                 #f))))))
               (else
                (cairo-move-to cr (layout-x layout)
                               (+ (layout-top layout)
                                  (layout-line-height layout)))
                (cairo-show-text cr word)
                (render text
                        (layout-advance layout
                                        word-width
                                        (cond
                                         ((or subword? (string-null? text)) 0)
                                         ((and can-end-sentence?
                                               (terminal? word))
                                          (* 1.5 space-width))
                                         (else space-width))))))))))))))

(define (verbatim-text cr params layout text)
  (let-params params (text-height text-scaling font-family line-spacing
                      font-weight font-slant)
    (cairo-select-font-face cr font-family font-slant font-weight)
    (cairo-set-font-size cr (* text-height text-scaling))
    (let lp ((lines (string-split text #\newline)) (layout layout))
      (cairo-move-to cr (layout-x layout)
                     (+ (layout-top layout)
                        (layout-line-height layout)))
      (cairo-show-text cr (car lines))
      (if (null? (cdr lines))
          (layout-advance layout (text-x-advance cr (car lines)))
          (lp (cdr lines) (layout-next-line layout line-spacing))))))

(define (text-handler cr text params layout) 
  (let-params params (verbatim?)
    ((if verbatim? verbatim-text flow-text)
     cr params layout text)))

(define (ul-pre-layout cr tree params layout)
  (let-params params (indent-width text-height text-scaling)
    (layout-enter (layout-indent layout indent-width)
                  (* text-height text-scaling))))

(define (ul-post cr tag params old-layout layout)
  (let-params params (indent-width block-spacing line-spacing)
    (layout-return (layout-indent layout (- indent-width))
                   block-spacing line-spacing)))

(define (make-bullet cr params layout)
  (let-params params (bullet-string bullet-font-family)
    (flow-text cr (specialize-param params 'font-family bullet-font-family)
               layout bullet-string)))

(define (li-post cr tag params old-layout layout)
  (let-params params (indent-width)
    (make-bullet cr params (layout-indent old-layout (- indent-width)))
    (default-post cr tag params old-layout layout)))

(define (title-pre-layout cr tree params layout)
  (let-params params (margin-top text-height text-scaling)
    ;; go to the middle of the page?
    (layout-enter (layout-scroll layout margin-top)
                  (* text-height text-scaling))))

(define (image-width-for-height filename target-height)
  (cond
   ((string-suffix? ".svg" (string-downcase filename))
    (call-with-values
        (lambda ()
          (rsvg-handle-get-dimensions (rsvg-handle-new-from-file
                                       filename)))
      (lambda (width height em ex)
        (* target-height 1.0 (/ width height)))))
   ((string-suffix? ".png" (string-downcase filename))
    (let ((surf (cairo-image-surface-create-from-png filename)))
      (* target-height 1.0 (/ (cairo-image-surface-get-width surf)
                              (cairo-image-surface-get-height surf)))))
   ((or (string-suffix? ".jpg" (string-downcase filename))
        (string-suffix? ".jpeg" (string-downcase filename)))
    (call-with-values (lambda () (jpeg-dimensions filename))
      (lambda (width height)
        (* target-height 1.0 (/ width height)))))
   (else
    (error "unknown image type" filename))))

(define (create-image-surface filename target-width target-height)
  (cond
   ((string-suffix? ".svg" (string-downcase filename))
    (let ((surf (cairo-image-surface-create 'argb32 target-width target-height)))
      (let ((cr (cairo-create surf)))
        (rsvg-handle-render-cairo
         (rsvg-handle-new-from-file filename) cr)
        (cairo-surface-flush surf)
        (values surf target-width target-height))))
   ((string-suffix? ".png" (string-downcase filename))
    (let ((surf (cairo-image-surface-create-from-png filename)))
      (values surf
              (cairo-image-surface-get-width surf)
              (cairo-image-surface-get-height surf))))
   ((or (string-suffix? ".jpg" (string-downcase filename))
        (string-suffix? ".jpeg" (string-downcase filename)))
    (call-with-values (lambda () (jpeg-dimensions filename))
      (lambda (width height)
        (let* ((stride (cairo-format-stride-for-width 'rgb24 width))
               (rgb (jpeg->rgb filename #:argb? #t
                               #:stride-for-width (lambda (_) stride))))
          (values (cairo-image-surface-create-for-data
                      (interleaved-image-buffer rgb)
                      'rgb24 width height stride)
                  width
                  height)))))
   (else
    (warn "unknown image type" filename)
    (values #f #f #f))))

(define* (paint-image cr filename x0 y0 width height #:key stretch?
                      (center-horizontally? #t) (center-vertically? #t))
  (define (scale-dimensions aspect)
    (cond
     (stretch?
      (values x0 y0 width height))
     ((< aspect (/ width height))
      ;; Tall source.
      (let ((new-width (* height aspect)))
        (values (if center-horizontally?
                    (+ x0 (/ (- width new-width) 2))
                    x0)
                y0
                new-width height)))
     (else
      ;; Wide source.
      (let ((new-height (/ width aspect)))
        (values x0
                (if center-vertically?
                    (+ y0 (/ (- height new-height) 2))
                    y0)
                width new-height)))))
  (call-with-values (lambda () (create-image-surface filename width height))
    (lambda (surface swidth sheight)
      (if surface
          (call-with-values (lambda () (scale-dimensions (/ swidth 1.0 sheight)))
            (lambda (x0 y0 width height)
              (cairo-save cr)
              (cairo-translate cr x0 y0)
              (cairo-scale cr (/ width swidth) (/ height sheight))
              (cairo-set-source-surface cr surface 0 0)
              (cairo-pattern-set-filter (cairo-get-source cr) 'best)
              (cairo-rectangle cr 0 0 swidth sheight)
              (cairo-fill cr)
              (cairo-restore cr)
              (values width height)))
          (values 0 0)))))

(define (image-post cr tag params old-layout layout)
  (let-params params (image-filename (image-width #f) (image-height #f)
                      height width margin-right margin-bottom inline?
                      text-height text-scaling line-spacing)
    (cond
     (inline?
      ;; An image in a text block: restrict to the line height.
      (let* ((layout (layout-apply-space layout))
             (avail-x (- width margin-right (layout-x layout)))
             (width-for-height
              (image-width-for-height image-filename
                                      (* text-height text-scaling)))
             (layout (if (< avail-x width-for-height)
                         (layout-next-line layout line-spacing)
                         layout)))
        (paint-image cr image-filename
                     (layout-x layout) (layout-top layout)
                     width-for-height (* text-height text-scaling)
                     #:stretch? #t)
        (layout-advance layout width-for-height)))
     (else
      ;; An image at the top level: horizontally center in available
      ;; space.
      (let* ((avail-x (- width margin-right (layout-x layout)))
             (avail-y (- height (layout-top layout) margin-bottom))
             (max-width (or image-width avail-x))
             (max-height (or image-height avail-y))
             (x0 (+ (layout-x layout) (/ (- avail-x max-width) 2.0))))
        (call-with-values
            (lambda ()
              (paint-image cr image-filename
                           x0 (layout-top layout)
                           max-width max-height
                           #:center-vertically? #f))
          (lambda (width height)
            (layout-scroll layout height))))))))

(define (set-source-rgb cr rgb)
  (cairo-set-source-rgb cr
                        (/ (logand (ash rgb -16) #xff) 255.0)
                        (/ (logand (ash rgb -8) #xff) 255.0)
                        (/ (logand (ash rgb 0) #xff) 255.0)))

(define (slide-pre-layout cr tree params layout)
  (let-params params (margin-left margin-top background background-color
                      foreground-color width height text-height text-scaling)
    (set-source-rgb cr background-color)
    (cairo-rectangle cr 0 0 width height)
    (cairo-fill cr)
    (when background
      (paint-image cr background 0 0 width height))
    (set-source-rgb cr foreground-color)
    (make-layout margin-left margin-top margin-left
                 (* text-height text-scaling))))

(define (slide-post cr tag params old-layout layout)
  (cairo-show-page cr)
  old-layout)

(define (presentation-post cr tag params old-layout layout)
  old-layout)

(define *presentation->svg-rules*
  `((presentation
     (post . ,presentation-post))
    (slide
     (pre-layout . ,slide-pre-layout)
     (post . ,slide-post))
    (title
     (pre-layout . ,title-pre-layout))
    (image
     (post . ,image-post))
    (ul
     (pre-layout . ,ul-pre-layout)
     (post . ,ul-post))
    (li
     (post . ,li-post))
    (*text* . ,text-handler)
    (*default*
     (pre-layout . ,default-pre-layout)
     (post . ,default-post))))

(define *default-params*
  '((indent-width 64)
    (margin-left 64)
    (margin-right 64)
    (margin-top 64)
    (margin-bottom 64)
    (line-spacing 1.1)
    (inline? #f)
    (absolute? #f)
    (can-end-sentence? #t)
    (verbatim? #f)
    (pretty-punctuation? #t)
    (block-spacing 1.4)
    (font-family "Serif")
    (font-slant normal)
    (font-weight normal)
    (bullet-string "❧")
    (bullet-font-family "Sans")
    (text-height 42)
    (text-scaling 1/1)
    (background #f)
    (background-color #xFFFFFF)
    (foreground-color #x000000)
    (width 1024)
    (height 768)))

(define *null-layout* #f)

(define *presentation-stylesheet*
  '((title (text-height 96))
    (header (text-height 64))
    (tt (font-family "Monospace") (inline? #t)
        (can-end-sentence? #f) (pretty-punctuation? #f) (text-height 36))
    (pre (font-family "Monospace") (verbatim? #t) (pretty-punctuation? #f) (text-height 36) (line-spacing 1.2))
    (span (inline? #t))
    (image (inline? #t))
    (i (font-slant italic) (inline? #t))
    (b (font-weight bold) (inline? #t))))

(define (adjoin-stylesheets presentation stylesheet)
  (define (adjoin tag key value stylesheet)
    (match stylesheet
      (() `((,tag (,key ,value))))
      (((t . params) . stylesheet)
       (if (eq? t tag)
           `((,t (,key ,value) . ,params) . ,stylesheet)
           (acons t params (adjoin tag key value stylesheet))))))
  (match presentation
    (('presentation ('@ . params) . body)
     (let lp ((in params) (out '()) (stylesheet stylesheet))
       (match in
         (() (values `(presentation (@ ,@(reverse out)) . ,body)
                     stylesheet))
         (((and param (tag key value)) . in)
          (lp in out (adjoin tag key value stylesheet)))
         ((param . in)
          (lp in (cons param out) stylesheet)))))
    (_ (values presentation stylesheet))))

(define (presentation-render-cairo presentation cr)
  "Convert an SXML document in the @code{presentation} vocabulary to a
multi-layered SVG.

The result will still be a document in SXML format, so if you want to
write it to disk, use @code{sxml->xml}. @xref{sxml simple,(sxml
simple),(sxml simple),guile-library,Guile Library}, for more
information.

The resulting SVG will be written with annotations readable by Inkscape,
a vector graphics editor, which help to make the SVG easily editable. If
your toolchain does not understand namespaces, you might want to filter
out elements that start with @samp{sodipodi:}, @samp{xmlns:}, and
@samp{inkscape:}.
"
  (call-with-values (lambda ()
                      (adjoin-stylesheets presentation
                                          *presentation-stylesheet*))
    (lambda (presentation stylesheet)
      (fold-cairo cr presentation *presentation->svg-rules* *default-params*
                  *null-layout* stylesheet))))