path: root/pict.scm

;;; pict.scm --- A simple picture language for Guile

;;; Copyright © 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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/>.


(define-module (pict)
  #:use-module (pict sxml)
  #:use-module (pict base64)
  #:use-module ((sxml simple) #:hide (xml->sxml))
  #:use-module (sxml transform)
  #:use-module (sxml fold)
  #:use-module ((sxml xpath) #:hide (filter))
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (rsvg)
  #:use-module (cairo)
  #:use-module (ice-9 match)
  #:export (pict?
            pict-sxml
            pict-width
            pict-height
            pict-rotation
            pict->file
            pict->pdf
            pict-from-file

            ;; modifiers
            fill
            colorize
            remove-outline
            scale
            expand
            grow
            shrink
            rotate
            blur
            cellophane

            frame

            ;; graphics primitives
            move-to
            close-path
            curve
            line-to
            path

            line
            polyline
            polygon
            circle
            ellipse
            rectangle

            ;; other graphics
            vline
            hline
            disk
            filled-ellipse
            filled-rectangle
            triangle
            filled-triangle
            octagon
            filled-octagon

            text

            ;; composition
            vl-append
            vc-append
            vr-append

            ht-append
            hc-append
            hb-append

            lt-superimpose
            lc-superimpose
            lb-superimpose

            ct-superimpose
            cc-superimpose
            cb-superimpose

            rt-superimpose
            rc-superimpose
            rb-superimpose

            pin-over
            pin-under
            ghost

            ;; colors
            rgb
            random-color
            colors))


;;; Records

;; This is the main record for pictures, a simple wrapper around SXML.
;; We only use a record so that we can abuse the record type printer
;; facility (see below).  All operations are really performed on the
;; wrapped SXML.
(define-record-type <pict>
  (make-pict sxml)
  pict?
  (sxml pict-sxml))

