[beirc-cvs] CVS beirc

[afuchs]

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))