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

   1 ;;; xwem-mogu.el --- XWEM MOuse Grid Uberness.
   2
   3 ;; Copyright (C) 2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Thu Mar  3 22:24:27 MSK 2005
   7 ;; Keywords: xwem, mouse, grid
   8
   9 ;; This file is part of XWEM.
  10
  11 ;; XWEM is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  18 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  19 ;; License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 ;; 02111-1307, USA.
  25
  26 ;;; Synched up with: Not in FSF
  27
  28 ;;; Commentary:
  29
  30 ;;  When xwem-mogu is enabled whole screen is splited by set of
  31 ;; horizontal and vertical lines.  Each vertical line has
  32 ;; corresponding <number> and each horizontal line has corresponding
  33 ;; <character>.  Each intersection of horizontal and vertical lines
  34 ;; denotes NODE.  Each node has unique identificator - cons cell in
  35 ;; form: (<character> . <number>).  The closest node to pointer
  36 ;; location called MOUSE-NODE.  Set of nodes of same <number> called
  37 ;; NODE-VLINE.  Set of nodes of same <character> called NODE-HLINE.
  38
  39 ;; Here is an ASCII Scheme:
  40
  41 ;;    1          2          3          4
  42 ;;   a*----------*----------*----------*
  43 ;;    |          |          |          |
  44 ;;    |          |          |          |
  45 ;;    |          |          |          |
  46 ;;    |          |          |          |
  47 ;;    |          |          |          |
  48 ;;    |          |          |          |
  49 ;;   b*----------o----------*----------*
  50 ;;    |          |          |          |
  51 ;;    |          | 7\       |          |
  52 ;;    |          |          |          |
  53 ;;    |          |          |          |
  54 ;;    |          |          |          |
  55 ;;    |          |          |          |
  56 ;;   c*----------*----------*----------*
  57 ;;
  58 ;;      7\ - Pointer
  59 ;;      *  - node
  60 ;;      o  - mouse-node
  61
  62 ;;; Code:
  63 \f
  64 (require 'xlib-xlib)
  65 (require 'xlib-xshape)
  66
  67 (require 'xwem-load)
  68 (require 'xwem-interactive)
  69
  70 (defgroup xwem-mogu nil
  71   "Group to customize xwem mouse grid uberness."
  72   :prefix "xwem-mogu-"
  73   :group 'xwem-modes)
  74
  75 (defcustom xwem-mogu-keep-pointer-offset nil
  76   "*Non-nil mean mouse offset is kept when mouse-node is moved."
  77   :type 'boolean
  78   :group 'xwem-mogu)
  79
  80 (defcustom xwem-mogu-numbers-characters-visible-p t
  81   "*Non-nil mean <number>s and <character>s are visible."
  82   :type 'boolean
  83   :group 'xwem-mogu)
  84
  85 (defcustom xwem-mogu-identificators-visible-p nil
  86   "*Non-nil identificators are shown for each node."
  87   :type 'boolean
  88   :group 'xwem-mogu)
  89
  90 (defcustom xwem-mogu-numbers 8
  91   "Maximum number of <number>s."
  92   :type 'number
  93   :group 'xwem-mogu)
  94
  95 (defcustom xwem-mogu-characters 6
  96   "Maximum number of <character>s."
  97   :type 'number
  98   :group 'xwem-mogu)
  99
 100 (defcustom xwem-mogu-grid-width 1
 101   "*Width of grid lines."
 102   :type 'number
 103   :group 'xwem-mogu)
 104
 105 (defcustom xwem-mogu-grid-color "gray78"
 106   "Color for grid."
 107   :type 'color
 108   :group 'xwem-mogu)
 109
 110 (defcustom xwem-mogu-node-color "gray50"
 111   "Color for nodes."
 112   :type 'color
 113   :group 'xwem-mogu)
 114
 115 (defcustom xwem-mogu-mouse-node-color "red4"
 116   "Color for mouse-node."
 117   :type 'color
 118   :group 'xwem-mogu)
 119
 120 (defcustom xwem-mogu-stack-rank
 121   '(((eval t) . (30 . 30)))
 122   "Stack ranks specification for xwem mogu."
 123   :type '(cons (sexp :tag "Client MATCH-SPEC")
 124                (cons (number :tag "Active")
 125                      (number :tag "Inactive")))
 126   :group 'xwem-mogu)
 127
 128 (define-xwem-face xwem-mogu-face
 129   `(((grid) (:foreground ,xwem-mogu-grid-color))
 130     ((node) (:foreground ,xwem-mogu-node-color))
 131     ((mouse-node) (:foreground ,xwem-mogu-mouse-node-color)))
 132   "Face for use by xwem-mogu."
 133   :group 'xwem-mogu
 134   :group 'xwem-faces)
 135
 136 (defcustom xwem-mogu-minor-mode-hook nil
 137   "Hooks to run when mogu mode is enabled or disabled.
 138 When running hooks value of `xwem-mogu-minor-mode' is non-nil when
 139 mogu minor mode is enabling.
 140 When running hooks value of `xwem-mogu-minor-mode' is nil when mogu
 141 minor mode is disabling."
 142   :type 'hook
 143   :group 'xwem-hooks
 144   :group 'xwem-mogu)
 145
 146 (defvar xwem-mogu-minor-mode nil
 147   "Non-nil mean mogu minor mode is enabled.")
 148
 149 \f
 150
 151 (defvar xwem-mogu-xwin nil)
 152
 153 (defmacro xwem-mogu-xmask (xwin)
 154   `(X-Win-get-prop ,xwin 'xwem-mogu-xmask))
 155 (defsetf xwem-mogu-xmask (xwin) (xmask)
 156   `(X-Win-put-prop ,xwin 'xwem-mogu-xmask ,xmask))
 157
 158 (defmacro xwem-mogu-mouse-node (xwin)
 159   `(X-Win-get-prop ,xwin 'xwem-mogu-mouse-node))
 160 (defsetf xwem-mogu-mouse-node (xwin) (mouse-node)
 161   `(X-Win-put-prop ,xwin 'xwem-mogu-mouse-node ,mouse-node))
 162
 163 ;;; Functions
 164 (defun xwem-mogu-redimentionize-grid ()
 165   "`xwem-mogu-numbers' or `xwem-mogu-characters' changed, so handle it."
 166   ;; TODO: write me
 167   )
 168
 169 (defun xwem-mogu-query-mouse-node ()
 170   "Return node that is most close to pointer location."
 171   (let* ((qp (XQueryPointer (xwem-dpy) xwem-mogu-xwin))
 172          (x (nth 5 qp))
 173          (y (nth 6 qp))
 174          (wid-step (+ (/ (X-Geom-width (xwem-rootgeom)) xwem-mogu-numbers)
 175                       xwem-mogu-grid-width))
 176          (hei-step (+ (/ (X-Geom-height (xwem-rootgeom)) xwem-mogu-characters)
 177                       xwem-mogu-grid-width))
 178          (rx (/ x wid-step))
 179          (ry (/ y hei-step))
 180          (wr (% x wid-step))
 181          (hr (% y hei-step)))
 182     (when (> wr (- wid-step wr))
 183       (incf rx))
 184     (when (> hr (- hei-step hr))
 185       (incf ry))
 186     ;(cons rx (int-to-char (+ ry (char-to-int ?a))))
 187     (cons rx ry)))
 188
 189 (defun xwem-mogu-create-grid ()
 190   "Create xwem-mogu grid."
 191   ;; TODO: write me
 192   (unless xwem-mogu-xwin
 193     (let* ((wid (X-Geom-width (xwem-rootgeom)))
 194            (wid-step (/ wid xwem-mogu-numbers))
 195            (hei (X-Geom-height (xwem-rootgeom)))
 196            (hei-step (/ hei xwem-mogu-characters)))
 197       (setq xwem-mogu-xwin
 198             (XCreateWindow (xwem-dpy) (xwem-rootwin) 0 0
 199                            wid hei 0
 200                            nil nil nil
 201                            (make-X-Attr :override-redirect t
 202                                         :background-pixel
 203                                         (XAllocColor (xwem-dpy) (XDefaultColormap (xwem-dpy))
 204                                                      (xwem-make-color xwem-mogu-grid-color)))))
 205       ;; XXX Setup stack rank
 206       (xwem-misc-set-xwin-always-on-top xwem-mogu-xwin 100)
 207
 208       ;; Create mask pixmap
 209       (setf (xwem-mogu-xmask xwem-mogu-xwin)
 210             (XCreatePixmap (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy)
 211                                                      :id (X-Dpy-get-id (xwem-dpy)))
 212                            xwem-mogu-xwin 1 wid hei))
 213
 214       (XFillRectangle (xwem-dpy) (xwem-mogu-xmask xwem-mogu-xwin)
 215                       xwem-misc-mask-fgc 0 0 wid hei)
 216
 217       (loop for xo from 0 to wid by (+ wid-step xwem-mogu-grid-width)
 218         do (loop for yo from 0 to hei by (+ hei-step xwem-mogu-grid-width)
 219              do (XFillRectangle (xwem-dpy) (xwem-mogu-xmask xwem-mogu-xwin)
 220                                 xwem-misc-mask-bgc
 221                                 (+ xo xwem-mogu-grid-width) (+ yo xwem-mogu-grid-width)
 222                                 wid-step hei-step)))
 223
 224       (X-XShapeMask (xwem-dpy) xwem-mogu-xwin
 225                     X-XShape-Bounding X-XShapeSet 0 0
 226                     (xwem-mogu-xmask xwem-mogu-xwin))
 227
 228       ;; Initialise mouse-node
 229       (setf (xwem-mogu-mouse-node xwem-mogu-xwin)
 230             (xwem-mogu-query-mouse-node))
 231
 232       ;; Show mouse grid
 233       (XMapWindow (xwem-dpy) xwem-mogu-xwin)
 234
 235       xwem-mogu-xwin)))
 236
 237 \f
 238 ;;; Commands:
 239 (define-xwem-command xwem-turn-on-mogu ()
 240   "Enable mogu minor mode."
 241   (xwem-interactive)
 242   (unless xwem-mogu-minor-mode
 243     (if xwem-mogu-xwin
 244         (XMapWindow (xwem-dpy) xwem-mogu-xwin)
 245       (xwem-mogu-create-grid))
 246     (xwem-turn-on-minor-mode nil 'xwem-mogu-minor-mode)
 247     (run-hooks 'xwem-mogu-minor-mode-hook)))
 248
 249 (define-xwem-command xwem-turn-off-mogu ()
 250   "Disable mogu minor mode."
 251   (xwem-interactive)
 252   (when xwem-mogu-minor-mode
 253     (XUnmapWindow (xwem-dpy) xwem-mogu-xwin)
 254     (xwem-turn-off-minor-mode nil 'xwem-mogu-minor-mode)
 255     (run-hooks 'xwem-mogu-minor-mode-hook)))
 256
 257 (define-xwem-command xwem-mogu-minor-mode (arg)
 258   "Toggle mogu minor mode.
 259 If ARG is positive number - enable it.
 260 If ARG is negative number - disable it."
 261   (xwem-interactive "P")
 262   (if (or (and (numberp arg)
 263                (> arg 0))
 264           (not xwem-mogu-minor-mode))
 265       (xwem-turn-on-mogu)
 266     (xwem-turn-off-mogu)))
 267
 268 (defun xwem-mogu-goto (id-x id-y)
 269   "Move to node with ID."
 270   (let* ((qp (XQueryPointer (xwem-dpy) xwem-mogu-xwin))
 271          (x (nth 5 qp))
 272          (y (nth 6 qp))
 273          (wid-step (+ (/ (X-Geom-width (xwem-rootgeom)) xwem-mogu-numbers)
 274                       xwem-mogu-grid-width))
 275          (hei-step (+ (/ (X-Geom-height (xwem-rootgeom)) xwem-mogu-characters)
 276                       xwem-mogu-grid-width))
 277          wr hr)
 278
 279     (if (not xwem-mogu-keep-pointer-offset)
 280         (setq wr 0 hr 0)
 281
 282       (setq wr (% x wid-step)
 283             hr (% y hei-step))
 284       (when (> wr (- wid-step wr))
 285         (setq wr (- wr wid-step)))
 286       (when (> hr (- hei-step hr))
 287         (setq hr (- hr hei-step))))
 288
 289     ;; Save new mouse-node
 290     (setf (xwem-mogu-mouse-node xwem-mogu-xwin)
 291           (cons id-x id-y))
 292
 293     (XWarpPointer (xwem-dpy) (xwem-rootwin) xwem-mogu-xwin
 294                   0 0 0 0
 295                   (+ (* wid-step id-x) wr)
 296                   (+ (* hei-step id-y) hr))))
 297
 298 (defun xwem-mogu-move (direction arg)
 299   "Move in DIRECTION ARG times.
 300 DIRECTION is one of 'left, 'right, 'up or 'down.
 301 ARG is number."
 302   (let ((m-n (xwem-mogu-mouse-node xwem-mogu-xwin)))
 303     (ecase direction
 304       (left
 305        (if (< arg 0)
 306            (xwem-mogu-move 'right (- arg))
 307          (xwem-mogu-goto (decf (car m-n) arg) (cdr m-n))))
 308       (right
 309        (if (< arg 0)
 310            (xwem-mogu-move 'left (- arg))
 311          (xwem-mogu-goto (incf (car m-n) arg) (cdr m-n))))
 312       (up
 313        (if (< arg 0)
 314            (xwem-mogu-move 'down (- arg))
 315          (xwem-mogu-goto (car m-n) (decf (cdr m-n) arg))))
 316       (down
 317        (if (< arg 0)
 318            (xwem-mogu-move 'up (- arg))
 319          (xwem-mogu-goto (car m-n) (incf (cdr m-n) arg))))
 320       )))
 321
 322 (define-xwem-command xwem-mogu-right (arg)
 323   "Move forward ARG nodes."
 324   (xwem-interactive "p")
 325   (xwem-mogu-move 'right arg))
 326
 327 (define-xwem-command xwem-mogu-left (arg)
 328   "Move backward ARG nodes."
 329   (xwem-interactive "p")
 330   (xwem-mogu-move 'left arg))
 331
 332 (define-xwem-command xwem-mogu-up (arg)
 333   "Move up ARG nodes."
 334   (xwem-interactive "p")
 335   (xwem-mogu-move 'up arg))
 336
 337 (define-xwem-command xwem-mogu-down (arg)
 338   "Move down ARG nodes."
 339   (xwem-interactive "p")
 340   (xwem-mogu-move 'down arg))
 341
 342 (define-xwem-command xwem-mogu-hline-beginning ()
 343   "Goto beginning of hline."
 344   (xwem-interactive)
 345   (xwem-mogu-goto 0 (cdr (xwem-mogu-mouse-node xwem-mogu-xwin))))
 346
 347 (define-xwem-command xwem-mogu-hline-end ()
 348   "Goto end of hline."
 349   (xwem-interactive)
 350   (xwem-mogu-goto xwem-mogu-numbers
 351                   (cdr (xwem-mogu-mouse-node xwem-mogu-xwin))))
 352
 353 (define-xwem-command xwem-mogu-vline-beginning ()
 354   "Goto beginning of vline."
 355   (xwem-interactive)
 356   (xwem-mogu-goto (car (xwem-mogu-mouse-node xwem-mogu-xwin)) 0))
 357
 358 (define-xwem-command xwem-mogu-vline-end ()
 359   "Goto end of vline."
 360   (xwem-interactive)
 361   (xwem-mogu-goto (car (xwem-mogu-mouse-node xwem-mogu-xwin))
 362                   xwem-mogu-characters))
 363
 364 \f
 365 (provide 'xwem-mogu)
 366
 367 ;;; On-load actians
 368 (xwem-add-minor-mode 'xwem-mogu-minor-mode "Mogu")
 369
 370 ;;; xwem-mogu.el ends here