bug#69602: 29.1; Image :map should adjust with :scale and :rotation

[Joseph Turner]

Currently, when running `image-increase-size' or `image-decrease-size'
on an image with a :map property, the image scales but the image map
does not.  For example, run the following snippet:

(with-current-buffer (get-buffer-create "*image-properties-test*")
  (let ((svg "<?xml version=\"1.0\" encoding=\"UTF-8\" 
standalone=\"no\"?>\n<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n 
\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\";>\n<!-- Generated by 
graphviz version 2.43.0 (0)\n -->\n<!-- Title: orggraphview Pages: 1 -->\n<svg 
width=\"128pt\" height=\"128pt\"\n viewBox=\"0.00 0.00 127.59 127.59\" 
xmlns=\"http://www.w3.org/2000/svg\"; 
xmlns:xlink=\"http://www.w3.org/1999/xlink\";>\n<g id=\"graph0\" class=\"graph\" 
transform=\"scale(1 1) rotate(0) translate(4 
123.59)\">\n<title>orggraphview</title>\n<polygon fill=\"white\" 
stroke=\"transparent\" points=\"-4,4 -4,-123.59 123.59,-123.59 123.59,4 
-4,4\"/>\n<!-- a -->\n<g id=\"node1\" class=\"node\">\n<title>a</title>\n<g 
id=\"a_node1\"><a xlink:href=\"1\" xlink:title=\"Hover me!\">\n<ellipse 
fill=\"none\" stroke=\"black\" cx=\"59.79\" cy=\"-59.79\" rx=\"59.59\" 
ry=\"59.59\"/>\n<text text-anchor=\"middle\" x=\"59.79\" y=\"-56.09\" 
font-family=\"Times,serif\" font-size=\"14.00\" fill=\"#000000\">Hover 
me!</text>\n</a>\n</g>\n</g>\n</g>\n</svg>\n")
        (map '(((circle (85 . 85) . 80) "1" (help-echo "Surprise!"))))
        (inhibit-read-only t))
    (erase-buffer)
    (insert-image (create-image svg 'svg t :map map))
    (goto-char (point-min))
    (pop-to-buffer (current-buffer))))

Hovering the circle alters the pointer style and displays the tooltip.

Now run `M-x image-increase-size' or press "i +".  While the image
becomes larger, the area which activates the tooltip remains the same.

See earlier discussion here:

https://yhetil.org/emacs-devel/87r0gng41l.fsf@ushin.org/T/#t

While a proper solution perhaps belongs on the C side, the following
workaround adds an :unscaled-map property to images and sets :map
according to :unscaled-map and :scale whenever :scale changes.

This workaround does not (yet) handle :rotation.

--8<---------------cut here---------------start------------->8---

(defun image--scale-map (map factor)
  "Scale MAP by FACTOR, destructively modifying it."
  (unless (= 1 factor)
    (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
      (pcase-exhaustive type
        ('rect
         (setf (caar coords) (round (* (caar coords) factor)))
         (setf (cdar coords) (round (* (cdar coords) factor)))
         (setf (cadr coords) (round (* (cadr coords) factor)))
         (setf (cddr coords) (round (* (cddr coords) factor))))
        ('circle
         (setf (caar coords) (round (* (caar coords) factor)))
         (setf (cdar coords) (round (* (cdar coords) factor)))
         (setf (cdr coords) (round (* (cdr coords) factor))))
        ('poly
         (dotimes (i (length coords))
           (aset coords i
                 (round (* (aref coords i) factor))))))))
  map)

(defun image--create-image-add-unscaled-map
    (orig-fun file-or-data &optional type data-p &rest props)
  "Add :unscaled-map property to image returned by ORIG-FUN and return it.
Intended to be used as :around advice for `create-image'."
  (let ((image (apply orig-fun file-or-data type data-p props)))
    (when-let ((map (image-property image :map)))
      (setq image (nconc image
                         (list :unscaled-map (copy-tree map t))))
      (when-let* ((props-scale (plist-get props :scale))
                  ((numberp props-scale)))
        (setf (image-property image :unscaled-map)
              (image--scale-map (image-property image :unscaled-map)
                                (/ 1.0 props-scale)))))
    image))

(advice-add #'create-image :around #'image--create-image-add-unscaled-map)

(defun image--change-size-scale-map (_factor &optional position)
  "Scale :map property of image at point to fit its :scale.
Intended to be used as :after advice for `image--change-size'."
  (when-let* ((image (image--get-imagemagick-and-warn position))
              (map (image-property image :map))
              (unscaled-map (image-property image :unscaled-map))
              (scale (image-property image :scale)))
    (setf (image-property image :map)
          ;; TODO: Instead of copying `:unscaled-map', reuse the :map vector?
          (image--scale-map (copy-tree unscaled-map t) scale))))

(advice-add #'image--change-size :after #'image--change-size-scale-map)

--8<---------------cut here---------------end--------------->8---

Thank you!

Joseph




In GNU Emacs 29.1 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.24.37,
cairo version 1.16.0)
Windowing system distributor 'The X.Org Foundation', version 11.0.12101007
System Description: Debian GNU/Linux 12 (bookworm)