(define (pict->svg-sxml pict)
  "Wrap the PICT's SXML data in a proper SVG wrapper with height,
width, and SVG namespace."
  `(svg (@ (width ,(pict-width pict))
           (height ,(pict-height pict))
           (xmlns "http://www.w3.org/2000/svg"))
        ,(pict-sxml pict)))

(define (pict->file pict file-name)
  "Write the PICT to a file with name FILE-NAME.  If FILE-NAME is a
procedure, it is called with the XML that is supposed to be written to
the file to determine the file name.  Return the file name."
  (let* ((xml (with-output-to-string
                (lambda _ (sxml->xml (pict->svg-sxml pict)))))
         (name (if (procedure? file-name)
                   (file-name xml) file-name)))
    (with-output-to-file name
      (lambda _ (display xml)))
    name))

;; XXX: This is a hack to let Geiser display the image.
;; Since Geiser only supports the display of images that are
;; associated with a file we write out the SVG to a temp file and
;; return #<Image: /path/to/svg>.
;; Hey, where are you going?  You haven't seen the rest...!
(set-record-type-printer! <pict>
 (lambda (record port)
   (let ((name (pict->file record
                           (lambda (xml)
                             (string-append "/tmp/geiser-"
                                            (number->string (string-hash xml))
                                            ".svg")))))
     (format port "#<Image: ~a>" name))))

(define %dpi 72) ; like cairo

(define* (pict->pdf pict out #:key page-height page-width)
  "Read SVG from picture PICT and write a PDF file to OUT."
  (let* ((port (mkstemp! (string-copy "/tmp/pictXXXXXXX")))
         (name (port-filename port)))
    (sxml->xml (pict->svg-sxml pict) port)
    (close-port port)
    (let*-values (((d) (rsvg-set-default-dpi-x-y %dpi %dpi))
                  ((handle) (rsvg-handle-new-from-file name))
                  ((c) (rsvg-handle-close handle))
                  ((width height em ex) (rsvg-handle-get-dimensions handle)))
      (let* ((surf (if (and page-height page-width)
                       (cairo-pdf-surface-create page-width page-height out)
                       (cairo-pdf-surface-create width height out)))
             (ctx (cairo-create surf)))
        (rsvg-handle-render-cairo handle ctx)
        (cairo-show-page ctx)
        (cairo-surface-finish surf)
        out))))


;;; Miscellaneous utilities

(define (scan vals)
  "Return a list of cumulative offsets for each numeric value in the
list VALS."
  (reverse
   (fold (lambda (val acc)
           (match acc
             ((last . lst)
              (let ((offset (+ val last)))
                (cons offset (cons offset lst))))))
         '(0 . ())
         (cons 0 vals))))

(define (png-size file-name)
  "Return two values: width and height of the PNG file at FILE-NAME."
  (define (bv->size bv)
    (car (bytevector->uint-list bv (endianness big) 4)))
  (call-with-input-file file-name
    (lambda (port)
      (get-bytevector-n port 8) ; throw away header
      (get-bytevector-n port 4) ; throw away first chunk length
      (if (bytevector=? (get-bytevector-n port 4)
                        #vu8(73 72 68 82))   ; IHDR
          (values
           (bv->size (get-bytevector-n port 4))  ; width
           (bv->size (get-bytevector-n port 4))) ; height
          (values #f #f)))))

(define (pict-from-file file-name)
  "Attempt to read FILE-NAME, convert its contents to SXML and wrap it
in a <PICT> record.  If this fails return #F."
  (let ((header (call-with-input-file file-name
                  (lambda (port) (get-bytevector-n port 8)))))
    (make-pict
     (match header
       (#vu8(137 80 78 71 13 10 26 10) ; PNG
        (call-with-values
            (lambda () (png-size file-name))
          (lambda (width height)
            `(svg (@ (width ,width)
                     (height ,height)
                     (xmlns "http://www.w3.org/2000/svg")
                     (xmlns:xlink "http://www.w3.org/1999/xlink"))
                  (image (@ (width ,width)
                            (height ,height)
                            (xlink:href
                             ,(string-append
                               "data:image/png;base64,"
                               (call-with-input-file file-name
                                 (lambda (port)
                                   (base64-encode (get-bytevector-all port)))
                                 #:binary #t)))))))))
       (_ ; Assume SVG
        (catch 'parser-error
          (lambda ()
            (match (call-with-input-file file-name xml->sxml)
              (('*TOP* ('*PI* . rest) svg) svg)
              (('*TOP* svg) svg)))
          (lambda args
            (format (current-error-port)
                    "Failed to load picture from file `~a'.~%Only PNG or SVG are supported.~%~a~%"
                    file-name args)
            #f)))))))


;;; SXML utilities

(define (modify-attribute search-key proc node)
  "Find an attribute with the key SEARCH-KEY in the attributes of
NODE.  Run PROC on the current value of the found attribute or create
the attribute by running PROC on #F."
  (let ((attributes (cdr node)))
    (cons '@
     (match (fold (lambda (attribute state)
                    (match attribute
                      ((key vals)
                       (if (eq? key search-key)
                           (cons #t     ; replaced!
                                 (cons (list key (proc vals))
                                       (cdr state)))
                           (cons (car state)
                                 (cons attribute (cdr state)))))))
                  '(#f . ())
                  attributes)
       ((#f . attrs)
        (cons (list search-key (proc #f))
              attrs))
       ((_ . attrs) attrs)))))

(define (attribute-modifier attribute proc)
  "Return a procedure that takes an SXML element and modifies or adds
ATTRIBUTE by applying PROC to the current value (or #F)."
  (match-lambda
    ((tag attrs . inner)
     `(,tag ,(modify-attribute attribute proc attrs)
            ,@inner))))

(define (transform-string->list ts)
  "Split the transform string TS into a list of lists from keys to
values."
  (map (compose (cut take <> 2)
                (cut string-split <> #\()
                (cut string-trim-both <>))
       (filter (negate string-null?) (string-split ts #\)))))

(define (transform-list->string lst)
  "Returns an SVG string of transforms that are built from the list
of transform lists LST."
  (string-join (map (match-lambda
                      ((key val)
                       (string-append key "(" val ")")))
                    lst)))

(define (transform-modifier key proc)
  "Return a function that replaces KEY in the transforms of a pict
with the return value of PROC applied to the current value.  If KEY
does not exist it is added with PROC applied to #F."
  (attribute-modifier
   'transform
   (lambda (transform-str)
     (transform-list->string
      (match (fold (lambda (item state)
                     (match item
                       ((k v)
                        (if (string=? k key)
                            (cons #t    ; replaced!
                                  (cons (list key (proc v))
                                        (cdr state)))
                            (cons (car state)
                                  (cons item (cdr state)))))))
                   '(#f . ())
                   (transform-string->list (or transform-str "")))
        ((#f . items)
         (cons (list key (proc #f))
               items))
        ((_ . items) items))))))

(define (rotation->values str)
  "Returns a list of three rotation values by converting the rotation
string STR."
  (if str
      (map string->number (string-split str #\space))
      (list 0 0 0)))

(define (style-string->list styles)
  "Split the styles string into a list of lists from keys to values."
  (map (cut string-split <> #\:)
       (string-split styles #\;)))

(define (style-list->string lst)
  "Returns a string of semicolon-separated pairs of colon-separated
strings that are built from the list of attributes LST."
  (string-join (map (cut string-join <> ":") lst) ";"))

(define (style-modifier key value)
  (attribute-modifier
   'style
   (lambda (style-str)
     (style-list->string
      (cons (list key value)
            (filter (match-lambda
                      ((k _)
                       (not (string=? k key)))
                      (_ '()))
                    (style-string->list (or style-str ""))))))))

(define (update-style key value sxml)
  ((style-modifier key value) sxml))


;;; Picture modifiers

;; Picts are wrapped in an SVG tag to allow us to record the width and
;; height (and any transformations).  Graphic primitives may be buried
;; deep inside wrapping SVG elements after composition and
;; transformations, so we use foldt to apply modifications to the
;; inner graphic primitives.
(define (pict-modify-primitives pict proc)
  "Apply PROC to all graphic primitives in PICT."
  (make-pict
   (foldt (lambda (thing)
            (let ((tag (car thing)))
              (if (member tag '(path rect polygon polyline circle ellipse text))
                  (proc thing) thing)))
          identity
          (pict-sxml pict))))

(define (fill pict color)
  "Fill PICT with COLOR."
  (pict-modify-primitives pict
                          (lambda (inner)
                            (update-style "fill" color inner))))

(define (colorize pict color)
  "Set the outer COLOR of PICT."
  (pict-modify-primitives pict
                          (lambda (inner)
                            (update-style "stroke" color inner))))

(define remove-outline (cut colorize <> "none"))

(define pi (/ 355 113))
(define (deg->rad deg)
  (* deg (/ pi 180)))

;; Nested SVGs lose their transforms!  So we need to use "g" and SVG
;; for wrapping.  "g" for the transform and SVG for x, y, width, and
;; height (because "g" doesn't have those).

(define (rotate pict deg)
  "Rotate the PICT by DEG degrees."
  (define (compute-modifiers inner)
    (let* ((width  (pict-width inner))
           (height (pict-height inner))
           (cx     (exact->inexact (/ width 2)))
           (cy     (exact->inexact (/ height 2)))
           (vecx   (make-rectangular width 0))
           (vecy   (make-rectangular 0 height))
           (degs   (+ deg
                      ;; Current rotation
                      (pict-rotation pict)))
           (rot    (make-polar 1 (deg->rad degs)))
           (rotx   (* vecx rot))
           (roty   (* vecy rot))
           (new-height (+ (abs (imag-part rotx))
                          (abs (imag-part roty))))
           (new-width  (+ (abs (real-part rotx))
                          (abs (real-part roty)))))
      (values
       (compose (transform-modifier "translate"
                                    (const
                                     (format #f "~a ~a"
                                             (exact->inexact (/ (- new-width width) 2))
                                             (exact->inexact (/ (- new-height height) 2)))))
                (transform-modifier "rotate"
                                    (const
                                     (format #f "~a ~a ~a"
                                             degs cx cy))))
       new-height
       new-width)))
  ;; If pict has an svg.rotate + g.transform wrapper: modify that.
  ;; Only wrap it if there is no such wrapper.  Limiting the number of
  ;; wrappers to 1 ensures that the bounding box of the pict does not
  ;; grow on successive rotations.
  (make-pict
   (match (pict-sxml pict)
     (('svg attr ('g (and g-attrs
                          ('@ ('class "transform") rest))
                     ;; TODO: this should only be a single child
                     children))
      (let-values (((modifiers new-height new-width)
                    (compute-modifiers (make-pict children))))
        ((compose (attribute-modifier 'height (const new-height))
                  (attribute-modifier 'width (const new-width)))
         `(svg ,attr
               ,(modifiers `(g ,g-attrs ,children))))))
     (sxml
      (let-values (((modifiers new-height new-width)
                    (compute-modifiers pict)))
        `(svg (@ (height ,new-height)
                 (width ,new-width)
                 (class "rotate")
                 (x 0)
                 (y 0))
              ,(modifiers
                `(g (@ (class "transform")) ,sxml))))))))

(define (scale pict factor)
  "Scale the PICT by the given FACTOR."
  (make-pict
   `(svg (@ (height ,(* factor (pict-height pict)))
            (width ,(* factor (pict-width pict)))
            (class "scale")
            (x 0)
            (y 0))
         ,((transform-modifier "scale" (const (number->string factor)))
           `(g (@ (class "transform"))
               ,(pict-sxml pict))))))

(define* (expand pict
                 #:key
                 (amount 0)
                 (left amount) (right amount)
                 (top amount) (bottom amount))
  "Expand the bounding box of PICT."
  (let ((w (pict-width pict))
        (h (pict-height pict)))
    (make-pict
     `(svg (@ (width ,(+ w left right))
              (height ,(+ h top bottom)))
           ,((compose (attribute-modifier 'x (lambda (x) (+ left x)))
                      (attribute-modifier 'y (lambda (y) (+ top y))))
             (pict-sxml pict))))))

(define (grow pict amount)
  "Grow the bounding box of PICT."
  (expand pict #:amount amount))

(define (shrink pict amount)
  "Shrink the bounding box of PICT."
  (expand pict #:amount (- amount)))

;;; XXX: Emacs doesn't render filters when the image type is SVG.  It
;;; only does this when the image type is 'imagemagick, i.e. when the
;;; SVG is first fed to ImageMagick and the raster image is displayed.

;;; We have no control over whether the image is rendered with
;;; ImageMagick or with librsvg.
(define (blur pict radius)
  "Apply a Gaussian blur with blur RADIUS to the PICT."
  (let ((new-height (+ (pict-height pict) (* 2 radius)))
        (new-width (+ (pict-width pict) (* 2 radius))))
    (make-pict
     `(svg (@ (width ,new-width)
              (height ,new-height)
              (class "blur"))
           (g (defs
                (filter
                 (@ (id "blur")
                    (width ,new-width)
                    (height ,new-height))
                 (feGaussianBlur
                  (@ (stdDeviation ,(number->string radius)))))))
           ,((compose (style-modifier "filter" "url(#blur)")
                      (attribute-modifier 'x (const (/ (- new-width
                                                          (pict-width pict))
                                                       2)))
                      (attribute-modifier 'y (const (/ (- new-height
                                                          (pict-height pict))
                                                       2))))
             (pict-sxml pict))))))

(define (cellophane pict opacity)
  "Set the opacity of PICT to OPACITY, a numeric value between 0 (for
full transparency) and 1 (for full opacity)."
  (make-pict
   `(svg (@ (height ,(pict-height pict))
            (width ,(pict-width pict))
            (class "opacity")
            (x 0)
            (y 0))
         ,((attribute-modifier 'opacity (const opacity))
           `(g (@ (class "opacity")
                  (opacity ,opacity))
               ,(pict-sxml pict))))))

(define* (frame pict #:key (color "black") (stroke-width 1))
  "Draw a box around PICT."
  (cc-superimpose pict
                  (rectangle (pict-width pict)
                             (pict-height pict)
                             #:border-color color
                             #:border-width stroke-width)))

(define (ghost pict)
  "Create an empty picture with the same size as PICT."
  (make-pict
   `(svg (@ (height ,(pict-height pict))
            (width  ,(pict-width pict))
            (class "ghost")
            (x 0)
            (y 0)))))


;;; SVG graphics primitives.

;;; Each shape is wrapped in an SVG tag that records the width,
;;; height, and the coordinates.

;; This is a record for path draw instruction
(define-record-type <instruction>
  (make-instruction type absolute? points compile)
  instruction?
  (type      instruction-type)
  (absolute? instruction-absolute?)
  (points    instruction-points)
  (compile   instruction-compile))

(define* (move-to point #:key absolute?)
  (make-instruction
   'move absolute?
   (list point)
   (lambda ()
     (format #false "~a ~a,~a"
             (if absolute? "M" "m")
             (car point) (cdr point)))))

(define (close-path)
  (make-instruction
   'close #false
   (list)
   (const "z")))

(define* (line-to point #:key absolute?)
  (make-instruction
   'line-to absolute?
   (list point)
   (lambda ()
     (format #false "~a ~a,~a"
             (if absolute? "L" "l")
             (car point) (cdr point)))))

;; The last point is the target
(define* (curve points #:key absolute?)
  (call-with-values
      (lambda ()
        (match points
          ((one)
           (values "s" (list one one)))
          ((one two)
           (values "s" (list one two)))
          ((and (one two . more) points)
           (values "c" points))))
    (lambda (command points)
      (make-instruction
       'curveto absolute?
       points
       (lambda ()
         (format #false "~a ~{~a~^ ~}"
                 (if absolute? (string-upcase command) command)
                 (map (lambda (point)
                        (format #false "~a,~a"
                                (car point) (cdr point)))
                      points)))))))

(define* (path instructions
               #:key
               (color "black")
               (stroke-width 1))
  "TODO"
  (match (fold
          (lambda (instruction acc)
            (match (instruction-points instruction)
              (() acc)
              (lst
               (let ((point (last lst)))
                 (match acc
                   ((cursor-x cursor-y min-x max-x min-y max-y)
                    (match point
                      ((x . y)
                       (if (instruction-absolute? instruction)
                           (list x y
                                 (min x min-x)
                                 (max x max-x)
                                 (min y min-y)
                                 (max y max-y))
                           (list (+ x cursor-x)
                                 (+ y cursor-y)
                                 (min (+ cursor-x x) min-x)
                                 (max (+ cursor-x x) max-x)
                                 (min (+ cursor-y y) min-y)
                                 (max (+ cursor-y y) max-y)))))))))))
          (list 0 0 0 0 0 0)
          instructions)
    ((cursor-x cursor-y min-x max-x min-y max-y)
     (make-pict
      `(svg (@ (width ,(+ (abs min-x)
                          (abs max-x)))
               (height ,(+ (abs min-y)
                           (abs max-y)))
               (x 0)
               (y 0))
            (path (@ (d ,(string-join
                          (map (lambda (instruction)
                                 ((instruction-compile instruction)))
                               instructions)))
                     (style ,(style-list->string
                              `(("fill" "none")
                                ("stroke" ,color)
                                ("stroke-width"
                                 ,(number->string stroke-width))))))))))))

(define* (line x1 y1 x2 y2
               #:optional (maxw 0) (maxh 0)
               #:key
               (color "black")
               (stroke-width 1))
  "Return a straight line connecting the start point described by the
numbers X1 and Y1 and the end point described by the numbers X2 and
Y2.  Optionally, the numbers MAXW and MAXH can be provided to set the
width or height, respectively, of the resulting picture.  The keys
COLOR (a string) and STROKE-WIDTH (a number) are accepted to override
the line color and line thickness."
  (make-pict
   `(svg (@ (width ,(max maxw (let ((new-width (+ (min x1 x2)
                                                  (abs (- x2 x1)))))
                                (if (zero? new-width)
                                    stroke-width new-width))))
            (height ,(max maxh (let ((new-height (+ (min y1 y2)
                                                    (abs (- y2 y1)))))
                                 (if (zero? new-height)
                                     stroke-width new-height))))
            (x 0)
            (y 0))
         (line (@ (x1 ,x1)
                  (y1 ,y1)
                  (x2 ,x2)
                  (y2 ,y2)
                  (style ,(style-list->string
                           `(("stroke" ,color)
                             ("stroke-width"
                              ,(number->string stroke-width))))))))))

(define* (hline w h
                #:key
                (color "black")
                (stroke-width 1))
  "Return a horizontal line segment of width W.  The bounding box
height is H and the line is drawn in the vertical center of the
bounding box.  The keys COLOR (a string) and STROKE-WIDTH (a number)
are accepted to override the line color and line thickness."
  (let ((vcenter (exact->inexact (/ h 2))))
    (line 0 vcenter w vcenter w h
          #:color color #:stroke-width stroke-width)))

(define* (vline w h
                #:key
                (color "black")
                (stroke-width 1))
  "Return a vertical line segment of height H.  The bounding box width
is W and the line is drawn in the horizontal center of the bounding
box.  The keys COLOR (a string) and STROKE-WIDTH (a number) are
accepted to override the line color and line thickness."
  (let ((hcenter (exact->inexact (/ w 2))))
    (line hcenter 0 hcenter h w h
          #:color color #:stroke-width stroke-width)))

(define* (polyline points
                   #:key
                   (color "black")
                   (stroke-width 1))
  "Draw a polyline from POINTS, a list of x and y coordinate pairs.
The keys COLOR (a string) and STROKE-WIDTH (a number) are accepted to
override the line color and line thickness."
  (let* ((xs (map car points))
         (ys (map cdr points)))
    (make-pict
     `(svg (@ (width ,(+ (apply min xs)
                         (apply max xs)))
              (height ,(+ (apply min ys)
                          (apply max ys)))
              (x 0)
              (y 0))
           (polyline (@ (points ,(string-join
                                  (map (match-lambda
                                         ((x . y)
                                          (string-append (number->string x)
                                                         ","
                                                         (number->string y))))
                                       points)))
                        (style ,(style-list->string
                                 `(("fill" "none")
                                   ("stroke" ,color)
                                   ("stroke-width"
                                    ,(number->string stroke-width)))))))))))

(define* (polygon points
                  #:key
                  (border-color "black")
                  (border-width 1))
  "Draw a polygon from POINTS, a list of x and y coordinate pairs.
The keys BORDER-COLOR (a string) and BORDER-WIDTH (a number) are
accepted to override the line color and line thickness."
  (let* ((xs (map car points))
         (ys (map cdr points)))
    (make-pict
     `(svg (@ (width ,(+ (apply min xs)
                         (apply max xs)))
              (height ,(+ (apply min ys)
                          (apply max ys)))
              (x 0)
              (y 0))
           (polygon (@ (points ,(string-join
                                 (map (match-lambda
                                        ((x . y)
                                         (string-append (number->string x)
                                                        ","
                                                        (number->string y))))
                                      points)))
                       (style ,(style-list->string
                                `(("fill" "none")
                                  ("stroke" ,border-color)
                                  ("stroke-width"
                                   ,(number->string border-width)))))))))))

;; An isosceles triangle
(define* (triangle w h
                   #:key
                   (border-color "black")
                   (border-width 1))
  "Return an isosceles triangle with width W and height H.  The keys
BORDER-COLOR (a string) and BORDER-WIDTH (a number) are accepted to
override the line color and line thickness."
  (polygon `((0 . ,h)
             (,w . ,h)
             (,(/ w 2) . 0))
           #:border-color border-color
           #:border-width border-width))

(define* (filled-triangle w h #:key (color "black"))
  (remove-outline (fill (triangle w h) color)))

;; A boring p8 symmetric isogonal octagon
(define* (octagon size
                  #:key
                  (border-color "black")
                  (border-width 1))
  "Return an octagon (more accurately a p8 symmetric isogonal octagon)
with a maximum width of SIZE.  The keys BORDER-COLOR (a string) and
BORDER-WIDTH (a number) are accepted to override the default line
color and line thickness."
  (let* ((half-line-width (exact->inexact (/ border-width 2)))
         (size* (- size half-line-width))
         (third (exact->inexact (/ size 3))))
    (polygon `((,half-line-width . ,(* 2 third))
               (,half-line-width . ,third)
               (,third . ,half-line-width)
               (,(* 2 third) . ,half-line-width)
               (,size* . ,third)
               (,size* . ,(* 2 third))
               (,(* 2 third) . ,size*)
               (,third . ,size*))
             #:border-color border-color
             #:border-width border-width)))

(define* (filled-octagon size #:key (color "black"))
  (remove-outline (fill (octagon size) color)))

(define* (circle size
                 #:key
                 (border-color "black")
                 (border-width 1))
  "Return a circle with an outer diameter of SIZE."
  (let* ((border-width (min border-width (/ size 2)))
         (radius (exact->inexact
                  (/ (- size border-width) 2))))
    (make-pict
     `(svg (@ (width ,size)
              (height ,size)
              (x 0)
              (y 0))
           (circle (@ (style ,(style-list->string
                               `(("fill" "none")
                                 ("stroke" ,border-color)
                                 ("stroke-width"
                                  ,(number->string border-width)))))
                      (cx ,(+ radius (/ border-width 2)))
                      (cy ,(+ radius (/ border-width 2)))
                      (r  ,radius)))))))

(define* (disk size
               #:key
               (color "black"))
  "Return a disk with an outer diameter of SIZE.  It is filled with
the given COLOR."
  (fill (circle size #:border-width 0 #:border-color "none") color))

(define* (ellipse w h
                  #:key
                  (border-color "black")
                  (border-width 1))
  "Return an ellipse with width W and height H.  The keys
BORDER-COLOR (a string) and BORDER-WIDTH (a number) are accepted to
override the line color and line thickness."
  (make-pict
   (let ((w* (- w border-width))
         (h* (- h border-width)))
     `(svg (@ (width ,w)
              (height ,h)
              (x 0)
              (y 0))
           (ellipse (@ (style ,(style-list->string
                                `(("fill" "none")
                                  ("stroke" ,border-color)
                                  ("stroke-width"
                                   ,(number->string border-width)))))
                       (cx ,(exact->inexact (+ (/ w* 2) (/ border-width 2))))
                       (cy ,(exact->inexact (+ (/ h* 2) (/ border-width 2))))
                       (rx ,(exact->inexact (/ w* 2)))
                       (ry ,(exact->inexact (/ h* 2)))))))))

(define* (filled-ellipse w h #:key (color "black"))
  (remove-outline (fill (ellipse w h) color)))

(define* (rectangle w h
                    #:key
                    (border-color "black")
                    (border-width 1)
                    (rx 0)
                    (ry 0))
  "Return a rectangle with width W and height H.  The keys
BORDER-COLOR (a string) and BORDER-WIDTH (a number) are accepted to
override the line color and line thickness, respectively.  The keys RX
and RY can be provided to round off the corners."
  (make-pict
   (let ((half-line-width (exact->inexact (/ border-width 2))))
       `(svg (@ (width ,w)
                (height ,h)
                (x 0)
                (y 0))
             (rect (@ (style ,(style-list->string
                               `(("fill" "none")
                                 ("stroke" ,border-color)
                                 ("stroke-width"
                                  ,(number->string border-width)))))
                      (x ,half-line-width)
                      (y ,half-line-width)
                      (width ,(- w border-width))
                      (height ,(- h border-width))
                      (rx ,rx)
                      (ry ,ry)))))))

(define* (filled-rectangle w h #:key
                           (color "black")
                           (border-color "none")
                           (border-width 1)
                           (rx 0)
                           (ry 0))
  "Return a filled rectangle with width W and height H.  The keys
BORDER-COLOR (a string) and BORDER-WIDTH (a number) are accepted to
override the line color and line thickness, respectively.  The keys RX
and RY can be provided to round off the corners.  The key COLOR (a
string) controls the fill color of the rectangle; by default it is
filled with black."
  (fill (rectangle w h
                   #:border-color border-color
                   #:border-width border-width
                   #:rx rx
                   #:ry ry) color))


;;; Text support

;; Text cannot be implemented in SVG alone because in order to
;; determine the size of a text object it first needs to be
;; constructed with a font.  We use the rsvg library to obtain the
;; width and height.

;; Unfortunately, librsvg in Geiser does not support text baseline
;; alignment, so the text is always vertically misaligned.  I tried to
;; use path-aligned text, but that also won't work.  To work around
;; this problem we first compute the full height of rendered text with
;; U+2588 and then align the text.
(define* (text txt #:key
               (color "black")
               (border-color "none")
               (border-width 0)
               (font-family "sans-serif")
               (font-size 32)
               (font-style 'normal)
               (font-weight 'normal))
  "Render the provided string TXT.  The keywords COLOR (a string),
BORDER-COLOR (a string), BORDER-WIDTH (an integer), FONT-FAMILY (a
string), FONT-SIZE (an integer), FONT-STYLE (a symbol), and
FONT-WEIGHT (also a symbol) can be used to change the appearance."
  (define validate-weight
    (or (member font-weight '(normal bold bolder lighter))
        (error "font-weight must be one of: normal, bold, bolder, lighter.")))
  (define validate-style
    (or (member font-style '(normal italic oblique))
        (error "font-style must be one of: normal, italic, oblique.")))
  ;; Return ascent, descent, height, max_x_advance, max_y_advance
  (define (font-extents)
    (call-with-values
        (lambda ()
          (let ((surf #f))
            (dynamic-wind
              (const #f)
              (lambda ()
                (set! surf (cairo-image-surface-create 'rgb24 1 1))
                (let ((ctx (cairo-create surf)))
                  (cairo-select-font-face ctx font-family font-style font-weight)
                  (cairo-set-font-size ctx font-size)
                  (cairo-font-extents ctx)))
              (lambda ()
                (when surf
                  (cairo-surface-finish surf)
                  (cairo-surface-destroy surf))))))
      (lambda (dimensions)
        (apply values (f64vector->list dimensions)))))
  (define (text-extents)
    (call-with-values
        (lambda ()
          (let ((surf #f))
            (dynamic-wind
              (const #f)
              (lambda ()
                (set! surf (cairo-image-surface-create 'rgb24 1 1))
                (let ((ctx (cairo-create surf)))
                  (cairo-select-font-face ctx font-family font-style font-weight)
                  (cairo-set-font-size ctx font-size)
                  (cairo-text-extents ctx txt)))
              (lambda ()
                (when surf
                  (cairo-surface-finish surf)
                  (cairo-surface-destroy surf))))))
      (lambda (dimensions)
        (apply values (f64vector->list dimensions)))))

  ;; XXX: We cannot use rsvg-handle-write nor
  ;; rsvg-handle-new-from-data, because they throw an error upon
  ;; closing the handle if we had written any non-ASCII characters to
  ;; them before.  So we write the SVG to a file and use
  ;; rsvg-handle-new-from-file.
  (define (dimensions svg)
    (let* ((port (mkstemp! (string-copy "/tmp/pictXXXXXXX")))
           (name (port-filename port)))
      (sxml->xml svg port)
      (close-port port)
      (let*-values (((d) (rsvg-set-default-dpi-x-y %dpi %dpi))
                    ;; This fails with non-ASCII data.  Curious.
                    ;; But it leads to the correct font dimensions!
                    #;
                    ((handle) (rsvg-handle-new-from-data
                               (with-output-to-string
                                 (lambda ()
                                   (sxml->xml svg)))))
                    ((handle) (rsvg-handle-new-from-file name))
                    ((c) (rsvg-handle-close handle))
                    ((width height em ex) (rsvg-handle-get-dimensions handle)))
        (values width height))))
  (define (make-text content)
    `(text (@ (style ,(style-list->string
                       `(("fill" ,color)
                         ("stroke" ,border-color)
                         ("stroke-width" ,(number->string border-width))
                         ("font-family" ,font-family)
                         ("font-style" ,(symbol->string font-style)))))
              (font-size ,font-size)
              (font-weight ,(symbol->string font-weight)))
           ,content))
  (let-values (((ascent descent height max-x-advance max-y-advance)
                (font-extents))
               ((x-bearing y-bearing t-width t-height x-advance y-advance)
                (text-extents))
               ((full-width _h)
                (dimensions `(svg (@ (xmlns "http://www.w3.org/2000/svg"))
                                  ,(make-text txt)))))
    (make-pict `(svg (@ (height ,(+ ascent descent))
                        ;; XXX: Annoyingly, Cairo reports the wrong
                        ;; x-advance when Chinese characters are
                        ;; involved, so we're using the width of the
                        ;; rendered SVG together with the x-bearing.
                        (width ,(+ x-bearing full-width))
                        (x 0)
                        (y 0))
                     ;; Shift the text into view.
                     ,((attribute-modifier
                        'y (const ascent))
                       (make-text txt))))))


(define* (pict-attr attr pict #:key (path '()))
  "Return the value of the selected ATTRIBUTE of the outermost element
of the SVG of PICT or #F."
  (and=> ((sxpath `(,@path @ ,attr *any*))
          (pict-sxml pict))
         (lambda (m)
           (and (pair? m) (car m)))))

(define (pict-height pict)
  "Return the numeric height of PICT."
  (match (pict-attr 'height pict)
    ((? string? s)
     ;; Take value up to unit and convert to number
     (let ((index (string-skip s char-set:digit)))
       (string->number (substring s 0 index))))
    ((? number? n) n)
    (_ 150)))

(define (pict-width pict)
  "Return the numeric width of PICT."
  (match (pict-attr 'width pict)
    ((? string? s)
     ;; Take value up to unit and convert to number
     (let ((index (string-skip s char-set:digit)))
       (string->number (substring s 0 index))))
    ((? number? n) n)
    (_ 150)))

(define (pict-rotation pict)
  "Return the rotation of PICT."
  (let ((m (assoc-ref (transform-string->list
                       (or (pict-attr 'transform pict #:path '(g)) ""))
                      "rotate")))
    (or (and (pair? m)
             (and=> (first m)
                    (lambda (m) (first (rotation->values m)))))
        0)))

(define (append-align xalign yalign picts)
  "Append PICTS and align them vertically to the top, center, bottom,
or spread by an offset according to the symbol YALIGN and horizontally
to the left, center, right, or spread them with an offset according to
the symbol XALIGN.  When the first element of PICTS is a number, use
it as a gap between PICTS."
  (let-values (((gap picts) (match picts
                              (((? number? gap) . picts)
                               (values gap picts))
                              (_ (values 0 picts)))))
    (let* ((heights    (map pict-height picts))
           (widths     (map pict-width picts))
           (gaps       (* (- (length picts) 1) gap))
           (new-height (if (eq? yalign 'offset)
                           (+ (apply + heights) gaps)
                           (apply max heights)))
           (new-width  (if (eq? xalign 'offset)
                           (+ (apply + widths) gaps)
                           (apply max widths)))
           (x-offsets  (if (eq? xalign 'offset)
                           (map + (scan widths)
                                  (scan (list-tabulate (length picts) (const gap))))
                           (list-tabulate (length picts) (const gap))))
           (y-offsets  (if (eq? yalign 'offset)
                           (map + (scan heights)
                                  (scan (list-tabulate (length picts) (const gap))))
                           (list-tabulate (length picts) (const gap))))
           (aligner    (match-lambda
                         ((xoffset yoffset pict)
                          ((compose
                            (attribute-modifier
                             'x (match xalign
                                  ('left   identity)
                                  ('center (lambda _
                                             (exact->inexact
                                              (- (/ new-width 2)
                                                 (/ (pict-width pict) 2)))))
                                  ('right  (lambda _
                                             (exact->inexact
                                              (- new-width
                                                 (pict-width pict)))))
                                  ('offset (const xoffset))))
                            (attribute-modifier
                             'y (match yalign
                                  ('top    identity)
                                  ('center (lambda _
                                             (exact->inexact
                                              (- (/ new-height 2)
                                                 (/ (pict-height pict) 2)))))
                                  ('bottom (lambda _
                                             (exact->inexact
                                              (- new-height
                                                 (pict-height pict)))))
                                  ('offset (const yoffset)))))
                           (pict-sxml pict))))))
      (make-pict
       `(svg (@ (height ,new-height)
                (width  ,new-width)
                (class ,(string-append "aligned-"
                                       (symbol->string xalign)
                                       "-"
                                       (symbol->string yalign)))
                (x 0)
                (y 0))
             ,@(map aligner (zip x-offsets y-offsets picts)))))))

(define (ht-append . picts)
  "Line up the given PICTS horizontally on the top."
  (append-align 'offset 'top picts))

(define (hc-append . picts)
  "Line up the given PICTS horizontally and center them."
  (append-align 'offset 'center picts))

(define (hb-append . picts)
  "Line up the given PICTS horizontally on the top."
  (append-align 'offset 'bottom picts))

(define (vl-append . picts)
  "Line up the given PICTS vertically and left-align them."
  (append-align 'left 'offset picts))

(define (vc-append . picts)
  "Line up the given PICTS vertically and center them."
  (append-align 'center 'offset picts))

(define (vr-append . picts)
  "Line up the given PICTS vertically and right-align them."
  (append-align 'right 'offset picts))

(define (lt-superimpose . picts)
  "Stack the given PICTS and align them left and at the top."
  (append-align 'left 'top picts))
(define (lc-superimpose . picts)
  "Stack the given PICTS and align them left and center them
vertically."
  (append-align 'left 'center picts))
(define (lb-superimpose . picts)
  "Stack the given PICTS and align them left and at the bottom."
  (append-align 'left 'bottom picts))

(define (ct-superimpose . picts)
  "Stack the given PICTS and center them horizontally and align at the
top."
  (append-align 'center 'top picts))
(define (cc-superimpose . picts)
  "Stack the given PICTS and center them horizontally and vertically."
  (append-align 'center 'center picts))
(define (cb-superimpose . picts)
  "Stack the given PICTS and center them horizontally and align at the
bottom."
  (append-align 'center 'bottom picts))

(define (rt-superimpose . picts)
  "Stack the given PICTS and align them right and at the top."
  (append-align 'right 'top picts))
(define (rc-superimpose . picts)
  "Stack the given PICTS and align them right and center them vertically."
  (append-align 'right 'center picts))
(define (rb-superimpose . picts)
  "Stack the given PICTS and align them right and at the bottom."
  (append-align 'right 'bottom picts))

(define (pin-over base dx dy pict)
  "Create a pict with the same dimensions as BASE, but with PICT
placed on top.  PICT is offset from the top left corner of BASE by DX
and DY."
  (make-pict
   `(svg (@ (height ,(pict-height base))
            (width  ,(pict-width base))
            (class "pinned")
            (x 0)
            (y 0))
         ,(pict-sxml base)
         ,((compose (attribute-modifier 'y (const dy))
                    (attribute-modifier 'x (const dx)))
           (pict-sxml pict)))))

(define (pin-under base dx dy pict)
  "Create a pict with the same dimensions as BASE, but with PICT
placed underneath.  PICT is offset from the top left corner of BASE by
DX and DY."
  (make-pict
   `(svg (@ (height ,(pict-height base))
            (width  ,(pict-width base))
            (class "pinned")
            (x 0)
            (y 0))
         ,((compose (attribute-modifier 'y (const dy))
                    (attribute-modifier 'x (const dx)))
           (pict-sxml pict))
         ,(pict-sxml base))))


;;; Colors

(define (rgb r g b)
  (when (any (lambda (comp)
               (or (> comp 255)
                   (negative? comp)))
             (list r g b))
    (error "Color component values must be between 0 and 255."))
  (format #f "rgb(~a,~a,~a)" r g b))

(define (random-color)
  (rgb (random 256) (random 256) (random 256)))

;; List of defined SVG color names
(define colors
  (list "aliceblue" "antiquewhite" "aqua" "aquamarine" "azure" "beige"
        "bisque" "black" "blanchedalmond" "blue" "blueviolet" "brown"
        "burlywood" "cadetblue" "chartreuse" "chocolate" "coral"
        "cornflowerblue" "cornsilk" "crimson" "cyan" "darkblue"
        "darkcyan" "darkgoldenrod" "darkgray" "darkgreen" "darkgrey"
        "darkkhaki" "darkmagenta" "darkolivegreen" "darkorange"
        "darkorchid" "darkred" "darksalmon" "darkseagreen"
        "darkslateblue" "darkslategray" "darkslategrey" "darkturquoise"
        "darkviolet" "deeppink" "deepskyblue" "dimgray" "dimgrey"
        "dodgerblue" "firebrick" "floralwhite" "forestgreen" "fuchsia"
        "gainsboro" "ghostwhite" "gold" "goldenrod" "gray" "grey"
        "green" "greenyellow" "honeydew" "hotpink" "indianred" "indigo"
        "ivory" "khaki" "lavender" "lavenderblush" "lawngreen"
        "lemonchiffon" "lightblue" "lightcoral" "lightcyan"
        "lightgoldenrodyellow" "lightgray" "lightgreen" "lightgrey"
        "lightpink" "lightsalmon" "lightseagreen" "lightskyblue"
        "lightslategray" "lightslategrey" "lightsteelblue"
        "lightyellow" "lime" "limegreen" "linen" "magenta" "maroon"
        "mediumaquamarine" "mediumblue" "mediumorchid" "mediumpurple"
        "mediumseagreen" "mediumslateblue" "mediumspringgreen"
        "mediumturquoise" "mediumvioletred" "midnightblue" "mintcream"
        "mistyrose" "moccasin" "navajowhite" "navy" "oldlace" "olive"
        "olivedrab" "orange" "orangered" "orchid" "palegoldenrod"
        "palegreen" "paleturquoise" "palevioletred" "papayawhip"
        "peachpuff" "peru" "pink" "plum" "powderblue" "purple" "red"
        "rosybrown" "royalblue" "saddlebrown" "salmon" "sandybrown"
        "seagreen" "seashell" "sienna" "silver" "skyblue" "slateblue"
        "slategray" "slategrey" "snow" "springgreen" "steelblue" "tan"
        "teal" "thistle" "tomato" "turquoise" "violet" "wheat" "white"
        "whitesmoke" "yellow" "yellowgreen"))