+;;; New rectangle integration with kill-ring.
+
+;; FIXME: known problems with the new rectangle support:
+;; - lots of commands handle the region without paying attention to its
+;; rectangular shape.
+
+(add-function :around redisplay-highlight-region-function
+ #'rectangle--highlight-for-redisplay)
+(add-function :around redisplay-unhighlight-region-function
+ #'rectangle--unhighlight-for-redisplay)
+(add-function :around region-extract-function
+ #'rectangle--extract-region)
+
+(defvar rectangle-mark-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [?\C-o] 'open-rectangle)
+ (define-key map [?\C-t] 'string-rectangle)
+ (define-key map [remap exchange-point-and-mark]
+ 'rectangle-exchange-point-and-mark)
+ (dolist (cmd '(right-char left-char forward-char backward-char
+ next-line previous-line))
+ (define-key map (vector 'remap cmd)
+ (intern (format "rectangle-%s" cmd))))
+ map)
+ "Keymap used while marking a rectangular region.")
+
+;;;###autoload
+(define-minor-mode rectangle-mark-mode
+ "Toggle the region as rectangular.
+Activates the region if needed. Only lasts until the region is deactivated."
+ nil nil nil
+ (rectangle--reset-crutches)
+ (when rectangle-mark-mode
+ (add-hook 'deactivate-mark-hook
+ (lambda () (rectangle-mark-mode -1)))
+ (unless (region-active-p)
+ (push-mark)
+ (activate-mark)
+ (message "Mark set (rectangle mode)"))))
+
+(defun rectangle-exchange-point-and-mark (&optional arg)
+ "Like `exchange-point-and-mark' but cycles through the rectangle's corners."
+ (interactive "P")
+ (if arg
+ (progn
+ (setq this-command 'exchange-point-and-mark)
+ (exchange-point-and-mark arg))
+ (let* ((p (point))
+ (repeat (eq this-command last-command))
+ (m (mark))
+ (p<m (< p m))
+ (cols (if p<m (rectangle--pos-cols p m) (rectangle--pos-cols m p)))
+ (cp (if p<m (car cols) (cdr cols)))
+ (cm (if p<m (cdr cols) (car cols))))
+ (if repeat (setq this-command 'exchange-point-and-mark))
+ (rectangle--reset-crutches)
+ (goto-char p)
+ (rectangle--col-pos (if repeat cm cp) 'mark)
+ (set-mark (point))
+ (goto-char m)
+ (rectangle--col-pos (if repeat cp cm) 'point))))
+
+(defun rectangle--*-char (cmd n &optional other-cmd)
+ ;; Part of the complexity here is that I'm trying to avoid making assumptions
+ ;; about the L2R/R2L direction of text around point, but this is largely
+ ;; useless since the rectangles implemented in this file are "logical
+ ;; rectangles" and not "visual rectangles", so in the presence of
+ ;; bidirectional text things won't work well anyway.
+ (if (< n 0) (rectangle--*-char other-cmd (- n))
+ (let ((col (rectangle--point-col (point))))
+ (while (> n 0)
+ (let* ((bol (line-beginning-position))
+ (eol (line-end-position))
+ (curcol (current-column))
+ (nextcol
+ (condition-case nil
+ (save-excursion
+ (funcall cmd 1)
+ (cond
+ ((> bol (point)) (- curcol 1))
+ ((< eol (point)) (+ col (1+ n)))
+ (t (current-column))))
+ (end-of-buffer (+ col (1+ n)))
+ (beginning-of-buffer (- curcol 1))))
+ (diff (abs (- nextcol col))))
+ (cond
+ ((and (< nextcol curcol) (< curcol col))
+ (let ((curdiff (- col curcol)))
+ (if (<= curdiff n)
+ (progn (cl-decf n curdiff) (setq col curcol))
+ (setq col (- col n) n 0))))
+ ((< nextcol 0) (ding) (setq n 0 col 0)) ;Bumping into BOL!
+ ((= nextcol curcol) (funcall cmd 1))
+ (t ;; (> nextcol curcol)
+ (if (<= diff n)
+ (progn (cl-decf n diff) (setq col nextcol))
+ (setq col (if (< col nextcol) (+ col n) (- col n)) n 0))))))
+ ;; FIXME: This rectangle--col-pos's move-to-column is wasted!
+ (rectangle--col-pos col 'point))))
+
+(defun rectangle-right-char (&optional n)
+ "Like `right-char' but steps into wide chars and moves past EOL."
+ (interactive "p") (rectangle--*-char #'right-char n #'left-char))
+(defun rectangle-left-char (&optional n)
+ "Like `left-char' but steps into wide chars and moves past EOL."
+ (interactive "p") (rectangle--*-char #'left-char n #'right-char))
+
+(defun rectangle-forward-char (&optional n)
+ "Like `forward-char' but steps into wide chars and moves past EOL."
+ (interactive "p") (rectangle--*-char #'forward-char n #'backward-char))
+(defun rectangle-backward-char (&optional n)
+ "Like `backward-char' but steps into wide chars and moves past EOL."
+ (interactive "p") (rectangle--*-char #'backward-char n #'forward-char))
+
+(defun rectangle-next-line (&optional n)
+ "Like `next-line' but steps into wide chars and moves past EOL.
+Ignores `line-move-visual'."
+ (interactive "p")
+ (let ((col (rectangle--point-col (point))))
+ (forward-line n)
+ (rectangle--col-pos col 'point)))
+(defun rectangle-previous-line (&optional n)
+ "Like `previous-line' but steps into wide chars and moves past EOL.
+Ignores `line-move-visual'."
+ (interactive "p")
+ (let ((col (rectangle--point-col (point))))
+ (forward-line (- n))
+ (rectangle--col-pos col 'point)))
+
+
+(defun rectangle--extract-region (orig &optional delete)
+ (if (not rectangle-mark-mode)
+ (funcall orig delete)
+ (let* ((strs (funcall (if delete
+ #'delete-extract-rectangle
+ #'extract-rectangle)
+ (region-beginning) (region-end)))
+ (str (mapconcat #'identity strs "\n")))
+ (when (eq last-command 'kill-region)
+ ;; Try to prevent kill-region from appending this to some
+ ;; earlier element.
+ (setq last-command 'kill-region-dont-append))
+ (when strs
+ (put-text-property 0 (length str) 'yank-handler
+ `(rectangle--insert-for-yank ,strs t)
+ str)
+ str))))
+
+(defun rectangle--insert-for-yank (strs)
+ (push (point) buffer-undo-list)
+ (let ((undo-at-start buffer-undo-list))
+ (insert-rectangle strs)
+ (setq yank-undo-function
+ (lambda (_start _end)
+ (undo-start)
+ (setcar undo-at-start nil) ;Turn it into a boundary.
+ (while (not (eq pending-undo-list (cdr undo-at-start)))
+ (undo-more 1))))))
+
+(defun rectangle--place-cursor (leftcol left str)
+ (let ((pc (window-parameter nil 'rectangle--point-crutches)))
+ (if (and (eq left (car pc)) (eq leftcol (cdr pc)))
+ (put-text-property 0 1 'cursor 1 str))))
+
+(defun rectangle--highlight-for-redisplay (orig start end window rol)
+ (cond
+ ((not rectangle-mark-mode)
+ (funcall orig start end window rol))
+ (rectangle--inhibit-region-highlight
+ (rectangle--unhighlight-for-redisplay orig rol)
+ nil)
+ ((and (eq 'rectangle (car-safe rol))
+ (eq (nth 1 rol) (buffer-chars-modified-tick))
+ (eq start (nth 2 rol))
+ (eq end (nth 3 rol))
+ (equal (rectangle--crutches) (nth 4 rol)))
+ rol)
+ (t
+ (save-excursion
+ (let* ((nrol nil)
+ (old (if (eq 'rectangle (car-safe rol))
+ (nthcdr 5 rol)
+ (funcall redisplay-unhighlight-region-function rol)
+ nil)))
+ (cl-assert (eq (window-buffer window) (current-buffer)))
+ ;; `rectangle--pos-cols' looks up the `selected-window's parameter!
+ (with-selected-window window
+ (apply-on-rectangle
+ (lambda (leftcol rightcol)
+ (let* ((mleft (move-to-column leftcol))
+ (left (point))
+ ;; BEWARE: In the presence of other overlays with
+ ;; before/after/display-strings, this happens to move to
+ ;; the column "as if the overlays were not applied", which
+ ;; is sometimes what we want, tho it can be
+ ;; considered a bug in move-to-column (it should arguably
+ ;; pay attention to the before/after-string/display
+ ;; properties when computing the column).
+ (mright (move-to-column rightcol))
+ (right (point))
+ (ol
+ (if (not old)
+ (let ((ol (make-overlay left right)))
+ (overlay-put ol 'window window)
+ (overlay-put ol 'face 'region)
+ ol)
+ (let ((ol (pop old)))
+ (move-overlay ol left right (current-buffer))
+ ol))))
+ ;; `move-to-column' may stop before the column (if bumping into
+ ;; EOL) or overshoot it a little, when column is in the middle
+ ;; of a char.
+ (cond
+ ((< mleft leftcol) ;`leftcol' is past EOL.
+ (overlay-put ol 'before-string (rectangle--space-to leftcol))
+ (setq mright (max mright leftcol)))
+ ((and (> mleft leftcol) ;`leftcol' is in the middle of a char.
+ (eq (char-before left) ?\t))
+ (setq left (1- left))
+ (move-overlay ol left right)
+ (goto-char left)
+ (overlay-put ol 'before-string (rectangle--space-to leftcol)))
+ ((overlay-get ol 'before-string)
+ (overlay-put ol 'before-string nil)))
+ (cond
+ ;; While doing rectangle--string-preview, the two sets of
+ ;; overlays steps on the other's toes. I fixed some of the
+ ;; problems, but others remain. The main one is the two
+ ;; (rectangle--space-to rightcol) below which try to virtually
+ ;; insert missing text, but during "preview", the text is not
+ ;; missing (it's provided by preview's own overlay).
+ (rectangle--string-preview-state
+ (if (overlay-get ol 'after-string)
+ (overlay-put ol 'after-string nil)))
+ ((< mright rightcol) ;`rightcol' is past EOL.
+ (let ((str (rectangle--space-to rightcol)))
+ (put-text-property 0 (length str) 'face 'region str)
+ ;; If cursor happens to be here, draw it at the right place.
+ (rectangle--place-cursor leftcol left str)
+ (overlay-put ol 'after-string str)))
+ ((and (> mright rightcol) ;`rightcol's in the middle of a char.
+ (eq (char-before right) ?\t))
+ (setq right (1- right))
+ (move-overlay ol left right)
+ (if (= rightcol leftcol)
+ (overlay-put ol 'after-string nil)
+ (goto-char right)
+ (let ((str (rectangle--space-to rightcol)))
+ (put-text-property 0 (length str) 'face 'region str)
+ (when (= left right)
+ (rectangle--place-cursor leftcol left str))
+ (overlay-put ol 'after-string str))))
+ ((overlay-get ol 'after-string)
+ (overlay-put ol 'after-string nil)))
+ (when (and (= leftcol rightcol) (display-graphic-p))
+ ;; Make zero-width rectangles visible!
+ (overlay-put ol 'after-string
+ (concat (propertize " "
+ 'face '(region (:height 0.2)))
+ (overlay-get ol 'after-string))))
+ (push ol nrol)))
+ start end))
+ (mapc #'delete-overlay old)
+ `(rectangle ,(buffer-chars-modified-tick)
+ ,start ,end ,(rectangle--crutches)
+ ,@nrol))))))
+
+(defun rectangle--unhighlight-for-redisplay (orig rol)
+ (if (not (eq 'rectangle (car-safe rol)))
+ (funcall orig rol)
+ (mapc #'delete-overlay (nthcdr 5 rol))
+ (setcar (cdr rol) nil)))
+