McCLIM backends - Part I: Medium Output Protocol

Tagged as lisp, clim, backends, tutorial

Written on 2022-04-15 by Daniel 'jackdaniel' KochmaƄski

Table of Contents

  1. Introduction
  2. Using a drawing backend
  3. Defining a new backend
  4. Implementing the medium protocol
    1. The first 90 percent of drawing
    2. The following 9 percent of drawing
      1. Basic shapes
      2. The line style
      3. The text style
      4. Arbitrary clip regions
    3. The last 1% of drawing
      1. Images, tiles and transformed patterns
      2. Recursive designs
      3. Masked in- and out- composition
    4. Features that are not implemented
  5. Conclusions

Introduction

CLIM backends may be categorized as:

  • interactive: handles I/O and is used by applications
  • drawing: renders graphics in a specified format

McCLIM currently provides the following drawing backends:

  • PostScript : .ps
  • PDF : .pdf
  • RasterImage: .png, .tiff etc. (using the library opticl)

This tutorial focuses on using, defining and implementing drawing backends. It is also applicable to the rendering part of the interactive backend.

In this part we'll focus on using drawing backends, defining a new backend and on implementing output protocols.

Using a drawing backend

A typical use of a drawing backend involves creating a stream and drawing on it with operators specified in Part IV: Sheet and Medium Output Facilities. The PostScript backend is special because it is defined in the specification.

(with-open-file (file-stream "/tmp/file.ps" :direction :output :if-exists :supersede)
  (with-output-to-postscript-stream (stream file-stream)
    (draw-rectangle* stream 10 10 90 90 :ink clim:+red+)))

Executing the form above will create a postscript document with a red rectangle drawn near the top-left corner of the page. Notice that the second argument passed to the macro is a stream - this provides an important insight: drawing backends are filters that convert CLIM operations to a device-specific format1.

McCLIM provides an extension that unifies the access to drawing:

;; similar to with-output-to-postscript-stream
(with-output-to-drawing-stream (stream :ps "/tmp/file.ps")
  (draw-rectangle* stream 10 10 90 90 :ink +red+))

;; interactive backends open a window by default
(with-output-to-drawing-stream (stream :clx-ttf nil)
  (draw-rectangle* stream 10 10 90 90 :ink +red+))

;; requires loading the system "mcclim-raster-image"
(with-output-to-drawing-stream (stream :raster "/tmp/file.png" :width 200 :height 200)
  (draw-rectangle* stream 10 10 90 90 :ink +red+))

The first argument is a variable to be bound to a drawing stream, the second argument is a symbol that designates the backend, and the third argument is a destination. All remaining arguments are parsed by the backend.

Let's define a smoke test for different shapes and drawing styles:

