Emacs can crop images

;;; cropimages.el --- Crop Image -*- lexical-binding: t; -*-

;; Copyright (C) 2018-2021 Free Software Foundation, Inc.

;; Author: Emilio Torres-Manzanera <torres@uniovi.es>
;; Keywords: image, crop, paste

;; cropimages is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; cropimages is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;;; Commentary:

;; Based on the work of https://lars.ingebrigtsen.no/2018/11/12/cropping-images-in-emacs/
;; https://github.com/larsmagne/ewp
;; It provides the following functions
;; `M-x etm-ewp-crop-image'
;; `M-x etm-ewp-yank-paste-picture-image'
;; `M-x etm-ewp-save-image'
;; `M-x etm-ewp-trim-image'


;;; Code:


(require 'cl)
(require 'svg)

(defvar etm-ewp-display-width nil
  "Max width of imaged when editing.
If nil, use the frame width.")

(defun etm-ewp--display-width ()
  (or etm-ewp-display-width
      (- (frame-pixel-width) 50)))

(defun etm-ewp--image-type ()
  (if (or (and (fboundp 'image-transforms-p)
               (image-transforms-p))
          (not (fboundp 'imagemagick-types)))
      nil
    'imagemagick))

(defun etm-ewp-insert-image-data (image)
  (goto-char (point-min))
  (insert image)
  (goto-char (point-min))
  (image-toggle-display-image))




(defun etm-ewp-content-type (image)
  ;; Get the MIME type by running "file" over it.
  (with-temp-buffer
    (set-buffer-multibyte nil)
    (insert image)
    (call-process-region (point-min) (point-max)
                         "file" t (current-buffer) nil
                         "--mime-type" "-")
    (cadr (split-string (buffer-string)))))


(defun etm-ewp-yank-paste-picture-image ()
  "Yank the contents of the current X image selection/clipboard, if any."
  (interactive)
  (let ((data
         (cl-loop for type in '(PRIMARY CLIPBOARD)
                  for st = (cl-loop for st across
                                    (gui-get-selection type 'TARGETS)
                                    when (equal (car (split-string
                                                      (symbol-name st) "/"))
                                                "image")
                                    return st)
                  when st
                  return (x-get-selection-internal type st))))
    (if (not data)
        (message "No image data in the current selection/clipboard")
      (set-mark (point))
      (etm-ewp-insert-image-data data))))


(defun etm-ewp-crop-image (&optional square)
  "Crop the image under point.
If SQUARE (the prefix), crop a square from the image."
  (interactive "P")
  (let ((image (get-text-property (point) 'display)))
    (when (or (not image)
              (not (consp image))
              (not (eq (car image) 'image)))
      (error "No image under point"))
    ;; We replace the image under point with an SVG image that looks
    ;; just like that image.  That allows us to draw lines over it.
    ;; At the end, we replace that SVG with a cropped version of the
    ;; original image.
    (let* ((data (getf (cdr image) :data))
           (undo-handle (prepare-change-group))
           (orig-data data)
           (type (cond
                  ((getf (cdr image) :format)
                   (format "%s" (getf (cdr image) :format)))
                  (data
                   (etm-ewp-content-type data))))
           (image-scaling-factor 1)
           (size (image-size image t))
           (svg (svg-create (car size) (cdr size)
                            :xmlns:xlink "http://www.w3.org/1999/xlink"
                            :stroke-width 5))
           (text (buffer-substring (line-beginning-position)
                                   (line-end-position)))
           (inhibit-read-only t))
      (with-temp-buffer
        (set-buffer-multibyte nil)
        (if (null data)
            (insert-file-contents-literally (getf (cdr image) :file))
          (insert data))
        ;; (let ((ewp-exif-rotate nil))
        ;;   (ewp-possibly-rotate-buffer image))
        (setq orig-data (buffer-string))
        (setq type (etm-ewp-content-type orig-data))
        (call-process-region (point-min) (point-max)
                             "convert" t (current-buffer) nil
                             "-resize" "600x"
                             "-"
                             (format "%s:-" (cadr (split-string type "/"))))
        (setq data (buffer-string)))
          (delete-region (point-min) (point-max))
      (svg-embed svg data type t
                 :width (car size)
                 :height (cdr size))
      (delete-region (line-beginning-position)
                     (line-end-position))
      (svg-insert-image svg)
      (let ((area (condition-case _
                      (save-excursion
                        (forward-line 1)
                        (etm-ewp-crop-image-1 svg square
                                              (car size) (cdr size)))
                    (quit nil))))
        (delete-region (line-beginning-position) (line-end-position))
        (if area
            (etm-ewp-crop-image-update area orig-data size type)
          ;; If the user didn't complete the crop, re-insert the
          ;; original image (and text).
          (insert text))
        (undo-amalgamate-change-group undo-handle)))))

(defun etm-ewp-crop-image-update (area data size type)
  (let* ((image-scaling-factor 1)
         (osize (image-size (create-image data (etm-ewp--image-type) t) t))
         (factor (/ (float (car osize)) (car size))))
    (etm-ewp-insert-image-data
     (with-temp-buffer
       (set-buffer-multibyte nil)
       (insert data)
       (call-process-region
        (point-min) (point-max) "convert"
        t (list (current-buffer) nil) nil
        "+repage" "-crop"
        (format
         ;; width x height + left + top
         "%dx%d+%d+%d"
         (abs (truncate (* factor (- (getf area :right) (getf area :left)))))
         (abs (truncate (* factor (- (getf area :bottom) (getf area :top)))))
         (truncate (* factor (min (getf area :left) (getf area :right))))
         (truncate (* factor (min (getf area :top) (getf area :bottom)))))
        "-" (format "%s:-" (cadr (split-string type "/"))))
       (buffer-string)))))

(defun etm-ewp-crop-image-1 (svg &optional square image-width image-height)
  (track-mouse
    (cl-loop with prompt = (if square "Move square" "Set start point")
             and state = (if square 'move-unclick 'begin)
             and area = (if square
                            (list :left (- (/ image-width 2)
                                           (/ image-height 2))
                                  :top 0
                                  :right (+ (/ image-width 2)
                                            (/ image-height 2))
                                  :bottom image-height)
                          (list :left 0
                                :top 0
                                :right 0
                                :bottom 0))
             and corner = nil
             for event = (read-event prompt)
             do (if (or (not (consp event))
                        (not (consp (cadr event)))
                        (not (nth 7 (cadr event)))
                        ;; Only do things if point is over the SVG being
                        ;; tracked.
                        (not (eq (getf (cdr (nth 7 (cadr event))) :type)
                                 'svg)))
                    ()
                  (let ((pos (nth 8 (cadr event))))
                    (cl-case state
                      ('begin
                       (cond
                        ((eq (car event) 'down-mouse-1)
                         (setq state 'stretch
                               prompt "Stretch to end point")
                         (setf (getf area :left) (car pos)
                               (getf area :top) (cdr pos)
                               (getf area :right) (car pos)
                               (getf area :bottom) (cdr pos)))))
                      ('stretch
                       (cond
                        ((eq (car event) 'mouse-movement)
                         (setf (getf area :right) (car pos)
                               (getf area :bottom) (cdr pos)))
                        ((memq (car event) '(mouse-1 drag-mouse-1))
                         (setq state 'corner
                               prompt "Choose corner to adjust (RET to crop)"))))
                      ('corner
                       (cond
                        ((eq (car event) 'down-mouse-1)
                         ;; Find out what corner we're close to.
                         (setq corner (etm-ewp-find-corner
                                       area pos
                                       '((:left :top)
                                         (:left :bottom)
                                         (:right :top)
                                         (:right :bottom))))
                         (when corner
                           (setq state 'adjust
                                 prompt "Adjust crop")))))
                      ('adjust
                       (cond
                        ((memq (car event) '(mouse drag-mouse-1))
                         (setq state 'corner
                               prompt "Choose corner to adjust"))
                        ((eq (car event) 'mouse-movement)
                         (setf (getf area (car corner)) (car pos)
                               (getf area (cadr corner)) (cdr pos)))))
                      ('move-unclick
                       (cond
                        ((eq (car event) 'down-mouse-1)
                         (setq state 'move-click
                               prompt "Move"))))
                      ('move-click
                       (cond
                        ((eq (car event) 'mouse-movement)
                         (setf (getf area :left) (car pos)
                               (getf area :right) (+ (car pos) image-height)))
                        ((memq (car event) '(mouse-1 drag-mouse-1))
                         (setq state 'move-unclick
                               prompt "Click to move")))))))
             do (svg-line svg (getf area :left) (getf area :top)
                          (getf area :right) (getf area :top)
                          :id "top-line" :stroke-color "white")
             (svg-line svg (getf area :left) (getf area :bottom)
                       (getf area :right) (getf area :bottom)
                       :id "bottom-line" :stroke-color "white")
             (svg-line svg (getf area :left) (getf area :top)
                       (getf area :left) (getf area :bottom)
                       :id "left-line" :stroke-color "white")
             (svg-line svg (getf area :right) (getf area :top)
                       (getf area :right) (getf area :bottom)
                       :id "right-line" :stroke-color "white")
             while (not (member event '(return ?q)))
             finally (return (and (eq event 'return)
                                  area)))))

(defun etm-ewp-find-corner (area pos corners)
  (cl-loop for corner in corners
           ;; We accept 10 pixels off.
           when (and (< (- (car pos) 10)
                        (getf area (car corner))
                        (+ (car pos) 10))
                     (< (- (cdr pos) 10)
                        (getf area (cadr corner))
                        (+ (cdr pos) 10)))
           return corner))

(defun etm-ewp-trim-image (fuzz)
  "Trim (i.e., remove black borders) the image under point.
FUZZ (the numerical prefix) says how much fuzz to apply."
  (interactive "p")
  (let ((image (get-text-property (point) 'display))
        new-data)
    (when (or (not image)
              (not (consp image))
              (not (eq (car image) 'image)))
      (error "No image under point"))
    (let* ((data (getf (cdr image) :data))
           (inhibit-read-only t))
      (when (null data)
        (with-temp-buffer
          (set-buffer-multibyte nil)
          (insert-file-contents-literally (getf (cdr image) :file))
          (setq data (buffer-string)))
        (setq type (etm-ewp-content-type data)))
      (with-temp-buffer
        (set-buffer-multibyte nil)
        (insert data)
        (call-process-region (point-min) (point-max)
                             "convert" t (current-buffer) nil
                             "-trim" "+repage"
                             "-fuzz" (format "%d%%" fuzz)
                             (format "%s:-" (car (last (split-string
                                                        (etm-ewp-content-type data)
                                                        "/"))))
                             "jpg:-")
        (setq new-data (buffer-string)))
      (delete-region (line-beginning-position) (line-end-position))
      (etm-ewp-insert-image-data new-data))))

(defun etm-ewp-save-image (filename)
  "Save the image under point."
  (interactive "FFilename: ")
  (let ((image (get-text-property (point) 'display))
        new-data)
    (when (or (not image)
              (not (consp image))
              (not (eq (car image) 'image)))
      (error "No image under point"))
    (let* ((data (getf (cdr image) :data))
           (inhibit-read-only t))
      (when (null data)
        (with-temp-buffer
          (set-buffer-multibyte nil)
          (insert-file-contents-literally (getf (cdr image) :file))
          (setq data (buffer-string)))
        (setq type (etm-ewp-content-type data)))
      (with-temp-buffer
        (set-buffer-multibyte nil)
        (insert data)
        (write-region (point-min) (point-max) filename))
      (delete-region (line-beginning-position) (line-end-position 2)))))


(provide 'emacs-rc-images)
;;; emacs-rc-images.el ends here