pcs/edwin/allcoms2.scm

;;;
;;;	Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;     Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;; Window Motion Commands

(define next-screen-context-lines 2)

(define-initial-command-key ("^R Next Screen" argument)
  "Move down to display next screenful of text."
(
(define-initial-key  (integer->char 22) procedure)    ;;; C-V
)
  (scroll-window (current-window)
		 (cond ((not argument)
			(- (window-y-size (current-window))
			   next-screen-context-lines))
		       ((command-argument-negative-only?)
			(- next-screen-context-lines
			   (window-y-size (current-window))))
		       (else argument))))

(define-initial-command-key ("^R Previous Screen" argument)
  "Move up to display previous screenful of text."
(
(define-initial-key  (list meta-char #\V) procedure)      ;;; M-V
(define-initial-key (list alt-char (integer->char 47)) procedure)  ;;;alt-v
)
  (scroll-window (current-window)
		 (cond ((not argument)
			(- next-screen-context-lines
			   (window-y-size (current-window))))
		       ((command-argument-negative-only?)
			(- (window-y-size (current-window))
			   next-screen-context-lines))
		       (else (- 0 argument)))))

(define (scroll-window window n)
  (if (if (negative? n)
          (window-mark-visible? window
		 (buffer-start (window-buffer window)))
          (window-mark-visible? window
		 (buffer-end (window-buffer window))))
      (if (negative? n)
	(editor-error "Beginning of buffer")
	(editor-error "End of buffer")))
  (window-scroll-y-relative! window n))


;;;; Kill Commands
;;;; Deletion

(define %delete-check
  (lambda (mark1 mark2)
    (if (not mark2) (editor-error "Delete exceeds buffer bounds"))
    (eq? (mark-line mark1) (mark-line mark2))))

(define-initial-command-key ("^R Backward Delete Character" argument)
  "Delete character before point."
(
(define-initial-key  #\Backspace procedure)
)
  (if (not argument)
      (let ((m1 (mark-1+ (current-point) #!false)))
        (if (%delete-check (current-point) m1)
            (%region-delete-char! m1)
            (delete-region m1)))
      (kill-region (mark- (current-point) argument #!false))))

(define-initial-command-key ("^R Delete Character" argument)
  "Delete character after point."
(
(define-initial-key  (integer->char 4) procedure)     ;;C-D
)
  (if (not argument)
      (let ((m1 (mark1+ (current-point) #!false)))
        (if (%delete-check (current-point) m1)
            (%region-delete-char! (current-point))
            (delete-region m1)))
      (kill-region (mark+ (current-point) argument #!false))))

(define-initial-command-key ("^R Kill Line" argument)
  "Kill to end of line, or kill an end of line."
(
(define-initial-key  (integer->char 11) procedure)     ;;; C-K
)
  (let ((point (current-point)))
    (kill-region
      (cond ((not argument)
	     (let ((end (line-end point 0 #!false)))
	       (if (region-blank? (make-region point end))
		   (mark1+ end #!false)
		   end)))
	    ((positive? argument)
	     (conjunction (not (group-end? point))
			  (line-start point argument 'LIMIT)))
	    ((zero? argument)
	     (line-start point 0 #!false))
	    (else
	     (conjunction (not (group-start? point))
			  (line-start point
				      (if (line-start? point)
					  argument
                                          (1+ argument))
				      'LIMIT)))))))

(define-initial-command-key ("^R Append Next Kill" argument)
  "Make following kill commands append to last batch."
(
(define-initial-key (list meta-char (integer->char 23)) procedure) ;;;M C-W
)
  (set-command-message! append-next-kill-tag))


;;;; Un/Killing

(define-initial-command-key ("^R Kill Region" argument)
  "Kill from point to mark."
(
(define-initial-key (integer->char 23) procedure)       ;;; C-W
)
  (kill-region (current-mark)))

(define-initial-command-key ("^R Copy Region" argument)
  "Stick region into kill-ring without killing it."
(
(define-initial-key (list meta-char #\W) procedure)              ;;; M-W
(define-initial-key (list alt-char (integer->char 17)) procedure);;; alt-W
)
  (copy-region (current-mark)))

(define un-kill-tag
  "Un-kill")

(define-initial-command-key ("^R Un-Kill" (argument 1))
  "Re-insert the last stuff killed."
(
(define-initial-key (integer->char 25) procedure)           ;;; C-Y
)
  (let ((ring (current-kill-ring)))
    (if (or (> argument (ring-size ring))
	    (ring-empty? ring))
	(editor-error "Nothing to un-kill"))
    (if (command-argument-multiplier-only?)
	(un-kill-region (ring-ref ring 0))
	(un-kill-region-reversed (ring-ref ring (-1+ argument)))))
  (set-command-message! un-kill-tag))

(define-initial-command-key ("^R Pop Kill Ring" (argument 1))
  " Pop kill ring"
(
 (define-initial-key (list ctrl-x-char (integer->char 11)) procedure)
)
 (let ((ring (current-kill-ring)))
   (if (> argument (ring-size ring))
       (editor-error "Not enough entries in the kill ring"))
   (ring-stack-pop! ring argument)))

(define-initial-command-key ("^R Un-kill Pop" (argument 1))
  "Correct after ^R Un-Kill to use an earlier kill."
(
(define-initial-key (list meta-char #\Y) procedure)              ;;; M-Y
(define-initial-key (list alt-char (integer->char 21)) procedure);;;Alt-Y
)
  (%edwin-un-kill-pop argument))


;;;; Marks

(define-initial-command-key ("^R Set/Pop Mark" argument)
  "Sets or pops the mark."
(
(define-initial-key (list alt-char (integer->char 3)) procedure)  ;;C-@
)
  (let ((n (command-argument-multiplier-exponent)))
    (cond ((zero? n) (push-current-mark! (current-point))
                     (temporary-message "Mark Set"))
	  ((= n 1) (set-current-point! (pop-current-mark!)))
	  ((= n 2) (pop-current-mark!))
	  (else (editor-error)))))

;;; These are temporarily commented out becuase the C-< and C-> ar blocked
;;; by DSR.

;;;(define-initial-command-key ("^R Mark Beginning" argument)
;;;  "Set mark at beginning of buffer."
;;;(
;;;(define-initial-key (list ctrl-^-char #\<) procedure)      ;;; C-^ <
;;;)
;;;  (push-current-mark! (buffer-start (current-buffer))))
;;;
;;;(define-initial-command-key ("^R Mark End" argument)
;;;  "Set mark at end of buffer."
;;;(
;;;(define-initial-key (list ctrl-^-char #\>) procedure)     ;;; C-^ >
;;;)
;;;  (push-current-mark! (buffer-end (current-buffer))))

(define-initial-command-key ("^R Mark Whole Buffer" argument)
  "Set point at beginning and mark at end of buffer."
(
(define-initial-key (list ctrl-x-char  #\H) procedure)    ;;; C-X H
)
  (push-current-mark! (current-point))
  ((if (not argument) set-current-region! set-current-region-reversed!)
   (buffer-region (current-buffer))))

(define-initial-command-key ("^R Exchange Point and Mark" argument)
  "Exchange positions of point and mark."
(
(define-initial-key (list ctrl-x-char ctrl-x-char) procedure)  ;;; C-X C-X
)
  (let ((point (current-point))
	(mark (current-mark)))
    (if (not mark) (editor-error "No mark to exchange"))
    (set-current-point! mark)
    (set-current-mark! point)))


;;;; Transposition

(define-initial-command-key ("^R Transpose Characters" (argument 1))
  "Transpose the characters before and after the cursor."
(
(define-initial-key (integer->char 20) procedure)  ;;; C-T
)
  (%edwin-transpose-characters argument))



;;; These are commented out becuase are not bound to any keys. These may be
;;; used with extended commands

;;;; Search Commands
;;;; Character Search

;;;(define-initial-command-key ("^R Character Search" argument)
;;;  "Search for a single character."
;;;(#!false)
;;;  (let ((mark
;;;	 (find-next-char (current-point)
;;;			 (buffer-end (current-buffer))
;;;			 (prompt-for-char "Character Search"))))
;;;    (if (not mark) (editor-error))
;;;    (set-current-point! (mark1+ mark #!false))))
;;;
;;;(define-initial-command-key ("^R Reverse Character Search" argument)
;;;  "Search backwards for a single character."
;;;(#!false)
;;;  (let ((mark
;;;	 (find-previous-char (current-point)
;;;			     (buffer-start (current-buffer))
;;;			     (prompt-for-char "Reverse Character Search"))))
;;;    (if (not mark) (editor-error))
;;;    (set-current-point! (mark-1+ mark #!false))))

;;;; String Search

;; **** This is a per-editor variable. ****
   (define previous-successful-search-string "")
;;;
;;;(define-initial-command-key ("^R String Search" argument)
;;;  "Search for a character string."
;;;(#!false)
;;;  (let ((string (prompt-for-string "String Search"
;;;				   previous-successful-search-string)))
;;;    (let ((mark
;;;	   (find-next-string (current-point)
;;;			     (buffer-end (current-buffer))
;;;			     string)))
;;;      (if (not mark) (editor-error))
;;;      (set-current-point! (mark+ mark (string-length string) #!false)))
;;;    (set! previous-successful-search-string string)))
;;;
;;;(define-initial-command-key ("^R Reverse String Search" argument)
;;;  "Search backwards for a character string."
;;;(#!false)
;;;  (let ((string (prompt-for-string "Reverse String Search"
;;;				   previous-successful-search-string)))
;;;    (let ((mark
;;;	   (find-previous-string (current-point)
;;;				 (buffer-start (current-buffer))
;;;				 string)))
;;;      (if (not mark) (editor-error))
;;;      (set-current-point! mark))
;;;    (set! previous-successful-search-string string)))

;;;; Incremental Search

(define-initial-command-key ("^R Incremental Search" argument)
  "Search for character string as you type it."
(
(define-initial-key (integer->char 19) procedure)      ;;; C-S
)
  (incremental-search #!TRUE))

(define-initial-command-key ("^R Reverse Search" argument)
  "Incremental Search Backwards."
(
(define-initial-key (integer->char 18) procedure)     ;;; C-R
)
  (incremental-search #!FALSE))


;;; Word Motion


(define-initial-command-key ("^R Forward Word" (argument 1))
  "Move one or more words forward."
(
(define-initial-key (list meta-char #\f) procedure)               ;;; M-F
(define-initial-key (list alt-char (integer->char 33)) procedure) ;;; alt-F
)
  (move-thing forward-word argument))

(define-initial-command-key ("^R Backward Word" (argument 1))
  "Move one or more words forward."
(
(define-initial-key (list alt-char (integer->char 48)) procedure) ;;; alt-B
(define-initial-key (list meta-char #\b) procedure)               ;;; M-B
)
  (move-thing backward-word argument))

(define-initial-command-key ("^R Mark Word" (argument 1))
  "Set mark one or more words from point."
(
 (define-initial-key (list meta-char #\@) procedure)                ;;; M-@
 (define-initial-key (list alt-char (integer->char 121)) procedure) ;;;alt-@
)
  (mark-thing forward-word argument))

(define-initial-command-key ("^R Kill Word" (argument 1))
 "Kill one or more words forward"
(
 (define-initial-key (list meta-char #\d) procedure)              ;;;M-D
 (define-initial-key (list alt-char (integer->char 32)) procedure);;; Alt D
)
 (kill-thing forward-word argument))

(define-initial-command-key ("^R Backward Kill Word" (argument 1))
  "Kill one or more words backwards"
(
 (define-initial-key (list meta-char #\backspace) procedure) 
)                                                            ;;; alt is blocked
  (kill-thing backward-word argument))



;;; Sentences


(define-initial-command-key ("^R Forward Sentence" (argument 1))
  "Move one or more sentences forward."
(
(define-initial-key (list meta-char #\e) procedure)               ;;; M-E
(define-initial-key (list alt-char (integer->char 18)) procedure) ;;; alt-E
)
  (move-thing forward-sentence argument))

(define-initial-command-key ("^R Backward Sentence" (argument 1))
  "Move one or more sentences forward."
(
(define-initial-key (list alt-char (integer->char 30)) procedure) ;;; alt-A
(define-initial-key (list meta-char #\a) procedure)               ;;; M-A
)
  (move-thing backward-sentence argument))


(define-initial-command-key ("^R Kill Sentence" (argument 1))
 "Kill one or more sentences forward"
(
 (define-initial-key (list meta-char #\k) procedure)              ;;;M-K
 (define-initial-key (list alt-char (integer->char 37)) procedure);;; Alt K
)
 (kill-thing forward-sentence argument))

(define-initial-command-key ("^R Backward Kill Sentence" (argument 1))
  "Kill one or more sentences backwards"
(
 (define-initial-key (list ctrl-x-char #\backspace) procedure) 
)                                     
  (kill-thing backward-sentence argument))



(define-initial-command-key ("^R Forward Paragraph" (argument 1))
  "Move one or more paragraph forward."
(
(define-initial-key (list meta-char #\]) procedure)               ;;; M-]
)
  (move-thing forward-paragraph argument))

(define-initial-command-key ("^R Backward Paragraph" (argument 1))
  "Move one or more sentences forward."
(
(define-initial-key (list meta-char #\[) procedure)               ;;; M-[
)
  (move-thing backward-paragraph argument))


(define-initial-command-key ("^R Mark Paragraph" (argument 1))
  "mark the beginning and end of the paragraph"
(
 (define-initial-key (list meta-char #\h) procedure)
 (define-initial-key (list alt-char (integer->char 35)) procedure)
)
  (let ((end (forward-paragraph (current-point) 1 'ERROR)))
    (set-current-region! (make-region (backward-paragraph end 1 'ERROR) end))))