Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv19171
Modified Files: application.lisp Log Message: Add /{Next,Previous} Page and /Top and /Bottom commands:
* bound to PgDown, PgUp, Ctrl-Home and Ctrl-End.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:12:05 1.55 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 09:39:08 1.56 @@ -400,29 +400,46 @@ (irc:part connection channel)))) (remove-receiver receiver *application-frame*))
-(macrolet ((define-highlighted-message-jumper (com-name keystroke next-pos-form fallback-position) +(macrolet ((define-scroller-command ((com-name keystroke) (top-var bot-var) next-pos-form &optional fallback-position) `(define-beirc-command (,com-name :name t :keystroke ,keystroke) () (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) - (next-y-position ,next-pos-form) - (bottom (max 0 (- (bounding-rectangle-height pane) - (bounding-rectangle-height (sheet-parent pane))))) - (top 0)) - (scroll-extent pane 0 (if next-y-position - (min next-y-position bottom) - (progn - (beep) - (funcall ,fallback-position bottom top)))))))) - (define-highlighted-message-jumper com-previous-highlighted-message (:prior :shift) + (,bot-var (max 0 (- (bounding-rectangle-height pane) + (bounding-rectangle-height (sheet-parent pane))))) + (,top-var 0) + (next-y-position ,next-pos-form)) + (declare (ignorable ,top-var ,bot-var)) + (scroll-extent pane 0 ,(if fallback-position + `(if next-y-position + (max 0 (min next-y-position bottom)) + (progn + (beep) + ,fallback-position)) + `(max 0 (min next-y-position bottom)))))))) + (define-scroller-command (com-previous-highlighted-message (:prior :shift)) (top bottom) (find-if (lambda (position) (< position (bounding-rectangle-min-y (pane-viewport-region pane)))) (positions-mentioning-user (current-receiver *application-frame*))) - (lambda (bottom top) (declare (ignore bottom)) top)) - (define-highlighted-message-jumper com-next-highlighted-message (:next :shift) + top) + (define-scroller-command (com-next-highlighted-message (:next :shift)) (top bottom) (loop for (this prev . rest) on (positions-mentioning-user (current-receiver *application-frame*)) until (null prev) if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) do (return this)) - (lambda (bottom top) (declare (ignore top)) bottom))) + bottom) + (define-scroller-command (com-previous-page (:prior)) (top bottom) + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (pane-min-y (rectangle-min-y (pane-viewport-region pane))) + (scroll-by (* (rectangle-height (pane-viewport-region pane)) 19/20))) + (- pane-min-y scroll-by))) + (define-scroller-command (com-next-page (:next)) (top bottom) + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (pane-min-y (rectangle-min-y (pane-viewport-region pane))) + (scroll-by (* (rectangle-height (pane-viewport-region pane)) 19/20))) + (+ pane-min-y scroll-by))) + (define-scroller-command (com-top (:home :control)) (top bottom) + top) + (define-scroller-command (com-bottom (:end :control)) (top bottom) + bottom))
(define-beirc-command (com-remove-inactive-queries :name t) () (let ((receivers-to-close nil))