From: David Ponce via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
To: 69992@debbugs.gnu.org
Cc: Eli Zaretskii <eliz@gnu.org>,
Joseph Turner <joseph@breatheoutbreathe.in>
Subject: bug#69992: Minor improvement to image map transformation logic
Date: Fri, 29 Mar 2024 11:19:11 +0100 [thread overview]
Message-ID: <182126ee-57b1-4a86-82c6-ba46e4b676cb@orange.fr> (raw)
In-Reply-To: <d700809c-b4ab-43bc-acbb-e548cc3123c1@orange.fr>
[-- Attachment #1: Type: text/plain, Size: 1397 bytes --]
[...]
> The attached new patch fixes the logic to be consistent with Emacs
> internal implementation, plus some other tweaks to check if a
> transformation apply before to call the transformation function.
> I also updated some tests according to functions changes.
> Here is a possible change log:
>
> 2024-03-28 David Ponce <da_vid@orange.fr>
>
> * lisp/image.el (image--compute-scaling)
> (image--compute-rotation): New functions.
> (image--compute-map, image--compute-original-map): Use them.
> Ensure all transformations are applied or undone according to what
> Emacs does internally. Call a transformation function only when
> needed. Fix doc string.
> (image--scale-map): Assume effective scale argument.
> (image--rotate-map): Assume effective rotation argument.
> (image--rotate-coord): Improve doc string.
> (image--flip-map): Remove no more used flip argument.
>
> * test/lisp/image-tests.el (image-create-image-with-map): Use a
> valid SVG image otherwise `image-size' will not return a valid
> value and calculation of scale could fail.
> (image-transform-map): Update according to changed signature of
> image--flip-map.
[...]
Hello,
Please find attached a new patch with an additional small fix I forgot to
include. Sorry.
Regards
[-- Attachment #2: image-compute-map-V1.patch --]
[-- Type: text/x-patch, Size: 13927 bytes --]
diff --git a/lisp/image.el b/lisp/image.el
index d7496485aca..2627d0be10a 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -1423,115 +1423,139 @@ image-recompute-map-p
:type 'boolean
:version "30.1")
+(defsubst image--compute-scaling (image)
+ "Return the current scaling of IMAGE, or 1 if no scaling."
+ ;; The image may be scaled due to many reasons (:scale, :max-width,
+ ;; etc), so using `image--current-scaling' to get ratio between the
+ ;; original image size and the displayed size) is better than just
+ ;; using the :scale value. Unfortunately each call to `image_size' is
+ ;; very resource consuming!
+ ;; (image--current-scaling
+ ;; image (image--image-without-parameters image))
+ (or (image-property image :scale) 1))
+
+(defsubst image--compute-rotation (image)
+ "Return the current rotation of IMAGE, or 0 if no rotation.
+Also return nil if rotation is not a multiples of 90 degrees (0, 90,
+180[-180] and 270[-90])."
+ (let ((degrees (or (image-property image :rotation) 0)))
+ (and (= 0 (mod degrees 1))
+ (car (memql (truncate (mod degrees 360)) '(0 90 180 270))))))
+
(defun image--compute-map (image)
"Compute map for IMAGE suitable to be used as its :map property.
-Return a copy of :original-image transformed based on IMAGE's :scale,
+Return a copy of :original-map 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)
+ (when-let ((map (image-property image :original-map)))
+ (setq map (copy-tree map t))
+ (let* ((scale (image--compute-scaling image))
+ (rotation (image--compute-rotation image))
+ ;; Image is flipped only if rotation is a multiple of 90,
+ ;; including 0.
+ (flip (and rotation (image-property image :flip)))
+ (size (image-size image t)))
+ ;; SIZE fits MAP after transformations. Scale MAP before flip and
+ ;; rotate operations, since both need MAP to fit SIZE.
+ (unless (= scale 1)
+ (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))
+ (when (memql rotation '(90 180 270))
+ (image--rotate-map
+ map rotation (if (= rotation 180)
+ size
;; If rotated ±90°, swap width and height.
- (cons height width)
- size))
+ (cons (cdr size) (car size)))))
;; After rotation, there's no need to swap width and height.
- (image--flip-map map flip size))
+ (when flip
+ (image--flip-map map size)))
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* ((original-map (copy-tree (image-property image :map) t))
- (scale (or (image-property image :scale) 1))
- (rotation (or (image-property image :rotation) 0))
- (flip (image-property image :flip))
+When there is no transformation, return copy of :map."
+ (when-let ((original-map (image-property image :map)))
+ (setq original-map (copy-tree original-map t))
+ (let* ((scale (image--compute-scaling image))
+ (rotation (image--compute-rotation image))
+ ;; Image is flipped only if rotation is a multiple of 90
+ ;; including 0.
+ (flip (and rotation (image-property image :flip)))
(size (image-size image t)))
- (when (and ; Handle only 90-degree rotations
- (zerop (mod rotation 1))
- (zerop (% (truncate rotation) 90)))
- ;; In rendered images, rotation is always applied before flip.
- ;; To undo the transformation, flip before rotating. SIZE fits
- ;; ORIGINAL-MAP before transformations are applied. Therefore,
- ;; scale ORIGINAL-MAP after flip and rotate operations, since
- ;; both need ORIGINAL-MAP to fit SIZE.
- (image--flip-map original-map flip size)
- (image--rotate-map original-map (- rotation) size)
- (image--scale-map original-map (/ 1.0 scale)))
- original-map)))
+ ;; In rendered images, rotation is always applied before flip.
+ ;; To undo the transformation, flip before rotating. SIZE fits
+ ;; ORIGINAL-MAP before transformations are applied. Therefore,
+ ;; scale ORIGINAL-MAP after flip and rotate operations, since
+ ;; both need ORIGINAL-MAP to fit SIZE.
+ ;; In rendered images, rotation is always applied before flip.
+ (when flip
+ (image--flip-map original-map size))
+ (when (memql rotation '(90 180 270))
+ (image--rotate-map original-map (- rotation) size))
+ (unless (= scale 1)
+ (image--scale-map original-map (/ 1.0 scale))))
+ original-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))))))))
+ (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.
+ROTATION must be a non-zero multiple of 90.
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))))))))
+ (setq rotation (mod rotation 360))
+ (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 rotation ; 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)
(defun image--rotate-coord (x y angle size)
"Rotate coordinates X and Y by ANGLE in image of SIZE.
-ANGLE must be a multiple of 90. Returns a cons cell of rounded
-coordinates (X1 Y1)."
+ANGLE must be a multiple of 90 in [90 180 270]. Returns a cons cell of
+rounded coordinates (X1 Y1)."
(pcase-let* ((radian (* (/ angle 180.0) float-pi))
(`(,width . ,height) size)
;; y is positive, but we are in the bottom-right quadrant
@@ -1552,25 +1576,24 @@ 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.
+(defun image--flip-map (map size)
+ "Horizontally flip MAP according to 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)))))))))
+ (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)
diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el
index 6a5f03e38a0..020781eff50 100644
--- a/test/lisp/image-tests.el
+++ b/test/lisp/image-tests.el
@@ -158,7 +158,7 @@ image-rotate
(ert-deftest image-create-image-with-map ()
"Test that `create-image' correctly adds :map and/or :original-map."
(skip-unless (display-images-p))
- (let ((data "foo")
+ (let ((data "<svg width=\"30\" height=\"30\" version=\"1.1\" xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"></svg>")
(map '(((circle (1 . 1) . 1) a)))
(original-map '(((circle (2 . 2) . 2) a)))
(original-map-other '(((circle (3 . 3) . 3) a))))
@@ -282,7 +282,7 @@ image-transform-map
'(((circle (12 . 4) . 2) "circle")
((rect (7 . 3) 9 . 8) "rect")
((poly . [4 6 2 7 1 2]) "poly"))))
- (should (equal (image--flip-map (copy-tree map t) t `(,width . ,height))
+ (should (equal (image--flip-map (copy-tree map t) `(,width . ,height))
'(((circle (6 . 3) . 2) "circle")
((rect (2 . 6) 7 . 8) "rect")
((poly . [4 11 3 13 8 14]) "poly"))))
@@ -291,7 +291,7 @@ image-transform-map
;; Scale size because the map has been scaled.
(image--rotate-map copy 90 `(,(* 2 width) . ,(* 2 height)))
;; Swap width and height because the map has been flipped.
- (image--flip-map copy t `(,(* 2 height) . ,(* 2 width)))
+ (image--flip-map copy `(,(* 2 height) . ,(* 2 width)))
(should (equal copy
'(((circle (6 . 8) . 4) "circle")
((rect (12 . 6) 16 . 16) "rect")
next prev parent reply other threads:[~2024-03-29 10:19 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
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 [this message]
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
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=182126ee-57b1-4a86-82c6-ba46e4b676cb@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 external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.