(defun test-drawing (stream)
  (with-drawing-options (stream :transformation (make-reflection-transformation* 0 180 100 180))
    (draw-ellipse* stream 320 180 300 0 0 150 :ink +grey+)
    (draw-ellipse* stream 320 180 300 0 0 150 :ink +black+ :filled nil
                                              :line-dashes '(8 16)
                                              :line-thickness 8)
    (draw-circle* stream 220 250 25 :ink +blue+)
    (draw-circle* stream 420 250 25 :ink +blue+)
    (draw-point* stream 220 250 :ink +cyan+ :line-thickness 15)
    (draw-point* stream 420 250 :ink +cyan+ :line-thickness 15)
    (draw-rectangle* stream 125 150 150 175 :ink +deep-pink+ )
    (draw-rectangle* stream 515 150 490 175 :ink +deep-pink+ )
    (draw-polygon* stream (list 320 225 280 150 360 150) :filled t :ink +orange+)
    (draw-polygon* stream (list 320 225 280 150 360 150) :filled nil :ink +black+
                                                         :line-thickness 4
                                                         :line-joint-shape :round)
    (draw-line* stream 175 125 465 125 :ink +blue+ :line-thickness 4 :line-cap-shape :no-end-point)
    (draw-line* stream 175 130 465 130 :ink +blue+ :line-thickness 4 :line-cap-shape :butt)
    (draw-line* stream 175 135 465 135 :ink +blue+ :line-thickness 4 :line-cap-shape :square)
    (draw-line* stream 175 140 465 140 :ink +blue+ :line-thickness 4 :line-cap-shape :round)

    (let ((smile '(200 100 280 75 360 75 440 100 200 100 200 100 200 100)))
      (draw-bezigon* stream smile :filled t :ink +red+)
      (draw-bezigon* stream smile :filled nil :ink +black+ :line-dashes nil :line-thickness 4))
    (draw-circle* stream 0 0 25 :ink +red+)
    (draw-circle* stream 320 300 20 :ink +cyan+)
    (draw-line* stream 300 300 340 300 :line-thickness 1)
    (draw-text* stream "McCLIM" 320 300
                :align-x :center :align-y :center :text-size :large
                :transform-glyphs t
                :ink +dark-green+
                :transformation (make-rotation-transformation* (/ pi 6) 320 300))))

;;; (ql:quickload 'mcclim-raster-image)
(with-output-to-drawing-stream (stream :raster "smoke-test.png" :width 640 :height 360)
  (test-drawing stream))

img

Defining a new backend

It is time to define the SVG backend. The whole implementation will reside in a package mcclim-svg. Packages clime and climb export symbols for core extensions provided by McCLIM.

;; (ql:quickload '("mcclim" "mcclim-bitmaps" "mcclim-fonts/truetype"
;;                 "alexandria" "cl-who" "cl-base64" "flexi-streams"))

(defpackage #:mcclim-svg
  (:use #:clim #:clime #:climb #:clim-lisp)
  (:local-nicknames (#:alx #:alexandria)))

(in-package #:mcclim-svg)

A port is an object that represents a display server. It is used for specialization, handling input and maintaining allocated resources. New backends should subclass basic-port that implements essential defaults. The slot destination stores the stream for writing, and the slot resources is a hash table storing the defined resource identifiers.

(defclass svg-port (mcclim-truetype:ttf-port-mixin basic-port)
  ((destination :accessor destination)
   (resources :initform (make-hash-table :test #'equal) :reader resources)))

Our port will have a simple resource manager. In SVG some resources may be defined in the section <defs> and then referenced by id. The manager will try to return the identifier, and if absent, assign an unique string. A macro ensure-resource-id executes the body conditionally.

(defun resource-id (holder resource)
  (let ((ht (resources (port holder))))
    (alx:ensure-gethash resource ht
      (format nil "r~4,'0d" (hash-table-count ht)))))

(defmacro ensure-resource-id ((medium object) &body body)
  (alx:with-gensyms (foundp)
    `(multiple-value-bind (^resource-id ,foundp)
         (resource-id ,medium ,object)
       (unless ,foundp ,@body)
       ^resource-id)))

Every port is designated by a symbol and parameterized by a supplied server path. The server path looks like this: (port-designator . port-parameters). Instances of the same class are distinguished by the use of equal to compare canonical server paths.

A backend may provide a server-path parser to ensure a consistent order of arguments, to add additional options, and to sanitize parameters.

The svg-port represents a single SVG document. To avoid a situation where the same port is used for two documents we append a unique id so that find-port will always return a fresh instance.

(defun parse-server-path (server-path)
  (destructuring-bind (port-type &rest args &key dpi width height)
      server-path
    (declare (ignore dpi width height))
    (list* port-type :id (gensym) args)))

The function find-port-type is used by McCLIM to map symbols to port classes and their corresponding parsers.

(defmethod find-port-type ((port (eql :svg)))
  (values (find-class 'svg-port) 'parse-server-path))

For example:

CLIM-USER> (find-port :server-path :svg) ;-> #<MCCLIM-SVG::SVG-PORT #x302007C9D9CD>, NIL
CLIM-USER> (find-port :server-path :svg) ;-> #<MCCLIM-SVG::SVG-PORT #x302007C9ADAD>, NIL

A drawing backend is created by a macro with-output-to-drawing-stream that expands to a call to the function invoke-with-output-to-drawing-stream. We will define a DWIM method that coerces the destination to a stream. We call destroy-port in the end to ensure that it is not referenced in the core.

;;; Ensure that the "real" method receives a stream.
(defmethod invoke-with-output-to-drawing-stream
    (cont (port (eql :svg)) destination &rest args &key (preview nil))
  (let* ((args (alx:remove-from-plist args :preview))
         (port (find-port :server-path (list* port args))))
    (unwind-protect
         (etypecase destination
           ((or string pathname)
            (with-open-file (stream destination :direction :output
                                                :if-exists :supersede
                                                :if-does-not-exist :create
                                                :element-type 'character)
              (invoke-with-output-to-drawing-stream cont port stream))
            (when preview
              (when (eq preview t)
                (setf preview "xdg-open"))
              (uiop:launch-program (format nil "~a ~a" preview destination)))
            destination)
           (null
            (with-output-to-string (stream nil :element-type 'character)
              (invoke-with-output-to-drawing-stream cont port stream)))
           ((eql t)
            (let ((stream *standard-output*))
              (invoke-with-output-to-drawing-stream cont port stream))
            nil)
           (stream
            (invoke-with-output-to-drawing-stream cont port destination)))
      (destroy-port port))))

Lisp numbers can't be directly serialized to SVG - strings like 1/4 or 1.0d0 won't be parsed as numbers. We introduce a function fmt that formats the number to either an integer or a float without its type indicator:

(defun fmt (number)
  (if (integerp number)
      (format nil "~d" number)
      (format nil "~f" number)))

The "real" method is specialized to the port. CLIM and SVG default coordinate systems are the same. That is not always true, for example PDF and PostScript origins are located at the lower-left corner and Y grows upwards. We introduce a necessary boilerplate to create a document. We specify the document size in real-size units depending on the dpi.

(defvar *viewport-w*)
(defvar *viewport-h*)

(defmethod invoke-with-output-to-drawing-stream
    (continuation (port svg-port) (destination stream) &rest args)
  (declare (ignore args))
  (destructuring-bind (port-type &key (dpi 96) (width 640) (height 360) &allow-other-keys)
      (port-server-path port)
    (declare (ignore port-type))
    (setf (destination port) destination)
    (let ((medium (make-medium port nil))
          (clip (make-rectangle* 0 0 width height))
          (w-in (format nil "~ain" (fmt (/ width dpi))))
          (h-in (format nil "~ain" (fmt (/ height dpi))))
          (bbox (format nil "0 0 ~a ~a" (fmt width) (fmt height)))
          (*viewport-w* width)
          (*viewport-h* height))
      (with-drawing-options (medium :clipping-region clip)
        (cl-who:with-html-output (destination destination)
          (:svg :version "1.1" :width w-in :height h-in :|viewBox| bbox
           :xmlns "http://www.w3.org/2000/svg"
           :|xmlns:xlink| "http://www.w3.org/1999/xlink"
           (funcall continuation medium)))))))

Let's try it!

CLIM-USER> (with-output-to-drawing-stream (stream :svg nil)
             (declare (ignore stream)))
"<svg version='1.1' width='6.6666665'in height='3.75in' viewBox='0 0 640 360' xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'></svg>"

Implementing the medium protocol

A drawing backend must implement CLIM's medium protocol. It should also implement CLIM's output stream protocol.

A medium is the object that is responsible for maintaining the drawing context and for performing the drawing. New mediums should subclass basic-medium that implements essential defaults. We associate the medium class with a port by specializing the method make-medium.

(defclass svg-medium (mcclim-truetype:ttf-medium-mixin basic-medium)
  ())

(defmethod make-medium ((port svg-port) sheet)
  (make-instance 'svg-medium :stream sheet :port port))

To CLIM, the drawable accessed with a reader medium-drawable is an opaque object. It may be a file stream, a pixmap, an ffi handler etc. Handling the drawable is the "know-how" contributed by the backend.

(defmethod medium-drawable ((medium svg-medium))
  (if (medium-sheet medium)
      (call-next-method)
      (destination (port medium))))

The first 90 percent of drawing

Drawing usually involves establishing a context that specifies the clipping region, the paint color, and other drawing properties. Manually handling it for each drawing method may be a bit tedious - that's why we'll introduce a macro for establishing the context for us.

(defmacro with-drawing-context ((drawable-var medium mode) &body body)
  (alx:with-gensyms (cont)
    `(flet ((,cont (,drawable-var) ,@body))
       (declare (dynamic-extent (function ,cont)))
       (invoke-with-drawing-context (function ,cont) ,medium ,mode))))

Clipping in SVG may be achieved either by defining a clip path or by defining a mask. The former is much more performant while the latter is more flexible. The function medium-clip will return the clip type and its value:

(defun url (id)
  (format nil "url(#~a)" id))

(defgeneric medium-clip (medium region)
  (:method ((medium svg-medium) (region (eql +nowhere+)))
    (values :none nil))
  (:method ((medium svg-medium) (region (eql +everywhere+)))
    (values :clip "none"))
  (:method ((medium svg-medium) (region bounding-rectangle))
    (let ((id (ensure-resource-id (medium (cons :clip region))
                (cl-who:with-html-output (drawable (medium-drawable medium))
                  (:defs (:|clipPath| :id ^resource-id (draw-design medium region)))))))
      (values :clip (url id))))
  (:method ((medium svg-medium) (region standard-region-complement))
    (error "SVG: Unsupported clip ~s." 'standard-region-complement))
  (:method ((medium svg-medium) (region standard-region-intersection))
    (error "SVG: Unsupported clip ~s." 'standard-region-intersection)))

The paint color and opacity in SVG are treated separately. The function medium-design-ink will return two values that are suitable as values for attributes "fill", "stroke" and "opacity".

;;; This would be so much nicer had SVG accept RGBA as a fill from the get-go.
(defun uniform-design-values (design)
  (multiple-value-bind (r g b a) (color-rgba design)
    (values (format nil "#~2,'0x~2,'0x~2,'0x"
                    (truncate (* r 255))
                    (truncate (* g 255))
                    (truncate (* b 255)))
            (format nil "~,2f" a))))

(defgeneric medium-design-ink (medium design)
  (:method ((medium svg-medium) (design color))
    (uniform-design-values design))
  (:method ((medium svg-medium) (design opacity))
    (uniform-design-values design))
  (:method ((medium svg-medium) (design climi::uniform-compositum))
    (uniform-design-values design))
  (:method ((medium svg-medium) (design indirect-ink))
    (medium-design-ink medium (indirect-ink-ink design)))
  (:method ((medium svg-medium) design)
    (warn "SVG: Unsupported design ~s." (class-name (class-of design)))
    (medium-design-ink medium +deep-pink+)))

Notice that unsupported clips lead to an error, while unsupported paints signal a warning and use a characteristic color. Finally, all drawing is expected to be transformed by the device transformation, which maps points from a drawing plane to the device plane. The SVG transformation matrix is specified in a column-major order - unlike McCLIM!

;;; SVG transformation matrix is in column-major order.
(defun svg-transform (transformation)
  (multiple-value-bind (mxx mxy myx myy tx ty)
      (climi::get-transformation transformation)
    (format nil "matrix(~f ~f ~f ~f ~f ~f)"
            (fmt mxx) (fmt myx)
            (fmt mxy) (fmt myy)
            (fmt  tx) (fmt  ty))))

Finally, let's write the function that establishes the drawing context. Did you notice that in the function medium-clip we call the function draw-design? We need to prevent infinite recursion, and we do that with *configuring-device-p*. We'll use the hierarchical SVG element <g> to configure the device.

(defvar *configuring-device-p* nil)

(defun invoke-with-drawing-context (cont medium mode)
  (declare (ignorable mode))
  (alx:when-let ((drawable (medium-drawable medium)))
    (when *configuring-device-p*
      (return-from invoke-with-drawing-context
        (funcall cont drawable)))
    (cl-who:with-html-output (drawable)
      (labels ((configure-clip ()
                 (multiple-value-bind (clip value)
                     (medium-clip medium (medium-clipping-region medium))
                   (when clip
                     (cl-who:htm
                      (ecase clip
                        (:clip (cl-who:htm (:g :clip-path value (configure-draw))))
                        (:mask (cl-who:htm (:g :mask      value (configure-draw))))
                        (:none))))))
               (configure-draw ()
                 (multiple-value-bind (paint opacity)
                     (medium-design-ink medium (medium-ink medium))
                   (let ((transformation (svg-transform (medium-device-transformation medium))))
                     (cl-who:htm
                      (ecase mode
                        (:area
                         (cl-who:htm
                          (:g :transform transformation :fill paint :opacity opacity
                              (configure-area))))
                        (:path
                         (cl-who:htm
                          (:g :transform transformation :fill "none" :stroke paint :opacity opacity
                              (configure-path))))
                        (:text
                         (cl-who:htm
                          (:g :transform transformation :fill paint :opacity opacity
                              (configure-text)))))))))
               (configure-area ()
                 (funcall cont drawable))
               (configure-path ()
                 (funcall cont drawable))
               (configure-text ()
                 (funcall cont drawable)))
        (let ((*configuring-device-p* t))
          (configure-clip))))))

The first drawing function we will implement is medium-draw-polygon*. It is responsible for drawing both polygons and polylines. All coordinates must be sanitized as floats.

(defmethod medium-draw-polygon* ((medium svg-medium) coord-seq closed filled)
  (alx:when-let ((drawable (medium-drawable medium)))
    (multiple-value-bind (rgb-color opacity)
        (multiple-value-bind (r g b a) (color-rgba (medium-ink medium))
          (values (format nil "#~2,'0x~2,'0x~2,'0x"
                          (truncate (* r 255))
                          (truncate (* g 255))
                          (truncate (* b 255)))
                  (format nil "~,2f" a)))
      (let* ((transformation (medium-device-transformation medium))
             (coord-seq (climi::transform-positions transformation coord-seq))
             (points (format nil "~{~f~^ ~}" (coerce coord-seq 'list)))
             (fill   (if filled rgb-color "none"))
             (stroke (if filled "none" rgb-color)))
        (if (or filled closed)
            (cl-who:with-html-output (stream drawable)
              (:polygon :points points :fill fill :stroke stroke :opacity opacity))
            (cl-who:with-html-output (stream drawable)
              (:polyline :points points :fill fill :stroke stroke :opacity opacity)))))))

For example:

CLIM-USER> (with-output-to-drawing-stream (stream :svg "first-drawing.svg" :preview t)
             (with-rotation (stream (/ pi 6))
               (test-drawing stream)))
"first-drawing.svg"

img

Wow! We have a complete picture, why? The explanation is simple - the default drawing methods fall back to medium-draw-polygon*. In other words to have a very fine working prototype it is enough to define one function. That said, there are important shortcomings of this solution:

  • approximating shapes with polygons is expensive (the file has over 400KB!)
  • incomplete drawing context (line styles, text styles)

Fret not, we will address all of them. That said, please take a moment to look back at the source code buffer and appreciate - roughly 200 lines of code is enough to have the first working prototype - we can even render the text!

The following 9 percent of drawing

Approximating drawing with polygons is fun and games but it is time to get serious. SVG provides elements that can be utilized by McCLIM for drawing.

Basic shapes

Points will be represented based on the line cap shape. The thickness of a point is returned by the function line-style-effective-thickness - it accounts for the line style unit and thickness.

(defmethod medium-draw-point* ((medium svg-medium) x y)
  (with-drawing-context (drawable medium :area)
    (let* ((line-style (medium-line-style medium))
           (thickness (line-style-effective-thickness line-style medium))
           (radius (/ thickness 2)))
      (case (line-style-cap-shape line-style)
        (:round
         (cl-who:with-html-output (drawable drawable)
           (:circle :cx (fmt x) :cy (fmt y) :r (fmt radius))))
        (:square
         (cl-who:with-html-output (drawable drawable)
           (:rect :x (fmt (- x radius)) :y (fmt (- y radius))
                  :width (fmt thickness) :height (fmt thickness))))
        (otherwise
         (let* ((coord-seq (list (- x radius) y x (- y radius) (+ x radius) y x (+ y radius)))
                (points (format nil "~{~a~^ ~}" (map 'list #'fmt coord-seq))))
           (cl-who:with-html-output (drawable drawable)
             (:polygon :points points))))))))

Drawing lines and rectangles is trivial:

(defmethod medium-draw-line* ((medium svg-medium) x1 y1 x2 y2)
  (with-drawing-context (drawable medium :path)
    (cl-who:with-html-output (stream drawable)
      (:line :x1 (fmt x1) :y1 (fmt y1) :x2 (fmt x2) :y2 (fmt y2)))))

(defmethod medium-draw-rectangle* ((medium svg-medium) x1 y1 x2 y2 filled)
  (with-drawing-context (drawable medium (if filled :area :path))
    (cl-who:with-html-output (stream drawable)
      (:rect :x (fmt x1) :y (fmt y1) :width (fmt (- x2 x1)) :height (fmt (- y2 y1))))))

To draw a bezigon we need to construct a path.

(defmethod medium-draw-bezigon* ((medium svg-medium) coord-seq filled)
  (with-drawing-context (drawable medium (if filled :area :path))
    (let* ((coord-seq (coerce coord-seq 'list))
           (points (with-output-to-string (str)
                     (destructuring-bind (x0 y0 . coords) coord-seq
                       (format str "M ~f ~f " x0 y0)
                       (loop for (x1 y1 x2 y2 x3 y3) on coords by (lambda (lst) (nthcdr 6 lst))
                             do (format str "C ~f ~f, ~f ~f, ~f ~f " x1 y1 x2 y2 x3 y3))))))
      (cl-who:with-html-output (drawable)
        (:path :d points)))))

Drawing ellipses is always a pain in CLIM. Part of the complexity comes from the fact that CLIM allows drawing only a slice of an ellipse. If it weren't for that complexity, we could have used the built-in element. There are other gotchas:

  • ellipse is specified as a paralleogram: the issue is alleviated with the function ellipse-normalized-representation*

  • angles are CCW in screen coordinates starting at [1,0]: the start point is correct so we only need to transform the direction

Here is how we draw an ellipse:

(defvar +angle-transformation+ (make-reflection-transformation* 0 0 1 0))

(defun draw-sliced-ellipse (medium cx cy rx ry trans filled eta1 eta2)
  ;; IMPORTANT compare angles /before/ the transformation.
  (let ((lf (if (< 0 (- eta2 eta1) pi) 0 1))
        (sf 0))
    (climi::with-transformed-angles (+angle-transformation+ nil eta1 eta2)
      (multiple-value-bind (x1 y1)
          (climi::ellipse-point eta1 cx cy rx ry 0)
        (multiple-value-bind (x2 y2)
            (climi::ellipse-point eta2 cx cy rx ry 0)
          (let ((points (format nil "M ~f ~f L ~f ~f A ~f ~f 0 ~a ~a ~f ~f L ~f ~f"
                                cx cy   x1 y1   rx ry   lf sf x2 y2   cx cy)))
            (with-drawing-context (drawable medium (if filled :area :path))
              (cl-who:with-html-output (drawable)
                (:path :d points :transform trans)))))))))

(defun draw-simple-ellipse (medium cx cy rx ry trans filled)
  (with-drawing-context (drawable medium (if filled :area :path))
    (cl-who:with-html-output (drawable)
      (:ellipse :cx (fmt cx) :cy (fmt cy) :rx (fmt rx) :ry (fmt ry) :transform trans))))

(defmethod medium-draw-ellipse* ((medium svg-medium) cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2 filled)
  (multiple-value-bind (rx ry rotation)
      (climi::ellipse-normalized-representation* rdx1 rdy1 rdx2 rdy2)
    (let  ((trans (format nil "rotate(~a ~a ~a)" (fmt (/ (* rotation 360) (* 2 pi))) (fmt cx) (fmt cy))))
      (if (< (- eta2 eta1) (* 2 pi))
          (draw-sliced-ellipse medium cx cy rx ry trans filled eta1 eta2)
          (draw-simple-ellipse medium cx cy rx ry trans filled)))))

And a smoke test:

(defun test-ellipse (stream)
  (draw-ellipse* stream 200 180 100 0 0 50 :ink +red+)
  (draw-ellipse* stream 440 180 100 0 0 50
                 :ink +blue+ :start-angle (/ pi 6) :end-angle (* 7/4 pi))
  (draw-ellipse* stream 440 180 100 0 0 50
                 :ink +white+ :filled nil :start-angle (/ pi 6) :end-angle (* 7/4 pi)))

(with-output-to-drawing-stream (stream :svg "/tmp/smoke-ellipse.svg" :preview t)
  (test-ellipse stream))

img

Finally the function to draw text. The text style will be configured as part of a drawing context. Arguments transform-glyphs, toward-x and toward-y will be ignored because their specification is ambiguous. Most code comes from the alignment setting2.

(defmethod medium-draw-text* ((medium svg-medium) string x y start end
                              align-x align-y toward-x toward-y
                              transform-glyphs)
  (declare (ignore toward-x toward-y transform-glyphs))
  (with-drawing-context (drawable medium :text)
    (let ((text-anchor
            (ecase align-x
              (:left "start")
              (:center "middle")
              (:right "end")))
          (dominant-baseline
            (ecase align-y
              (:top "text-before-edge")
              (:center "central")
              (:baseline "alphabetic")
              (:bottom "text-after-edge"))))
      (cl-who:with-html-output (stream drawable)
        (:text :x (fmt x)
               :y (fmt y)
               :text-anchor text-anchor
               :dominant-baseline dominant-baseline
               (cl-who:fmt (subseq string start (or end (length string)))))))))

That covers all basic shapes provided by McCLIM. Let's draw the "smiley" again!

(with-output-to-drawing-stream (stream :svg "/tmp/second-drawing.svg" :preview t)
  (with-rotation (stream (/ pi 6))
    (test-drawing stream)))

img

This looks fairly the same! The difference is in size - the result is around 5kB and is 80x smaller than the previous drawing. Not to mention that polygonalizing everything is disgusting a realm of 3d rendering.

The line style

The standard line style has five attributes:

  1. line-style-unit is a unit for measuring thickness and dash length.
    • :coordinate is a device unit (pixel). Lengths are a subject of transformations - the line thickness is scaled along with graphics

    • :point is a physical unit (1/72in). Lengths are not a subject of transformations - the line thickness is independent from transformation

    • :normal is a unit that depends on the renderer. Like a physical unit it is not a subject of scaling. This is a default value and should adapt the underlying device idiosyncrasies - for clx this will be a pixel (that doesn't scale) while the text backend will try to use glyphs that imitate a line (for a reasonably small thickness). As a rule of thumb the line of thickness 1 should match the stroke thickness of text.

  2. line-style-thickness is (hah!) a thickness of the line in units specified by the line-style-unit. The length is pixels may be easily computed by calling line-style-effective-thickness. The default method assumes that the effective thickness may be a float and that the unit :normal is commensurate with a pixel3.

    ;; Example method assuming that the underlying engine accepts only integers
    (defmethod line-style-effective-thickness
        (line-style (medium fixated-medium))
      (floor (+ .5 (call-next-method))))
    
  3. line-style-dashes defaults to nil (no dashes). It may be also specified as t, then dashes depend on the rendering engine.

    When line-style-dashes is a sequence then it must have an even number of elements where consecutive pairs are "fill" and "gap" values specified in units specified by the line-style-unit. Like with the line thickness McCLIM provides a function line-style-effective-dashes. Tentatively it is permissible for the renderer to not fully support line dashes.

  4. line-cap-shape specifies the shape for the ends of lines. Possible values are :butt, :square, :round or :no-end-point. It is permissible for the renderer to not fully support all cap shapes.

  5. line-joint-shape specifies the shapes of joints between segments of unfilled figures. The possible values are :miter, :bevel, :round and :none (the default is :miter). It is permissible for the renderer to not fully support all cap shapes.

    McCLIM specifies a generic function medium-miter-limit. When the line-style-joint-shape is :miter and the angle between two joined lines is less than the limit, then :bevel style is used.

As for the SVG renderer - most attributes map easily to the SVG element attributes and the implementation is very straightforward.

The only exception is the miter limit that must be casted between representations - McCLIM specifies the angle between lines while SVG specifies a ratio of the miter length to the stroke width.

Without further ado:

(defun svg-miter-limit (miter-limit-as-angle)
  ;; svg-miter-limit = miter-length / stroke-width = 1 / sin(theta/2)
  (/ 1 (sin (/ miter-limit-as-angle 2))))

(defun invoke-with-drawing-context (cont medium mode)
  ...
  (labels (...
           (configure-path ()
             (let* ((line-style (medium-line-style medium))
                    (thickness (fmt (line-style-effective-thickness line-style medium)))
                    (dashes (map 'list #'fmt (line-style-effective-dashes line-style medium)))
                    (cap-shape (ecase (line-style-cap-shape line-style)
                                      ((:butt :no-end-point) "butt")
                                      (:square "square")
                                      (:round "round")))
                    (joint-shape (ecase (line-style-joint-shape line-style)
                                        ((:bevel :none) "bevel")
                                        (:miter "miter")
                                        (:round "round")))
                    (miter-limit (svg-miter-limit (medium-miter-limit medium))))
               (cl-who:htm
                 (:g :stroke-width thickness
                     :stroke-dasharray (format nil "~{~a~^ ~}" dashes)
                     :stroke-linecap cap-shape
                     :stroke-linejoin joint-shape
                     :miter-limit miter-limit
                     (funcall cont drawable))))
             ...))
    ...))

For example:

(defun test-line-style (stream)
  (labels ((draw-lines (&rest options)
             (apply #'draw-line* stream 10 10 90 10 options)
             (apply #'draw-line* stream 10 20 90 20 :line-thickness 4 options)
             (apply #'draw-line* stream 10 30 90 30 :line-thickness 4 :line-dashes t options)
             (apply #'draw-line* stream 10 40 90 40 :line-thickness 4 :line-dashes #(8 8 4 4) options)
             (apply #'draw-polygon* stream  '(10 75 30 50 50 100 100 75)
                    :line-thickness 2 :filled nil options)))
    (with-translation (stream 0 0)
      (draw-lines))
    (with-translation (stream 0 100)
      (draw-lines :line-style (make-line-style :joint-shape :round :cap-shape :round)))
    (with-translation (stream 100 0)
      (with-scaling (stream 2 2)
        (draw-lines :line-style (make-line-style :unit :coordinate :joint-shape :round))))
    (with-translation (stream 300 0)
      (with-scaling (stream 2 2)
        (draw-lines :line-unit :normal)))))

(with-output-to-drawing-stream (stream :svg "/tmp/line-styles.svg" :preview t)
  (test-line-style stream))

img

The text style

The text style in CLIM is specified by three components:

  1. text-style-family specifies the family of the text style. Families that must be recognized by the backend are :serif, :sans-serif and :fix.

  2. text-style-face specifies the face of the text style. Faces that must be recognized by the backend are :roman, :bold and :italic. It is possible that the text face will be also a list (:bold :italic) or (:italic :bold).

  3. text-style-size is either specified in printer points (1/72 inch) or as a logical size (:normal, :tiny, :very-small, :small, :large, :very-large, :huge) and a relative size (:smaller or :larger) - relative sizes are merged with the *default-text-style.

McCLIM extends the legal values of family and face to include strings (in additional to portable keyword symbols). Each backend defines its specific syntax for these families and faces - using such text style is not portable across backends. When the backend can't parse the text style then it should fall back to *undefined-text-style*.

(make-text-style "fantasy" "oblique" :normal)

The function parse-text-style* takes the medium, the text style and returns a normalized text style:

  • device text styles are returned as is (backend-specific text styles)
  • unspecified components are filled from the *default-text-style*
  • the size is normalized to a number (specified in printer points)
  • when values are invalid then *undefined-text-style* is returned

SVG is more elaborate with font styles and we won't support all options, however To illustrate a possible direction for extensions we will do minor parsing of a font face. Non-portable font family will be passed verbatim.

(defun svg-parse-text-style-family (text-style-family)
  (case text-style-family
    (:serif "serif")
    (:sans-serif "sans-serif")
    (:fix "monospace")
    (otherwise text-style-family)))

;;; Returns values: font-style, font-weight and font-variant.
(defun svg-parse-text-style-face (text-style-face)
  (etypecase text-style-face
    (symbol
     (ecase text-style-face
       (:italic (values "italic" "normal" "normal"))
       (:bold   (values "normal" "bold"   "normal"))
       (:roman (values "normal" "normal" "normal"))))
    (list
     (values (if (member :italic text-style-face) "italic" "normal")
             (if (member :bold   text-style-face) "bold"   "normal")
             "normal"))
    (string
     (handler-case (let* ((s1 (position #\- text-style-face))
                          (s2 (position #\- text-style-face :start (1+ s1)))
                          (style   (subseq text-style-face 0 s1))
                          (weight  (subseq text-style-face (1+ s1) s2))
                          (variant (subseq text-style-face (1+ s2))))
                     (values style weight variant))
       (error ()
         (svg-parse-text-style-face
          (text-style-face *undefined-text-style*)))))))

(defun invoke-with-drawing-context (cont medium mode)
  ...
  (labels (...
           (configure-text ()
             (multiple-value-bind (family face size)
                 (text-style-components (parse-text-style* (medium-text-style medium)))
               (let ((font-family (svg-parse-text-style-family family)))
                 (multiple-value-bind (font-style font-weight font-variant)
                     (svg-parse-text-style-face face)
                   (cl-who:htm
                     (:g :font-family font-family
                         :font-style font-style
                         :font-weight font-weight
                         :font-variant font-variant
                         :font-size size
                         (funcall cont drawable))))))))
    ...))

For example:

(defun test-text-style (stream)
  (draw-rectangle* stream 0 0 300 300 :ink +light-cyan+)
  (loop for dy from 50 by 50
        for family in '(:serif :sans-serif :fix "fantasy")
        for style  in '(:roman :bold (:bold :italic) :italic)
        for size in   '(:normal :small :large :smaller)
        for ts = (make-text-style family style size) do
          (draw-text* stream "Hello World" 20 dy :align-y :top :text-style ts :ink +dark-red+)))

(with-output-to-drawing-stream (stream :svg "/tmp/smoke-text.svg" :preview t)
  (test-text-style stream))

img

Arbitrary clip regions

We've already implemented clipping the output to a solid degree. We rely on the function draw-design that is expected to draw the path for us. That does not work for region intersections and complements because they can't be represented as simple regions.

Conceptually there are a few possible approaches to the intersection. For example the most intuitive one, we could clip the clipping path:

<clipPath id='clip1' clip-path='none')...</clipPath>
<clipPath id='clip2' clip-path='url(#clip1)'>...</clipPath>
<clipPath id='clip3' clip-path='url(#clip2)'>...</clipPath>

But this approach doesn't work on "modern" web browsers. Alternatively we could use the feComposite filter using patterns loaded with the filter feImage:

<pattern id='clip1' ...>...</pattern>
<pattern id='clip2' ...>...</pattern>
<filter id='intersection' x=0 y=0 width=100% height=100% filterUnits='userSpaceOnUse'>
  <feImage xlink:href="#clip1" result="stencil1" />
  <feImage xlink:href="#clip2" result="stencil2" />
  <feComposite in="SourceGraphic" in2="stencil1" operator="in" />
  <feComposite
      in2="stencil2" operator="in" />
</filter>
<mask id='mask' x=0 y=0 width=100% height=100% maskUnits='userSpaceOnUse'
      fill='white' filter='url(#intersection)'>
  <rect x=0 y=0 width='100%' height='100%' />
</mask>

Needless to say this works even worse across SVG renderers. We need to use masks. We'll start with the region complement as the easier one. While the region complement in theory is infinite, in practice we are always working on a bounded region:

  • fill the drawing plane with "white"
  • fill the complementary shape with "black"

Code:

(defmethod medium-clip ((medium svg-medium) (region standard-region-complement))
  (let ((id (ensure-resource-id (medium (cons :mask region))
              (cl-who:with-html-output (drawable (medium-drawable medium) :indent t)
                (:defs nil nil
                  (let ((pattern-id
                          (ensure-resource-id (medium (cons :mask-pattern region))
                            (cl-who:htm (:pattern :id ^resource-id :|patternUnits| "userSpaceOnUse"
                                         :x 0 :y 0 :width "100%" :height "100%")
                                        (let ((*fgcolor* "white"))
                                          (draw-design medium +everywhere+))
                                        (let ((*fgcolor* "black"))
                                          (draw-design medium (region-complement region)))
                                        ))))
                    (cl-who:htm
                     (:mask :id ^resource-id :|maskUnits| "userSpaceOnUse"
                      :x 0 :y 0 :width "100%" :height "100%"
                      (:rect :x 0 :y 0 :width "100%" :height "100%" :fill (url pattern-id))))))))))
    (cons :mask (url id))))

The intersection is implemented as follows:

  • for each region being part of the intersection construct a mask from the shape's pattern
  • regions other than the first one are masked by the previous mask

For example:

  1. draw mask-1 as a rectangle with a fill pattern-1
  2. draw mask-2 as a rectangle with a fill pattern-2 and masked with mask-1
  3. draw mask-3 as a rectangle with a fill pattern~3 and masked with mask-2

Code

(defmethod medium-clip ((medium svg-medium) (clip standard-region-intersection))
  (let ((mask-id "none"))
    (cl-who:with-html-output (drawable (medium-drawable medium) :indent t)
      (:defs nil nil
        (labels ((add-pattern (region)
                   (ensure-resource-id (medium (cons :mask-pattern region))
                     (cl-who:htm (:pattern :id ^resource-id :|patternUnits| "userSpaceOnUse"
                                  :x 0 :y 0 :width "100%" :height "100%"
                                  (etypecase region
                                    (standard-region-intersection
                                     (error "BUG: not canonical form!"))
                                    (standard-region-complement
                                     (cl-who:htm (:g :fill "white" (draw-design medium +everywhere+)))
                                     (cl-who:htm (:g :fill "black" (draw-design medium (region-complement region)))))
                                    (bounding-rectangle
                                     (cl-who:htm (:g :fill "white" (draw-design medium region)))))))))
                 (add-mask (pattern-id mask-id)
                   (ensure-resource-id (medium (cons :mask pattern-id))
                     (cl-who:htm
                      (:mask :id ^resource-id :|maskUnits| "userSpaceOnUse"
                       :x 0 :y 0 :width "100%" :height "100%"
                       (:rect :x 0 :y 0 :width "100%" :height "100%"
                              :fill pattern-id :mask mask-id))))))
          (loop for region in (region-set-regions clip)
                for pattern-id = (add-pattern region)
                do (setf mask-id (url (add-mask (url pattern-id) mask-id)))))))
    (values :mask mask-id)))

This covers pretty much all possible clipping regions possible with McCLIM. Most renderers I've tried are able to handle such clip paths.

(defun test-clipping (stream show-hints-p)
  (let* ((regions (list (make-rectangle* 25 25 175 175)
                        (make-rectangle* 150 25 300 175)
                        (make-rectangle* 25 150 175 300)
                        (make-ellipse* 225 225 90 0 0 90)))
         (inter (reduce #'region-intersection regions :initial-value +everywhere+))
         (negative (make-ellipse* 162.5 162.5 8 0 0 8))
         (clipping (region-difference inter negative))
         )
    ;; Show the clipping region.
    (when show-hints-p
      (loop for region in regions
            for base-ink in (list +cyan+ +cyan+ +cyan+   +orange+)
            do (draw-design stream region :ink (compose-in base-ink (make-opacity 0.1))))
      (loop for region in regions
            do (draw-design stream region :filled nil :line-dashes t)))
    ;; ;; Draw the thing.
    (with-drawing-options (stream :clipping-region clipping)
      (draw-rectangle* stream 5 5 345 345 :filled t :ink +dark-green+))
    ;; Draw the negative region outline.
    (when show-hints-p
      (draw-design stream negative :ink +dark-red+ :filled nil :line-dashes '(4 4) :line-thickness 2))))

(with-output-to-drawing-stream (stream :svg "/tmp/advanced-clipping.svg" :preview t)
  (test-clipping stream t))

img

The last 1% of drawing

True to the ninety-ninety-ninety rule we have a few features that need to be implemented for the backend to be "100%" complete. Don't expect all backends to implement every feature mentioned in this section. SVG does not have a proper support for composition so "general designs" may be only partially implemented.

For example is the medium-clear-area - it is expected to perform a "source" composition while we are forced to rely on the default method that does an "over" composition with a solid fill. Another one is a flipping ink - it requires an access to the background image and to perform a boole xor operation on the background and the ink colors.

;;; Clearing the area is a "source"-composition - not the same as drawing the
;;; rectangle which is an "over"-composition. Given that SVG 1.1 doesn't seem to
;;; specify such compsition let's take that the default method is "good enough".
;;; -- jd 2022-03-17
#+ (or)
(defmethod medium-clear-area ((medium svg-medium) x1 y1 x2 y2)
  (multiple-value-bind (fill opacity)
      (medium-design-ink medium (medium-background medium))
    (with-drawing-context (drawable medium)
      (cl-who:with-html-output (stream drawable)
        (:rect :x x1 :y y1 :width (- x2 x1) :height (- y2 y1)
               :fill fill :opacity opacity :stroke *nocolor* :comp-op "src")))))

;;; Flipping ink requires access to the underlying picture to mix with the
;;; background. So-called "modern" browsers apparently can't implement the
;;; "BackgroundImage" input source. Imaginary implementation could look
;;; something like this. This is not entirely true - the "xor" filter in
;;; feComposite seems to work only on the alpha channel.. -- jd 2022-03-24
#+ (or)
(defmethod medium-design-ink ((medium svg-medium) (design climi::standard-flipping-ink))
  (let* ((filter-id
           (ensure-resource-id (medium (cons :filter design))
             (let* ((ink1 (slot-value design 'climi::design1))
                    ;; (ink2 (slot-value design 'climi::design2))
                    ;; (logxor (format nil "#~x" (logxor (rgb-as-hex ink1) (rgb-as-hex ink2))))
                    (logxor (uniform-design-values ink1)))
               (cl-who:with-html-output (drawable (medium-drawable medium))
                 (:defs nil nil
                   (:filter :id ^resource-id :|filterUnits| "userSpaceOnUse" :x 0 :y 0 :width "100%" :height "100%"
                            (:|feFlood| :flood-color logxor :result "xor-source")
                            (:|feComposite| :in "xor-source" :operation "xor" :in2 "BackgroundImage")))))))
         (pattern-id
           (ensure-resource-id (medium (cons :pattern design))
             (cl-who:with-html-output (drawable (medium-drawable medium))
               (:defs nil nil
                 (:pattern :id ^resource-id :x 0 :y 0 :width "100%" :height "100%"
                           :|patternUnits| "userSpaceOnUse"
                           (:rect :width "100%" :height "100%" :filter (url filter-id))))))))
    (values (url pattern-id) *opacity*)))

Without inquiring too much general designs may be characterized as:

  • bounded or unbounded
  • uniform or non-uniform
  • solid or translucent
  • colorless or colored

Designs we have worked with until now were:

design bounded uniform solid colorless
region both no yes yes
color no yes yes no
opacity no yes no yes
uniform-compositum no yes no no

An indirect ink is a special design that is a "trampoline" to another one - it doesn't have any predefined characteristics.

Other designs that weren't mentioned yet are:

  • composite designs: in-compositum, out-compositum, over-compositum
  • pattern: an indexed array with other designs as inks
  • stencil: an array with opacities
  • tiled design: a design that repeats itself
  • transformed design: a design with a transformation
  • output record design: a vector graphics design

The concept of design is an unification of a shape, a color and an opacity. Depending on the function call the design may be used as clipping region, a paint or a mask. For example in the call below ~ is used only for the opacity value, the "blue part" is ignored.

(draw-design <rectangle> :ink (compose-in +red+ <translucent-blue>))

Images, tiles and transformed patterns

It is said that cat pictures make about 90% of the internet, the rest is the content generated by AI. Time to draw a raster image. Here is a function that encodes images in a form that may be embedded in SVG:

(defun encode-svg-pattern (pattern &optional (format :jpeg))
  (check-type format (member :png :jpeg))
  (with-output-to-string (stream)
    (format stream "data:image/~(~a~);base64," format)
    (cl-base64:usb8-array-to-base64-stream
     (flexi-streams:with-output-to-sequence (octet-stream)
       (climi::write-bitmap-file pattern octet-stream :format format))
     stream)))

Patterns may be categorized in three groups:

  • simple pattern: a rectangle with the origin at [0,0]
  • rectangular-tile: a pattern that repeats itself
  • transformed-pattern: a pattern with an associated transformation

A simple pattern is limited by its dimensions. In the code bellow the size of the pattern is 100% while the image has finite width and height. We do that because SVG patterns are rectangular tiles in CLIM terminology and by making them this big we prevent the repetition.

(defmethod medium-design-ink ((medium svg-medium) (pattern image-pattern))
  (let ((id (ensure-resource-id (medium (cons :image pattern))
              (let* ((href (encode-svg-pattern pattern)) ;; :png for alpha channel
                     (width (pattern-width pattern))
                     (height (pattern-height pattern)))
                (cl-who:with-html-output (drawable (medium-drawable medium))
                  (:defs nil nil
                    (:pattern :id ^resource-id :x 0 :y 0 :width "100%" :height "100%"
                              :|patternUnits| "userSpaceOnUse"
                              (:image :|xlink:href| href :x 0 :y 0 :width (fmt width) :height (fmt height)))))))))
    (values (url id) 1.0)))

To display the image we may either use the function draw-pattern or use the image as an ink. There is an important difference between these two methods:

  • when used as an ink, then the pattern is anchored at the viewport's origin
  • when drawn with draw-pattern, then the pattern may be transformed if it is not located at the viewport's origin

Example:

(defvar *kitten*
  (make-pattern-from-bitmap-file
   (asdf:component-pathname
    (asdf:find-component "clim-examples" '("images" "kitten.jpg")))))

(defun draw-the-internet (stream precision)
  (assert (< precision 90))
  (draw-circle* stream 550 180 150 :ink *kitten*))

(with-output-to-drawing-stream (stream :svg "/tmp/internet.svg" :preview t)
  (draw-the-internet stream 88))

img

A rectangular tile takes the source design and repeats it after specified width and height. Its implementation is very similar to the image pattern, but in this case the svg pattern size is not "100%" of the viewport but the tile size, so it repeats itself.

(defmethod medium-design-ink ((medium svg-medium) (pattern rectangular-tile))
  (let ((id (ensure-resource-id (medium (cons :design-ink pattern))
              (let* ((src-pattern (rectangular-tile-design pattern))
                     (src-id (medium-design-ink medium src-pattern))
                     (src-width (fmt (pattern-width src-pattern)))
                     (src-height (fmt (pattern-height src-pattern)))
                     ;;
                     (tile-width (fmt (pattern-width pattern)))
                     (tile-height (fmt (pattern-height pattern))))
                (cl-who:with-html-output (drawable (medium-drawable medium))
                  (:defs nil nil
                    (:pattern :id ^resource-id :x 0 :y 0 :width tile-width :height tile-height
                              :|patternUnits| "userSpaceOnUse"
                              (:rect :x 0 :y 0 :width src-width :height src-height :fill src-id))))))))
    (values (url id) 1.0)))

For example:

(defvar *checkers-array*
  (let ((array (make-array '(100 100) :element-type 'fixnum :initial-element 0)))
    (loop for row from 0 below 50 do
      (loop for col from 0 below 50 do
        (setf (aref array row col) 1)
        (setf (aref array (- 99 row) (- 99 col)) 1)))
    array))

(defun make-checkers (design1 design2 width height)
  (make-rectangular-tile
   (make-pattern *checkers-array* (list design1 design2))
   width height))

(defun draw-rectangular-tile (stream)
  (let ((pattern (make-checkers +black+ +white+ 75 75)))
    (draw-circle* stream 550 180 150 :ink pattern)
    (draw-circle* stream 550 180 150 :ink +dark-blue+ :filled nil :line-thickness 4)))

(with-output-to-drawing-stream (stream :svg "/tmp/tile.svg" :preview t)
  (draw-rectangular-tile stream))

img

Designs have the same origin and orientation as the native region. It is possible to transform a design - in that case its origin and orientation may change. When the source design is bounded then the transformed design is also bounded. For tiles it is not bounded.

It is important to apply the transformation to the whole pattern instead of applying it to the source design and tile the result. Otherwise the result may be wrong when the design is rotated - tiled parts won't be connected.

(defmethod medium-design-ink ((medium svg-medium) (pattern transformed-pattern))
  (let ((id (ensure-resource-id (medium (cons :design-ink pattern))
              (let* ((transform (svg-transform (transformed-design-transformation pattern)))
                     (src-pattern (transformed-design-design pattern))
                     (src-id (medium-design-ink medium src-pattern))
                     (src-width (fmt (pattern-width src-pattern)))
                     (src-height (fmt (pattern-height src-pattern)))
                     ;;
                     (tilep (typep src-pattern 'rectangular-tile))
                     (width  (if tilep src-width  "100%"))
                     (height (if tilep src-height "100%")))
                (cl-who:with-html-output (drawable (medium-drawable medium))
                  (:defs nil nil
                    (:pattern :id ^resource-id :x 0 :y 0 :width width :height height
                              :|patternUnits| "userSpaceOnUse"
                     :|patternTransform| transform
                     (:rect :x 0 :y 0 :width src-width :height src-height :fill src-id))))))))
    (values (url id) 1.0)))

For example:

(defun draw-transformed-tile (stream)
  (let* ((pattern (transform-region
                   (make-rotation-transformation (/ pi 6))
                   (make-checkers +black+ +white+ 75 75))))
    (draw-circle* stream 550 180 150 :ink pattern)
    (draw-circle* stream 550 180 150 :ink +dark-blue+ :filled nil :line-thickness 4)))

(with-output-to-drawing-stream (stream :svg "/tmp/transformed.svg" :preview t)
  (draw-transformed-tile stream))

img

Finally a default method that should work for any other pattern:

(defmethod medium-design-ink ((medium svg-medium) (pattern pattern))
  (let ((id (ensure-resource-id (medium (cons :design-ink pattern))
              (let* ((href (encode-svg-pattern pattern :png))
                     (width (pattern-width pattern))
                     (height (pattern-height pattern)))
                (cl-who:with-html-output (drawable (medium-drawable medium))
                  (:defs nil nil
                    (:pattern :id ^resource-id :x 0 :y 0 :width "100%" :height "100%"
                              :|patternUnits| "userSpaceOnUse"
                              (:image :|xlink:href| href :x 0 :y 0 :width (fmt width) :height (fmt height)))))))))
    (values (url id) 1.0)))

Recursive designs

When the source design is "flat" then things are simple, but the source may be also a recursive pattern. For example when we tile an indexed pattern that uses non-uniform designs as inks, then it may show different design in different repetitions. The same concern applies to transformed patterns - only the pattern is transformed, not inks used as its palette. For example:

(defvar *checkers-array*
  (let ((array (make-array '(100 100) :element-type 'fixnum :initial-element 0)))
    (loop for row from 0 below 50 do
      (loop for col from 0 below 50 do
        (setf (aref array row col) 1)
        (setf (aref array (- 99 row) (- 99 col)) 1)))
    array))

(defun make-checkers (design1 design2)
  (make-rectangular-tile
   (make-pattern *checkers-array* (list design1 design2))
   100 100))

(defun draw-recursive-pattern (stream)
  (let ((pattern (make-checkers +black+ *kitten*)))
    (draw-circle* stream 550 180 150 :ink pattern)
    (draw-circle* stream 550 180 150 :ink +dark-blue+ :filled nil :line-thickness 4)))

(with-output-to-drawing-stream (stream :svg "/tmp/recursive.svg")
  (draw-recursive-pattern stream))

When implemented naively, the tile repeats the beginning of the kitten design instead of providing "holes" that show the kitten:

img

The pattern should look like this:

img

The most straightforward solution to that is by using composition and treating the indexed pattern as a stencil. Since we don't have any GPU nearby, we will analyze the pattern and decide what to do with it. When we detect a recursive pattern then we collapse it so it may be used on the whole viewport. This is not effective, because for a tile it will encode the image with the same size as the produced document.

Encoding cat pictures that way is grossly inefficient, so when we detect such situation we signal a warning.

(defun maybe-collapse-pattern (pattern)
  (let ((tile-p nil))
    (labels ((unmoveable-pattern-p (design)
               (typecase design
                 (rectangular-tile
                  (setf tile-p t)
                  (unmoveable-pattern-p (rectangular-tile-design design)))
                 (transformed-pattern
                  (unmoveable-pattern-p (transformed-design-design design)))
                 (otherwise
                  (and (typep design 'climi::indexed-pattern)
                       (some (lambda (p)
                               (not (typep p '(or color opacity climi::uniform-compositum))))
                             (climi::pattern-designs design))
                       design)))))
      (when (unmoveable-pattern-p pattern)
        ;; FIXME hardcoded viewport size.
        (if tile-p
            (climi::%collapse-pattern pattern 0 0 *viewport-w* *viewport-h*)
            (with-bounding-rectangle* (x0 y0 :width width :height height) pattern
              (transform-region (make-translation-transformation x0 y0)
                                (climi::%collapse-pattern pattern x0 y0 width height))))))))

;;; This method is very inefficient (evaluation time and memory) and very
;;; expensive (file size). We are flexing to do the right thing. Normally we'd
;;; use palette in-composition using shaders.
(defmethod medium-design-ink :around ((medium svg-medium) (pattern pattern))
  (alx:if-let ((collapsed (maybe-collapse-pattern pattern)))
    (warn "Encoding a collapsed tile as an RGBA image.")
    (let ((id (ensure-resource-id (medium (cons :design-ink pattern))
                (alx:simple-style-warning
                 "Collapsing the pattern for the viewport - this is very inefficient!")
                (let* ((rht (resources (port medium)))
                       (cid (progn (medium-design-ink medium collapsed)
                                   (resource-id medium (cons :design-ink collapsed)))))
                  (setf (gethash (cons :design-ink pattern) rht) cid)
                  (setf ^resource-id cid)))))
      (values (url id) 1.0))
    (call-next-method)))

Masked in- and out- composition

It is possible to provide a stencil when drawing the image. in-compositum and out-compositum both have an ink and a mask. Only the alpha channel is taken from the mask and applied to the ink. out-compositum has the alpha channel values inverted out(alpha) = (1- alpha). For solid masks the result is the same as if we had clipped to the region or its complement.

There two types of masks that should be supported by McCLIM:

  • uniform mask
  • stencil mask

Let's start with the former. Only uniform have methods defined on the function opacity-value:

(defmethod medium-design-ink ((medium svg-medium) (design climi::in-compositum))
  (let ((ink (climi::compositum-ink design))
        (mask (climi::compositum-mask design)))
    (alx:if-let ((opacity (ignore-errors (opacity-value mask))))
      (multiple-value-bind (ink-url ink-opacity)
          (medium-design-ink medium ink)
        (values ink-url (* ink-opacity opacity)))
      (compose-stencil medium design))))

(defmethod medium-design-ink ((medium svg-medium) (design climi::out-compositum))
  (let ((ink (climi::compositum-ink design))
        (mask (climi::compositum-mask design)))
    (alx:if-let ((opacity (ignore-errors (opacity-value mask))))
      (multiple-value-bind (ink-url ink-opacity)
          (medium-design-ink medium ink)
        (values ink-url (* ink-opacity (- 1.0 opacity))))
      (compose-stencil medium design))))

For example:

(defvar *glider*
  (make-pattern-from-bitmap-file
   (asdf:component-pathname
    (asdf:find-component "clim-examples" '("images" "glider.png")))))

(defun draw-masked-compositums (stream mask)
  (let* ((glider (make-rectangular-tile *glider* 100 100))
         (pattern-1 (compose-in glider mask))
         (pattern-2 (compose-out glider mask)))
    (draw-circle* stream 50 50 150 :ink (make-checkers +dark-green+ +dark-blue+ 75 75))
    (draw-circle* stream 50 50 50 :ink pattern-1)
    (draw-circle* stream 100 100 50 :ink pattern-2)
    (draw-circle* stream 50 50 150 :ink +dark-blue+ :filled nil :line-thickness 4)))

(with-output-to-drawing-stream (stream :svg "/tmp/in-out-uniform.svg" :preview t)
  (draw-masked-compositums stream (make-opacity 0.3)))

img

Stencil is an array of opacities. We will simply collapse the pattern. Doing it as a mask is also an option.

;;; Normally we'd use a mask, but this is yet another feature that is handled
;;; differently by every second renderer. That's why we simply flatten the ink
;;; when it is not an uniform compositum.
;;;
;;; CLIM II specification hints that handling only uniform masks is OK.  That
;;; said we still want to support stencils so let's get lazy big time.
(defun compose-stencil  (medium pattern)
  (let* ((pattern* (climi::%collapse-pattern pattern 0 0 *viewport-w* *viewport-h*)))
    (medium-design-ink medium pattern*)))

And a test

(defvar *stencil*
  (let ((array (make-array '(100 100) :element-type '(single-float 0.0 1.0) :initial-element 0.0)))
    (loop for row from 0 below 100 do
      (loop for col from 0 below 100 do
        (setf (aref array row col)
              (- 1.0
                 (/ (sqrt (+ (expt (- row 50) 2)
                             (expt (- col 50) 2)))
                    50.0)))))
    (make-stencil array)))

(defun draw-stencil (stream stencil)
  (let* ((glider (make-rectangular-tile *glider* 100 100))
         (pattern-1 (compose-in glider stencil))
         (pattern-2 (compose-out glider stencil)))
    (draw-circle* stream 50 50 150 :ink (make-checkers +dark-green+ +dark-blue+ 75 75))
    (draw-rectangle* stream 0 0 50 150 :ink pattern-1)
    (draw-rectangle* stream 50 0 100 150 :ink pattern-2)
    (draw-circle* stream 50 50 150 :ink +dark-blue+ :filled nil :line-thickness 4)))

(with-output-to-drawing-stream (stream :svg "/tmp/in-out-stencil.svg" :preview t)
  (draw-stencil stream *stencil*))

img

Features that are not implemented

Default methods defined on basic-medium are often no-op stubs or approximations (like with drawing routines that resort to using draw-polygon). Sometimes the functionality is not applicable to a drawing backend or it is unfeasible to implement it correctly. The following parts of the output protocol are not implemented:

  • src-composition: medium-{clear,copy}-area
  • xor-composition: flipping inks
  • offscreen drawing: invoke-with-output-{buffered,to-pixmap}
  • attracting the user's attention: medium-beep
  • precise font metrics: text-size and text-bounding-rectangle*
  • output record patterns: these are not implemented yet in McCLIM

We are also doing a poor job with composing things - collapsing patterns is correct but inefficient. Sometimes it may be necessary to specialize other medium or port functions, but that varies on case-to-case basis. We could also add some bonus features, like gradient patterns.

Congratulations, we've implemented the medium output protocol targeting an SVG document4!

Conclusions

Implementing the medium output protocol is relatively easy and it gets gradually harder when we exercise more niche features. In this post we've uncovered various shortcoming of the SVG format and renderers. The current ([2022-04-15 Fri]) version of this backend may be found in a feature branch.

In the next part of this tutorial the SVG port will be extended to implement the sheet output recording protocol. It will be much shorter than this one and will cover grafts and sheets.

Footnotes

1 Not all output devices operate on streams of data - sometimes "drawing a rectangle" may involve calling a function from a library. In that case the second argument to the macro could be a handler.

2 Not all SVG renderers I've tried honor the attribute dominant-baseline.

3 Currently it is 1px but I'm considering changing it to 2px so that a rectilinear line of thickness 1 with all coordinates being integers is not a subject of rounding. See the figure 12.7 in the specification.

4 It is worth noting that it is more complete (the last 1%-wise) than pdf and postscript backends.