diff --git a/lisp/image.el b/lisp/image.el index 55340ea03dc..2e3928478ca 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 (1- (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 (1- (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