From: David Ponce via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
To: Eli Zaretskii <eliz@gnu.org>,
Joseph Turner <joseph@breatheoutbreathe.in>
Cc: 69992@debbugs.gnu.org
Subject: bug#69992: Minor improvement to image map transformation logic
Date: Wed, 27 Mar 2024 15:21:18 +0100 [thread overview]
Message-ID: <c348afa4-e837-4362-9edb-1f7474a8c28b@orange.fr> (raw)
In-Reply-To: <86cyrfj0t3.fsf@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 837 bytes --]
On 27/03/2024 13:50, Eli Zaretskii wrote:
>> Date: Wed, 27 Mar 2024 12:16:11 +0100
>> From: David Ponce via "Bug reports for GNU Emacs,
>> the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
>>
>> Many thanks for this feature, which is particularly useful to
>> automatically recalculate the map of computed images like SVG.
>>
>> To make the code faster, by avoiding multiple scans of the map for
>> copy and parsing, I propose the following patch which factors most of
>> the code into the functions `image--compute-map' and `image--compute
>> -original-map'. I have done some tests on my side which are
>> conclusive.
>>
>> Furthermore, I wonder if the term :base-map would not be more
>> descriptive than :original-map?
>
> Thanks.
>
> Joseph, any comments or suggestions?
Attached the same patch slightly cleaned up.
[-- Attachment #2: image.el-compute-map-V1.patch --]
[-- Type: text/x-patch, Size: 13333 bytes --]
diff --git a/lisp/image.el b/lisp/image.el
index 55340ea03dc..92b9dff01e1 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -1427,107 +1427,170 @@ image--compute-map
"Compute map for IMAGE suitable to be used as its :map property.
Return a copy of :original-image transformed based on IMAGE's :scale,
:rotation, and :flip. When IMAGE's :original-map is nil, return nil.
-When :rotation is not a multiple of 90, return copy of :original-map."
- (pcase-let* ((original-map (image-property image :original-map))
- (map (copy-tree original-map t))
- (scale (or (image-property image :scale) 1))
- (rotation (or (image-property image :rotation) 0))
- (flip (image-property image :flip))
- ((and size `(,width . ,height)) (image-size image t)))
- (when (and ; Handle only 90-degree rotations
- (zerop (mod rotation 1))
- (zerop (% (truncate rotation) 90)))
- ;; SIZE fits MAP after transformations. Scale MAP before
- ;; flip and rotate operations, since both need MAP to fit SIZE.
- (image--scale-map map scale)
- ;; In rendered images, rotation is always applied before flip.
- (image--rotate-map
- map rotation (if (or (= 90 rotation) (= 270 rotation))
- ;; If rotated ±90°, swap width and height.
- (cons height width)
- size))
- ;; After rotation, there's no need to swap width and height.
- (image--flip-map map flip size))
- map))
+When there is no transformation, return :original-map."
+ (when-let ((omap (image-property image :original-map)))
+ (let* ((scale (let ((s (image--current-scaling
+ image
+ (image--image-without-parameters image))))
+ (unless (= s 1) s)))
+ (rotate (let ((d (image-property image :rotation)))
+ ;; Handle only 90-degree rotations
+ (and d (= 0 (mod d 1)) (= 0 (% d 90))
+ (truncate (mod d 360)))))
+ (flip (image-property image :flip))
+ (map omap)
+ size flip-w)
+ (when (or scale rotate flip)
+ (setq map nil
+ size (image-size image t)
+ flip-w (car size))
+ (if (memql rotate '(90 270))
+ ;; If rotated ±90°, swap width and height.
+ (setq size (cons (cdr size) (car size))))
+ ;; SIZE fits MAP after transformations. Scale MAP before flip
+ ;; and rotate operations, since both need MAP to fit SIZE.
+ (pcase-dolist (`(,area ,id ,plist) omap)
+ (pcase-exhaustive area
+ ;; Rectangle hot spot.
+ (`(rect . ((,x0 . ,y0) . (,x1 . ,y1)))
+ (if scale
+ (setq x0 (round (* x0 scale)) y0 (round (* y0 scale))
+ x1 (round (* x1 scale)) y1 (round (* y1 scale))))
+ (if rotate
+ (let ((p0 (image--rotate-coord x0 y0 rotate size))
+ (p1 (image--rotate-coord x1 y1 rotate size)))
+ (setq x0 (car p0) y0 (cdr p0)
+ x1 (car p1) y1 (cdr p1))))
+ (if flip
+ (let ((xa x0) (xb x1))
+ (setq x0 (- flip-w xb)
+ x1 (- flip-w xa))))
+ ;; Normalize rect coords to be top/left bottom/right.
+ (if (> x0 x1)
+ (let ((rw (abs (- x0 x1))))
+ (setq x0 (- x0 rw) x1 (+ x1 rw))))
+ (if (> y0 y1)
+ (let ((rh (abs (- y0 y1))))
+ (setq y0 (- y0 rh) y1 (+ y1 rh))))
+ (push `((rect . ((,x0 . ,y0) . (,x1 . ,y1))) ,id ,plist)
+ map))
+ ;; Circle hot spot.
+ (`(circle . ((,x0 . ,y0) . ,r))
+ (if scale
+ (setq x0 (round (* x0 scale)) y0 (round (* y0 scale))
+ r (round (* r scale))))
+ (if rotate
+ (let ((p0 (image--rotate-coord x0 y0 rotate size)))
+ (setq x0 (car p0) y0 (cdr p0))))
+ (if flip
+ (setq x0 (- flip-w x0)))
+ (push `((circle . ((,x0 . ,y0) . ,r)) ,id ,plist) map))
+ ;; Poly hot spot.
+ (`(poly . ,coords)
+ (setq coords (copy-sequence coords))
+ (let ((i 0) (n (length coords)))
+ (while (< i n)
+ (let* ((j (1+ i))
+ (x (aref coords i))
+ (y (aref coords j)))
+ (if scale
+ (setq x (round (* x scale))
+ y (round (* y scale))))
+ (if rotate
+ (let ((p (image--rotate-coord x y rotate size)))
+ (setq x (car p) y (cdr p))))
+ (if flip
+ (setq x (- flip-w x)))
+ (aset coords i x)
+ (aset coords j y))
+ (setq i (+ i 2))))
+ (push `((poly . ,coords) ,id ,plist) map))
+ )))
+ map)))
(defun image--compute-original-map (image)
"Return original map for IMAGE.
If IMAGE lacks :map property, return nil.
-When :rotation is not a multiple of 90, return copy of :map."
- (when (image-property image :map)
- (let* ((image-copy (copy-tree image t))
- (map (image-property image-copy :map))
- (scale (or (image-property image-copy :scale) 1))
- (rotation (or (image-property image-copy :rotation) 0))
- (flip (image-property image-copy :flip))
- (size (image-size image-copy t)))
- (when (and ; Handle only 90-degree rotations
- (zerop (mod rotation 1))
- (zerop (% (truncate rotation) 90)))
+When there is no transformation, return :map."
+ (when-let ((map (image-property image :map)))
+ (let* ((scale (let ((s (image--current-scaling
+ image
+ (image--image-without-parameters image))))
+ (unless (= s 1) s)))
+ (rotate (let ((d (image-property image :rotation)))
+ ;; Handle only 90-degree rotations
+ (and d (= 0 (mod d 1)) (= 0 (% d 90))
+ (truncate (mod (- d) 360)))))
+ (flip (image-property image :flip))
+ (omap map)
+ size flip-w)
+ (when (or scale rotate flip)
+ (setq omap nil
+ size (image-size image t)
+ flip-w (car size))
;; In rendered images, rotation is always applied before flip.
;; To undo the transformation, flip before rotating.
- ;; SIZE fits MAP before it is transformed back to ORIGINAL-MAP.
- ;; Therefore, scale MAP after flip and rotate operations, since
- ;; both need MAP to fit SIZE.
- (image--flip-map map flip size)
- (image--rotate-map map (- rotation) size)
- (image--scale-map map (/ 1.0 scale)))
- map)))
-
-(defun image--scale-map (map scale)
- "Scale MAP according to SCALE.
-Destructively modifies and returns MAP."
- (unless (= 1 scale)
- (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
- (pcase-exhaustive type
- ('rect
- (setf (caar coords) (round (* (caar coords) scale)))
- (setf (cdar coords) (round (* (cdar coords) scale)))
- (setf (cadr coords) (round (* (cadr coords) scale)))
- (setf (cddr coords) (round (* (cddr coords) scale))))
- ('circle
- (setf (caar coords) (round (* (caar coords) scale)))
- (setf (cdar coords) (round (* (cdar coords) scale)))
- (setcdr coords (round (* (cdr coords) scale))))
- ('poly
- (dotimes (i (length coords))
- (aset coords i
- (round (* (aref coords i) scale))))))))
- map)
-
-(defun image--rotate-map (map rotation size)
- "Rotate MAP according to ROTATION and SIZE.
-Destructively modifies and returns MAP."
- (unless (zerop rotation)
- (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
- (pcase-exhaustive type
- ('rect
- (let ( x0 y0 ; New upper left corner
- x1 y1) ; New bottom right corner
- (pcase (truncate (mod rotation 360)) ; Set new corners to...
- (90 ; ...old bottom left and upper right
- (setq x0 (caar coords) y0 (cddr coords)
- x1 (cadr coords) y1 (cdar coords)))
- (180 ; ...old bottom right and upper left
- (setq x0 (cadr coords) y0 (cddr coords)
- x1 (caar coords) y1 (cdar coords)))
- (270 ; ...old upper right and bottom left
- (setq x0 (cadr coords) y0 (cdar coords)
- x1 (caar coords) y1 (cddr coords))))
- (setcar coords (image--rotate-coord x0 y0 rotation size))
- (setcdr coords (image--rotate-coord x1 y1 rotation size))))
- ('circle
- (setcar coords (image--rotate-coord
- (caar coords) (cdar coords) rotation size)))
- ('poly
- (dotimes (i (length coords))
- (when (= 0 (% i 2))
- (pcase-let ((`(,x . ,y)
- (image--rotate-coord
- (aref coords i) (aref coords (1+ i)) rotation size)))
- (aset coords i x)
- (aset coords (1+ i) y))))))))
- map)
+ ;; SIZE fits MAP before it is transformed back to
+ ;; ORIGINAL-MAP. Therefore, scale MAP after flip and rotate
+ ;; operations, since both need MAP to fit SIZE.
+ (pcase-dolist (`(,area ,id ,plist) map)
+ (pcase-exhaustive area
+ ;; Rectangle hot spot.
+ (`(rect . ((,x0 . ,y0) . (,x1 . ,y1)))
+ (if flip
+ (let ((xa x0) (xb x1))
+ (setq x0 (- flip-w xb)
+ x1 (- flip-w xa))))
+ (if rotate
+ (let ((p0 (image--rotate-coord x0 y0 rotate size))
+ (p1 (image--rotate-coord x1 y1 rotate size)))
+ (setq x0 (car p0) y0 (cdr p0)
+ x1 (car p1) y1 (cdr p1))))
+ (if scale
+ (setq x0 (round (/ x0 scale)) y0 (round (/ y0 scale))
+ x1 (round (/ x1 scale)) y1 (round (/ y1 scale))))
+ ;; Normalize rect coords to be top/left bottom/right.
+ (if (> x0 x1)
+ (let ((rw (abs (- x0 x1))))
+ (setq x0 (- x0 rw) x1 (+ x1 rw))))
+ (if (> y0 y1)
+ (let ((rh (abs (- y0 y1))))
+ (setq y0 (- y0 rh) y1 (+ y1 rh))))
+ (push `((rect . ((,x0 . ,y0) . (,x1 . ,y1))) ,id ,plist)
+ omap))
+ ;; Circle hot spot.
+ (`(circle . ((,x0 . ,y0) . ,r))
+ (if flip
+ (setq x0 (- flip-w x0)))
+ (if rotate
+ (let ((p0 (image--rotate-coord x0 y0 rotate size)))
+ (setq x0 (car p0) y0 (cdr p0))))
+ (if scale
+ (setq x0 (round (/ x0 scale)) y0 (round (/ y0 scale))
+ r (round (/ r scale))))
+ (push `((circle . ((,x0 . ,y0) . ,r)) ,id ,plist) omap))
+ ;; Poly hot spot.
+ (`(poly . ,coords)
+ (setq coords (copy-sequence coords))
+ (let ((i 0) (n (length coords)))
+ (while (< i n)
+ (let* ((j (1+ i))
+ (x (aref coords i))
+ (y (aref coords j)))
+ (if flip
+ (setq x (- flip-w x)))
+ (if rotate
+ (let ((p (image--rotate-coord x y rotate size)))
+ (setq x (car p) y (cdr p))))
+ (if scale
+ (setq x (round (/ x scale))
+ y (round (/ y scale))))
+ (aset coords i x)
+ (aset coords j y))
+ (setq i (+ i 2))))
+ (push `((poly . ,coords) ,id ,plist) omap))
+ )))
+ omap)))
(defun image--rotate-coord (x y angle size)
"Rotate coordinates X and Y by ANGLE in image of SIZE.
@@ -1553,27 +1616,6 @@ image--rotate-coord
(y1 (- y1)))
(cons (round x1) (round y1))))
-(defun image--flip-map (map flip size)
- "Horizontally flip MAP according to FLIP and SIZE.
-Destructively modifies and returns MAP."
- (when flip
- (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
- (pcase-exhaustive type
- ('rect
- (let ((x0 (- (car size) (cadr coords)))
- (y0 (cdar coords))
- (x1 (- (car size) (caar coords)))
- (y1 (cddr coords)))
- (setcar coords (cons x0 y0))
- (setcdr coords (cons x1 y1))))
- ('circle
- (setf (caar coords) (- (car size) (caar coords))))
- ('poly
- (dotimes (i (length coords))
- (when (= 0 (% i 2))
- (aset coords i (- (car size) (aref coords i)))))))))
- map)
-
(provide 'image)
;;; image.el ends here
next prev parent reply other threads:[~2024-03-27 14:21 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-03-25 1:00 bug#69992: Minor improvement to image map transformation logic Joseph Turner via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-27 11:16 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-27 12:50 ` Eli Zaretskii
2024-03-27 14:21 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors [this message]
2024-03-27 22:17 ` Joseph Turner via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-27 23:53 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-28 22:22 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-29 10:19 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-30 8:10 ` Eli Zaretskii
2024-03-30 8:55 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-30 12:59 ` David Ponce via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-03-30 13:37 ` Eli Zaretskii
2024-03-30 19:07 ` Joseph Turner via Bug reports for GNU Emacs, the Swiss army knife of text editors
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=c348afa4-e837-4362-9edb-1f7474a8c28b@orange.fr \
--to=bug-gnu-emacs@gnu.org \
--cc=69992@debbugs.gnu.org \
--cc=da_vid@orange.fr \
--cc=eliz@gnu.org \
--cc=joseph@breatheoutbreathe.in \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).