Function: table-shorten-cell
table-shorten-cell is an autoloaded, interactive and byte-compiled
function defined in table.el.gz.
Signature
(table-shorten-cell N)
Documentation
Shorten the current cell by N lines by shrinking the cell vertically.
Shortening is done by removing blank lines from the bottom of the cell and possibly from the top of the cell as well. Therefore, the cell must have some bottom/top blank lines to be shorten effectively. This is applicable to all the cells aligned horizontally with the current one because they are also shortened in order to keep the rectangular table structure.
Key Bindings
Source Code
;; Defined in /usr/src/emacs/lisp/textmodes/table.el.gz
;;;###autoload
(defun table-shorten-cell (n)
"Shorten the current cell by N lines by shrinking the cell vertically.
Shortening is done by removing blank lines from the bottom of the cell
and possibly from the top of the cell as well. Therefore, the cell
must have some bottom/top blank lines to be shorten effectively. This
is applicable to all the cells aligned horizontally with the current
one because they are also shortened in order to keep the rectangular
table structure."
(interactive "*p")
(if (< n 0) (setq n 1))
(table--finish-delayed-tasks)
(let* ((table-inhibit-update t)
(coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t)))
(left-list nil)
(this-list coord-list)
(right-list (cdr coord-list))
(bottom-budget-list nil)
(bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
(current-coordinate (table--get-coordinate))
(current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
(blank-line-regexp "\\s *$"))
(message "Shortening...");; this operation may be lengthy
;; for each cell calculate the maximum number of blank lines we can delete
;; and adjust the argument n. n is adjusted so that the total number of
;; blank lines from top and bottom of a cell do not exceed n, all cell has
;; at least one line height after blank line deletion.
(while this-list
(let ((this (prog1 (car this-list) (setq this-list (cdr this-list)))))
(table--goto-coordinate (car this))
(table-recognize-cell 'force)
(table-with-cache-buffer
(catch 'end-count
(let ((blank-line-count 0))
(table--goto-coordinate (cons 0 (1- table-cell-info-height)))
;; count bottom
(while (and (looking-at blank-line-regexp)
(setq blank-line-count (1+ blank-line-count))
;; need to leave at least one blank line
(if (> blank-line-count n) (throw 'end-count nil) t)
(if (zerop (forward-line -1)) t
(setq n (if (zerop blank-line-count) 0
(1- blank-line-count)))
(throw 'end-count nil))))
(table--goto-coordinate (cons 0 0))
;; count top
(while (and (looking-at blank-line-regexp)
(setq blank-line-count (1+ blank-line-count))
;; can consume all blank lines
(if (>= blank-line-count n) (throw 'end-count nil) t)
(zerop (forward-line 1))))
(setq n blank-line-count))))))
;; construct the bottom-budget-list which is a list of numbers where each number
;; corresponds to how many lines to be deleted from the bottom of each cell. If
;; this number, say bb, is smaller than n (bb < n) that means the difference (n - bb)
;; number of lines must be deleted from the top of the cell in addition to deleting
;; bb lines from the bottom of the cell.
(setq this-list coord-list)
(while this-list
(let ((this (prog1 (car this-list) (setq this-list (cdr this-list)))))
(table--goto-coordinate (car this))
(table-recognize-cell 'force)
(table-with-cache-buffer
(setq bottom-budget-list
(cons
(let ((blank-line-count 0))
(table--goto-coordinate (cons 0 (1- table-cell-info-height)))
(while (and (looking-at blank-line-regexp)
(< blank-line-count n)
(setq blank-line-count (1+ blank-line-count))
(zerop (forward-line -1))))
blank-line-count)
bottom-budget-list)))))
(setq bottom-budget-list (nreverse bottom-budget-list))
;; vertically shorten each cell from left to right
(setq this-list coord-list)
(while this-list
(let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
(this (prog1 (car this-list) (setq this-list (cdr this-list))))
(right (prog1 (car right-list) (setq right-list (cdr right-list))))
(bottom-budget (prog1 (car bottom-budget-list) (setq bottom-budget-list (cdr bottom-budget-list))))
(exclude-left (and left (< (cddr left) (cddr this))))
(exclude-right (and right (<= (cddr right) (cddr this))))
(beg (table--goto-coordinate (cons (caar this) (cdar this))))
(end (table--goto-coordinate (cons (cadr this) bottom-border-y)))
(rect (extract-rectangle beg end))
(height (+ (- (cddr this) (cdar this)) 1))
(blank-line (make-string (- (cadr this) (caar this)) ?\s)))
;; delete lines from the bottom of the cell
(setcdr (nthcdr (- height bottom-budget 1) rect) (nthcdr height rect))
;; delete lines from the top of the cell
(if (> n bottom-budget)
(let ((props (text-properties-at 0 (car rect))))
(setq rect (nthcdr (- n bottom-budget) rect))
(set-text-properties 0 1 props (car rect))))
;; append blank lines below the table
(setq rect (append rect (make-list n blank-line)))
;; now swap the area with the prepared rect of the same size
(delete-rectangle beg end)
(goto-char beg)
(table--insert-rectangle rect)
;; for the left and right borders always delete lines from the bottom of the cell
(unless exclude-left
(let* ((beg (table--goto-coordinate (cons (1- (caar this)) (cdar this))))
(end (table--goto-coordinate (cons (caar this) bottom-border-y)))
(rect (extract-rectangle beg end)))
(setcdr (nthcdr (- height n 1) rect) (nthcdr height rect))
(setq rect (append rect (make-list n " ")))
(delete-rectangle beg end)
(goto-char beg)
(table--insert-rectangle rect)))
(unless exclude-right
(let* ((beg (table--goto-coordinate (cons (cadr this) (cdar this))))
(end (table--goto-coordinate (cons (1+ (cadr this)) bottom-border-y)))
(rect (extract-rectangle beg end)))
(setcdr (nthcdr (- height n 1) rect) (nthcdr height rect))
(setq rect (append rect (make-list n " ")))
(delete-rectangle beg end)
(goto-char beg)
(table--insert-rectangle rect)))
;; if this is the cell where the original point was in, adjust the point location
(if (null (equal this current-cell-coordinate)) nil
(let ((y (- (cdr current-coordinate) (cdar this))))
(if (< y (- n bottom-budget))
(setcdr current-coordinate (cdar this))
(if (< (- y (- n bottom-budget)) (- height n))
(setcdr current-coordinate (+ (cdar this) (- y (- n bottom-budget))))
(setcdr current-coordinate (+ (cdar this) (- height n 1)))))))))
;; remove the appended blank lines below the table if they are unnecessary
(table--goto-coordinate (cons 0 (1+ (- bottom-border-y n))))
(table--remove-blank-lines n)
;; re-recognize the current cell's new dimension
(table--goto-coordinate current-coordinate)
(table-recognize-cell 'force)
(table--update-cell-heightened)
(message "")))