cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-pager.el

   1 ;;; xwem-pager.el --- Simple frame pager.
   2
   3 ;; Copyright (C) 2004,2005 by XWEM Org.
   4
   5 ;; Author: Richard Klinda <ignotus@hixsplit.hu>
   6 ;;         Zajcev Evgeny <zevlg@yandex.ru>
   7 ;; Created: Wed Aug 18 08:05:09 MSD 2004
   8 ;; Keywords: xwem
   9 ;; X-CVS: $Id: xwem-pager.el,v 1.2 2005-04-04 19:54:15 lg Exp $
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;; Simple dockapp to show xwem frames.  Somekind of extension of
  33 ;; xwem-framei.el
  34
  35 ;;; Code:
  36 \f
  37 (require 'xwem-load)
  38 (require 'xlib-xshape)
  39
  40 \f
  41 ;; veryvery simple pager / 2d viewport support
  42 ;; the code works, do the following:
  43 ;;
  44 ;; add to XWEM-after-init-hook:
  45 ;;
  46 ;;    (setq *pager-dockapp* (xwem-2dframes-start-dockapp))
  47 ;;
  48 ;; ugly i know, that starts the dockapp
  49 ;;
  50 ;;   (xwem-2dframes-make-frames)
  51 ;;
  52 ;; that will create the frames
  53 ;;
  54 ;; load this code, restart your XWEM and be happy.  If you want to try it
  55 ;; out without restarting then MAKE SURE you have only 1 frame, load the
  56 ;; code then:
  57 ;; M-x xwem-2dframes-make-frames
  58 ;;
  59 ;; eval (setq *pager-dockapp* (xwem-2dframes-start-dockapp))
  60 ;;
  61 ;; change viewports / frames somehow so the dockapp gets updated
  62 ;;
  63 ;; i know this code is hackis, but if you rename the variables / sturcture
  64 ;; the code like you want it to be i'll work on it to make it full featured
  65 ;; + add more comments / docstrings.
  66
  67 ;;; //////////////////////////////////////////////////////////////////////
  68
  69 \f
  70 ;;;; Pager
  71 (defgroup xwem-pager nil
  72   "Group to customize xwem pager."
  73   :prefix "xwem-pager-"
  74   :group 'xwem-tray)
  75
  76 (defcustom xwem-pager-dim (cons '(2 . 3) '(4 . 4))
  77   "Minimum and maximum viewports to show at X and Y."
  78   :type '(cons (cons :tag "Minimum"
  79                      (number :tag "X")
  80                      (number :tag "Y"))
  81                (cons :tag "Maximum"
  82                      (number :tag "X")
  83                      (number :tag "Y")))
  84   :set (lambda (sym val)
  85          (set sym val)
  86          (when (xwem-pager-xwin)
  87            (xwem-pager-redimentionize)))
  88   :initialize 'custom-initialize-default
  89   :group 'xwem-pager)
  90
  91 (defcustom xwem-pager-prefer-horizontal t
  92   "*Non-nil mean pager will prefer horizontal increment when redimentinizing."
  93   :type 'boolean
  94   :set (lambda (sym val)
  95          (set sym val)
  96          (when (xwem-pager-xwin)
  97            (xwem-pager-redimentionize)))
  98   :initialize 'custom-initialize-default
  99   :group 'xwem-pager)
 100
 101 (defcustom xwem-pager-viewport-size '(12 . 6)
 102   "\(X . Y\) where X*Y pixel will represent one viewport."
 103   :type '(cons (number :tag "X")
 104                (number :tag "Y"))
 105   :set (lambda (sym val)
 106          (set sym val)
 107          (when (xwem-pager-xwin)
 108            (xwem-pager-redimentionize)))
 109   :initialize 'custom-initialize-default
 110   :group 'xwem-pager)
 111
 112 (defcustom xwem-pager-grid-p t
 113   "*Set to non-nil if you want visible grid."
 114   :type 'boolean
 115   :set (lambda (sym val)
 116          (set sym val)
 117          (when (xwem-pager-xwin)
 118            (xwem-pager-redraw (xwem-pager-xwin) t)))
 119   :initialize 'custom-initialize-default
 120   :group 'xwem-pager)
 121
 122 (define-xwem-face xwem-pager-face
 123   `(((selected) (:foreground "grey30"))
 124     ((border selected) (:foreground "grey10"))
 125     ((deselected) (:foreground "grey55"))
 126     ((border deselected) (:foreground "grey35"))
 127     ((unavailable) (:foreground "grey80"))
 128     ((border unavailable) (:foreground "grey100")))
 129   "Face for pager."
 130   :group 'xwem-pager)
 131
 132 (defvar xwem-pager-keymap
 133   (let ((map (make-sparse-keymap)))
 134     (define-key map [button1] 'xwem-pager-iswitch)
 135     (define-key map [button3] 'xwem-pager-popup-menu)
 136     map)
 137   "Keymap for pager operations.")
 138
 139 \f
 140 ;; Macroses
 141 (defvar xwem-pager-xwin nil
 142   "XWIN of xwem pager.")
 143
 144 ;; Pager xwin
 145 (defmacro xwem-pager-xwin (&optional xwin)
 146   "Return pager's dockapp X window."
 147   `(or ,xwin xwem-pager-xwin))
 148 (defsetf xwem-pager-xwin () (xwin)
 149   `(setq xwem-pager-xwin ,xwin))
 150 ;; Pager pixmap
 151 (defmacro xwem-pager-xpix (&optional xwin)
 152   "Return pager's dockapp X window."
 153   `(X-Win-get-prop (xwem-pager-xwin ,xwin) 'xwem-pager-xpixmap))
 154 (defsetf xwem-pager-xpix (&optional xwin) (pix)
 155   `(X-Win-put-prop (xwem-pager-xwin ,xwin) 'xwem-pager-xpixmap ,pix))
 156 ;; Pager dimentions (X . Y
 157 (defmacro xwem-pager-dim (&optional xwin)
 158   `(X-Win-get-prop (xwem-pager-xwin ,xwin) 'xwem-pager-dim))
 159 (defsetf xwem-pager-dim (&optional xwin) (dim)
 160   `(X-Win-put-prop (xwem-pager-xwin ,xwin) 'xwem-pager-dim ,dim))
 161
 162 \f
 163 ;; Functions
 164 (define-xwem-deffered xwem-pager-redraw-for-frame (frame-num &optional xwin)
 165   "Redraw FRAME."
 166   (when (< frame-num (apply '* (xwem-pager-dim xwin)))
 167     ;; FRAME shows in pager
 168     (let* ((frame (nth frame-num xwem-frames-list))
 169            (dim (xwem-pager-dim xwin))
 170            (tags (cond ((not (xwem-frame-alive-p frame))
 171                         '(unavailable))
 172                        ((xwem-frame-selected-p frame)
 173                         '(selected))
 174                        (t '(deselected))))
 175            (gc (xwem-face-get-gc 'xwem-pager-face tags))
 176            (col (% frame-num (car dim)))
 177            (row (/ frame-num (car dim))))
 178       (XFillRectangle (xwem-dpy) (xwem-pager-xpix xwin) gc
 179                       (* col (car xwem-pager-viewport-size))
 180                       (* row (cdr xwem-pager-viewport-size))
 181                       (car xwem-pager-viewport-size)
 182                       (cdr xwem-pager-viewport-size))
 183       (when xwem-pager-grid-p
 184         (XDrawRectangle (xwem-dpy) (xwem-pager-xpix xwin)
 185                         (xwem-face-get-gc 'xwem-pager-face `(border ,@tags))
 186                         (* col (car xwem-pager-viewport-size))
 187                         (* row (cdr xwem-pager-viewport-size))
 188                         (1- (car xwem-pager-viewport-size))
 189                         (1- (cdr xwem-pager-viewport-size))))
 190       (xwem-pager-redraw (xwem-pager-xwin xwin)))))
 191
 192 (define-xwem-deffered xwem-pager-redraw (xwin &optional full)
 193   "Redraw pager XWIN."
 194   (let* ((geom (XGetGeometry (xwem-dpy) (xwem-pager-xpix xwin)))
 195          (w (X-Geom-width geom))
 196          (h (X-Geom-height geom)))
 197     (if (not full)
 198         (XCopyArea (xwem-dpy) (xwem-pager-xpix xwin) xwin
 199                    (XDefaultGC (xwem-dpy)) 0 0 w h 0 0)
 200
 201       (XFillRectangle (xwem-dpy) (xwem-pager-xpix xwin)
 202                       (XDefaultGC (xwem-dpy))
 203                       0 0 w h)
 204       (loop for fnum from 0 to (apply '* (xwem-pager-dim xwin))
 205         do (xwem-pager-redraw-for-frame-1 fnum xwin)))))
 206
 207 (defun xwem-pager-redimentionize (&optional non-used-argument xwin)
 208   "Check is pager need redimentionisation."
 209   (let ((frames (length xwem-frames-list))
 210         (min-ddim (list (car (cdr xwem-pager-dim))
 211                         (cdr (cdr xwem-pager-dim)))))
 212     ;; Calculate new dimention
 213     (mapc (lambda (ddim)
 214             (let ((dval (- (apply '* ddim) frames))
 215                   (mval (- (apply '* min-ddim) frames)))
 216               ;; Change min-ddim only if:
 217               ;;  - DVAL is positive or zero and MVAL is negative
 218               ;;  - DVAL and MVAL of same sign and DVAL abs is lesser
 219               ;;  - DVAL and MVAL of same sign and DVAL is equal to MVAL, but
 220               ;;    DVAL's X and Y components differs lesser.
 221               (when (or (and (>= dval 0) (< mval 0))
 222                         (and (or (zerop dval)
 223                                  (= (signum dval) (signum mval)))
 224                              (or (< (abs dval) (abs mval))
 225                                  (and (= (abs dval) (abs mval))
 226                                       (< (abs (- (car ddim) (cadr ddim)))
 227                                          (abs (- (car min-ddim)
 228                                                  (cadr min-ddim)))))
 229                                  (and xwem-pager-prefer-horizontal
 230                                       (= (abs dval) (abs mval))
 231                                       (= (abs (- (car ddim) (cadr ddim)))
 232                                          (abs (- (car min-ddim)
 233                                                  (cadr min-ddim))))
 234                                       (> (car ddim) (car min-ddim))))))
 235                 (setq min-ddim ddim))))
 236           ;; Create a list of all possible dimentions
 237           (loop for i from (car (car xwem-pager-dim))
 238             to (car (cdr xwem-pager-dim))
 239             nconc (loop for j from (cdr (car xwem-pager-dim))
 240                     to (cdr (cdr xwem-pager-dim))
 241                     collect (list i j))))
 242
 243     (setf (xwem-pager-dim xwin) min-ddim)
 244     (let ((w (* (car min-ddim) (car xwem-pager-viewport-size)))
 245           (h (* (cadr min-ddim) (cdr xwem-pager-viewport-size))))
 246       (XResizeWindow (xwem-dpy) (xwem-pager-xwin xwin) w h)
 247       ;; Recreate pixmap (if necessary)
 248       (when (xwem-pager-xpix xwin)
 249         (XFreePixmap (xwem-dpy) (xwem-pager-xpix xwin)))
 250       (setf (xwem-pager-xpix xwin)
 251             (XCreatePixmap (xwem-dpy)
 252                            (make-X-Pixmap :id (X-Dpy-get-id (xwem-dpy)))
 253                            (xwem-pager-xwin xwin)
 254                            (XDefaultDepth (xwem-dpy))
 255                            w h))
 256       (when xwem-misc-turbo-mode
 257         (XSetWindowBackgroundPixmap (xwem-dpy) (xwem-pager-xwin xwin)
 258                                     (xwem-pager-xpix xwin))))
 259     (xwem-pager-redraw (xwem-pager-xwin xwin) t)))
 260
 261 (defun xwem-pager-frame-redraw (&optional frame)
 262   "Update xwem pager dockapp, because FRAME just selected/deselected."
 263   (unless frame (setq frame (xwem-frame-selected)))
 264   (xwem-pager-redraw-for-frame (xwem-frame-num frame)))
 265
 266 (defun xwem-pager-remove (xwin &optional need-destroy)
 267   "Destroy pager's XWIN."
 268   (XFreePixmap (xwem-dpy) (xwem-pager-xpix xwin))
 269   (setf (xwem-pager-xpix xwin) nil)
 270
 271   ;; Remove pager events handler
 272   (X-Win-EventHandler-rem xwin 'xwem-pager-event-handler)
 273
 274   ;; Destroy pager xwin if needed
 275   (when need-destroy
 276     (XDestroyWindow (xwem-dpy) xwin))
 277
 278   ;; Unset default pager xwin
 279   (when (eq (xwem-pager-xwin) xwin)
 280     (setf (xwem-pager-xwin) nil))
 281
 282   (remove-hook 'xwem-frame-select-hook 'xwem-pager-frame-redraw)
 283   (remove-hook 'xwem-frame-deselect-hook 'xwem-pager-frame-redraw)
 284   (remove-hook 'xwem-frame-creation-hook 'xwem-pager-redimentionize)
 285   (remove-hook 'xwem-frame-destroy-hook 'xwem-pager-redimentionize))
 286
 287 (defun xwem-pager-event-handler (xdpy xwin xev)
 288   "X Events handler for xwem pager dockapp."
 289   (X-Event-CASE xev
 290     (:X-Expose
 291      (xwem-pager-redraw xwin))
 292     (:X-DestroyNotify
 293      (xwem-pager-remove xwin))
 294     ((:X-ButtonPress :X-ButtonRelease)
 295      (let ((xwem-override-local-map xwem-pager-keymap))
 296        (xwem-dispatch-command-xevent xev)))))
 297
 298 ;;;###autoload
 299 (defun xwem-pager (&optional dockid dockgroup dockalign)
 300   "Start xwem pager dockapp.
 301 DOCKID, DOCKGROUP and DOCKALIGN specifies pager placement in xwem
 302 tray."
 303   (interactive)
 304   (let* ((pwin (XCreateWindow
 305                 (xwem-dpy) nil 0 0 1 1 0
 306                 nil nil nil
 307                 (make-X-Attr :event-mask
 308                              (Xmask-or XM-Exposure XM-StructureNotify
 309                                        XM-ButtonPress XM-ButtonRelease)
 310                              :override-redirect t))))
 311     ;; Set default pager window
 312     (unless (X-Win-p (xwem-pager-xwin))
 313       (setf (xwem-pager-xwin) pwin))
 314
 315     ;; Initialize sizes and stuff
 316     (xwem-pager-redimentionize nil pwin)
 317
 318     ;; Install events handler
 319     (X-Win-EventHandler-add pwin 'xwem-pager-event-handler nil
 320                             (list X-Expose X-DestroyNotify
 321                                   X-ButtonPress X-ButtonRelease))
 322
 323     ;; Initialize wd in sys tray
 324     (xwem-XTrayInit (xwem-dpy) pwin dockid dockgroup dockalign)
 325
 326     (add-hook 'xwem-frame-select-hook 'xwem-pager-frame-redraw)
 327     (add-hook 'xwem-frame-deselect-hook 'xwem-pager-frame-redraw)
 328     (add-hook 'xwem-frame-creation-hook 'xwem-pager-redimentionize)
 329     (add-hook 'xwem-frame-destroy-hook 'xwem-pager-redimentionize)
 330
 331     pwin))
 332
 333 (defun xwem-pager-frame-at (xwin x y)
 334   "Return frame that is under X Y position in XWIN pager."
 335   (let* ((dim (xwem-pager-dim xwin))
 336          (col (/ x (car xwem-pager-viewport-size)))
 337          (row (/ y (cdr xwem-pager-viewport-size)))
 338          (num (+ (* row (car dim)) col)))
 339     (nth num xwem-frames-list)))
 340
 341 ;; Commands
 342 (define-xwem-command xwem-pager-iswitch (ev)
 343   "Switch to frame."
 344   (xwem-interactive (list xwem-last-event))
 345   (unless (button-event-p ev)
 346     (error 'xwem-error
 347            "`xwem-pager-iswitch-frame' must be bound to mouse event"))
 348   (let ((frame (xwem-pager-frame-at
 349                 (X-Event-win xwem-last-xevent)
 350                 (X-Event-xbutton-event-x xwem-last-xevent)
 351                 (X-Event-xbutton-event-y xwem-last-xevent))))
 352     (when (xwem-frame-p frame)
 353       (xwem-select-frame frame))))
 354
 355 (define-xwem-command xwem-pager-popup-menu (ev)
 356   "Popup menu."
 357   (xwem-interactive (list xwem-last-event))
 358   (unless (button-event-p ev)
 359     (error 'xwem-error
 360            "`xwem-pager-popup-menu' must be bound to mouse event"))
 361   (xwem-popup-menu
 362    (list "Pager"
 363          "---"
 364          (vector "Destroy"
 365                  `(xwem-pager-remove ,(X-Event-win xwem-last-xevent) t)))))
 366
 367 \f
 368 ;;;; 2D Frames
 369 ;;;###autoload
 370 (defun xwem-pager-make-frames ()
 371   "Make the frames, call from XWEM-AFTER-INIT-HOOK!"
 372   (dotimes (it (- (* (car (cdr xwem-pager-dim))
 373                      (cdr (cdr xwem-pager-dim)))
 374                   (length (xwem-frames-list 'desktop))))
 375     (xwem-make-frame-1 'desktop :noselect t)))
 376
 377 ;;;###autoload(autoload 'xwem-pager-move-up "xwem-pager" nil t)
 378 (define-xwem-command xwem-pager-move-up (&optional arg)
 379   "Move one viewport up."
 380   (xwem-interactive "p")
 381   (xwem-pager-move 'up arg))
 382
 383 ;;;###autoload(autoload 'xwem-pager-move-down "xwem-pager" nil t)
 384 (define-xwem-command xwem-pager-move-down (&optional arg)
 385   "Move one viewport down."
 386   (xwem-interactive "p")
 387   (xwem-pager-move 'down arg))
 388
 389 ;;;###autoload(autoload 'xwem-pager-move-left "xwem-pager" nil t)
 390 (define-xwem-command xwem-pager-move-left (&optional arg)
 391   "Move one viewport left."
 392   (xwem-interactive "p")
 393   (xwem-pager-move 'left arg))
 394
 395 ;;;###autoload(autoload 'xwem-pager-move-right "xwem-pager" nil t)
 396 (define-xwem-command xwem-pager-move-right (&optional arg)
 397   "Move one viewport right."
 398   (xwem-interactive "p")
 399   (xwem-pager-move 'right arg))
 400
 401 (defun xwem-pager-move (dir &optional arg)
 402   "Generic function to move to frame in DIR direction.
 403 DIR is one of `up', `down', `right' or `left'."
 404   (unless arg (setq arg 1))
 405   (xwem-frame-switch-nth
 406    (case dir
 407     (up (- (xwem-frame-num (xwem-frame-selected))
 408            (* arg (car (xwem-pager-dim)))))
 409     (down (+ (xwem-frame-num (xwem-frame-selected))
 410              (* arg (car (xwem-pager-dim)))))
 411     (left (- (xwem-frame-num (xwem-frame-selected)) arg))
 412     (right (+ (xwem-frame-num (xwem-frame-selected)) arg)))))
 413
 414 ;;;###autoload
 415 (defun xwem-pager-install-bindings ()
 416   "Install default bindings for 2D frames commands."
 417   (xwem-global-set-key [(super h)] 'xwem-pager-move-left)
 418   (xwem-global-set-key [(super t)] 'xwem-pager-move-down)
 419   (xwem-global-set-key [(super n)] 'xwem-pager-move-up)
 420   (xwem-global-set-key [(super s)] 'xwem-pager-move-right))
 421
 422 \f
 423 (provide 'xwem-pager)
 424
 425 ;;; xwem-pager.el ends here