Skip to content

Instantly share code, notes, and snippets.

@dkochmanski
Last active March 31, 2020 16:52
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save dkochmanski/d262e57862ecfbc23e72853c8fc4f6f5 to your computer and use it in GitHub Desktop.
Save dkochmanski/d262e57862ecfbc23e72853c8fc4f6f5 to your computer and use it in GitHub Desktop.
tutorial.org

Writing CLIM backend tutorial

I had few attempts to write a complete guide for writing a McCLIM backend. This time I will try to do it in few iterations starting from a naive output-only backend, through more complete solution up to the interactive version. Some McCLIM-specific interfaces may be used.

Project skeleton

We are going to write a HTML5 backend. Our output will be targetting a canvas object and we will manipulate it with a generated javascript. Our file hierarchy is somewhat minimalistic. Below is the project skeleton on which we will build the backend.

eu.turtleware.clim.html5-backend.asd
system definition
(in-package #:asdf-user)

(defsystem "eu.turtleware.clim.html5-backend"
  :author "Daniel 'jackdaniel' Kochmański"
  :license "LGPL-2.1+"
  :description "McCLIM backend for creating html5 content."
  :depends-on ("mcclim" "alexandria" "cl-who")
  :components ((:static-file "eu.turtleware.clim.html5-backend.asd")
               (:static-file "eu.turtleware.clim.html5-backend.tutorial.org")
               (:static-file "eu.turtleware.clim.html5-backend.examples.lisp")
               (:file "eu.turtleware.clim.html5-backend")))

(defsystem "eu.turtleware.clim.html5-backend/examples"
  :depends-on ("eu.turtleware.clim.html5-backend" "hunchentoot")
  :components ((:file "eu.turtleware.clim.html5-backend.examples")))
    
eu.turtleware.clim.html5-backend.lisp
implementation
(defpackage #:eu.turtleware.clim.html5-backend
  (:export #:with-html5-stream))
(defpackage #:eu.turtleware.clim.html5-backend.implementation
  (:use #:clim-lisp #:eu.turtleware.clim.html5-backend))
(in-package #:eu.turtleware.clim.html5-backend.implementation)

(defmacro with-html5-stream ((var stream &rest options) &body body)
  (let ((cont (gensym)))
    `(flet ((,cont (,var)
              (declare (ignorable ,var))
              ,@body))
       (declare (dynamic-extent #',cont))
       (invoke-with-html5-stream #',cont ,stream ,@options))))

(defun invoke-with-html5-stream (cont stream &rest options)
  (declare (ignore cont options))
  (setf (cl-who:html-mode) :html5)
  (cl-who:with-html-output (stream stream :prologue t :indent t)
    (:html
     (:head)
     (:body
      (:canvas :id "McCLIM" :width 800 :height 600
               :style "border:1px solid #000000")
      (:script)))))
    
eu.turtleware.clim.html5-backend.examples.lisp
examples
(defpackage #:eu.turtleware.clim.html5-backend.examples
  (:use #:clim-lisp)
  (:local-nicknames (#:html5 #:eu.turtleware.clim.html5-backend))
  (:export #:start #:stop #:test))
(in-package #:eu.turtleware.clim.html5-backend.examples)

(defvar *acceptor* (make-instance 'hunchentoot:easy-acceptor :port 4242))
(defvar *stream* nil)
(defvar *stream-render* nil)

(defun start (&optional debug)
  (when *stream*
    (clim:close *stream*))
  (setf *stream*
        (clim:open-window-stream :record nil :label "CLX"))
  (when *stream-render*
    (clim:close *stream-render*))
  (setf *stream-render*
        (let ((clim:*default-server-path* :clx-fb))
          (clim:open-window-stream :record nil :label "FB")))
  (setf hunchentoot:*catch-errors-p* (not debug))
  (hunchentoot:start *acceptor*))

(defun stop ()
  (when *stream*
    (clim:close *stream*)
    (setf *stream* nil))
  (when *stream-render*
    (clim:close *stream-render*)
    (setf *stream-render* nil))
  (hunchentoot:stop *acceptor*))

(declaim (notinline test))
(defun test (stream)
  (clim:draw-rectangle* stream 100 100 700 500 :ink clim:+dark-blue+))

(hunchentoot:define-easy-handler (say-yo :uri "/yo") ()
  (flet ((show-window-stream (stream)
           (clim:window-clear stream)
           (clim:draw-rectangle* stream 0 0 800 600 :filled nil)
           (test stream)
           (finish-output stream)))
    (show-window-stream *stream*)
    (show-window-stream *stream-render*))
  ;; html5 stream
  (setf (hunchentoot:content-type*) "text/html")
  (with-output-to-string (stream)
    (html5:with-html5-stream (stream stream)
      (test stream))))
    
eu.turtleware.clim.html5-backend.tutorial.org
this tutorial
#1=(#1#)
    

We define two systems: eu.turtleware.clim.html5-backend for backend implementation and eu.turtleware.clim.html5-backend/examples for sample code.

The main system is called eu.turtleware.clim.html5-backend and has two packages:

eu.turtleware.clim.html5-backend
this package exports symbols which are meant to be consumed by the API client. No package (even common-lisp) is used by this package
eu.turtleware.clim.html5-backend.implementation
this is an implementation package where everything is defined. It “uses” eu.turtleware.clim.html5-backend

This package organization is my favourite. The API packages have no code and are used strictly for symbol export and all implementation code is written in a single package. Thanks to this approach there is no risk of symbol name conflicts in a single system. Alternative approaches put a significant burden on me to manage the package definitions (especially when something changes).

Notice also that I’m not using package prefix for defpackage – if someone shadows the symbol when loading my systems I expect that they know what they are doing and it is a deliberate change. Same goes for the operator in-package.

An API of the output-only backend is trival: with-html5-stream is a macro which creates a CLIM stream on which we may perform drawing operations. Macro is responsible for creating the appropriate context and binds the clim stream to a variable. Since our backend outputs the text we may see what will happen if we bind the *standard-output* to the stream:

CL-USER> (add-package-local-nickname "HTML5" "EU.TURTLEWARE.CLIM.HTML5-BACKEND")
#<PACKAGE "COMMON-LISP-USER">

CL-USER> (html5:with-html5-stream (stream *standard-output*)
           (clim:draw-rectangle* stream 0 0 10 10))
<!DOCTYPE html>

<html>
  <head></head>
  <body>
    <canvas id='McCLIM' width='800' height='600' style='border:1px solid #000000'></canvas>
    <script></script>
  </body>
</html>
NIL

An example output above hints how we are going to tackle the problem. First we create a canvas and then generate a script which performs drawing. All in a single HTML document for simplicity.

The interactive testing code defined in the system eu.turtleware.clim.html5-backend/examples is tailored for a differential testing between the html5, the clx and the framebuffer renderer backends. The same body is executed for each context.

The function start opens two CLIM window streams and the hunchentoot acceptor. Function stop closes both windows and the acceptor. When an easy handler say-yo is invoked windows all streams are redrawn by the function test. We test by redefining the test function to perform tested operations and then refresh the page.

Now load the system ~”eu.turtleware.clim.html5-backend/examples”~, start the acceptor and open the browser on http://localhost:4242/yo. Currently with-html5-output is a stub which ignores its body, so the canvas is empty. You should see a dark blue rectangle in two other windows.

A HTML5 canvas crash course

Canvas in HTML5 is a drawing area with an API to access it from JavaScript. To create a canvas it is enough to insert a canvas tag into the html document body:

<canvas id='McCLIM'
        width='800'
        height='600'
        style='border:1px solid #000000'>
</canvas>

ID is used to find the object in the script. All drawing is done through a context handler which may be requested from the canvas object. For instance we could draw a rectangle like this:

<script>
  var canvas = document.getElementById('McCLIM');
  var context = canvas.getContext('2d');
  context.beginPath();
  context.moveTo(0, 0);
  context.lineTo(20, 0);
  context.lineTo(20, 20);
  context.lineTo(0, 20);
  context.closePath();
  context.fill();
</script>

All operations are performed in four steps:

  1. Start a new path with beginPath()
  2. Configure a transformation, a color and a line style (optional)
  3. Create the path with a set of operations like moveTo, lineTo etc
  4. Execute the operation (fill(), stroke() or clip())

For complete reference of available functions see the official w3schools canvas reference. Another useful resource is the MDN API for a canvas rendering context. We will use one extension which is supported by all so-called “modern” browsers, that is a function setLineDash(). Another extension we will use is the Path2D API which allows concatenating paths.

Defining a backend

Macro name with-html-stream clearly indicates, that we are dealing with a stream. CLIM streams are sheets which are the fundamental window abstraction defined by CLIM. A graft is a special kind of sheet directly connected to a display server – usually a root window of the display (i.e the screen, in our case the canvas).

Defining a port

Logical representation of a display service is called a port (i.e an instance maintaining the socket for communication with X11 server, in our case it is a text stream to which we write the html output).

It is possible to have many ports running in McCLIM at the same time. Ports are designated by their server path, if the port can’t be found it is created. For example here is a possible server path for the X11 server (:clx :host "localhost"). The first agument is the backend designator – this symbol plist should have two properties defined:

:port-type
a name of the port class
:server-path-parser
a function taking whole server path and returning its canonicalized version

When McCLIM looks for a port it first canonicalizes the path and then if there is no existing port with the same (equal-wise path), then it creates an instance of it. The find function could look like this:

(defun find-port (&key (server-path *default-server-path*))
  (let* ((port-type          (first server-path))
         (server-path-parser (get port-type :server-path-parser))
         (server-path*       (funcall server-path-parser) server-path)
         (port-type*         (first server-path*)))
    (or (find server-path* *all-ports* :key #'port-server-path :test #'equal)
        (let ((port (make-instance port-type :server-path server-path*)))
          (prog1 port (push port *all-ports*))))))

This means in particular, that the server-path-parser may return a server path with a different backend designator than the original. Without further ado let’s define the port class.

(defclass html5-port (clim:basic-port)
  ;; This stream is an output sink (i.e a html file).
  ((stream :accessor html5-port-stream)))

(defmethod initialize-instance :after ((port html5-port) &key)
  (let* ((options (cdr (clim:port-server-path port)))
         (stream (getf options :stream)))
    (setf (html5-port-stream port) stream))
  (climb:make-graft port))

(setf (get :html5 :port-type) 'html5-port)
(setf (get :html5 :server-path-parser) 'identity)

Defining a stream (in this case also a graft)

Since we are writing a backend which performs only output there is no need for a windowing hierarchy whatsoever. In that case our stream will be both a graft and a standard-extended-output-stream. Things will get more interesting when we will go beyond canvas in the next parts of the tutorial.

The standard extended output stream interface allows us to use the stream in i.e cl:format. Such stream maintains the text cursor position, text style, margins, line break strategy etc. The output recording interface allows us to format the output before it is put on the canvas (i.e to layout a graph).

;;; Represents the canvas.
(defclass html5-stream (clim:graft      ; sheet - a root window
                        clim:sheet-mute-input-mixin ; output only
                        clim:sheet-mute-repainting-mixin ; doesn't repaint itself
                        clim:permanent-medium-sheet-output-mixin ; has a medium
                        clim:standard-extended-output-stream ; maintains a text page
                        clim:standard-output-recording-stream ; records its output
                        )
  ())

(defmethod climb:make-graft
    ((port html5-port) &key (orientation :default) (units :device))
  (make-instance 'html5-stream :port port
                               :mirror (html5-port-stream port)
                               :orientation orientation
                               :units units))

Defining a medium

A medium is responsible for maintaining the drawing context for a sheet and the actual drawing operations are specialized on medium. Display-specific drawing operations are performed on an opaque handler accessed with a function medium-drawable.

The reference to a window system object is called a mirror. We have two arguments for specialization when creating a medium: the port and the sheet class. That allows us to handle different kinds of mirrors on the same port depending on a sheet class.

Initial test function draws a rectangle. To avoid an error we will implement a single (incomplete) method for drawing a rectangle called medium-draw-rectangle*. We will use a slightly modified example from the crash course from before. The medium is expected to emit a javascript code which draws on the canvas.

;;; Maintains a html5-stream drawing context.
(defclass html5-medium (clim:basic-medium)
  ())

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

(defmethod clim:medium-draw-rectangle*
    ((medium html5-medium) x1 y1 x2 y2 filled)
  (let ((mirror (clim:medium-drawable medium))
        (width  (- x2 x1))
        (height (- y2 y1))
        (op     (if filled "fill" "stroke")))
   (format mirror
           "
  var canvas = document.getElementById('McCLIM');
  var context = canvas.getContext('2d');
  context.beginPath();
  context.rect(~f, ~f, ~f, ~f);
  context.closePath();
  context.~a();"
           x1 y1 width height op)))

Creating the context

Now that we have all necessary classes we may create the context in the function invoke-with-html5-stream. We wrap the body in a macro climb:with-port, which binds the variable to a port found from the server path. Then we bind the graft and call the continuation on it in a (:script) section of the html.

(defun invoke-with-html5-stream (cont stream &rest options)
  (declare (ignore options))
  (climb:with-port (port :html5 :stream stream)
    (let ((html5-stream (clim:find-graft :port port)))
      (setf (cl-who:html-mode) :html5)
      (cl-who:with-html-output (stream stream :prologue t :indent t)
        (:html
         (:head)
         (:body
          (:canvas :id "McCLIM" :width 800 :height 600
                   :style "border:1px solid #000000")
          (:script (funcall cont html5-stream))))))))

Now that we have everything in place it is time to test whether the backend works.

> (ql:quickload "eu.turtleware.clim.html5-backend/examples")
> (eu.turtleware.clim.html5-backend.examples:start t)

When you open now the url http://localhost:4242/yo in a web browser which implements html5 canvas you should see a black rectangle. Also in two created windows you should see rectangles with the same size but filled with a blue color. If you check the source of the web page you will see the generated script.

Drawing on canvas

A backend is expected to implement a few medium-specific drawing functions. Higher levels of abstraction will use that for rendering. Proper drawing requires drawing a shape with properties derived from the medium: a line style, a filling style, a text style and a clipping region.

To bring a joy of the interactive development we will introduce a new test function and drawing methods stubs, so after modifying each method we’ll be able to recompile it and refresh the page to see the result immedietely. The new test function will draw each shape in a box normalized to coordinates [0,0] -> [1,1]. Modify the test function in the examples file. For now we will fill two first rows with various figures.

Keep in mind, that even the reference backend may exhibit some invalid behavior, that’s why different outputs (i.e the framebuffer drawing and x11 protocol drawing) may differ. Differences may be also a result of different implementation of the same concepts.

(defun test (stream)
  ;; draw a grid
  (loop for x from 100 upto 700 by 100
        do (clim:draw-line* stream x 0 x 600))
  (loop for y from 100 upto 600 by 100
        do (clim:draw-line* stream 0 y 800 y))
  (clim:with-drawing-options (stream :line-thickness 5)
    (macrolet ((with-box ((column row) &body body)
                 "Estabilishes normalized local coordinates."
                 `(clim:with-translation (stream (* ,column 100) (* ,row 100))
                    (clim:with-scaling (stream 100 100)
                      ,@body))))
      (flet ((test-point ()
               (clim:draw-point* stream .5 .5))
             (test-points ()
               (let* ((coords-1 '(.5 .1 .5 .3 .5 .7 .5 .9))
                      (coords-2 '(.1 .5 .3 .5 .7 .5 .9 .5))
                      (coords (append coords-1 coords-2)))
                 (clim:draw-points* stream coords)))
             (test-line ()
               (clim:draw-line* stream .1 .1 .9 .9))
             (test-lines ()
               (let* ((coords-1 '(.1 .1 .9 .9))
                      (coords-2 '(.1 .9 .9 .1))
                      (coords (append coords-1 coords-2)))
                 (clim:draw-lines* stream coords)))
             (test-polyline ()
               (let* ((coords-1 '(.1 .1 .9 .9))
                      (coords-2 '(.1 .9 .9 .1))
                      (coords (append coords-1 coords-2)))
                 (clim:draw-polygon* stream coords :filled nil :closed t)))
             (test-frame ()
               (clim:draw-rectangle* stream .1 .1 .9 .9 :filled nil))
             (test-frames ()
               (let* ((coords-1 '(.1 .1 .5 .5))
                      (coords-2 '(.3 .3 .9 .9))
                      (coords (append coords-1 coords-2)))
                 (clim:draw-rectangles* stream coords :filled nil)))
             (test-elliptical-arc ()
               ;; draw radius lines to make things more apparent
               (multiple-value-bind (cx cy rdx1 rdy1 rdx2 rdy2)
                   (values .5 .5 .3 .3 -.2 .2)
                 (clim:with-drawing-options (stream :line-thickness 1 :line-dashes t)
                   (clim:draw-line* stream cx cy (+ cx rdx1) (+ cy rdy1))
                   (clim:draw-line* stream cx cy (+ cx rdx2) (+ cy rdy2)))
                 (clim:draw-ellipse* stream cx cy rdx1 rdy1 rdx2 rdy2
                                     :filled nil :start-angle 0 :end-angle (* 3/2 pi))))
             (test-polygon ()
               (let* ((coords-1 '(.1 .1 .9 .9))
                      (coords-2 '(.1 .9 .9 .1))
                      (coords (append coords-1 coords-2)))
                 (clim:draw-polygon* stream coords :filled t)))
             (test-rectangle ()
               (clim:draw-rectangle* stream .1 .1 .9 .9 :filled t))
             (test-rectangles ()
               (let* ((coords-1 '(.1 .1 .5 .5))
                      (coords-2 '(.3 .3 .9 .9))
                      (coords (append coords-1 coords-2)))
                 (clim:draw-rectangles* stream coords :filled t)))
             (test-ellipse ()
               (multiple-value-bind (cx cy rdx1 rdy1 rdx2 rdy2)
                   (values .5 .5 .3 .3 -.2 .2)
                 (clim:draw-ellipse* stream cx cy rdx1 rdy1 rdx2 rdy2
                                     :filled t :start-angle 0 :end-angle (* 3/2 pi))))
             (test-text-1 ()
               (clim:draw-text* stream "hello world!" .5 .5
                                :align-x :center :align-y :center))
             (test-text-2 ()
               (clim:with-rotation (stream (/ pi 4) (clim:make-point .5 .5))
                 (clim:with-scaling (stream .01 .01 (clim:make-point .5 .5))
                   (clim:draw-text* stream "hello world!" .5 .5
                                    :align-x :center :align-y :center
                                    :transform-glyphs t))))
             (test-text-3 ()
               (clim:draw-text* stream "hello world!" 1.0 1.0
                                :align-x :right :align-y :bottom))
             (test-text-4 ()
               ;; draw a helper line
               (clim:with-drawing-options (stream :line-thickness 1 :line-dashes t)
                 (clim:draw-line* stream .1 .3 .9 .8))
               (clim:draw-text* stream "hello world!" .1 .3
                                :toward-x .9 :toward-y .8)))
        (with-box (0 0) (test-point))
        (with-box (1 0) (test-points))
        (with-box (2 0) (test-line))
        (with-box (3 0) (test-lines))

        (with-box (4 0) (test-polyline))
        (with-box (5 0) (test-frame))
        (with-box (6 0) (test-frames))
        (with-box (7 0) (test-elliptical-arc))

        (with-box (0 1) (test-text-1))
        (with-box (1 1) (test-text-2))
        (with-box (2 1) (test-text-3))
        (with-box (3 1) (test-text-4))

        (with-box (4 1) (test-polygon))
        (with-box (5 1) (test-rectangle))
        (with-box (6 1) (test-rectangles))
        (with-box (7 1) (test-ellipse))))))

Also we want to know when something goes wrong, so we will wrap the html5 stream invocation in the handler-case operator:

(hunchentoot:define-easy-handler (say-yo :uri "/yo") ()
  (flet ((show-window-stream (stream)
           (clim:window-clear stream)
           (clim:draw-rectangle* stream 0 0 800 600 :filled nil)
           (test stream)
           (finish-output stream)))
    (show-window-stream *stream*)
    (show-window-stream *stream-render*))
  ;; html5 stream
  (setf (hunchentoot:content-type*) "text/html")
  (handler-case (with-output-to-string (stream)
                  (html5:with-html5-stream (stream stream)
                    (test stream)))
    (error (c)
      (setf (hunchentoot:content-type*) "text/plain")
      (format nil "~a" c))))

Finally, to avoid too many errors from the start we will define “default” methods which do nothing. Since our stream is recording output it needs to know text dimensions, we will provide a method stub for the function climb:text-bounding-rectangle* too.

(defmethod clim:medium-draw-point*     ((medium html5-medium) x y))
(defmethod clim:medium-draw-line*      ((medium html5-medium) x1 y1 x2 y2))
(defmethod clim:medium-draw-polygon*   ((medium html5-medium) coord-seq closed filled))
(defmethod clim:medium-draw-rectangle* ((medium html5-medium) x1 y1 x2 y2 filled))
(defmethod clim:medium-draw-ellipse*   ((medium html5-medium) cx cy rdx1 rdy1 rdx2 rdy2
                                        start-angle end-angle filled))
(defmethod climb:medium-draw-text*     ((medium html5-medium) string x y start end
                                        align-x align-y toward-x toward-y transform-glyphs))

(defmethod climb:text-bounding-rectangle*
    ((medium html5-medium) string
     &key text-style start end align-x align-y direction)
  (declare (ignore medium string text-style start end
                   align-x align-y direction))
  (values 0 0 0 0))

Drawing shapes

  • medium-draw-point* (medium x y)

    HTML5 canvas API does not mention points, however it does mention drawing arcs and point is a small circle. We set the radius to .5.

    (defmethod clim:medium-draw-point* ((medium html5-medium) x y)
      (let ((mirror (clim:medium-drawable medium)))
        (format mirror "context.beginPath();~%")
        (format mirror "context.arc(~f, ~f, ~f, ~f, ~f);~%" x y .5 0 (* 2 pi))
        (format mirror "context.fill();")))
        
  • medium-draw-line* (medium x1 y1 x2 y2)

    Drawing a line requires moving the pen first to the line start coordinate. Then we use a function lineTo and stoke the path.

    (defmethod climb:medium-draw-line* ((medium html5-medium) x1 y1 x2 y2)
      (let ((mirror (clim:medium-drawable medium)))
        (format mirror "context.beginPath();~%")
        (format mirror "context.moveTo(~f, ~f);~%" x1 y1)
        (format mirror "context.lineTo(~f, ~f);~%" x2 y2)
        (format mirror "context.stroke();~%")))
        
  • medium-draw-polygon* (medium coord-seq closed filled)

    Drawing a polygon (or a polyline!) poses little more problem. First we need to move the pen, and then draw lines until coord-seq has ended. After that optinally we need to close the path.

    (defmethod climb:medium-draw-polygon* ((medium html5-medium) coord-seq closed filled)
      (let ((mirror (clim:medium-drawable medium)))
        (format mirror "context.beginPath();~%")
        (loop with coords = (coerce coord-seq 'list)
              with x1 = (pop coords)
              with y1 = (pop coords)
                initially
                   (format mirror "context.moveTo(~f, ~f);~%" x1 y1)
              for (x y) on coords by #'cddr
              do
                 (format mirror "context.lineTo(~f, ~f);~%" x y)
              finally
                 (when closed
                   (format mirror "context.closePath();~%")))
        (if filled
            (format mirror "context.fill();")
            (format mirror "context.stroke();"))))
        
  • medium-draw-rectangle*

    Unlike CLIM canvas’s API requires width and height of the rectangle instead of coordinates of the opposite vertex.

    (defmethod clim:medium-draw-rectangle* ((medium html5-medium) x1 y1 x2 y2 filled)
      (let ((mirror (clim:medium-drawable medium)))
        (format mirror "context.beginPath();~%")
        (format mirror "context.rect(~f, ~f, ~f, ~f);~%" x1 y1 (- x2 x1) (- y2 y1))
        (if filled
            (format mirror "context.fill();")
            (format mirror "context.stroke();~%"))))
        
  • medium-draw-ellipse* (medium cx cy rdx1 rdy1 rdx2 rdy2 start-angle end-angle filled)

    Drawing an ellipse as it is specified is a bit problematic. Radiuses are not necessarily orthogonal, the ellipse may be rotated and have the start-angle and the end-angle[fn:1]. The canvas API has the function arc, however it is used only for drawing circles. Fortunetely for us we may apply a transformation to the canvas to draw the ellipse. This approach is not entirely right, but we’ll focus on correcting that in a separate section.

    I’ll use the CLIM internal function to reparametrize an ellipse to have more drawing-friendly representation: two scalar radiuses and a rotation. Then we’ll use that to apply the necessary tranformations, correct angles and to draw the circle.

    (defmethod clim:medium-draw-ellipse* ((medium html5-medium) cx cy rdx1 rdy1 rdx2 rdy2
                                          start-angle end-angle filled)
      (let ((mirror (clim:medium-drawable medium)))
        (format mirror "context.beginPath();~%")
        (multiple-value-bind (a b theta)
            (climi::reparameterize-ellipse rdx1 rdy1 rdx2 rdy2)
          (format mirror "context.save();~%")
          (format mirror "context.translate(~f, ~f);~%" cx cy)
          (format mirror "context.rotate(~f);~%" theta)
          (format mirror "context.scale(~f, ~f);~%" (/ a b) -1)
          (format mirror "context.arc(~f, ~f, ~f, ~f, ~f, false);~%" 0 0 b
                  (+ start-angle theta) (+ end-angle theta))
          (format mirror "context.restore();~%"))
        (if filled
            (progn (format mirror "context.lineTo(~f, ~f);~%" cx cy)
                   (format mirror "context.fill();~%"))
            (format mirror "context.stroke();~%"))))
        
  • medium-draw-text*

The following functions have default methods built on top of the above:

  • [X] medium-draw-points* (medium coord-seq)
  • [X] medium-draw-lines* (medium coord-seq)
  • [X] medium-draw-rectangles* (medium coord-seq filled)

CLIM II specification does not specify the filled argument present in some functions, however for instance it mentions that medium-draw-polygon* draws a polygon or a polyline. From that we’ve assumed that it is a missing argument and McCLIM includes it.

To avoid repeated code we’ll move the variable assignment for canvas directly into invoke-with-html5-stream function.

(:script
 (fresh-line stream)
 (format stream "var canvas = document.getElementById('McCLIM');~%")
 (format stream "var context = canvas.getContext('2d');~%")
 (funcall cont html5-stream))

All coordinates are printed as floats with the format directive f. This way “our” numbers will be accepted by javascript.

medium-draw-point*

medium-draw-line*

medium-draw-polygon*

medium-draw-rectangle*

medium-draw-ellipse*

medium-draw-text*

Footnotes

[fn:1] Angles are measured in radians and are counter-clockwise in graphics coordinate system, that is when the positive Y axis grows upwards (in right-handed coordinate system). Since our coordinate system is left-handed (because Y grows downards), we may treat angles as being directed clockwise. bla bla, this needs a better description.

;;; (c) 2020 by Daniel Kochmański <daniel@turtleware.eu>
;;; (l) LGPL-2.1+
;;;
;;; This backend is currently an output-only stream just like PS and
;;; PDF backends. We create a single html5 file with inlined JS and a
;;; single canvas element on which we draw (Mc)CLIM graphics.
(defpackage #:eu.turtleware.clim.html5-backend
(:export #:with-html5-stream))
(defpackage #:eu.turtleware.clim.html5-backend.implementation
(:use #:clim-lisp #:eu.turtleware.clim.html5-backend))
(in-package #:eu.turtleware.clim.html5-backend.implementation)
(defclass html5-port (clim:basic-port)
((stream :accessor html5-port-stream)))
(defclass html5-medium (clim:basic-medium)
())
(defclass html5-graft (clim:graft)
())
(defclass html5-stream (clim:sheet-leaf-mixin
clim:sheet-parent-mixin
clim:sheet-transformation-mixin
clim:sheet-mute-input-mixin
clim:sheet-mute-repainting-mixin
clim:basic-sheet
clim:standard-extended-output-stream
clim:standard-output-recording-stream
clim:permanent-medium-sheet-output-mixin)
((port :initform nil :initarg :port :accessor clim:port)
(mirror :initform nil :initarg :mirror :accessor mirror)))
(defun make-html5-stream (port)
(make-instance 'html5-stream :port port :mirror (html5-port-stream port)))
(defmethod climb:make-graft
((port html5-port) &key (orientation :default) (units :device))
(let ((graft (make-instance 'html5-graft :port port
:mirror (html5-port-stream port)
:orientation orientation
:units units)))
;; XXX
(push graft (climi::port-grafts port))
graft))
(defmethod climb:make-medium ((port html5-port) (sheet html5-stream))
(make-instance 'html5-medium :sheet sheet))
(defmethod initialize-instance :after ((port html5-port) &key)
(let* ((options (cdr (clim:port-server-path port)))
(stream (getf options :stream)))
(setf (html5-port-stream port) stream))
(climb:make-graft port))
(setf (get :html5 :port-type) 'html5-port)
(setf (get :html5 :server-path-parser) 'identity)
;;; XXX fixme methods
(defmethod clim:pane-viewport ((medium html5-stream))
#+ (or) (break "ooof"))
(defmethod clim:scroll-extent ((medium html5-stream) x y)
#+ (or) (break "ooof"))
(defmethod climb:text-bounding-rectangle*
((medium html5-medium) string
&key text-style start end align-x align-y direction)
(declare (ignore medium string text-style start end align-x align-y direction))
#+ (or) (break "ooof")
(values 10 10 10 10))
;;; Graphics
;;;
;;; Except the most obvious part, that is drawing a primitive, the
;;; following needs to be accounted for:
;;;
;;; - drawing color
;;; - path cap shape, joint shape, thickness, miter limit and dashes
;;; - clipping and transformations (mind a transform-coordinates-mixin)
;;; - text style face, size and family
(defvar *context* "context" "Drawing context.")
(defgeneric draw-shape (mirror shape &rest args)
;; eql-specializers are mainly for medium-draw-* operations where
;; arguments are bare naked. Thanks to that we don't have to
;; construct regions unnecessarily.
(:method ((mirror stream) (shape (eql :line)) &rest args)
(destructuring-bind (x1 y1 x2 y2) args
(format mirror "~a.moveTo(~f, ~f);~%" *context* x1 y1)
(format mirror "~a.lineTo(~f, ~f);~%" *context* x2 y2)))
(:method ((mirror stream) (shape (eql :point)) &rest args)
(destructuring-bind (rad x y) args
(format mirror "~a.arc(~f, ~f, ~f, 0, 2 * Math.PI);" *context* x y rad)))
(:method ((mirror stream) (shape (eql :polygon)) &rest args)
(destructuring-bind (coord-seq closed) args
(destructuring-bind (x1 y1 &rest coord-seq) (coerce coord-seq 'list)
(format mirror "~a.moveTo(~f, ~f);~%" *context* x1 y1)
(loop for (x y) on coord-seq by #'cddr
do (format mirror "~a.lineTo(~f, ~f);~%" *context* x y)))
(when closed
(format mirror "~a.closePath();~%" *context*))))
(:method ((mirror stream) (shape (eql :rectangle)) &rest args)
(destructuring-bind (x1 y1 x2 y2) args
(format mirror "~a.rect(~f, ~f, ~f, ~f);~%"
*context* x1 y1 (- x2 x1) (- y2 y1))))
(:method ((mirror stream) (shape (eql :ellipse)) &rest args)
(destructuring-bind (cx cy rdx1 rdy1 rdx2 rdy2
start-angle end-angle)
args
(loop with coords = (multiple-value-list
(ellipse-arc* cx cy rdx1 rdy1 rdx2 rdy2
start-angle end-angle))
with x1 = (pop coords)
with y1 = (pop coords)
initially (format mirror "~a.moveTo(~f, ~f);~%" *context* x1 y1)
for (x2 y2 x3 y3 x4 y4) on coords by (alexandria:curry #'nthcdr 6)
do (format mirror "~a.bezierCurveTo(~f, ~f, ~f, ~f, ~f, ~f);~%"
*context* x2 y2 x3 y3 x4 y4))))
;; Region specializers (sometimes we delegate to eql versions). They
;; are most useful when clipping. Being lazy as I am I rely on the
;; fact that lines are also polylines and rectangles are also
;; polygons, so I'm not defining methods on i.e standard-line.
(:method ((mirror stream) (shape clim:point) &rest args)
(declare (ignore args))
(draw-shape mirror :point
(clim:point-x shape)
(clim:point-y shape)))
(:method ((mirror stream) (shape clim:polyline) &rest args)
(declare (ignore args))
(let ((movedp nil))
(clim:map-over-polygon-coordinates
(lambda (x y)
(if (null movedp)
(format mirror "~a.moveTo(~f, ~f);" *context* x y)
(format mirror "~a.lineTo(~f, ~f);" *context* x y))
(setf movedp t))
shape)))
(:method ((mirror stream) (shape clim:polygon) &rest args)
(declare (ignore args))
(let ((movedp nil))
(clim:map-over-polygon-coordinates
(lambda (x y)
(if (null movedp)
(format mirror "~a.moveTo(~f, ~f);~%" *context* x y)
(format mirror "~a.lineTo(~f, ~f);~%" *context* x y))
(setf movedp t))
shape)))
(:method ((mirror stream) (shape clim:ellipse) &rest args)
(declare (ignore args))
(multiple-value-bind (cx cy)
(clim:ellipse-center-point* shape)
(multiple-value-bind (rdx1 rdy1 rdx2 rdy2)
(clim:ellipse-radii shape)
(let ((start-angle (or (clim:ellipse-start-angle shape) 0.0))
(end-angle (or (clim:ellipse-end-angle shape) (* 2.0 pi))))
(draw-shape mirror :ellipse
cx cy rdx1 rdy1 rdx2 rdy2
start-angle end-angle))))))
(defun set-color (stream medium filledp)
(multiple-value-bind (r g b a)
(clime:color-rgba (clime:design-ink (clim:medium-ink medium) 0 0))
(format stream "context.~a = \"#~2,'0x~2,'0x~2,'0x~2,'0x\";~%"
(if filledp "fillStyle" "strokeStyle")
(round (* r 255))
(round (* g 255))
(round (* b 255))
(round (* a 255)))))
(defun untransform-width (transformation width)
(multiple-value-bind (dx dy)
(clim:untransform-distance transformation width 0)
(sqrt (+ (expt dx 2) (expt dy 2)))))
(defun set-path-properties (stream medium)
(set-color stream medium nil)
(let* ((line-style (clim:medium-line-style medium))
(line-cap (ecase (clim:line-style-cap-shape line-style)
(:butt "butt")
(:square "square")
(:round "round")
(:no-end-point
(warn "cap shape :no-end-point not supported")
"butt")))
(line-join (ecase (clim:line-style-joint-shape line-style)
(:miter "miter")
(:bevel "bevel")
(:round "round")
(:none
(warn "joint shape :none not supported")
"miter")))
;; XXX
(thickness (climi::line-style-effective-thickness line-style medium))
(miter (clime:medium-miter-limit medium))
(dashes (clim:line-style-dashes line-style)))
(format stream "context.lineCap = ~s;~%" line-cap)
(format stream "context.lineJoin = ~s;~%" line-join)
(format stream "context.miterLimit = ~f;~%" miter)
(format stream "context.lineWidth = ~f;~%" thickness)
;; Line dashes in canvas seem to be an extension. Screw Ghrome.
;; https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/setLineDash
(if (eql dashes t)
(format stream "context.setLineDash([2, 4]);~%")
(format stream "context.setLineDash([~{~f~^, ~}]);~%" dashes))))
(defun set-fill-properties (stream medium)
(set-color stream medium t))
(defun set-text-properties (stream medium)
(set-color stream medium t)
(let* ((text-style (clim:medium-text-style medium))
(size (climb:normalize-font-size
(clim:text-style-size text-style)))
(face (case (clim:text-style-face text-style)
((nil) "normal")
(:roman "normal")
(:bold "bold")
(:italic "italic")
(otherwise "bold italic")))
(family (ecase (clim:text-style-family text-style)
((nil) "Arial")
(:fix "Courier New")
(:serif "serif")
(:sans-serif "sans-serif"))))
(format stream "context.font = \"~a ~spx ~a\";~%" face size family)))
(defun clip-region-union (stream region-set)
(format stream "region1 = new Path2D();~%")
(clim:map-over-region-set-regions
(lambda (region)
(format stream "region2 = new Path2D();~%")
(let ((*context* "region2"))
(draw-shape stream region))
(format stream "region1.addPath(region2);~%"))
region-set)
(format stream "context.clip(region1);~%"))
(defun clip-region-intersection (stream region-set)
(clim:map-over-region-set-regions
(lambda (region)
(format stream "context.beginPath();~%")
(draw-shape stream region)
(format stream "context.clip();~%"))
region-set))
(defun clip-region-difference (stream region)
(warn "Congratulations, can't clip to a region difference."))
(defmacro with-clipped-region ((stream medium) &body body)
(alexandria:with-gensyms (clip)
`(let ((,clip (clim:medium-clipping-region ,medium)))
(if (clim:region-equal ,clip clim:+everywhere+)
(progn ,@body)
(unwind-protect
(progn
(format ,stream "context.save();~%")
(typecase ,clip
(clim:standard-region-intersection
(clip-region-intersection ,stream ,clip))
(clim:standard-region-difference
(clip-region-difference ,stream ,clip))
(climi::region-set
(clip-region-union ,stream ,clip))
(otherwise
(format ,stream "context.beginPath();~%")
(draw-shape ,stream ,clip)
(format ,stream "context.clip();~%")))
,@body)
(format ,stream "context.restore();~%"))))))
(defmacro with-drawing-context ((var medium op) &body body)
(alexandria:once-only (medium)
`(alexandria:when-let ((,var (clim:medium-drawable ,medium)))
(with-clipped-region (,var ,medium)
,(case op
(:text `(set-text-properties ,var ,medium))
(:fill `(set-fill-properties ,var ,medium))
(:path `(set-path-properties ,var ,medium))
(otherwise `(ecase ,op
(:text (set-text-properties ,var ,medium))
(:fill (set-fill-properties ,var ,medium))
(:path (set-path-properties ,var ,medium)))))
,@body))))
(defmethod climb:medium-draw-line* ((medium html5-medium) x1 y1 x2 y2)
(with-drawing-context (mirror medium :path)
(format mirror "context.beginPath();~%")
(draw-shape mirror :line x1 y1 x2 y2)
(format mirror "context.stroke();~%")))
;;;(defmethod climb:medium-draw-lines* ((medium html5-medium) coord-seq))
(defmethod climb:medium-draw-point* ((medium html5-medium) x y)
(with-drawing-context (mirror medium :fill)
(format mirror "context.beginPath();~%")
(let ((rad (* 0.5 (climi::line-style-effective-thickness
(clim:medium-line-style medium) medium))))
(draw-shape mirror :point rad x y))
(format mirror "context.fill();~%")))
;;;(defmethod climb:medium-draw-points* ((medium html5-medium) coord-seq))
(defmethod climb:medium-draw-polygon* ((medium html5-medium) coord-seq closed filled)
(with-drawing-context (mirror medium (if filled :fill :path))
(format mirror "context.beginPath();~%")
(draw-shape mirror :polygon coord-seq closed)
(if filled
(format mirror "context.fill();")
(format mirror "context.stroke();"))))
(defmethod climb:medium-draw-rectangle* ((medium html5-medium) x1 y1 x2 y2 filled)
(with-drawing-context (mirror medium (if filled :fill :path))
(format mirror "context.beginPath();~%")
(draw-shape mirror :rectangle x1 y1 x2 y2)
(if filled
(format mirror "context.fill();")
(format mirror "context.stroke();"))))
;;;(defmethod climb:medium-draw-rectangles* ((medium html5-medium) position-seq filled))
(defmethod climb:medium-draw-ellipse* ((medium html5-medium)
cx cy rdx1 rdy1 rdx2 rdy2
start-angle end-angle filled)
;; XXX this way of drawing ellipses distorts line
;; dashes. approximate with bezier curves.
(with-drawing-context (mirror medium (if filled :fill :path))
(format mirror "context.beginPath();~%")
(draw-shape mirror :ellipse
cx cy rdx1 rdy1 rdx2 rdy2
start-angle end-angle)
(if filled
(format mirror "context.fill();")
(format mirror "context.stroke();"))))
(defmethod climb:medium-draw-text* ((medium html5-medium) string x y
start end
align-x align-y
toward-x toward-y transform-glyphs)
(with-drawing-context (mirror medium :text)
(let ((baseline (ecase align-y
(:baseline "alphabetic")
(:top "top")
(:center "middle")
(:bottom "bottom")))
(align (ecase align-x
(:left "left")
(:center "center")
(:right "right")))
(text (subseq string start end)))
(format mirror "context.textBaseline = ~s;~%" baseline)
(format mirror "context.textAlign = ~s;~%" align)
(format mirror "context.fillText(~s, ~s, ~s);~%" text x y))))
(defmethod climb:medium-clear-area ((medium html5-medium) x1 y1 x2 y2)
(alexandria:when-let ((mirror (clim:medium-drawable medium)))
(let ((w (- x2 x1))
(h (- y2 y1)))
(format mirror "context.clearRect(~s, ~s, ~s, ~s);~%" x1 y1 w h))))
;;; macros
(defmacro with-html5-stream ((var stream &rest options) &body body)
(let ((cont (gensym)))
`(flet ((,cont (,var)
(declare (ignorable ,var))
,@body))
(declare (dynamic-extent #',cont))
(invoke-with-html5-stream #',cont ,stream ,@options))))
(defun invoke-with-html5-stream (cont stream &rest options)
(declare (ignore options))
(climb:with-port (port :html5 :stream stream)
(let ((html5-stream (make-html5-stream port)))
(clim:sheet-adopt-child (clim:find-graft :port port) html5-stream)
(setf (cl-who:html-mode) :html5)
(cl-who:with-html-output (stream stream :prologue t :indent t)
(:html
(:head)
(:body
(:h "McCLIM HTML5 canvas teaser.")
(:canvas :id "McCLIM" :width 800 :height 600
:style "border:1px solid #000000")
(:p "Brought to you by me :_)")
(:script
(fresh-line stream)
(format stream "var canvas = document.getElementById('McCLIM');~%")
(format stream "var context = canvas.getContext('2d');~%")
(format stream "var region1;~%")
(format stream "var region2;~%")
(funcall cont html5-stream)))))
nil)))
;;; Output destination of html5 may be a file to "save" on a disk or a
;;; stream to "serve" a http request.
;; (defclass html5-destination (climb:file-destination climb:stream-destination)
;; ())
;; (defmethod climb:invoke-with-standard-output
;; (continuation (output html5-destination))
;; (unless (alexandria:xor (climb:destination-file output)
;; (climb:destination-stream output))
;; (error "HTML5: initarg :FILE xor :STREAM must be supplied."))
;; (alexandria:if-let ((stream (climb:destination-stream output)))
;; (let ((*standard-output* (climb:destination-stream output)))
;; (funcall continuation))
;; (with-open-file (*standard-output* (climb:destination-file output)
;; :element-type 'character
;; :direction :output
;; :if-exists :supersede)
;; (format t "<p>Hello world!</p>")
;; (funcall continuation))))
;; (climb:register-output-destination-type "HTML5" 'html5-destination)
;;; Utilities
;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
;;; Adapted from Ben Deane's com.elbeno.curve 0.1 library, with
;;; permission. See http://www.elbeno.com/lisp/ for the original.
;;;
;;; Further adapted from Zachary Beane's vecto library for CLIM
;;; renderer. Copyright notice is included above.
(defparameter +cubic-error-coeffs-0+
(make-array '(2 4 4) :initial-contents
'((( 3.85268 -21.229 -0.330434 0.0127842)
(-1.61486 0.706564 0.225945 0.263682)
(-0.910164 0.388383 0.00551445 0.00671814)
(-0.630184 0.192402 0.0098871 0.0102527))
((-0.162211 9.94329 0.13723 0.0124084)
(-0.253135 0.00187735 0.0230286 0.01264)
(-0.0695069 -0.0437594 0.0120636 0.0163087)
(-0.0328856 -0.00926032 -0.00173573 0.00527385)))))
(defparameter +cubic-error-coeffs-1+
(make-array '(2 4 4) :initial-contents
'((( 0.0899116 -19.2349 -4.11711 0.183362)
( 0.138148 -1.45804 1.32044 1.38474)
( 0.230903 -0.450262 0.219963 0.414038)
( 0.0590565 -0.101062 0.0430592 0.0204699))
(( 0.0164649 9.89394 0.0919496 0.00760802)
( 0.0191603 -0.0322058 0.0134667 -0.0825018)
( 0.0156192 -0.017535 0.00326508 -0.228157)
(-0.0236752 0.0405821 -0.0173086 0.176187)))))
;;; [elbeno:]
;;; compute the error of a cubic bezier
;;; that approximates an elliptical arc
;;; with radii a, b
;;; between angles eta1 and eta2
(defun calc-c-term (i b/a etasum arr)
(loop
for j from 0 to 3
sum (* (/ (+ (* (aref arr i j 0) b/a b/a)
(* (aref arr i j 1) b/a)
(aref arr i j 2))
(+ (aref arr i j 3) b/a))
(cos (* j etasum)))))
(defun bezier-error (a b eta1 eta2)
(let* ((b/a (/ b a))
(etadiff (- eta2 eta1))
(etasum (+ eta2 eta1))
(arr (if (< b/a 0.25)
+cubic-error-coeffs-0+
+cubic-error-coeffs-1+)))
(* (/ (+ (* 0.001 b/a b/a) (* 4.98 b/a) 0.207)
(+ b/a 0.0067))
a
(exp (+ (calc-c-term 0 b/a etasum arr)
(* (calc-c-term 1 b/a etasum arr) etadiff))))))
(defun ellipse-val (cx cy a b theta eta)
(values
(+ cx
(* a (cos theta) (cos eta))
(* (- b) (sin theta) (sin eta)))
(+ cy
(* a (sin theta) (cos eta))
(* b (cos theta) (sin eta)))))
(defun ellipse-deriv-val (a b theta eta)
(values
(+ (* (- a) (cos theta) (sin eta))
(* (- b) (sin theta) (cos eta)))
(+ (* (- a) (sin theta) (sin eta))
(* b (cos theta) (cos eta)))))
(defun approximate-arc-single (cx cy a b theta eta1 eta2)
(let* ((etadiff (- eta2 eta1))
(k (tan (/ etadiff 2)))
(alpha (* (sin etadiff)
(/ (1- (sqrt (+ 4 (* 3 k k)))) 3)))
px1 py1
px2 py2
qx1 qy1
qx2 qy2
sx1 sy1
sx2 sy2)
(setf (values px1 py1) (ellipse-val cx cy a b theta eta1)
(values px2 py2) (ellipse-val cx cy a b theta eta2)
(values sx1 sy1) (ellipse-deriv-val a b theta eta1)
(values sx2 sy2) (ellipse-deriv-val a b theta eta2)
qx1 (+ px1 (* alpha sx1))
qy1 (+ py1 (* alpha sy1))
qx2 (- px2 (* alpha sx2))
qy2 (- py2 (* alpha sy2)))
(values qx1 qy1 qx2 qy2 px2 py2)))
(defun approximate-arc (cx cy a b theta eta1 eta2 err)
(cond ((< eta2 eta1)
(error "approximate-arc: eta2 must be bigger than eta1"))
((> eta2 (+ eta1 (/ pi 2) (* eta2 long-float-epsilon)))
(let ((etamid (+ eta1 (/ pi 2) (* eta2 long-float-epsilon))))
(multiple-value-call #'values
(approximate-arc cx cy a b theta eta1 etamid err)
(approximate-arc cx cy a b theta etamid eta2 err))))
(t (if (> err (bezier-error a b eta1 eta2))
(approximate-arc-single cx cy a b theta eta1 eta2)
(let ((etamid (/ (+ eta1 eta2) 2)))
(multiple-value-call #'values
(approximate-arc cx cy a b theta eta1 etamid err)
(approximate-arc cx cy a b theta etamid eta2 err)))))))
(defun approximate-elliptical-arc (cx cy a b theta eta1 eta2
&optional (err 0.5))
"Approximate an elliptical arc with a cubic bezier spline into the path."
(if (> b a)
(approximate-arc cx cy b a
(+ theta (/ pi 2))
(- eta1 (/ pi 2))
(- eta2 (/ pi 2)) err)
(approximate-arc cx cy a b theta eta1 eta2 err)))
(defun arc (cx cy r theta1 theta2)
(loop while (< theta2 theta1) do (incf theta2 (* 2 pi)))
(multiple-value-call #'values
(ellipse-val cx cy r r 0 theta1)
(approximate-elliptical-arc cx cy r r 0 theta1 theta2)))
(defun ellipse-arc (cx cy rx ry theta lambda1 lambda2)
(let ((eta1 (atan (/ (sin lambda1) ry) (/ (cos lambda1) rx)))
(eta2 (atan (/ (sin lambda2) ry) (/ (cos lambda2) rx)))
(2pi (* 2 pi)))
;; make sure we have eta1 <= eta2 <= eta1 + 2 PI
(decf eta2 (* 2pi (floor (- eta2 eta1) 2pi)))
;; the preceding correction fails if we have exactly et2 - eta1 = 2 PI
;; it reduces the interval to zero length
(when (and (> (- lambda2 lambda1) pi) (< (- eta2 eta1) pi))
(incf eta2 2pi))
(multiple-value-call #'values
(ellipse-val cx cy rx ry theta eta1)
(approximate-elliptical-arc cx cy rx ry theta eta1 eta2))))
(defun ellipse-arc* (cx cy rdx1 rdy rdx2 rdy2 start-angle end-angle)
(multiple-value-bind (a b theta)
(climi::reparameterize-ellipse rdx1 rdy rdx2 rdy2)
(let ((start (- (* 2 pi) end-angle theta))
(delta (- end-angle start-angle)))
(ellipse-arc cx cy a b theta start (+ start delta)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment