home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / vtwm.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  17KB  |  581 lines
  1. ;; vtwm.gwm --- VTWM profile for GWM
  2. ;;
  3. ;; Author: Anders Holst  (aho@sans.kth.se)  
  4. ;; Copyright (C) 1995  Anders Holst
  5. ;; Version: vtwm-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. ;; This file is the main file of the VTWM profile for gwm.
  15. ;;
  16. ;; This profile is highly inspired by, and in large parts stolen
  17. ;; directly from, the TWM profile by Arup Mukherjee
  18. ;; (arup@grasp.cis.upenn.edu). Thus much of the credit go to him.
  19. ;; However, bug reports (and complaints) go to me:  aho@nada.kth.se
  20. ;;
  21. ;; All normal user customization of the profile (colors, original
  22. ;; positions and sizes, behaviors, menus, etc.) can be done in
  23. ;; "vtwmrc.gwm".
  24. ;; 
  25.  
  26. (load "trace-func")
  27. (stack-print-level 5)
  28. (setq display-name-radix (match "\\([^:]*:[0-9][0-9]*\\)" display-name 1))
  29. (defname 'x-screen-name screen. '(+ display-name-radix "." (itoa screen)))
  30.  
  31. (if (= gwm-quiet 0)
  32.   (progn
  33.     (for screen (list-of-screens)
  34.       (? x-screen-name " " screen-width " x " screen-height " x " 
  35.     screen-depth "\n"))
  36.     (print "reading")
  37.     (: original-load load)
  38.     (defun load (file) (? ".")(original-load file))
  39. ))
  40.  
  41. (load "std-func")
  42.  
  43.  
  44. ;; General appearance
  45. ;; ------------------
  46.  
  47. (: move-grid-style 3)
  48. (: move-meter 0)
  49. (: resize-grid-style 4)
  50. (: resize-meter 0)
  51. (: property ())
  52. (: borderwidth 2)
  53. (: border-on-shaped 1)
  54.  
  55.  
  56. ;; Some nice names for use later in the profile
  57. ;; --------------------------------------
  58.  
  59. (set-color black Black)
  60. (set-color white White)
  61. (set-color grey Grey)
  62. (set-color darkgrey DarkSlateGrey)
  63.  
  64. (: name-font (font-make "9x15"))
  65. (: small-font (font-make "6x10"))
  66.  
  67. (: any-button (button any any))
  68. (: any-key (key any any))
  69.  
  70. (: select-button 1)
  71. (: action-button 2)
  72. (: menu-button 3)
  73.  
  74.  
  75. (for screen (list-of-screens)
  76.     (: invert-color (bitwise-xor black white))
  77. )
  78.  
  79.  
  80. ;;=============================================================================
  81. ;;          Load and define several useful functions
  82. ;;=============================================================================
  83.  
  84. (load "utils")
  85. (load "deltabutton")
  86.  
  87. (defun matches-token (token)
  88.   (if (not token)                 ; True and false are literary
  89.          ()
  90.       (= token t)
  91.          t
  92.       (= (type token) 'atom)      ; Atom is client class
  93.          (= window-client-class token)
  94.       (= (type token) 'string)    ; String is regexp matching name
  95.          (match token window-name)
  96.       (and (= (type token) 'list) ; Lisp expression
  97.            (or (and (= (type (# 0 token)) 'atom)
  98.                     (boundp (# 0 token))
  99.                     (member (type (eval (# 0 token)))
  100.                             '(subr fsubr expr fexpr)))
  101.                (= (type (# 0 token)) 'active)))
  102.          (eval token)
  103.       (and (= (type token) 'list) ; Windowspec
  104.            (= (type (# 0 token)) 'atom))
  105.          (match-windowspec token)
  106.          ()))                     ; Else no match
  107.  
  108. (defun matches-list (lst)
  109.   (tag return
  110.     (for ele lst
  111.        (if (matches-token ele)
  112.            (exit return t)))
  113.     ()))
  114.  
  115. (defun matches-cond (condlst)
  116.   (tag return
  117.     (for lst condlst
  118.        (if (matches-token (# 0 lst))
  119.            (exit return 
  120.                  (sublist 1 (length lst) lst))))
  121.     ()))
  122.  
  123.  
  124. ; default placement make title bar in screen
  125. (defun default-placement (flag)
  126.     (if flag
  127.     (if (< window-y 0) (move-window window-x 0))))
  128.  
  129. (setq place-x-offset 23)
  130. (setq place-y-offset 19)
  131. (setq place-x-wrap 1031)
  132. (setq place-y-wrap 871)
  133. (setq place-last-x 0)
  134. (setq place-last-y 100)
  135.  
  136. (defun random-placement (flag)
  137.   (if flag
  138.       (if (not (or window-was-on-screen
  139.                    ;; window-starts-iconic
  140.                    ;; window-is-transient-for
  141.                    (not (= window-status 'window))))
  142.           (with (left (+ place-last-x place-x-offset)
  143.                  right (+ left window-width)
  144.                  top (+ place-last-y place-y-offset)
  145.                  bottom (+ top window-height))
  146.             (if (> right 1024)
  147.                 (setq place-last-x (with (neg (- left place-x-wrap))
  148.                                          (+ neg (* (/ (- place-x-offset neg 1)
  149.                                                       place-x-offset)
  150.                                                    place-x-offset))))
  151.               (setq place-last-x left))
  152.             (if (> bottom 864)
  153.                 (setq place-last-y (with (neg (- top place-y-wrap))
  154.                                          (+ neg (* (/ (- place-y-offset neg 1)
  155.                                                       place-y-offset)
  156.                                                    place-y-offset))))
  157.               (setq place-last-y top))
  158.             (move-window place-last-x place-last-y)))))
  159.                    
  160. (defun vtwm-user-placement (flag)
  161.   (if flag
  162.       (if (not (or window-was-on-screen
  163.                    ;; window-starts-iconic
  164.                    ;; window-is-transient-for
  165.                    (not (= window-status 'window))))
  166.           (with (pos (current-mouse-position)
  167.                  cursor (cursor-make 130))
  168.             (move-window (# 0 pos) (# 1 pos))
  169.             (process-exposes)
  170.             (move-window)
  171.             (setq pos (current-mouse-position))
  172.             (if (> (# 2 pos) 0)
  173.                 (progn
  174.                   (warp-pointer 10 10)
  175.                   (twm-resize-window)))))))
  176.  
  177. (defun vtwm-placement (flag)
  178.   (if flag
  179.       (if (or window-was-on-screen
  180.               ;; window-starts-iconic
  181.               ;; window-is-transient-for
  182.               (= window-client-class 'Gwm)
  183.               (not (= window-status 'window))
  184.               ;; (virtual-nailed)
  185.               )
  186.              ()
  187.           (or (not (or window-program-set-position
  188.                        window-user-set-position))
  189.               (and (= window-x 0)
  190.                    (= window-y 0)))
  191.              (if place-randomly
  192.                  (random-placement flag)
  193.                (vtwm-user-placement flag))
  194.           window-user-set-position
  195.              (virtual-placement flag)
  196.           window-program-set-position
  197.              (with (left window-x
  198.                     right (+ left window-width)
  199.                     top window-y
  200.                     bottom (+ top window-height))
  201.                (if (not (and (> left -1) 
  202.                              (< right 1024)
  203.                              (> top -1)
  204.                              (< bottom 864)))
  205.                    (if place-randomly
  206.                        (random-placement flag)
  207.                      (vtwm-user-placement flag)))))))
  208.                     
  209.       
  210. (load "placements")
  211.  
  212. ;;=============================================================================
  213. ;;               Wrappers for some primitive functions
  214. ;;=============================================================================
  215.  
  216.  
  217. (if (not (boundp 'raise-window-orig))
  218.     (progn
  219.  
  220.       (: raise-window-orig raise-window)
  221.  
  222.       (defun raise-window arg
  223.         (if (and arg (# 0 arg))
  224.             (raise-window-orig (# 0 arg))
  225.           (raise-window-orig))
  226.         (if (not autofocus) 
  227.             (if arg
  228.                 (set-focus (# 0 arg))
  229.               (set-focus)))
  230.         (virtual-update))
  231. ))
  232.  
  233. (if (not (boundp 'lower-window-orig))
  234.     (progn
  235.  
  236.       (: lower-window-orig lower-window)
  237.  
  238.       (defun lower-window arg
  239.         (if (and arg (# 0 arg))
  240.             (lower-window-orig (# 0 arg))
  241.           (lower-window-orig))
  242.         (virtual-update))
  243. ))
  244.  
  245. (if (not (boundp 'move-window-orig))
  246.     (progn
  247.  
  248.       (: move-window-orig move-window)
  249.  
  250.       (defun move-window args
  251.         (if (and raise-on-move (< (length args) 2))
  252.             (if (= (length args) 1)
  253.                 (raise-window-orig (# 0 args))
  254.               (raise-window-orig)))
  255.         (if args
  256.             (eval (+ (list 'move-window-orig) args))
  257.           (move-window-orig))
  258.         (if (window-is-mapped)
  259.             (virtual-update)))
  260. ))
  261.  
  262. (if (not (boundp 'resize-window-orig))
  263.     (progn
  264.  
  265.       (: resize-window-orig resize-window)
  266.  
  267.       (defun resize-window args
  268.         (if (and raise-on-resize (< (length args) 2))
  269.             (if (= (length args) 1)
  270.                 (raise-window-orig (# 0 args))
  271.               (raise-window-orig)))
  272.         (if args
  273.             (eval (+ (list 'resize-window-orig) args))
  274.           (resize-window-orig))
  275.         (if (window-is-mapped)
  276.             (virtual-update)))
  277. ))
  278.  
  279. ;; This one is done in vtwm-icon-mgr.gwm instead
  280. ;;(if (not (boundp 'iconify-window-orig))
  281. ;;    (progn
  282. ;;
  283. ;;      (: iconify-window-orig iconify-window)
  284. ;;
  285. ;;      (defun iconify-window ()
  286. ;;        (if raise-on-iconify 
  287. ;;            (raise-window-orig))
  288. ;;        (iconify-window-orig)
  289. ;;        (virtual-update))
  290. ;;))
  291.  
  292.           
  293. (defun twm-resize-window ()
  294.   (with (resize-style 1
  295.          mwm-resize-style-corner-size 1
  296.          mwm-resize-style-catch-corners 1
  297.          cursor (cursor-make 52)
  298.          cursor-NW cursor
  299.          cursor-NE cursor
  300.          cursor-SW cursor
  301.          cursor-SE cursor
  302.          cursor-N cursor
  303.          cursor-W cursor
  304.          cursor-S cursor
  305.          cursor-E cursor)
  306.     (resize-window)))
  307.  
  308. ; (load "twm-resize-old")
  309.  
  310. ;;=============================================================================
  311. ;;                 Some more useful functions
  312. ;;=============================================================================
  313.  
  314. (defun backquote-eval (ele)
  315.   (if (= (type ele) 'list)
  316.       (if (= (# 0 ele) ',)
  317.           (eval (# 1 ele))
  318.         (mapfor subele ele 
  319.                 (backquote-eval subele)))
  320.     ele))
  321.  
  322. (defunq ` (body)
  323.   (backquote-eval body))
  324.  
  325. (defun apply (func lst)
  326.   (eval (+ (list func) (mapfor ele lst (list 'quote ele)))))
  327.  
  328. (defun windows-overlap (w1 w2)
  329.     (with (window w1
  330.          w1l window-x
  331.          w1t window-y
  332.          w1r (+ window-width w1l)
  333.          w1b (+ window-height w1t)
  334.          window w2
  335.          w2l window-x
  336.          w2t window-y
  337.          w2r (+ window-width w2l)
  338.          w2b (+ window-height w2t))
  339.        (and (< w2l w1r)
  340.           (< w2t w1b)
  341.           (> w2b w1t)
  342.           (> w2r w1l))))
  343.  
  344. (defun window-obscured ()
  345.   (with (unobscured t
  346.          might-obscure ())
  347.     (for w (list-of-windows 'stacking-order 'mapped)
  348.          (if (and might-obscure
  349.                   (not (= (# 'float w) 'up)) ; ignore floating windows
  350.                   (windows-overlap window w))
  351.               (: unobscured ()))
  352.           (if (= w window) (: might-obscure t)))
  353.     (not unobscured)))
  354.  
  355. (defun raiselower-window ()
  356.   (if (window-obscured)
  357.       (raise-window)
  358.     (lower-window)))
  359.  
  360. (defun raise-lower-move-window ()
  361.   (if (not autofocus)
  362.       (set-focus))
  363.   (if (deltabutton)
  364.       (move-window)
  365.     (raiselower-window)))
  366.  
  367. (defun pop-to-window ()
  368.   (if (and (wob-is-valid window)
  369.            (not (= window root-window)))
  370.       (with (wob window-window)
  371.         (virtual-make-window-visible)
  372.         (de-iconify-window)
  373.         (raise-window))))
  374.  
  375. (defun focus-window ()
  376.   (if (= window root-window)
  377.       (progn
  378.         (setq autofocus t)
  379.         (set-focus ()))
  380.     (progn
  381.       (setq autofocus ())
  382.       (set-focus window))))
  383.  
  384. (defun sleep-now ()
  385.   (set-screen-saver 1 0 1 1)
  386.   (with (ct (+ 2000 (elapsed-time)))
  387.     (while (> ct (elapsed-time))))
  388.   (process-events)
  389.   (set-screen-saver 300 0 1 1))
  390.  
  391. (defun deiconify-all ()
  392.   (for wob (list-of-windows)
  393.        (de-iconify-window)))
  394.  
  395. (defun redecorate-all ()
  396.   (with (show-icon-mgr ()
  397.          iconify-unmanaged-by-icon ()
  398.          show-virtual ())
  399.     (wob root-window)
  400.     (for wob (list-of-windows 'window)
  401.          (if (not (= window-client-class 'Gwm))
  402.              (re-decorate-window))))
  403.   (icon-mgr-show)
  404.   (virtual-show))
  405.  
  406. (defun virtual-coord-string (x y)
  407.   (+ "+" (itoa (virtual-x x))
  408.      "+" (itoa (virtual-y y))))
  409.  
  410. (defun place-window (flag)
  411.   (with (func (if (= window-status 'icon)
  412.                   (std-resource-get 'GwmIconPlacement)
  413.                 (= window-status 'window)
  414.                   (or (std-resource-get 'GwmPlacement)
  415.                       'vtwm-placement)))
  416.     (eval (list func flag))))
  417.   
  418. ;;=============================================================================
  419. ;;           Openings and Closings
  420. ;;=============================================================================
  421.  
  422. (: opening 
  423.    '(progn
  424.       (place-window t)
  425.       (icon-mgr-add)
  426.       (virtual-add)))
  427.  
  428. (: closing 
  429.   '(progn
  430.      (place-window ())
  431.      (virtual-remove)
  432.      (icon-mgr-remove)))
  433.  
  434. (: screen-opening 
  435.    '(progn
  436.       (: setup-done t)
  437.       (virtual-show)
  438.       (if show-pan-lists
  439.           (install-pan-lists))
  440.       (icon-mgr-show)))
  441.  
  442. (: screen-closing
  443.    '(progn
  444.       (virtual-move-home)
  445.       (for wob (list-of-windows 'window)
  446.            (map-window))))       ; Dont lose unmapped windows on restart
  447.  
  448.  
  449. ;;=============================================================================
  450. ;;                    User Profile
  451. ;;=============================================================================
  452.  
  453. (declare-screen-dependent
  454.   screen-tile
  455.   root-cursor
  456.   setup-done
  457.   autoraise
  458.   autocolormap
  459.   autofocus
  460.   raise-on-move
  461.   raise-on-resize
  462.   raise-on-iconify
  463.   to-be-done-after-setup
  464. )
  465.  
  466. ;;
  467. ;;    USER CUSTOMIZABLE VARIABLES
  468. ;;    ---------------------------  
  469. ;;    Adjust these in your own profile
  470. ;;
  471. (for screen (list-of-screens)
  472.      (defaults-to
  473.        screen-tile ()         ; Pixmap for screen background tiling     
  474.        root-cursor ()         ; Form of root cursor                     
  475.        autoraise ()           ; Raise windows when entered              
  476.        autocolormap t         ; Change colormap to that of the entered window
  477.        autofocus t            ; Set focus to entered window             
  478.        place-randomly t       ; Place windows pseudo randomly, and not by user
  479.        raise-on-move ()       ; Raise windows when they are moved       
  480.        raise-on-resize ()     ; Raise windows when they are resized     
  481.        raise-on-iconify ()    ; Raise windows (or icons) when iconifying
  482.        to-be-done-after-setup '(progn)    ; good for user setup
  483.        )
  484. )
  485.  
  486.  
  487. (for screen (list-of-screens)
  488.     (: setup-done ())
  489. )
  490.  
  491. (load "vtwm-window")
  492. (load "vtwm-zoom")
  493. (load "vtwm-icon-mgr")
  494. (load "vtwm-menu")
  495.  
  496. (load "virtual")
  497. (load "virtual-door")
  498. (load "virtual-pan")
  499.  
  500. (load "pick")
  501.  
  502. ;; Here comes the user settings:
  503. (if (= 0 gwm-quiet) (? "["))
  504. (for screen (list-of-screens) 
  505.     (load "vtwmrc"))
  506. (if (= 0 gwm-quiet) (? "]"))
  507.     
  508. ;; Some reasonable defaults if the user failed to give these:
  509. (defaults-to root-pop
  510.   (construct-menu
  511.    "Root Options"
  512.    '("Refresh" (refresh))
  513.    '("Exec cut" 
  514.      (execute-string (+ "(? " cut-buffer ")")))
  515.    '("Restart" (restart))
  516.    '("Quit" (end)))
  517. )
  518. (defaults-to root-behavior
  519.   (state-make
  520.     (on (buttonpress 3 any) (vtwm-pop-menu root-pop)))
  521. )
  522. (defaults-to vtwm-grabs ())
  523.  
  524. ;; Add "virtual" behavior (scrolling on arrows)
  525. (: standard-behavior (state-make standard-behavior (virtual-behavior)))
  526. (: root-behavior (state-make root-behavior (virtual-behavior)))
  527. (: vtwm-grabs (+ (virtual-grabs) vtwm-grabs))
  528.  
  529. ;; Let root behavior and grabs have effect
  530. (: root-fsm (fsm-make root-behavior))
  531. (: grabs (: root-grabs (: window-grabs (: icon-grabs vtwm-grabs))))
  532.  
  533. ;; The virtual door manager needs a special decoration - nothing at all.
  534. (defun no-border-window ()
  535.   (with (inner-borderwidth 0
  536.          borderwidth 0
  537.          fsm (vtwm-simple-window-fsm))
  538.     (window-make () () () () ())))
  539. (set-window Gwm.menu.door-mgr no-border-window)
  540.  
  541.  
  542. ;;=============================================================================
  543. ;;                    DESCRIBE-SCREEN & DESCRIBE-WINDOW
  544. ;;=============================================================================
  545.  
  546. (de describe-screen ()
  547.   (with (fsm root-fsm
  548.          cursor root-cursor
  549.          menu root-pop
  550.          tile screen-tile
  551.          grabs root-grabs
  552.          opening '(progn 
  553.                     (eval to-be-done-after-setup)
  554.                     (eval screen-opening)
  555.                     (if (= 0 gwm-quiet) 
  556.                         (? "Screen #" screen " ready.\n")))
  557.          closing '(eval screen-closing))
  558.     (window-make () () () () ())))
  559.  
  560. (de describe-window ()
  561.   (list
  562.    (autoload-description
  563.     (or (std-resource-get 'GwmWindow)
  564.         vtwm-window))
  565.    '(autoload-description
  566.      (or (std-resource-get 'GwmIconWindow)
  567.          vtwm-simple-icon))))
  568.  
  569.  
  570. ;; That's all, folks
  571. ;; -----------------
  572.  
  573. (if (= 0 gwm-quiet)
  574.   (progn
  575.     (setq load original-load)
  576.     (print "done\n")
  577.   )
  578.   (bell)
  579. )
  580.  
  581.