home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / virtual.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  18KB  |  472 lines
  1. ;; virtual.gwm --- Virtual Screen 
  2. ;;
  3. ;; Author: Anders Holst  (aho@sans.kth.se)  
  4. ;; Copyright (C) 1995  Anders Holst
  5. ;; Version: virtual-1.0
  6. ;; Last change: 17/6 1995
  7. ;;
  8. ;; This file is copyrighted under the same terms as the rest of GWM
  9. ;; (see the X Inc license for details). There is no warranty that it
  10. ;; works. 
  11. ;;
  12. ;; --------------------------------------------------------------------- 
  13. ;;
  14. ;; NOTE: To use this virtual screen in other profiles then the VTWM
  15. ;; profile, load "load-virtual.gwm" instead, which sets up the
  16. ;; necessary environment and loads the relevant files.
  17. ;; 
  18. ;; This code is inspired by and in large parts stolen from the vscreen
  19. ;; code my Emanuel Jay Berkenbilt, MIT.
  20. ;;
  21. ;; Differences from vscreen.gwm include:
  22. ;;  * The map looks neater, and the colors are highly customable.
  23. ;;  * It is updated automatically when the window configuration changes.
  24. ;;  * You can move the real screen or specific windows by clicking or
  25. ;;    dragging on the map.
  26. ;;
  27. ;; A good function to put into the window menu is '(virtual-toggle-nail)',
  28. ;; a function for the root-menu is '(virtual-toggle)', and something
  29. ;; to call from eg. an icon manager is '(virtual-make-window-visible)'.
  30. ;;
  31. ;; I hope that the variables below are self explanatory. However, the
  32. ;; variable 'virtual-fancy-colors' might need an explanation, via an
  33. ;; example:
  34. ;; 
  35. ;; (setq virtual-fancy-colors (list
  36. ;;   (list black (color-make "lightgray")) ; real screen border and background
  37. ;;   (list 'Emacs black (color-make "lightpink"))    ; emacs border and bg
  38. ;;   (list 'XTerm black (color-make "lightskyblue")) ; xterm border and bg
  39. ;;   (list t black white)))                ; all other windows
  40. ;;
  41.  
  42. (declare-screen-dependent
  43.   virtual-modifiers 
  44.   virtual-omit-nailed
  45.   virtual-omit-list
  46.   virtual-show-filled
  47.   virtual-fancy-colors 
  48.   virtual-xpos
  49.   virtual-ypos
  50.   virtual-pixsize
  51.   virtual-background white
  52.   virtual-foreground black
  53.   virtual-horizontal-step
  54.   virtual-vertical-step
  55.   virtual-nailed-list
  56.   virt-added-window
  57.   virt-removed-window
  58.   virt-pos
  59.   virt-wind
  60.   virt-pix
  61.   )
  62.  
  63. ;;
  64. ;;    USER CUSTOMIZABLE VARIABLES
  65. ;;    ---------------------------  
  66. ;;    Adjust these in your own profile
  67. ;;
  68. (for screen (list-of-screens)
  69.      (defaults-to
  70.        show-virtual t                  ; Show the map of the virtual screen
  71.        virtual-modifiers (together with-control with-alt) ; modifs for arrow keys
  72.        virtual-omit-nailed t           ; if t, map shows only non-nailed windows
  73.        virtual-omit-list ()            ; list of windows not shown in map
  74.        virtual-show-filled t           ; windows not drawn transparent in map
  75.        virtual-fancy-colors ()         ; list of (wind-class fg bg) specs.
  76.  
  77.        virtual-xpos 0                  ; original position of map
  78.        virtual-ypos 0                    
  79.        virtual-pixsize 160             ; size of the map
  80.        virtual-background white        ; default background of the map
  81.        virtual-foreground black        ; default window frame color on the map
  82.        
  83.        virtual-horizontal-step (/ screen-width 2)  ; amount to move by keys
  84.        virtual-vertical-step (/ screen-height 2)
  85.        
  86.        virtual-nailed-list '(Gwm)      ; initially nailed windows
  87.        )
  88. )
  89.  
  90. (for screen (list-of-screens)    ; Dont touch these
  91.      (setq virt-pos (list 0 0))
  92.      (setq virt-added-window ())
  93.      (setq virt-removed-window ())
  94. )
  95.  
  96. ;; Note: Uses 'matches-list' from vtwm.gwm
  97.  
  98. (defun virtual-nailed ()
  99.   ;; Determine whether the current window is nailed or not.
  100.   (if (setq tmp (# 'nailed window-window))
  101.     (not (= 'no tmp))
  102.     (if (or (matches-list virtual-nailed-list)
  103.             (and (= window-client-class 'Gwm)
  104.                  (= window-name 'virtual)))
  105.         (progn
  106.           (virtual-nail)
  107.           t)
  108.         (progn
  109.           (virtual-unnail)
  110.           ()))))
  111.  
  112. (defun virtual-nail ()
  113.   (## 'nailed window-window t))
  114.  
  115. (defun virtual-unnail ()
  116.   (## 'nailed window-window 'no))
  117.  
  118. (defun virtual-toggle-nail ()
  119.   (if (virtual-nailed)
  120.       (virtual-unnail)
  121.     (virtual-nail))
  122.   (if virtual-omit-nailed
  123.       (virtual-update)))
  124.  
  125. (defun virt-movable ()
  126.   ;; Returns a list of movable windows
  127.   (with (movable nil)
  128.     (for wob (list-of-windows 'window)
  129.          (if (not (virtual-nailed))
  130.              (setq movable (+ movable (list window)))))
  131.     movable))
  132.  
  133. (defun virtual-move-windows (deltax deltay)
  134.   ;; Moves windows by deltax and deltay adjusting virt-pos 
  135.   ;; appropriately
  136.   (with (move-window-func (if (boundp 'move-window-orig) 
  137.                               move-window-orig   ; to work with vtwm profile
  138.                               move-window))
  139.     (for wob (virt-movable)
  140.          (move-window-func (+ window-x deltax) (+ window-y deltay))))
  141.   (with (x (# 0 virt-pos) y (# 1 virt-pos))
  142.     (setq virt-pos (list (+ x deltax) (+ y deltay))))
  143.   (virtual-update))
  144.  
  145. (defun virtual-move-left ()
  146.   (virtual-move-windows virtual-horizontal-step 0))
  147.  
  148. (defun virtual-move-right ()
  149.   (virtual-move-windows (- virtual-horizontal-step) 0))
  150.  
  151. (defun virtual-move-up ()
  152.   (virtual-move-windows 0 virtual-vertical-step))
  153.  
  154. (defun virtual-move-down ()
  155.   (virtual-move-windows 0 (- virtual-vertical-step)))
  156.  
  157. (defun virtual-move-home ()
  158.   (virtual-move-windows (- (# 0 virt-pos))
  159.                         (- (# 1 virt-pos))))
  160.  
  161. (defun virtual-move-to (x y)
  162.   (virtual-move-windows (- (+ x (# 0 virt-pos)))
  163.                         (- (+ y (# 1 virt-pos)))))
  164.  
  165. (defun virtual-make-window-visible ()
  166.   ;; Move the virtual screen to make the current window visible.
  167.   (if (not (virtual-nailed))
  168.       (with (dx 0 dy 0 
  169.          window-top window-y
  170.              window-bot (+ window-y window-height)
  171.              window-left window-x
  172.              window-right (+ window-x window-width)
  173.              screen-top 0
  174.              screen-bot screen-height
  175.              screen-left 0
  176.              screen-right screen-width)
  177.         (if (or (ge window-left screen-right)  ; Check that no part visible
  178.                 (le window-right screen-left)
  179.                 (ge window-top screen-bot)
  180.                 (le window-bot screen-top))
  181.             (progn
  182.               (if (> window-right screen-right)
  183.                   (setq dx (- (ceildiv (min (- window-right screen-right)
  184.                                             (- window-left screen-left
  185.                                                virtual-horizontal-step))
  186.                                        virtual-horizontal-step))))
  187.               (if (< window-left screen-left)
  188.                   (setq dx (ceildiv (- screen-left window-left) 
  189.                                     virtual-horizontal-step)))
  190.               (if (> window-bot screen-bot)
  191.                   (setq dy (- (ceildiv (min (- window-bot screen-bot)
  192.                                             (- window-top screen-top
  193.                                                virtual-vertical-step))
  194.                                        virtual-vertical-step))))
  195.               (if (< window-top screen-top)
  196.                   (setq dy (ceildiv (- screen-top window-top)
  197.                                     virtual-vertical-step)))
  198.               (setq dx (* dx virtual-horizontal-step))
  199.               (setq dy (* dy virtual-vertical-step))
  200.               (virtual-move-windows dx dy))))))
  201.  
  202. (defun virtual-placement (flag)
  203.   (if flag
  204.       (if (not (or window-was-on-screen
  205.                    ;; window-starts-iconic
  206.                    ;; window-is-transient-for
  207.                    (not (= window-status 'window))))
  208.           (if (and (not (virtual-nailed))
  209.                    (not (= virt-pos '(0 0))))
  210.               (move-window (+ window-x (# 0 virt-pos))
  211.                            (+ window-y (# 1 virt-pos)))))))
  212.  
  213. (defun virtual-x (x)
  214.   (- x (# 0 virt-pos)))
  215.  
  216. (defun virtual-y (y)
  217.   (- y (# 1 virt-pos)))
  218.  
  219. (defun virt-drawable ()
  220.   (and (not (= window virt-removed-window))
  221.        (not (and virtual-omit-nailed
  222.                  (virtual-nailed)))
  223.        (not (matches-list virtual-omit-list))))
  224.  
  225. (defun virt-calc-params ()
  226.   ;; Return a list that contains scale factor, x position of origin,
  227.   ;; and y position of origin
  228.   (with (minx 0
  229.          miny 0
  230.          maxx screen-width
  231.          maxy screen-height
  232.           xcenter nil ycenter nil
  233.           range nil scale nil x0 nil y0 nil
  234.           low (list-of-windows 'window 'mapped))
  235.         (if (not (wob-is-valid wob))
  236.             (wob root-window))
  237.     (for wob (if virt-added-window
  238.                      (+ (list-of-windows 'window 'mapped)
  239.                         (list virt-added-window))
  240.                    (list-of-windows 'window 'mapped))
  241.            (if (virt-drawable)
  242.                (progn
  243.                  (setq minx (min minx window-x))
  244.                  (setq miny (min miny window-y))
  245.                  (setq maxx (max maxx (+ window-x window-width)))
  246.                  (setq maxy (max maxy (+ window-y window-height))))))
  247.     
  248.     (setq range (max (- maxy miny) (- maxx minx)))
  249.     (setq xcenter (/ (+ minx maxx) 2))
  250.     (setq ycenter (/ (+ miny maxy) 2))
  251.  
  252.     ;; Our scale factor is a simple quotient, times ten. We divide
  253.         ;; by .95 times the number of pixels to leave some inner border.
  254.     ;; To get the origin, figure out where 0,0 would be given that
  255.     ;; the center of the current screen should be in the center.
  256.  
  257.     (setq scale (/ (* 1000 range) (* 95 virtual-pixsize)))
  258.     (setq x0 (/ virtual-pixsize 2))
  259.     (setq y0 (/ virtual-pixsize 2))
  260.     (setq x0 (- x0 (/ (* 10 xcenter) scale)))
  261.     (setq y0 (- y0 (/ (* 10 ycenter) scale)))
  262.     (list scale x0 y0)))
  263.  
  264. (defun virt-draw-window (pix params border colf colb)
  265.   (with (foreground colf
  266.          background (or colb 0)
  267.          mode (if colb 3 1)
  268.          left (+ (/ (* 10 window-x) (# 0 params)) (# 1 params))
  269.          top (+ (/ (* 10 window-y) (# 0 params)) (# 2 params))
  270.          wdt (/ (* 10 window-width) (# 0 params))
  271.          hgt (/ (* 10 window-height) (# 0 params)))
  272.     (draw-rectangle pix left top wdt hgt border mode)))
  273.  
  274. (defun virt-get-color ()
  275.   (with (res (if (= window root-window)
  276.                  (with (ele (# 0 virtual-fancy-colors))
  277.                    (if (and ele
  278.                             (or (not (# 0 ele))
  279.                                 (= (type (# 0 ele)) 'number)))
  280.                        ele))
  281.                (matches-cond virtual-fancy-colors)))
  282.     (if (not res)
  283.         (list virtual-foreground 
  284.               (if virtual-show-filled
  285.                   virtual-background
  286.                 ()))
  287.       (not (# 0 res))
  288.         (list virtual-foreground
  289.               (# 1 res))
  290.         res)))
  291.  
  292. (defun virt-draw-windows (pix params)
  293.   (with (wob root-window
  294.          cols (virt-get-color))
  295.     (virt-draw-window pix params 2 (# 0 cols) (# 1 cols)))
  296.   (for wob (if virt-added-window
  297.                (+ (list-of-windows 'window 'stacking-order 'mapped)
  298.                   (list virt-added-window))
  299.              (list-of-windows 'window 'stacking-order 'mapped))
  300.        (if (virt-drawable)
  301.            (with (cols (virt-get-color))
  302.              (virt-draw-window pix params 1 (# 0 cols) (# 1 cols))))))
  303.  
  304. (defun virt-map-to-real (params relx rely)
  305.   (with (absx (/ (* (- relx (# 1 params)) (# 0 params)) 10)
  306.          absy (/ (* (- rely (# 2 params)) (# 0 params)) 10))
  307.     (list absx absy)))
  308.  
  309. (defun virt-real-to-map (params realx realy)
  310.   (with (mapx (+ (/ (* realx 10) (# 0 params)) (# 1 params))
  311.          mapy (+ (/ (* realy 10) (# 0 params)) (# 2 params)))
  312.     (list mapx mapy)))
  313.  
  314. (defun virtual-map-move-to ()
  315.   (with (params (virt-calc-params)
  316.          realpos (virt-map-to-real params
  317.                                    (current-event-relative-x)
  318.                                    (current-event-relative-y))
  319.          hswdt virtual-horizontal-step
  320.          hshgt virtual-vertical-step
  321.          absx (- (# 0 realpos) (# 0 virt-pos) (/ screen-width 2))
  322.          absy (- (# 1 realpos) (# 1 virt-pos) (/ screen-height 2))
  323.          absx (if (< absx 0) 
  324.                   (* hswdt (/ (- absx (/ hswdt 2)) hswdt))
  325.                   (* hswdt (/ (+ absx (/ hswdt 2)) hswdt)))
  326.          absy (if (< absy 0) 
  327.                   (* hshgt (/ (- absy (/ hshgt 2)) hshgt))
  328.                   (* hshgt (/ (+ absy (/ hshgt 2)) hshgt))))
  329.     (virtual-move-to absx absy)))
  330.  
  331. (defun virtual-map-move-window ()
  332.   (with (params (virt-calc-params)
  333.          wob virt-wind
  334.          mapleft (+ window-x wob-borderwidth
  335.                     window-client-x window-client-borderwidth -1)
  336.          maptop (+ window-y wob-borderwidth
  337.                    window-client-y window-client-borderwidth -1)
  338.          mapright (+ mapleft window-client-width)
  339.          mapbottom (+ maptop window-client-height)
  340.          mappos (current-mouse-position)
  341.          bmask 7936
  342.          init-button (bitwise-and bmask (# 2 mappos))
  343.          realpos (virt-map-to-real params
  344.                                    (- (# 0 mappos) mapleft)
  345.                                    (- (# 1 mappos) maptop))
  346.          wind (wob-at-coords (# 0 realpos) (# 1 realpos)))
  347.     (virtual-update)
  348.     (if (and wind
  349.              (with (wob wind) (virt-drawable)))
  350.         (with (wob wind
  351.                initpos (virt-real-to-map params window-x window-y)    
  352.                mouse-pos ()
  353.                cursor (cursor-make 130))
  354.           (virt-draw-window virt-pix params 2 virtual-foreground ())
  355.           (refresh virt-wind)
  356.           (process-events)
  357.           (tag ret
  358.                (grab-server root-window)
  359.                (warp-pointer (+ (# 0 initpos) mapleft)
  360.                              (+ (# 1 initpos) maptop)
  361.                              root-window)
  362.                (warp-pointer 0 0)   ; To get around bug in X11
  363.                (while t
  364.                  (: mouse-pos (current-mouse-position))
  365.                  (if (not (= (bitwise-and bmask (# 2 mouse-pos)) init-button))
  366.                      (exit ret
  367.                            (ungrab-server root-window)))))
  368.           (if (and (= (bitwise-and bmask (# 2 mouse-pos)) 0)
  369.                    (not (and (= (# 0 mouse-pos) (+ (# 0 initpos) mapleft))
  370.                              (= (# 1 mouse-pos) (+ (# 1 initpos) maptop))))
  371.                    (> (# 0 mouse-pos) mapleft)
  372.                    (< (# 0 mouse-pos) mapright)
  373.                    (> (# 1 mouse-pos) maptop)
  374.                    (< (# 1 mouse-pos) mapbottom))
  375.               (with (newpos (virt-map-to-real params
  376.                                               (- (# 0 mouse-pos) mapleft)
  377.                                               (- (# 1 mouse-pos) maptop)))
  378.                 (move-window wind (# 0 newpos) (# 1 newpos))))
  379.           (virtual-update)))))
  380.             
  381.  
  382. (defun virtual-show ()
  383.   (if (and (boundp 'virt-wind) virt-wind (wob-is-valid virt-wind))
  384.       (with (wob virt-wind
  385.              left (+ window-x wob-borderwidth
  386.                      window-client-x window-client-borderwidth)
  387.              top (+ window-y window-client-y
  388.                     wob-borderwidth window-client-borderwidth))
  389.         (setq virtual-xpos left)
  390.         (setq virtual-ypos top)
  391.         (delete-window)))
  392.   (if show-virtual
  393.       (with (params (virt-calc-params)
  394.              vmenu ())
  395.         (with (foreground virtual-background)
  396.           (setq virt-pix (pixmap-make virtual-pixsize virtual-pixsize)))
  397.         (virt-draw-windows virt-pix params)
  398.         (setq vmenu
  399.               (with (borderwidth 0
  400.                      bar-max-width virtual-pixsize
  401.                      fsm (fsm-make virtual-map-behavior))
  402.                 (menu-make (bar-make (plug-make virt-pix)))))
  403.         (process-events)
  404.         (with (reenter-on-opening ()
  405.                xpos (if (< virtual-xpos 0) 
  406.                         (- (+ screen-width virtual-xpos) virtual-pixsize)
  407.                       virtual-xpos)
  408.                ypos (if (< virtual-ypos 0) 
  409.                         (- (+ screen-height virtual-ypos) virtual-pixsize)
  410.                       virtual-ypos))
  411.           (setq virt-wind
  412.                 (place-menu 'virtual vmenu xpos ypos))))
  413.     (progn
  414.       (unbind 'virt-wind)
  415.       (unbind 'virt-pix))))
  416.  
  417. (defun virtual-toggle ()
  418.   (: show-virtual (not show-virtual))
  419.   (virtual-show))
  420.  
  421. (defun virtual-update ()
  422.   (if (and show-virtual (boundp 'virt-pix) (boundp 'virt-wind))
  423.       (with (params (virt-calc-params)
  424.              bar-max-width virtual-pixsize)
  425.         (with (background virtual-background)
  426.       (draw-rectangle virt-pix 0 0 virtual-pixsize virtual-pixsize 0 2))
  427.         (virt-draw-windows virt-pix params)
  428.         (refresh virt-wind))))
  429.  
  430. (defun virtual-add ()
  431.   (if (and (not (= window-status 'icon))
  432.            (not (= window-client-class 'Gwm)))
  433.       (with (virt-added-window window)
  434.         (virtual-update))))
  435.  
  436. (defun virtual-remove ()
  437.   (if (and (not (= window-status 'icon))
  438.            (not (= window-client-class 'Gwm)))
  439.       (with (virt-removed-window window)
  440.         (virtual-update))))
  441.  
  442. (if (not (boundp 'virtual-map-behavior))
  443. (: virtual-map-behavior
  444.    (state-make
  445.     (on (button 1 alone) (virtual-map-move-to))
  446.     (on (buttonpress 2 alone) (virtual-map-move-window))
  447.     (on (button 3 alone) (virtual-update))
  448.     ))
  449. )
  450.  
  451. (defun virtual-behavior ()
  452.    (if virtual-modifiers
  453.        (state-make
  454.         (on (keypress "Left" virtual-modifiers)
  455.             (virtual-move-left))
  456.         (on (keypress "Right" virtual-modifiers)
  457.             (virtual-move-right))
  458.         (on (keypress "Up" virtual-modifiers)
  459.             (virtual-move-up))
  460.         (on (keypress "Down" virtual-modifiers)
  461.             (virtual-move-down)))))
  462.  
  463. (defun virtual-grabs ()
  464.    (if virtual-modifiers
  465.        (list
  466.         (key "Left" virtual-modifiers)
  467.         (key "Right" virtual-modifiers)
  468.         (key "Up" virtual-modifiers)
  469.         (key "Down" virtual-modifiers)
  470.         )))
  471.       
  472.