Function: image-crop--crop-image-1

image-crop--crop-image-1 is a byte-compiled function defined in image-crop.el.gz.

Signature

(image-crop--crop-image-1 SVG OP)

Source Code

;; Defined in /usr/src/emacs/lisp/image/image-crop.el.gz
(defun image-crop--crop-image-1 (svg op)
  (track-mouse
    (cl-loop
     with prompt = (format
                    (substitute-command-keys
                     "Select area for %s (click \\`mouse-1' and drag)")
                    op)
     and state = 'begin
     and area = (list :left 0
		      :top 0
		      :right 0
		      :bottom 0)
     and corner = nil
     for event = (read-event prompt)
     do (cond
         ;; Go to "square" mode.
         ((eql event ?s)
          (setq state 'move-unclick
                prompt (format "Move square for %s" op))
          (let ((size (min (image-crop--width area) (image-crop--height area))))
            (setf (plist-get area :right) (+ (plist-get area :left) size)
                  (plist-get area :bottom) (+ (plist-get area :top) size))))
         ;; Go to "move" move.
         ((eql event ?m)
          (setq state 'move-unclick
                prompt (format "Move for %s" op)))
         ;; We have a (relevant) mouse event.
         ((and (consp event)
               (consp (cadr event))
               (nth 7 (cadr event))
	       ;; Only do things if point is over the SVG being
	       ;; tracked.
               (eq (cl-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 (format "Stretch to end point for %s" op))
		 (setf (cl-getf area :left) (car pos)
		       (cl-getf area :top) (cdr pos)
		       (cl-getf area :right) (car pos)
		       (cl-getf area :bottom) (cdr pos)))))
	      (stretch
	       (cond
		((eq (car event) 'mouse-movement)
		 (setf (cl-getf area :right) (car pos)
		       (cl-getf area :bottom) (cdr pos)))
		((memq (car event) '(mouse-1 drag-mouse-1))
		 (setq state 'corner
                       prompt (format
                               (substitute-command-keys
                                (concat
                                 "Type \\`RET' to %s, or click and drag "
                                 "\\`mouse-1' to adjust corners"))
                               op)))))
	      (corner
	       (cond
		((eq (car event) 'down-mouse-1)
		 ;; Find out what corner we're close to.
		 (setq corner (image-crop--find-corner
			       area pos
			       '((:left :top)
				 (:left :bottom)
				 (:right :top)
				 (:right :bottom))))
		 (when corner
		   (setq state 'adjust
                         prompt (format
                                 (substitute-command-keys
                                  "Adjusting %s area (release \\`mouse-1' to confirm)")
                                 op))))))
	      (adjust
	       (cond
		((memq (car event) '(mouse drag-mouse-1))
		 (setq state 'corner
                       prompt (format "Choose corner to adjust area for %s" op)))
		((eq (car event) 'mouse-movement)
		 (setf (cl-getf area (car corner)) (car pos)
		       (cl-getf area (cadr corner)) (cdr pos)))))
	      (move-unclick
	       (cond
		((eq (car event) 'down-mouse-1)
		 (setq state 'move-click
                       prompt (format "Move for %s" op)))))
	      (move-click
	       (cond
		((eq (car event) 'mouse-movement)
		 (setf (cl-getf area :right)
                       (+ (car pos) (image-crop--width area)))
                 (setf (cl-getf area :left) (car pos))
                 (setf (cl-getf area :bottom)
                       (+ (cdr pos) (image-crop--height area)))
                 (setf (cl-getf area :top) (cdr pos)))
		((memq (car event) '(mouse-1 drag-mouse-1))
		 (setq state 'move-unclick
                       prompt (format "Click to move for %s" op)))))))))
     do (svg-rectangle svg (cl-getf area :left) (cl-getf area :top)
                       (image-crop--width area) (image-crop--height area)
                       :stroke-color "red" :stroke-width 2
                       :fill-opacity 0.3 :fill "black" :id "rect")
     while (not (member event '(return ?q)))
     finally (return (and (eq event 'return)
			  area)))))