home *** CD-ROM | disk | FTP | other *** search
Text File | 1990-07-06 | 26.0 KB | 593 lines | [TEXT/MSWD] |
- ;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
- ;@@@ Keymacros to add to the programmin environment.
- ;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-
- ; overview: selection+movement macros; funcs to pop windows; and comment boxes
- ; and meta uparrow is bound to jump to previous listener cmd.
- ;*******************************************************************************
- ;*** Selection Extension Functions
- ;*******************************************************************************
- ;
- ; These functions were written to wrap an interface around the ccl::ed- functions
- ; of the same names such that if the shift key is depressed at the same time
- ; as the function is called, then the current selection is extended, a la the
- ; Macintosh interface guidelines.
- ;
- ; The functions included are:
- ;
- ; ccl::ed-forward-char
- ; ccl::ed-backward-char
- ; ccl::ed-next-line
- ; ccl::ed-previous-line
- ;
- ; ccl::ed-forward-word
- ; ccl::ed-backward-word
- ;
- ; ccl::ed-forward-sexp
- ; ccl::ed-backward-sexp
- ;
- ; ccl::ed-beginning-of-line
- ; ccl::ed-end-of-line
- ;
- ; In order to use them, assign the my- function in place of the ccl::ed- function
- ; to the relevant key.
-
- (defobfun (my-forward-char *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark)))
- (set-mark the-cursor-mark
- (min (1+ the-cursor-position)
- (buffer-size (window-buffer))))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-forward-char))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-backward-char *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark)))
- (set-mark the-cursor-mark
- (max (1- the-cursor-position) 0))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-backward-char))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-previous-line *fred-window*) ()
- (declare (object-variable shifted-goal-column))
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark))
- (the-goal-column (if (ownp 'shifted-goal-column)
- shifted-goal-column
- (have 'shifted-goal-column
- (buffer-column the-cursor-mark)))))
- (set-mark the-cursor-mark
- (min (+ (buffer-line-start the-cursor-mark the-cursor-position -1)
- the-goal-column)
- (buffer-line-end the-cursor-mark the-cursor-position -1)))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-previous-line)))
-
- (defobfun (my-next-line *fred-window*) ()
- (declare (object-variable shifted-goal-column))
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark))
- (the-goal-column (if (ownp 'shifted-goal-column)
- shifted-goal-column
- (have 'shifted-goal-column
- (buffer-column the-cursor-mark)))))
- (set-mark the-cursor-mark
- (min (+ (buffer-line-start the-cursor-mark the-cursor-position 1)
- the-goal-column)
- (buffer-line-end the-cursor-mark the-cursor-position 1)))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-next-line)))
-
- (defobfun (my-forward-word *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark))
- (the-goal-position
- (do* ((the-buffer (window-buffer))
- (the-buffer-end (buffer-size the-buffer))
- (the-goal-position the-cursor-position))
- ((= the-goal-position the-buffer-end) the-goal-position)
- (multiple-value-bind (start end)
- (buffer-word-bounds the-buffer the-goal-position)
- (cond ((or (= start end)
- (= end the-goal-position))
- (incf the-goal-position))
- ((and (<= start the-goal-position)
- (>= end the-goal-position)
- (= left right))
- (setf left start)
- (return end))
- (t (return end)))))))
- (set-mark the-cursor-mark the-goal-position)
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-forward-word))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-backward-word *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark))
- (the-goal-position
- (do* ((the-buffer (window-buffer))
- (the-goal-position the-cursor-position))
- ((= the-goal-position 0) the-goal-position)
- (multiple-value-bind (start end)
- (buffer-word-bounds the-buffer the-goal-position)
- (cond ((or (= start end)
- (= start the-goal-position))
- (decf the-goal-position))
- ((and (<= start the-goal-position)
- (>= end the-goal-position)
- (= left right))
- (setf right end)
- (return start))
- (t (return start)))))))
- (set-mark the-cursor-mark the-goal-position)
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-backward-word))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-forward-sexp *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark))
- (the-goal-position
- (let* ((the-buffer (window-buffer))
- (the-buffer-end (buffer-size the-buffer))
- (the-goal-position the-cursor-position)
- (start nil)
- (end nil))
- (loop
- (if (= the-goal-position the-buffer-end)
- (return the-goal-position)
- (progn
- (setf start (buffer-current-sexp-start-pos the-buffer
- the-goal-position)
- end (when start (buffer-fwd-sexp the-buffer start)))
- (cond ((or (null start)
- (= end the-goal-position))
- (incf the-goal-position))
- ((and (<= start the-goal-position)
- (>= end the-goal-position)
- (= left right))
- (setf left start)
- (return end))
- (t (return end)))))))))
- (set-mark the-cursor-mark the-goal-position)
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-forward-sexp))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-backward-sexp *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark))
- (the-goal-position
- (let* ((the-buffer (window-buffer))
- (the-goal-position the-cursor-position)
- (start nil)
- (end nil))
- (loop
- (if (= the-goal-position 0)
- (return the-goal-position)
- (progn
- (setf start (buffer-current-sexp-start-pos the-buffer
- the-goal-position)
- end (when start (buffer-fwd-sexp the-buffer start)))
- (cond ((or (null start)
- (= start the-goal-position))
- (decf the-goal-position))
- ((and (<= start the-goal-position)
- (>= end the-goal-position)
- (= left right))
- (setf right end)
- (return start))
- (t (return start)))))))))
- (set-mark the-cursor-mark the-goal-position)
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-backward-sexp))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-end-of-line *fred-window*) ()
- (declare (object-variable shifted-goal-column))
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark)))
- (set-mark the-cursor-mark (buffer-line-end the-cursor-mark))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-end-of-line))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-beginning-of-line *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark)))
- (set-mark the-cursor-mark (buffer-line-start the-cursor-mark))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-beginning-of-line))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-end-of-buffer *fred-window*) ()
- (declare (object-variable shifted-goal-column))
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark)))
- (set-mark the-cursor-mark (buffer-size (window-buffer)))
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-end-of-buffer))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
- (defobfun (my-beginning-of-buffer *fred-window*) ()
- (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
- (multiple-value-bind (left right)
- (selection-range)
- (let* ((the-cursor-mark (window-cursor-mark))
- (the-cursor-position (mark-position the-cursor-mark)))
- (set-mark the-cursor-mark 0)
- (if (eql the-cursor-position left)
- (set-selection-range right)
- (set-selection-range left))))
- (ccl::ed-beginning-of-buffer))
- (when (ownp 'shifted-goal-column)
- (makunbound 'shifted-goal-column)))
-
-
- ;*******************************************************************************
- ;*** Function Keys
- ;*******************************************************************************
- ;
- ; The function keys of the Apple Extended Keyboard are not supported by the
- ; ccl system: the function translating keystrokes to codes for lookup in the
- ; relevant command table translates all function keystrokes to #\^P, ie code 16.
- ; In order to support them then, without rewriting this translation function
- ; (#'event-keystroke, for the curious. See 9-10 of the ccl manual), assign a
- ; despatching function to #\^P in the comtab which looks at the raw event and
- ; then does its own comtab lookup in the globally defined *control-p-comtab*.
- ; The translation scheme sends function keys 1 through 15 to keys #\0 through
- ; #\15 in this *control-p-comtab*, and the esc key to key #\0.
- ;
- ; In order to use the function keys, then, merely assign the functions to be bound
- ; to the function key x to the key #\x in the *control-p-comtab*.
-
- ; create the *control-p-comtab* as a global
- ;
- (defvar *control-p-comtab* (make-comtab))
-
-
- ; the despatch function
- ;
- (defun funkey-despatch (keycode)
- (declare (special *current-event* *control-p-comtab*))
- (case keycode
- (53 (let ((res (comtab-get-key *control-p-comtab* #\0)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (122 (let ((res (comtab-get-key *control-p-comtab* #\1)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (120 (let ((res (comtab-get-key *control-p-comtab* #\2)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (99 (let ((res (comtab-get-key *control-p-comtab* #\3)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (118 (let ((res (comtab-get-key *control-p-comtab* #\4)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (96 (let ((res (comtab-get-key *control-p-comtab* #\5)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (97 (let ((res (comtab-get-key *control-p-comtab* #\6)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (98 (let ((res (comtab-get-key *control-p-comtab* #\7)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (100 (let ((res (comtab-get-key *control-p-comtab* #\8)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (101 (let ((res (comtab-get-key *control-p-comtab* #\9)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (109 (let ((res (comtab-get-key *control-p-comtab* #\10)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (103 (let ((res (comtab-get-key *control-p-comtab* #\11)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (111 (let ((res (comtab-get-key *control-p-comtab* #\12)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (105 (let ((res (comtab-get-key *control-p-comtab* #\13)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (107 (let ((res (comtab-get-key *control-p-comtab* #\14)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (113 (let ((res (comtab-get-key *control-p-comtab* #\15)))
- (if (and (not (null res)) (functionp res))
- (funcall res)
- (ed-beep))))
- (t (ed-beep))))
-
- ;*******************************************************************************
- ;*** Window Stack
- ;*******************************************************************************
- ;
- ; These functions implement a simple window management scheme: editing palettes
- ; are stacked to the right of the screen, while still not obscuring the disks etc
- ; shown by the finder, allowing the multifinder to be used; and a current editing
- ; palette is left where it is created, in the top left corner of the screen.
- ; The listener is placed below the current editing palette.
- ;
-
- ;;; window stacker
- (defobfun (push-window *fred-window*) (&optional (select-p t))
- (declare (special *window-stack*))
- (when (some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
- (clean-up-window-stack))
- (let ((pos (position (self) *window-stack*)))
- (if pos
- (move-to-stack-position pos)
- (progn
- (setf *window-stack* (append *window-stack* (list (self))))
- (move-to-stack-position (1- (length *window-stack*))))))
- (window-select-event-handler)
- (when (not select-p)
- (ask (find-if-not #'(lambda (w) (eq w (self))) (windows))
- (window-select-event-handler))))
-
- (defobfun (move-to-stack-position *fred-window*) (pos)
- (declare (special *stack-window-size* *stack-window-position* *screen-height*))
- (let ((position (min pos (floor (- *screen-height*
- 48
- (point-v *stack-window-size*)) 18))))
- (set-window-position (make-point (point-h *stack-window-position*)
- (+ (point-v *stack-window-position*)
- (* 18 position))))
- (set-window-size *stack-window-size*)
- (values (self))))
-
- (defun clean-up-window-stack (&optional (first 0))
- (declare (special *window-stack* *stack-window-size* *stack-window-position*))
- (when (some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
- (setf *window-stack* (remove-if #'(lambda (w) (ask w (not (ownp 'wptr))))
- *window-stack*))
- (setf first 0))
- (let ((the-length (length *window-stack*))
- (old-first (front-window)))
- (do ((pos first (1+ pos)))
- ((= pos the-length)
- (progn
- (ask old-first (window-select-event-handler))
- (values)))
- (ask (elt *window-stack* pos)
- (set-window-position (make-point (point-h *stack-window-position*)
- (+ (point-v *stack-window-position*)
- (* 18 pos))))
- (set-window-size *stack-window-size*)
- (window-select-event-handler)))))
-
- (defobfun (pull-window *fred-window*) ()
- (declare (special *window-stack*))
- (let ((pos (position (self) *window-stack*)))
- (when pos
- (setf *window-stack* (remove (self) *window-stack*))
- (set-window-position *fred-window-position*)
- (set-window-size *fred-window-size*)
- (cond ((some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
- (clean-up-window-stack))
- ((< pos (length *window-stack*))
- (clean-up-window-stack pos)))
- (window-select-event-handler))))
-
- (defun flip-window-stack (&optional (dir :forwards))
- (declare (special *window-stack*))
- (when (some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
- (clean-up-window-stack))
- (let ((current-in-stack (position (front-window) *window-stack*)))
- (if current-in-stack
- (ask (elt *window-stack*
- (cond ((eq dir :forwards)
- (mod (1+ current-in-stack) (length *window-stack*)))
- ((eq dir :backwards)
- (mod (1- current-in-stack) (length *window-stack*)))
- (t (error "flip-window-stack accepts only :forwards or :backwards"))))
- (window-select-event-handler))
- (ask (car *window-stack*) (window-select-event-handler)))))
-
- (when (> *screen-width* 600)
- (let ((width (floor (- *screen-width* 130) 2))
- (height (floor (- *screen-height* 74) 3)))
- (setf *fred-window-size* (make-point width (+ 4 (* 2 height))))
- (setf *fred-window-position* #@(4 44))
- (setf *listener-window-size* (make-point width height))
- (setf *listener-window-position* (make-point 4
- (+ (point-v *fred-window-position*)
- (point-v *fred-window-size*)
- 22)))
- (setf *stack-window-size* *fred-window-size*)
- (setf *stack-window-position* (make-point (+ (point-h *fred-window-position*)
- (point-h *fred-window-size*)
- 10)
- (point-v *fred-window-position*)))
- (pushnew :window-stacker *features*)
- (setf *window-stack* nil)))
-
- ;*******************************************************************************
- ;*** Comment Graphics
- ;*******************************************************************************
- ;
- ; This function merely draws nice posters to surround headings in the code.
- ; It supports five different levels of importance by drawing the poster with
- ; one of five different characters: @ * + = -.
-
- ;;; comment graphics
- (defobfun (comment-graphics *fred-window*) (level)
- (let* ((padchar (nth (- level 1) '(#\@ #\* #\+ #\= #\-)))
- (line1 (replace
- (make-string 80 :initial-element padchar)
- ";"
- :start1 0 :end1 1 :start2 0 :start2 1))
- (line2 (replace
- (replace
- (make-string 5 :initial-element padchar)
- ";"
- :start1 0 :end1 1 :start2 0 :start2 1)
- " "
- :start1 4 :end1 5 :start2 0 :start2 1)))
- (fresh-line (self))
- (write-line line1 (self))
- (write-string line2 (self))
- (let ((temp (mark-position (window-cursor-mark))))
- (terpri (self))
- (write-line line1 (self))
- (set-mark (window-cursor-mark) temp)
- (values))))
-
- ;*******************************************************************************
- ;*** History
- ;*******************************************************************************
- ;
- ; These functions implement a crude command-line history function
-
- ;;; to-last-cmnd-line moves the cursor to the last command line in the current
- ;;; buffer using find-last-cmnd-line.
-
- (defobfun (to-nearest-cmnd-line *fred-window*) (&optional (direction :up)) ; last command line
- (unless (collapse-selection t)
- (let ((p (find-nearest-cmnd-line
- direction
- (buffer-position (window-cursor-mark)))))
- (unless (null p) (set-mark (window-cursor-mark) p)))))
-
- ;;; find-last-cmnd-line uses the function buffer-string-pos
- ;;; with the key :from-end set to find the latest occurrance of the
- ;;; string "? " immediately preceded by a #\Newline.
- ;;; If there is none, then it returns the empty list.
- ;;; If it finds one, but the occurrance is in the same line as the
- ;;; position from which the search is proceeding (e.g. it was called
- ;;; with the cursor's position as the position from which to search, but
- ;;; with the cursor in a command line) then it recurs with the position
- ;;; of the found command line as the new starting point for the search.
- ;;; In other words, it ignores the command line from which it was called.
- ;;;
- ;;; There are further notes inline.
- ;;;
-
- (defobfun (find-nearest-cmnd-line *fred-window*) (direction pos)
- (let* ((buf (window-buffer))
- (p (cond ((eq direction :up)
- (buffer-string-pos buf
- (nsubstitute #\Newline #\n "n? ")
- :start 0
- :end (- pos 3)
- :from-end t))
- ((eq direction :down)
- (buffer-string-pos buf
- (nsubstitute #\Newline #\n "n? ")
- :start (+ pos 1)
- :end t
- :from-end nil))
- (t nil))))
- (cond ((null p) '())
- ((>= 2 ;skip over blank command lines
- (- (buffer-line-end buf (+ 1 p))
- (buffer-line-start buf (+ 1 p))))
- (find-nearest-cmnd-line direction p))
- (t (+ 3 p)))))
-
- ;;; up-a-window brings the last window in the list of windows up front
- (defobfun (up-a-window *fred-window*) ()
- (let ((windows (cdr (windows *fred-window*))))
- (if windows
- (ask (car (last windows)) (window-select))
- (ed-beep))))
-
- ;;; down-a-window brings the next window in the list of windows up front
- (defobfun (down-a-window *fred-window*) ()
- (let ((windows (cdr (windows *fred-window*))))
- (if windows
- (ask (car windows) (window-select))
- (ed-beep))))
-
-
- (provide 'keymacros)
-
-