Function: table-narrow-cell

table-narrow-cell is an autoloaded, interactive and byte-compiled function defined in table.el.gz.

Signature

(table-narrow-cell N)

Documentation

Narrow the current cell by N columns and shrink the cell horizontally.

Some other cells in the same table are narrowed as well to keep the table's rectangle structure.

View in manual

Key Bindings

Source Code

;; Defined in /usr/src/emacs/lisp/textmodes/table.el.gz
;;;###autoload
(defun table-narrow-cell (n)
  "Narrow the current cell by N columns and shrink the cell horizontally.
Some other cells in the same table are narrowed as well to keep the
table's rectangle structure."
  (interactive "*p")
  (if (< n 0) (setq n 1))
  (table--finish-delayed-tasks)
  (let* ((coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
	 (current-cell (table--cell-to-coord (table--probe-cell)))
	 (current-coordinate (table--get-coordinate))
	 tmp-list)
    (message "Narrowing...");; this operation may be lengthy
    ;; determine the doable n by try narrowing each cell.
    (setq tmp-list coord-list)
    (while tmp-list
      (let ((cell (prog1 (car tmp-list) (setq tmp-list (cdr tmp-list))))
	    (table-inhibit-update t)
	    cell-n)
	(table--goto-coordinate (car cell))
	(table-recognize-cell 'force)
	(table-with-cache-buffer
	  (table--fill-region (point-min) (point-max) (- table-cell-info-width n))
	  (if (< (setq cell-n (- table-cell-info-width (table--measure-max-width))) n)
	      (setq n cell-n))
	  (erase-buffer)
	  (setq table-inhibit-auto-fill-paragraph t))))
    (if (< n 1) nil
      ;; narrow only the contents of each cell but leave the cell frame as is because
      ;; we need to have valid frame structure in order for table-with-cache-buffer
      ;; to work correctly.
      (setq tmp-list coord-list)
      (while tmp-list
	(let* ((cell (prog1 (car tmp-list) (setq tmp-list (cdr tmp-list))))
	       (table-inhibit-update t)
	       (currentp (equal cell current-cell))
	       old-height)
	  (if currentp (table--goto-coordinate current-coordinate)
	    (table--goto-coordinate (car cell)))
	  (table-recognize-cell 'force)
	  (setq old-height table-cell-info-height)
	  (table-with-cache-buffer
	    (let ((out-of-bound (>= (- (car current-coordinate) (car table-cell-info-lu-coordinate))
				    (- table-cell-info-width n)))
		  (sticky (and currentp
			       (save-excursion
				 (unless (bolp) (forward-char -1))
				 (looking-at ".*\\S ")))))
	      (table--fill-region (point-min) (point-max) (- table-cell-info-width n))
	      (if (or sticky (and currentp (looking-at ".*\\S ")))
		  (setq current-coordinate (table--transcoord-cache-to-table))
		(if out-of-bound (setcar current-coordinate
					 (+ (car table-cell-info-lu-coordinate) (- table-cell-info-width n 1))))))
	    (setq table-inhibit-auto-fill-paragraph t))
	  (table--update-cell 'now)
	  ;; if this cell heightens and pushes the current cell below, move
	  ;; the current-coordinate (point location) down accordingly.
	  (if currentp (setq current-coordinate (table--get-coordinate))
	    (if (and (> table-cell-info-height old-height)
		     (> (cdr current-coordinate) (cdr table-cell-info-lu-coordinate)))
		(setcdr current-coordinate (+ (cdr current-coordinate)
					      (- table-cell-info-height old-height)))))
	  ))
      ;; coord-list is now possibly invalid since some cells may have already
      ;; been heightened so recompute them by table--vertical-cell-list.
      (table--goto-coordinate current-coordinate)
      (setq coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
      ;; push in the affected area above and below this table so that things
      ;; on the right side of the table are shifted horizontally neatly.
      (table--horizontally-shift-above-and-below (- n) (reverse coord-list))
      ;; finally narrow the frames for each cell.
      (let* ((below-list nil)
	     (this-list coord-list)
	     (above-list (cdr coord-list)))
	(while this-list
	  (let* ((below (prog1 (car below-list) (setq below-list (if below-list (cdr below-list) coord-list))))
		 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
		 (above (prog1 (car above-list) (setq above-list (cdr above-list)))))
	    (delete-rectangle
	     (table--goto-coordinate
	      (cons (- (cadr this) n)
		    (if (or (null above) (<= (cadr this) (cadr above)))
			(1- (cdar this))
		      (cdar this))))
	     (table--goto-coordinate
	      (cons (cadr this)
		    (if (or (null below) (< (cadr this) (cadr below)))
			(1+ (cddr this))
		      (cddr this)))))))))
    (table--goto-coordinate current-coordinate)
    ;; re-recognize the current cell's new dimension
    (table-recognize-cell 'force)
    (message "")))