path: root/Core/drawing/medium.lisp

;;; ---------------------------------------------------------------------------
;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
;;; ---------------------------------------------------------------------------
;;;
;;;  (c) copyright 1998-2000 by Michael McDonald <mikemac@mikemac.com>
;;;  (c) copyright 2002-2003 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;  (c) copyright 2014 by Robert Strandh <robert.strandh@gmail.com>
;;;  (c) copyright 2020-2022 by Daniel Kochmański <daniel@turtleware.eu>
;;;
;;; ---------------------------------------------------------------------------
;;;
;;; Implementation of the graphics state, mediums and line styles.
;;;

(in-package #:clim-internals)

;;; GRAPHICS-STATE class

;;; Factor out the graphics state portions of the output records so
;;; they can be manipulated seperately e.g., by incremental
;;; display. The individual slots of a graphics state are factored
;;; into mixin classes so that each output record can capture only the
;;; state that it needs. -- moore
;;;
;;; Now graphics-state is an ancestor of both medium and some of
;;; output-records. Thanks to that we can treat medium as
;;; graphics-state without consing new objects and assign its state
;;; from another graphics-state object. -- jd

(defclass graphics-state ()
  ()
  (:documentation "Stores those parts of the medium/stream graphics state
  that need to be restored when drawing an output record"))

(defmacro define-graphics-state-mixin (class-name slot-names)
  `(progn
     (defclass ,class-name (graphics-state)
       ,(loop for slot-name in slot-names
              for initarg = (make-keyword slot-name)
              for acc-name = (intern (format nil "GRAPHICS-STATE-~A" slot-name))
              collect `(,slot-name :initarg ,initarg :accessor ,acc-name)))
     (defmethod initialize-instance :after
         ((object ,class-name) &key (stream nil)
                                    (medium (when stream (sheet-medium stream))))
       (when medium
         ,@(loop for slot-name in slot-names
                 collect `(unless (slot-boundp object ',slot-name)
                            (setf (slot-value object ',slot-name)
                                  (slot-value medium ',slot-name))))))
     (defmethod (setf graphics-state) :after
         ((new-gs ,class-name) (old-gs ,class-name))
       ,@(loop for slot-name in slot-names
               collect `(setf (slot-value new-gs ',slot-name)
                              (slot-value old-gs ',slot-name))))))

(define-graphics-state-mixin gs-transformation-mixin
    (transformation))

(define-graphics-state-mixin gs-clip-mixin
    (clipping-region))

(define-graphics-state-mixin gs-ink-mixin
    (ink))

(define-graphics-state-mixin gs-line-style-mixin
    (line-style))

(define-graphics-state-mixin gs-text-style-mixin
    (text-style))

(define-graphics-state-mixin gs-layout-mixin
    (line-direction
     page-direction))

(defclass complete-medium-state (gs-transformation-mixin
                                 gs-clip-mixin
                                 gs-ink-mixin
                                 gs-line-style-mixin
                                 gs-text-style-mixin
                                 gs-layout-mixin)
  ((transformation
    :type transformation
    :initarg :transformation
    :initform +identity-transformation+
    :accessor medium-transformation)
   (clipping-region
    :type region
    :initarg :clipping-region
    :initform +everywhere+
    :documentation "Clipping region in the SHEET coordinates.")
   (ink
    :initarg :ink
    :initform +foreground-ink+
    :accessor medium-ink)
   (line-style
    :initarg :line-style
    :initform (make-line-style)
    :accessor medium-line-style)
   (text-style
    :initarg :text-style
    :initform *default-text-style*
    :accessor medium-text-style
    :type text-style)
   (line-direction
    :initarg :line-direction
    :initform :left-to-right
    :accessor medium-line-direction)
   (page-direction
    :initarg :page-direction
    :initform :top-to-bottom
    :accessor medium-page-direction)))

(defmethod (setf graphics-state) ((new-gs graphics-state) (gs graphics-state))
  #+(or) "This is a no-op, but :after methods don't work without a primary method.")

(defmethod graphics-state-line-style-border
    ((record gs-line-style-mixin) (medium medium))
  (let ((style (graphics-state-line-style record)))
    (/ (line-style-effective-thickness style medium)) 2))


;;; MEDIUM class

(defclass transform-coordinates-mixin ()
  ;; This class is reponsible for transforming coordinates in an :around method
  ;; on medium-draw-xyz. It is mixed into basic-medium. We should document it
  ;; and mix it in the appropriate downstream backend-specific medium.  Mixing
  ;; in basic-medium makes hardware-based transformations hard. -- jd 2018-03-06
  ())

(defclass basic-medium (transform-coordinates-mixin
                        multiline-medium-mixin
                        complete-medium-state
                        medium)
  (;; Default values
   (foreground :initarg :foreground
               :initform +black+
               :accessor medium-foreground
               :reader foreground)
   (background :initarg :background
               :initform +white+
               :accessor medium-background
               :reader background)
   (default-text-style :initarg :default-text-style
                       :initform *default-text-style*
                       :accessor medium-default-text-style
                       :type text-style)
   (sheet :initarg :sheet
          :initform nil ;; NIL means that medium is not linked to a sheet
          :reader medium-sheet
          :writer (setf %medium-sheet))
   (port :initarg :port
         :accessor port)
   (drawable :initform nil
             :accessor %medium-drawable)
   (buffering-p :initform nil
                :accessor medium-buffering-output-p))
  (:documentation "The basic class, on which all CLIM mediums are built."))

(defmethod medium-drawable ((medium basic-medium))
  (or (%medium-drawable medium)
      (when-let ((sheet (medium-sheet medium)))
        (sheet-mirror sheet))))

(defmethod (setf medium-drawable) (new-drawable (medium basic-medium))
  (setf (%medium-drawable medium) new-drawable))

(defmethod initialize-instance :after ((medium basic-medium) &rest args)
  (declare (ignore args))
  ;; Initial CLIPPING-REGION is in coordinates given by the initial
  ;; TRANSFORMATION, but we store it in SHEET's coords.
  (with-slots (clipping-region) medium
    (setf clipping-region (transform-region (medium-transformation medium)
                                            clipping-region))))

(defmethod medium-clipping-region ((medium basic-medium))
  (untransform-region (medium-transformation medium)
                      (slot-value medium 'clipping-region)))

(defmethod (setf medium-clipping-region) (region (medium basic-medium))
  (setf (slot-value medium 'clipping-region)
        (transform-region (medium-transformation medium) region)))

(defmethod medium-merged-text-style ((medium medium))
  (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))

;;; Medium Device functions

(defmethod medium-device-transformation ((medium medium))
  (if-let ((sheet (medium-sheet medium)))
    (sheet-device-transformation sheet)
    (medium-transformation medium)))

(defmethod medium-device-region ((medium medium))
  (if-let ((sheet (medium-sheet medium)))
    (sheet-device-region sheet)
    (transform-region (medium-device-transformation medium)
                      (medium-clipping-region medium))))

(defmethod medium-native-transformation ((medium medium))
  (if-let ((sheet (medium-sheet medium)))
    (sheet-native-transformation sheet)
    +identity-transformation+))

(defmethod medium-native-region ((medium medium))
  (if-let ((sheet (medium-sheet medium)))
    (sheet-native-region sheet)
    (transform-region (compose-transformations (medium-native-transformation medium)
                                               (medium-transformation medium))
                      (medium-clipping-region medium))))


;;; Line-Style class

(defclass standard-line-style (line-style)
  ((unit        :initarg :line-unit
                :initform :normal
                :reader line-style-unit
                :type (member :normal :point :coordinate))
   (thickness   :initarg :line-thickness
                :initform 1
                :reader line-style-thickness
                :type real)
   (joint-shape :initarg :line-joint-shape
                :initform :miter
                :reader line-style-joint-shape
                :type (member :miter :bevel :round :none))
   (cap-shape   :initarg :line-cap-shape
                :initform :butt
                :reader line-style-cap-shape
                :type (member :butt :square :round :no-end-point))
   (dashes      :initarg :line-dashes
                :initform nil
                :reader line-style-dashes
                :type (or (member t nil)
                          sequence))))

(defun make-line-style (&key (unit :normal) (thickness 1)
                          (joint-shape :miter) (cap-shape :butt)
                          (dashes nil))
  (make-instance 'standard-line-style
                 :line-unit unit
                 :line-thickness thickness
                 :line-joint-shape joint-shape
                 :line-cap-shape cap-shape
                 :line-dashes dashes))

(defmethod print-object ((self standard-line-style) stream)
  (print-unreadable-object (self stream :type t :identity nil)
    (format stream "~{~S ~S~^ ~}"
            (mapcan (lambda (slot)
                      (when (slot-boundp self slot)
                        (list
                         (intern (symbol-name slot) :keyword)
                         (slot-value self slot))))
                    '(unit thickness joint-shape cap-shape dashes)))))

(defun line-style-scale (line-style medium)
  (let ((unit (line-style-unit line-style)))
    (ecase unit
      (:normal 1)
      (:point (if-let ((graft (graft medium)))
                (/ (graft-width graft)
                   (graft-width graft :units :inches)
                   72)
                1))
      (:coordinate (let ((transformation (medium-transformation medium)))
                     (if (identity-transformation-p transformation)
                         1
                         (multiple-value-bind (x y)
                             (transform-distance transformation 0.71 0.71)
                           (sqrt (+ (expt x 2) (expt y 2))))))))))

(defmethod line-style-effective-thickness (line-style medium)
  (* (line-style-thickness line-style)
     (line-style-scale line-style medium)))

(defmethod line-style-effective-dashes (line-style medium)
  (when-let ((dashes (line-style-dashes line-style)))
    (cond ((not (eq (line-style-unit line-style) :normal))
           (let ((scale (line-style-scale line-style medium)))
             (flet ((scale (length)
                      (* scale length)))
               (declare (dynamic-extent #'scale))
               (if (eq dashes t)
                   (let ((scaled (scale 3))) ; arbitrary default length
                     (list scaled scaled))
                   (map 'list #'scale dashes)))))
          ((eq dashes t)
           '(3 3))
          (t
           dashes))))

(defun medium-effective-line-style (medium)
  (let ((line-style (medium-line-style medium)))
    (if (eq (line-style-unit line-style) :coordinate)
        (make-line-style :unit :normal
                         :thickness (line-style-effective-thickness line-style medium)
                         :dashes (line-style-effective-dashes line-style medium)
                         :joint-shape (line-style-joint-shape line-style)
                         :cap-shape (line-style-cap-shape line-style))
        line-style)))

(defmethod medium-miter-limit ((medium medium))
  #.(* 2 single-float-epsilon))

(defmethod equals ((a line-style) (b line-style))
  (line-style-equalp a b))

(defmethod line-style-equalp ((style1 standard-line-style)
                              (style2 standard-line-style))
  (and (eql (line-style-unit style1) (line-style-unit style2))
       (eql (line-style-thickness style1) (line-style-thickness style2))
       (eql (line-style-joint-shape style1) (line-style-joint-shape style2))
       (eql (line-style-cap-shape style1) (line-style-cap-shape style2))
       (eql (line-style-dashes style1) (line-style-dashes style2))))


;;; Misc ops

(defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
  (with-gensyms (cont)
    `(flet ((,cont () ,@body))
       (declare (dynamic-extent (function ,cont)))
       (invoke-with-output-buffered ,medium (function ,cont) ,buffer-p))))

;;; Default method.
(defmethod invoke-with-output-buffered
    (sheet continuation &optional (buffered-p t))
  (declare (ignore buffered-p))
  (funcall continuation))

(defmacro with-clipping-region ((medium clipping-region) &body body)
  (let ((cont (gensym "CONT")))
    `(flet ((,cont () ,@body))
       (declare (dynamic-extent (function ,cont)))
       (invoke-with-clipping-region ,medium (function ,cont) ,clipping-region))))

;;; This operator is specializable to allow creating compound output records
;;; responsible for clipping the output. -- jd 2022-11-03
(defgeneric invoke-with-clipping-region (medium continuation region)
  (:argument-precedence-order region medium continuation))

(defmethod invoke-with-clipping-region (medium continuation (region null))
  (declare (ignore medium region))
  (funcall continuation))

(defmethod invoke-with-clipping-region ((medium medium) continuation region)
  (let ((old-region (medium-clipping-region medium)))
    (if (or (eq region +everywhere+)
            (eq region old-region)
            (region-contains-region-p region old-region))
        (funcall continuation)
        (letf (((medium-clipping-region medium)
                (region-intersection region old-region)))
          (funcall continuation)))))


;;; Pixmaps

(defmethod medium-copy-area ((from-drawable basic-medium) from-x from-y width height
                             to-drawable to-x to-y)
  (declare (ignore from-x from-y width height to-drawable to-x to-y))
  (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))

(defmethod medium-copy-area (from-drawable from-x from-y width height
                             (to-drawable basic-medium) to-x to-y)
  (declare (ignore from-drawable from-x from-y width height to-x to-y))
  (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))

(defmethod invoke-with-output-to-pixmap ((medium basic-medium) cont &key width height)
  (unless (and width height)
    (error "WITH-OUTPUT-TO-PIXMAP: please provide :WIDTH and :HEIGHT."))
  (let* ((port (port medium))
         (pixmap (allocate-pixmap medium width height))
         (pixmap-medium (make-medium port (medium-sheet medium)))
         (drawing-plane (make-rectangle* 0 0 width height)))
    (degraft-medium pixmap-medium port medium)
    (letf (((medium-drawable pixmap-medium) pixmap)
           ((medium-clipping-region pixmap-medium) drawing-plane)
           ((medium-background pixmap-medium) +transparent-ink+))
      (medium-clear-area pixmap-medium 0 0 width height)
      (funcall cont pixmap-medium)
      pixmap)))


;;; Medium-specific Drawing Functions

;;; TRANSFORM-COORDINATES-MIXIN methods change the medium transformation to
;;; identity in order to avoid transforming coordinates multiple times by the
;;; backends. On the other hand LINE-STYLE-EFFECTIVE-{THICKNESS,DASHES} uses the
;;; medium transformation when the line unit is :COORDINATE. We address this
;;; issue by supplementing a line style with the unit :normal. -- jd 2022-04-05

(defmacro with-identity-transformation* ((medium &rest coords) &body body)
  (with-gensyms (transformation)
    `(let ((,transformation (medium-transformation ,medium)))
       (if (identity-transformation-p ,transformation)
           (progn ,@body)
           (with-transformed-positions* (,transformation ,@coords)
             (letf (((medium-line-style ,medium) (medium-effective-line-style ,medium))
                    ((medium-transformation ,medium) +identity-transformation+))
               ,@body))))))

(defmethod medium-draw-point* :around ((medium transform-coordinates-mixin) x y)
  (with-identity-transformation* (medium x y)
    (call-next-method medium x y)))

(defmethod medium-draw-points* :around ((medium transform-coordinates-mixin) coord-seq)
  (with-identity-transformation* (medium coord-seq)
    (call-next-method medium coord-seq)))

(defmethod medium-draw-line* :around ((medium transform-coordinates-mixin) x1 y1 x2 y2)
  (with-identity-transformation* (medium x1 y1 x2 y2)
    (call-next-method medium x1 y1 x2 y2)))

(defmethod medium-draw-lines* :around ((medium transform-coordinates-mixin) coord-seq)
  (with-identity-transformation* (medium coord-seq)
    (call-next-method medium coord-seq)))

(defmethod medium-draw-polygon* :around ((medium transform-coordinates-mixin) coord-seq closed filled)
  (with-identity-transformation* (medium coord-seq)
    (call-next-method medium coord-seq closed filled)))

(defmethod medium-draw-bezigon* :around ((medium transform-coordinates-mixin) coord-seq closed filled)
  (with-identity-transformation* (medium coord-seq)
    (call-next-method medium coord-seq closed filled)))

(defun expand-rectangle-coords (left top right bottom)
  "Expand the two corners of a rectangle into a polygon coord-seq"
  (vector left top right top right bottom left bottom))

(defmethod medium-draw-rectangle* :around ((medium transform-coordinates-mixin) x1 y1 x2 y2 filled)
  (if (rectilinear-transformation-p (medium-transformation medium))
      (with-identity-transformation* (medium x1 y1 x2 y2)
        (call-next-method medium (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2) filled))
      (medium-draw-polygon* medium (expand-rectangle-coords x1 y1 x2 y2) t filled)))

(defmethod medium-draw-rectangles* :around ((medium transform-coordinates-mixin) coord-seq filled)
  (if (rectilinear-transformation-p (medium-transformation medium))
      (with-identity-transformation* (medium coord-seq)
        (call-next-method medium coord-seq filled))
      (do-sequence ((x1 y1 x2 y2) coord-seq)
        (medium-draw-polygon* medium (vector x1 y1 x1 y2 x2 y2 x2 y1) t filled))))

(defmethod medium-draw-ellipse* :around ((medium transform-coordinates-mixin)
                                         cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2 filled)
  (let ((tr (medium-transformation medium)))
    (with-identity-transformation (medium)
      (if (identity-transformation-p tr)
          (call-next-method)
          (multiple-value-bind (cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2)
              (transform-ellipse tr cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2)
            (call-next-method medium cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2 filled))))))

(defmethod medium-draw-pattern* :around ((medium transform-coordinates-mixin) pattern x y)
  (with-identity-transformation* (medium x y)
    (call-next-method medium pattern x y)))

;;; If TRANSFORM-GLYPHS was always T, that is "text-size-unit" was always
;;; :COORDINATE, then this method would be correct,.  -- jd 2024-06-29
#+ (or)
(defmethod medium-draw-text* :around ((medium transform-coordinates-mixin)
                                      string x y start end
                                      align-x align-y toward-x toward-y transform-glyphs)
  (with-identity-transformation* (medium x y toward-x toward-y)
    (call-next-method medium string x y start end align-x align-y toward-x toward-y transform-glyphs)))

(defmethod medium-copy-area :around ((from-drawable transform-coordinates-mixin)
                                     from-x from-y width height
                                     (to-drawable transform-coordinates-mixin) to-x to-y)
  (with-identity-transformation* (from-drawable from-x from-y)
    (with-identity-transformation* (to-drawable to-x to-y)
      (call-next-method from-drawable from-x from-y width height to-drawable to-x to-y))))

(defmethod medium-copy-area :around ((from-drawable transform-coordinates-mixin)
                                     from-x from-y width height
                                     to-drawable to-x to-y)
  (with-identity-transformation* (from-drawable from-x from-y)
    (call-next-method from-drawable from-x from-y width height to-drawable to-x to-y)))

(defmethod medium-copy-area :around (from-drawable from-x from-y width height
                                     (to-drawable  transform-coordinates-mixin)
                                     to-x to-y)
  (with-identity-transformation* (to-drawable to-x to-y)
    (call-next-method from-drawable from-x from-y width height to-drawable to-x to-y)))

;;; Fallback methods relying on MEDIUM-DRAW-POLYGON*

(defmethod medium-draw-point* ((medium basic-medium) x y)
  (let ((radius (line-style-effective-thickness (medium-line-style medium) medium)))
    (medium-draw-circle* medium x y radius 0 (* 2 pi) t)))

(defmethod medium-draw-line* ((medium basic-medium) x1 y1 x2 y2)
  (medium-draw-polygon* medium (list x1 y1 x2 y2) nil nil))

(defmethod medium-draw-rectangle* ((medium basic-medium) x1 y1 x2 y2 filled)
  (medium-draw-polygon* medium (list x1 y1 x2 y1 x2 y2 x1 y2) t filled))

(defmethod medium-draw-circle* ((medium basic-medium) cx cy radius eta1 eta2 filled)
  (medium-draw-ellipse* medium cx cy radius 0 0 radius eta1 eta2 filled))

(defmethod medium-draw-ellipse* ((medium basic-medium)
                                 cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2 filled)
  (let ((coords (polygonalize-ellipse cx cy rdx1 rdy1 rdx2 rdy2 eta1 eta2 :filled filled)))
    (medium-draw-polygon* medium coords nil filled)))

#+ (or)
(defmethod medium-draw-circle* ((medium basic-medium) cx cy radius eta1 eta2 filled)
  (medium-draw-ellipse* medium cx cy radius 0 0 radius eta1 eta2 filled))

(defmethod medium-draw-bezigon* ((medium basic-medium) coord-seq closed filled)
  (let ((polygon-coord-seq (polygonalize-bezigon coord-seq)))
    (medium-draw-polygon* medium polygon-coord-seq closed filled)))

;;; Fall-through Methods For Multiple Objects Drawing Functions

(defmethod medium-draw-points* ((medium transform-coordinates-mixin) coord-seq)
  (do-sequence ((x y) coord-seq)
    (medium-draw-point* medium x y)))

(defmethod medium-draw-lines* ((medium transform-coordinates-mixin) position-seq)
  (do-sequence ((x1 y1 x2 y2) position-seq)
    (medium-draw-line* medium x1 y1 x2 y2)))

(defmethod medium-draw-rectangles* ((medium transform-coordinates-mixin) coord-seq filled)
  (do-sequence ((x1 y1 x2 y2) coord-seq)
    (medium-draw-rectangle* medium x1 y1 x2 y2 filled)))

;;; Other fallback methods
(defmethod medium-draw-pattern* ((medium basic-medium) pattern x y)
  (let ((new (transform-region (make-translation-transformation x y) pattern)))
    (letf (((medium-ink medium) new))
      (medium-draw-rectangle* medium x y
                              (+ x (pattern-width new))
                              (+ y (pattern-height new))
                              t))))


;;; Other Medium-specific Output Functions

(defmethod medium-finish-output ((medium basic-medium))
  nil)

(defmethod medium-force-output ((medium basic-medium))
  nil)

(defmethod medium-clear-area ((medium basic-medium) left top right bottom)
  (draw-rectangle* medium left top right bottom
                   :ink (compose-over (medium-background medium) +black+)))

(defmethod medium-beep ((medium basic-medium))
  nil)

;;;;;;;;;

(defmethod engraft-medium ((medium basic-medium) port sheet)
  (declare (ignorable port))
  (assert (eq (port medium) port))
  (setf (%medium-sheet medium) sheet))

(defmethod degraft-medium ((medium basic-medium) port sheet)
  (declare (ignorable port sheet))
  (assert (eq (port medium) port))
  (setf (%medium-sheet medium) nil))

(defmethod allocate-medium ((port port) sheet)
  ;; If we decide to use the resource pool, then this method should at least
  ;; setf the port of a recycled medium.
  (make-medium port sheet))

(defmethod make-medium ((port port) sheet)
  (make-instance 'basic-medium :port port :sheet sheet))

(defmethod deallocate-medium ((port port) medium)
  (declare (ignorable port))
  (setf (port medium) nil))

(defmethod graft ((medium basic-medium))
  (when-let ((sheet (medium-sheet medium)))
    (graft sheet)))

;;; XXX the specification says, that only mediums that have a mirrored sheet
;;; should return a non-NIL port. That is not practical, especially if we want
;;; to reuse mediums for pixmap operations. This method would fulfill the spec
;;; to the letter (or we could NIL the port when degrated). -- jd 2023-09-07
#+ (or)
(defmethod port :around ((medium basic-medium))
  (if-let ((sheet (medium-sheet medium)))
    (port sheet)
    (call-next-method)))


;;; Helpers and mixins
(defun draw-text-rotation* (x y toward-x toward-y)
  ;; Rounding here is important to ensure a numerical stability of rotation.
  (let* ((x (round-coordinate x))
         (y (round-coordinate y))
         (toward-x (round-coordinate toward-x))
         (toward-y (round-coordinate toward-y))
         (dx (- toward-x x))
         (dy (- toward-y y))
         (angle (find-angle 1 0 dx dy)))
    (make-rotation-transformation* angle 0 0)))

(defun draw-text-transformation* (medium x0 y0 x1 y1 transform-glyphs)
  (flet ((text-transformation (fx fy tx ty)
           (if (and (= fy ty) (< fx tx))
               (make-translation-transformation fx fy)
               (compose-transformations
                (make-translation-transformation fx fy)
                (draw-text-rotation* fx fy tx ty)))))
    (let ((transf (medium-transformation medium)))
      (if transform-glyphs
          (compose-transformations
           transf (text-transformation x0 y0 x1 y1))
          (with-transformed-positions* (transf x0 y0 x1 y1)
            (text-transformation x0 y0 x1 y1))))))


(defclass multiline-medium-mixin (medium) ())

(defmethod text-bounding-rectangle* :around ((medium multiline-medium-mixin) string
                                             &key text-style start end)
  (orf start 0)
  (orf end (length string))
  (let ((total-xmin 0)
        (total-ymin 0)
        (total-xmax 0)
        (total-ymax 0)
        (current-dx 0)
        (current-dy 0))
    (flet ((handle-line (idx0 idx1)
             (multiple-value-bind (xmin ymin xmax ymax)
                 (call-next-method medium string :text-style text-style
                                                 :start idx0 :end idx1)
               (minf total-xmin (+ current-dx xmin))
               (minf total-ymin (+ current-dy ymin))
               (maxf total-xmax (+ current-dx xmax))
               (maxf total-ymax (+ current-dy ymax))
               (ecase (medium-page-direction medium)
                 ((:top-to-bottom :right-to-left)
                  (incf current-dy (- ymax ymin)))
                 ((:bottom-to-top :left-to-right)
                  (decf current-dy (- ymax ymin))))))
           (handle-last (idx0)
             (multiple-value-bind (xmin ymin xmax ymax)
                 (call-next-method medium string :text-style text-style
                                                 :start idx0 :end end)
               (minf total-xmin (+ current-dx xmin))
               (minf total-ymin (+ current-dy ymin))
               (maxf total-xmax (+ current-dx xmax))
               (maxf total-ymax (+ current-dy ymax))
               (values total-xmin total-ymin total-xmax total-ymax))))
      (loop for idx0 = start then (1+ idx1)
            for idx1 = (position #\newline string :start idx0 :end end)
            until (null idx1)
            do (handle-line idx0 idx1)
            finally
               (return (handle-last idx0))))))

(defmethod text-size :around ((medium multiline-medium-mixin) string
                              &key text-style start end)
  (setf string (string string))
  (orf start 0)
  (orf end (length string))
  (let ((block-ws 0)
        (block-hs 0)
        (current-dy 0))
    (flet ((handle-line (idx0 idx1)
             (multiple-value-bind (ws hs dx dy baseline)
                 (call-next-method medium string :text-style text-style
                                                 :start idx0 :end idx1)
               (declare (ignore dx dy baseline))
               (maxf block-ws ws)
               (incf block-hs hs)
               (ecase (medium-page-direction medium)
                 ((:top-to-bottom :right-to-left)
                  (incf current-dy hs))
                 ((:bottom-to-top :left-to-right)
                  (decf current-dy hs)))))
           (handle-last (idx0)
             (multiple-value-bind (ws hs dx dy baseline)
                 (call-next-method medium string :text-style text-style
                                                 :start idx0 :end end)
               (declare (ignore dy))
               (maxf block-ws ws)
               (incf block-hs hs)
               (values block-ws
                       block-hs
                       dx current-dy
                       baseline))))
      (loop for idx0 = start then (1+ idx1)
            for idx1 = (position #\newline string :start idx0 :end end)
            until (null idx1)
            do (handle-line idx0 idx1)
            finally
               (return (handle-last idx0))))))

(defmethod medium-draw-text* :around ((medium multiline-medium-mixin) string x y
                                      start end
                                      align-x align-y toward-x toward-y
                                      transform-glyphs)
  (let (text-transf dx dy)
    (labels ((text-transf ()
               (or text-transf
                   (let ((base-transf (medium-device-transformation medium)))
                     (if transform-glyphs
                         (draw-text-rotation* x y toward-x toward-y)
                         (with-transformed-positions*
                             (base-transf x y toward-x toward-y)
                           (compose-transformations
                            (draw-text-rotation* x y toward-x toward-y)
                            (invert-transformation base-transf)))))))
             (position-box ()
               (multiple-value-bind (xmin ymin xmax ymax)
                   (text-bounding-rectangle* medium string :start start :end end)
                 (let* ((xmid (/ (+ xmin xmax) 2))
                        (ymid (/ (+ ymin ymax) 2))
                        (dx (ecase align-x
                              (:baseline 0)
                              (:left   (- xmin))
                              (:right  (- xmax))
                              (:center (- xmid))))
                        (dy (ecase align-y
                              (:baseline 0)
                              (:top    (- ymin))
                              (:bottom (- ymax))
                              (:center (- ymid)))))
                   (with-transformed-distance ((text-transf) dx dy)
                     (incf x dx) (incf toward-x dx)
                     (incf y dy) (incf toward-y dy)))
                 (setf align-x :baseline align-y :baseline)))
             (advance-line ()
               (unless dx
                 (multiple-value-bind (w h line-dx line-dy baseline)
                     (text-size medium #.(format nil " ~%"))
                   ;;      ;; IDX1 is a position of #\newline hence #'1+
                   #+ (or) (text-size medium string :start idx0 :end (1+ idx1))
                   (declare (ignore w h baseline))
                   (multiple-value-setq (dx dy)
                     (transform-distance (text-transf) line-dx line-dy))))
               (incf x dx) (incf toward-x dx)
               (incf y dy) (incf toward-y dy)))
      (when (and (or (not (eq align-x :baseline))
                     (not (eq align-y :baseline)))
                 (find #\newline string :start start :end end))
        (position-box))
      (loop for idx0 = start then (1+ idx1)
            for idx1 = (position #\newline string :start idx0 :end end)
            do (call-next-method medium string x y idx0 (or idx1 end)
                                 align-x align-y toward-x toward-y
                                 transform-glyphs)
            while idx1
            do (advance-line)))))