diff --git a/lisp/image.el b/lisp/image.el index d7496485aca..b609f0fc34c 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 (image-property image :rotation))) + (and degrees (= 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 "") (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")