lrs@esl.esl.com (Lynn Slater) (11/03/88)
matthew@blake.acs.washington.edu (Matthew D. Hendel) writes: > What I would like to implement is some sort of automatic > horizontal scrolling when the point reaches (passes) the window edge.> I did this as part of an enhanced picture mode once. The whole mode is included below in case the other parts are useful or of general interest to others. Amoung other things, this code can "pagitize" a buffer into regular sized rectangles possibly for printing as panels; it can also glue the panels back into the original buffer. -- Lynn =============================================================== Lynn Slater -- lrs@esl.com ESL/TRW 495 Java Drive, Box 3510, Sunnyvale, Ca 94088-3510 Office (408) 738-2888 x 4482; Home (415) 796-4149 =============================================================== ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; sun-picture.el --- Rough enhancements to picture mode ;; Author : Lynn Slater ;; Created On : Wed Dec 2 15:21:55 1987 ;; Last Modified By: Lynn Slater ;; Last Modified On: Wed Dec 2 15:24:12 1987 ;; Update Count : 2 ;; Status : Experimental, Use with caution! ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Rules and principals of the enhanced picture mode ;; ;; column operations are ;; C-c C-w to kill a column ;; C-c C-k to kill a rectangle ;; Esc C-space to mark a column ;; C-c C-y to yank a column or a rectangle ;; ;; Esc-< and Esc-> go to the top or bottom lines, but ;; try to retain the same column position. ;; ;; C-a and C-e jump to screen edges ;; Esc-C-a or Esc-C-e go to the true beginning or end of lines ;; ;; Control-u before a rectangle kill or yank does it with true ;; insertion/deletion. Otherwise, text is cleared or replaced. ;; Overwritten text is placed in register "X" and can be retrieved by C-C ;; C-x X. THIS IS NOT A STACK. If you make an error, you had better ;; undo it quickly or you will lose the ability to undo it. ;; ;; Left-right scrolling will be automatic as the cursor is moved. ;; C-x-> and C-x-< do half page scrolls by default. ;; ;; Rectangle operations work (for some unknown reason) ;; on the rectangle from the point to ONE LESS than the mark. ;; In other words, you must INCLUDE AN EXTRA COLUMN! ;; (load "picture") (load "tabify") (defun set-truncate-lines () (setq truncate-lines t)) (setq edit-picture-hook 'set-truncate-lines) (defun move-to-column-force (column) "Move to column COLUMN in current line. Differs from move-to-column in that it creates or modifies whitespace if necessary to attain exactly the specified column. This version (non-standard) insures that the column is visible, scrolling if needed." (move-to-column column) (let ((col (current-column))) (if (< col column) (indent-to column) (if (and (/= col column) (= (preceding-char) ?\t)) (let (indent-tabs-mode) (delete-char -1) (indent-to col) (move-to-column column))))) (point-wisiwig) ) (defun point-wisiwig () "scrolls the window horozontally to make point visible" (let* ((min (window-hscroll)) (max (- (+ min (window-width)) 2)) (here (current-column)) (delta (/ (window-width) 2)) ) (if (< here min) (scroll-right (max 0 (+ (- min here) delta))) (if (>= here max) (scroll-left (- (- here min) delta)) )))) (defun window-wysiwyg-point () "Makes point become the visible point Moves point, not the scroll. Current version good only for picture mode" (interactive) (let* ((min (window-hscroll)) (max (+ min (window-width))) (here (current-column)) (delta (/ (window-width) 2)) ) ;;(message "here=%s min=%s max=%s" here min max) ;;(sleep-for-millisecs 4000) (if (< here min) (move-to-column min) (if (>= here max) (move-to-column (- max 3)) )))) (defun scroll-right-half-page (&optional arg) "Is a scroll-right but by defaulty uses window-width/2" (interactive "P") ;;(message "p is %s %s" arg (prefix-numeric-value arg)) ;;(sleep-for-millisecs 3000) (scroll-right (or arg (/ (window-width) 2))) (window-wysiwyg-point) ) (defun scroll-left-half-page (&optional arg) "Is a scroll-right but by defaulty uses window-width/2" (interactive "P") ;;(message "p is %s %s" arg (prefix-numeric-value arg)) ;;(sleep-for-millisecs 3000) (scroll-left (or arg (/ (window-width) 2))) (window-wysiwyg-point) ) (defun picture-beginning-of-line () (interactive) (beginning-of-line) (point-wisiwig) ) (defun picture-end-of-line () (interactive) (end-of-line) (point-wisiwig) ) (defun buffer-width () (interactive) (let (here (max-width 0) ) (save-excursion (beginning-of-buffer) (while (not (eq (point) (point-max))) (setq here (point)) (end-of-line) (setq max-width (max max-width (- (point) here))) (if (not (eq (point) (point-max))) (forward-char)) ) ) max-width)) (defun find-point (column line) "returns the point that corresponds to column and line" (progn (goto-line line) (move-to-column column) (point))) (defun find-point-force (column line) "returns the point that corresponds to column and line" (progn (goto-line line) (move-to-column-force column) (point))) (defun compress-buffer () "Kills trailing whitespace and tabifies." (interactive) (message "Compressing . . .") (beginning-of-buffer) (untabify-file) (perform-replace " +$" "" nil t nil) (tabify (point-min) (point-max)) (message "")) (defun pagitize-buffer (w h) "Breaks down the buffer into pages with w and h" (interactive) (save-excursion (let* ((x 0) (y 1) (ylimit (+ y h)) (xlimit (+ x w)) (start 1) (end (find-point w h)) (max-x (buffer-width)) (max-y (progn (end-of-buffer) (count-lines 1 (point)))) (xp 0) (yp 0) data ) (with-output-to-temp-buffer "*Paged*") (while (<= y max-y) (setq x 0) (setq yp (+ yp 1)) (setq xp 0) (setq ylimit (+ y h)) (while (<= x max-x) (setq xlimit (+ x w)) (setq xp (+ xp 1)) (setq start (find-point-force x y)) (setq stop (find-point-force xlimit ylimit)) ;;(message "(%s %s) x:%s y:%s xl:%s yl:%s" start stop ;; x y xlimit ylimit) ;;(sleep-for-millisecs 2000) (setq x (+ xlimit 0)) (setq data (extract-rectangle start stop)) (switch-to-buffer "*Paged*") (end-of-buffer) (message "Panel %s, %s" xp yp) (insert (format "\n Panel (%s, %s)\n" xp yp)) (insert-rectangle data) (switch-to-buffer nil) ;;(output-panel start stop) ) (setq y (+ ylimit 1)) ) (switch-to-buffer "*Paged*") (compress-buffer) (switch-to-buffer nil) (scroll-right (current-column)) ;;(set-window-hscroll 0) ))) (defun pagit (&optional wid height) "Pagitize" (interactive "nWidth:\nnHeight:") (pagitize-buffer wid height)) (defun rectangularize-buffer () (interactive) (let ((width (buffer-width))) (goto-char 1) (while (not (>= (point) (point-max))) (move-to-column-force width) (next-line 1) ) (untabify-file) )) (defun last-line () "Moves to the current column in the last line of the buffer Creates columns as needed Attempts to maintain scrolling" (interactive) (let ((cc (current-column)) p) (save-excursion (end-of-buffer) (move-to-column-force cc) (setq p (point))) (goto-char p) p )) (defun first-line () "Moves to the current column in the first line of the buffer Creates columns as needed Attempts to maintain scrolling" (interactive) (let ((cc (current-column)) p) (save-excursion (beginning-of-buffer) (move-to-column-force cc) (setq p (point))) (goto-char p) p )) (defun goto-last-line () (interactive) (let ((pt (point))) (last-line) (push-mark pt))) (defun goto-first-line () (interactive) (let ((pt (point))) (first-line) (push-mark pt))) (defun flash-region (min max) "Temporarely moves the curser to the endpoints of a region." ; should probably be added to emacs, is usefull all over. ; April 23, 1987. lrs of Silvar-Lisco @sun!silvlis!lrs (interactive "r") (save-excursion (if (not (eq (point) min)) (progn (goto-char min) (sit-for-millisecs 400))) (if (not (eq (point) max)) (progn (goto-char max) (sit-for-millisecs 400))) )) (defun mark-columns () "Marks the columns represented by the columns of the current position and the mark. I.E. The same columns but on the top and bottom lines." (interactive) (let (cc1 cc2 (pt (point)) (mark (mark)) ) (save-excursion (setq cc1 (current-column)) (setq cc2 (progn (goto-char mark) (current-column)))) (if (= cc1 cc2) (message "Warning: columns are the same, rectangle ops will fail.") (if (< cc2 cc1) ;; exchange pt and mark data and do it again (progn ;;(setq cc2 cc1) ;;(setq cc1 (current-column)) ;;(setq mark pt) ;;(setq pt (point)) (exchange-point-and-mark) (mark-columns) ) (progn ;;(message "pt=%s c=%s mark=%s c=%s" pt cc1 mark cc2) ;;(sleep-for 3) (goto-char mark) (last-line) (sit-for-millisecs 800) (push-mark) (goto-char pt) (first-line) ))))) (defun kill-columns (squashp) "Stores the columns as a picture mode rectangle. If arguement, squashes the image." (interactive "P") (mark-columns) (picture-clear-rectangle (point) (mark) squashp) ) (defun picture-clear-rectangle (start end &optional killp) "Clear and save rectangle delineated by point and mark. The rectangle is saved for yanking by \\[picture-yank-rectangle] and replaced with whitespace. The previously saved rectangle, if any, is lost. With prefix argument, the rectangle is actually killed, shifting remaining text." (interactive "r\nP") (setq picture-killed-rectangle (picture-snarf-rectangle start end killp))) (defun picture-insert-rectangle (rectangle &optional insertp) "Overlay RECTANGLE with upper left corner at point. Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted. Leaves the region surrounding the rectangle." (let ((indent-tabs-mode nil)) (if (not insertp) (save-excursion (set-register 88 (delete-extract-rectangle (point) (progn (picture-forward-column (length (car rectangle))) (picture-move-down (1- (length rectangle))) (point)))))) (push-mark) (insert-rectangle rectangle))) (progn (define-key picture-mode-map "\e[C" 'picture-forward-column) (define-key picture-mode-map "\e[D" 'picture-backward-column) (define-key picture-mode-map "\e[B" 'picture-move-down) (define-key picture-mode-map "\e[A" 'picture-move-up) (define-key picture-mode-map "\e\C-a" 'picture-beginning-of-line) (define-key picture-mode-map "\e\C-e" 'picture-end-of-line) (define-key picture-mode-map "\e<" 'goto-first-line) (define-key picture-mode-map "\e>" 'goto-last-line) (define-key picture-mode-map "\e[210z" 'picture-clear-column) (define-key picture-mode-map "\e[209z" 'picture-clear-line) (define-key picture-mode-map "\e[214z" 'scroll-left-half-page) (define-key picture-mode-map "\e[216z" 'scroll-right-half-page) (define-key picture-mode-map "\C-x*ir" 'scroll-left-half-page) (define-key picture-mode-map "\C-x*gr" 'scroll-right-half-page) (define-key picture-mode-map "\C-x*iR" 'scroll-left-half-page) (define-key picture-mode-map "\C-x*gR" 'scroll-right-half-page) (define-key picture-mode-map "\e\C-m" 'newline) (define-key picture-mode-map "\C-x<" 'scroll-left-half-page) (define-key picture-mode-map "\C-x>" 'scroll-right-half-page) (define-key picture-mode-map "\e\C- " 'mark-columns) (define-key picture-mode-map "\C-c\C-w" 'kill-columns) ) ;;(load "sun-picture")