gnu/build/svg.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu build svg)
  21   #:use-module (rsvg)
  22   #:use-module (cairo)
  23   #:use-module (srfi srfi-11)
  24   #:export (svg->png))
  25
  26 (define* (downscaled-surface surface
  27                              #:key
  28                              source-width source-height
  29                              width height)
  30   "Return a new rendering context where SURFACE is scaled to WIDTH x HEIGHT."
  31   (let ((cr (cairo-create (cairo-image-surface-create 'argb32
  32                                                       width height))))
  33     (cairo-scale cr (/ width source-width) (/ height source-height))
  34     (cairo-set-source-surface cr surface 0 0)
  35     (cairo-pattern-set-filter (cairo-get-source cr) 'best)
  36     (cairo-rectangle cr 0 0 source-width source-height)
  37     (cairo-fill cr)
  38     cr))
  39
  40 (define* (svg->png in-svg out-png
  41                    #:key width height)
  42   "Render the file at IN-SVG as a PNG file in OUT-PNG.  When WIDTH and HEIGHT
  43 are provided, use them as the dimensions of OUT-PNG; otherwise preserve the
  44 dimensions of IN-SVG."
  45   (define svg
  46     (rsvg-handle-new-from-file in-svg))
  47
  48   (let-values (((origin-width origin-height em ex)
  49                 (rsvg-handle-get-dimensions svg)))
  50     (let* ((surf (cairo-image-surface-create 'argb32
  51                                              origin-width origin-height))
  52            (cr   (cairo-create surf)))
  53       (rsvg-handle-render-cairo svg cr)
  54       (cairo-surface-flush surf)
  55       (let ((cr (if (and width height
  56                          (not (= width origin-width))
  57                          (not (= height origin-height)))
  58                     (downscaled-surface surf
  59                                         #:source-width origin-width
  60                                         #:source-height origin-height
  61                                         #:width width
  62                                         #:height height)
  63                     cr)))
  64         (cairo-surface-write-to-png (cairo-get-target cr) out-png)))))
  65
  66 ;;; svg.scm ends here