[closure-cvs] CVS closure/src/gui

[emarsden]

Update of /project/closure/cvsroot/closure/src/gui
In directory clnet:/tmp/cvs-serv1214/src/gui

Modified Files:
	clim-gui.lisp 
Log Message:
GUI: implement beginning-of-page and end-of-page commands; add
keyboard shortcuts for back & forward. 


--- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp	2006/12/31 15:42:40	1.27
+++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp	2007/01/03 11:34:45	1.28
@@ -4,7 +4,7 @@
 ;;;   Created: 2002-07-22
 ;;;    Author: Gilbert Baumann <gilbert at base-engineering.com>
 ;;;   License: MIT style (see below)
-;;;       $Id: clim-gui.lisp,v 1.27 2006/12/31 15:42:40 dlichteblau Exp $
+;;;       $Id: clim-gui.lisp,v 1.28 2007/01/03 11:34:45 emarsden Exp $
 ;;; ---------------------------------------------------------------------------
 ;;;  (c) copyright 2002 by Gilbert Baumann
 
@@ -28,7 +28,12 @@
 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 ;; $Log: clim-gui.lisp,v $
+;; Revision 1.28  2007/01/03 11:34:45  emarsden
+;; GUI: implement beginning-of-page and end-of-page commands; add
+;; keyboard shortcuts for back & forward.
+;;
 ;; Revision 1.27  2006/12/31 15:42:40  dlichteblau
+;;
 ;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of
 ;; Closure don't have to depend on CLIM anymore.
 ;;
@@ -364,7 +369,7 @@
 (define-closure-command (com-reflow :name t) ()
   (reflow))
 
-(define-closure-command (com-back :name t) ()
+(define-closure-command (com-back :name t :keystroke (:left :control)) ()
   (let ((*standard-output* *query-io*)) 
     (cond ((null (cdr *back-history*))
            (format t "There is nowhere you can go back to.~%"))
@@ -373,8 +378,8 @@
            (format t "Going back to ~S.~%" (first *back-history*))
            (foo (first *back-history*))))))
 
-(define-closure-command (com-forward :name t) ()
-  (let ((*standard-output* *query-io*)) 
+(define-closure-command (com-forward :name t :keystroke (:right :control)) ()
+  (let ((*standard-output* *query-io*))
     (cond ((null *forw-history*)
            (format t "There is nowhere you can go forward to.~%"))
           (t
@@ -398,7 +403,7 @@
   (setf gui:*user-wants-images-p* t)
   (format *query-io* "Images are now on. You may want to reload.~%"))
 
-(define-closure-command (com-quit :name t) ()
+(define-closure-command (com-quit :name t :keystroke (#\q :control)) ()
   (frame-exit *application-frame*))
 
 (defun make-google-search-url (string)
@@ -561,9 +566,8 @@
      (lambda ()
        (with-simple-restart (forget "Just forget rendering this page.")
          (let* ((*package* (find-package :r2))
-                (*pane* (find-pane-named *frame* 'canvas))
-                (*medium* (sheet-medium *pane*)))
-           (progn ;; with-sheet-medium (*medium* *pane*)
+                (*pane* (find-pane-named *frame* 'canvas)))
+           (with-sheet-medium (*medium* *pane*)
              (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*)))
                (setf (sheet-pointer-cursor *pane*) :busy)
                (setq url (r2::parse-url* url))
@@ -664,13 +668,12 @@
   (setq gui:*zoom-factor* 1.0)
   (send-closure-command 'com-reflow))
 
-;; FIXME the :shift here is a McCLIM bug
-(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control :shift)) ()
+(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control)) ()
   (write-status "Zooming in...")
   (setq gui:*zoom-factor* (* gui:*zoom-factor* 1.2))
   (send-closure-command 'com-reflow))
 
-(define-closure-command (com-zoom-out :name t :keystroke (#\- :control :shift)) ()
+(define-closure-command (com-zoom-out :name t :keystroke (#\- :control)) ()
   (write-status "Zooming out...")
   (setq gui:*zoom-factor* (* gui:*zoom-factor* 0.8))
   (send-closure-command 'com-reflow))
@@ -692,6 +695,18 @@
     (scroll-extent pane 0
                    (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height))))))
 
+(define-closure-command (com-beginning-of-page :name t
+                                               :keystroke (:home :control)) ()
+  (let* ((pane (find-pane-named *frame* 'canvas))
+         (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)))
+    (scroll-extent pane 0 (gadget-min-value scrollbar))))
+
+(define-closure-command (com-end-of-page :name t
+                                         :keystroke (:end :control)) ()
+  (let* ((pane (find-pane-named *frame* 'canvas))
+         (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)))
+    (scroll-extent pane 0 (gadget-max-value scrollbar))))
+
 (define-closure-command (com-redraw :name t :keystroke (#\r :control)) ()
   (let* ((*pane* (find-pane-named *frame* 'canvas)) )
     (handle-repaint *pane* (sheet-region (pane-viewport *pane*))))