home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / .gwmrc.gwm next >
Lisp/Scheme  |  1995-07-03  |  17KB  |  616 lines
  1. ;;=============================================================================
  2. ;;                    STANDARD GWM PROFILE
  3. ;;=============================================================================
  4.  
  5. ;;File: .gwmrc.gwm -- the GWM standard profile
  6. ;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
  7. ;;Revision: 1.4 -- June 12 1989
  8. ;;State: Exp
  9. ;;GWM Version: 1.4
  10.  
  11. ;;=============================================================================
  12. ;;                    Initialisations
  13. ;;=============================================================================
  14.  
  15. ; banner
  16. ; ======
  17.  
  18. (load 'trace-func)
  19. (stack-print-level 3)
  20. (setq display-name-radix (match "\\([^:]*:[0-9][0-9]*\\)" display-name 1))
  21. (defname 'x-screen-name screen. '(+ display-name-radix "." (itoa screen)))
  22.  
  23. (if (= gwm-quiet 0)
  24.   (progn
  25.     (for screen (list-of-screens)
  26.       (? x-screen-name " " screen-width " x " screen-height " x " 
  27.     screen-depth "\n"))
  28.     (print "reading...")
  29.     (: original-load load)
  30.     (defun load (file) (? ".")(original-load file))
  31. ))
  32.  
  33. ; appearance
  34. ; ==========
  35.  
  36. (: name-font (font-make "9x15"))
  37. (: meter-font (font-make "9x15"))
  38. (: bull-font (font-make "9x15"))
  39. (: small-font (font-make "6x10"))
  40.  
  41. ; global switches
  42. ; ===============
  43.  
  44. (: move-grid-style 3)
  45. (: resize-grid-style 4)
  46.  
  47. (: property ())
  48. (: borderwidth 1)
  49. (: any-button (button any any))
  50. (: any-key (key any any))
  51.  
  52. (: select-button 1)
  53. (: action-button 2)
  54. (: menu-button 3)
  55.  
  56. (: autoraise ())
  57. (: autocolormap t)
  58. (: no-set-focus ())
  59. (: to-be-done-after-setup '(progn))    ; obsolete: use screen-opening
  60. (: screen-opening '(progn))        ; actions to be done before operation
  61. (: screen-closing            ; actions to be done when ending
  62.   '(progn
  63. )) 
  64.  
  65. (setq left "left")
  66. (setq base "base")
  67. (setq bottom "bottom")
  68. (setq right "right")
  69. (setq top "top")
  70.  
  71. ; per-screen data setting
  72. ; =======================
  73.  
  74. (defunq defname-in-screen-to args
  75.     (with (value (eval (# 0 args))
  76.          vars (sublist 1 (length args) args))
  77.       (for var vars
  78.            (defname var screen. value))))
  79.  
  80. (defunq set-color (name value)
  81.   (if (not (= screen. (namespace-of name)))
  82.     (progn
  83.       (defname name screen.)
  84.       (for screen (list-of-screens)
  85.     (set name (color-make value)))
  86. )))
  87.  
  88. (defunq set-pixmap args
  89.   (with (name (# 0 args)
  90.       pixmap-make-call (# 0 args 'pixmap-make))
  91.     (if (not (= screen. (namespace-of name)))
  92.       (progn
  93.     (defname name screen.)
  94.     (for screen (list-of-screens)
  95.       (set name (eval pixmap-make-call)))
  96. ))))
  97.  
  98. ; per-screen data
  99. ; ===============
  100.  
  101. (defname-in-screen-to () tile screen-tile bordertile menu root-cursor)
  102.  
  103. (defname 'root-pop screen.)
  104. (defname 'window-pop screen.)
  105. (defname 'icon-pop screen.)
  106. (set-color black Black)
  107. (set-color white White)
  108. (set-color grey Grey)
  109. (set-color darkgrey DarkSlateGrey)
  110. (set-color lightgrey LightGrey)
  111. (set-pixmap icon-pixmap "icon20")
  112.     
  113. (defname 'look-3d screen.)
  114. (for screen (list-of-screens)
  115.     (if (= 'mono screen-type)
  116.     (: look-3d ())
  117.     (: look-3d t)
  118.     (: invert-color (bitwise-xor black white))
  119.     ))))
  120.  
  121. ; functions to affect decorations to a client name
  122. ; =================================================
  123.  
  124. ; The assignement of decorations to client names:
  125. ; a decoration is either:
  126. ;     a function yielding the decoration
  127. ;       an unbound variable: the corresponding file is then loaded, which
  128. ;           must define the function
  129.  
  130. (load 'utils)
  131.  
  132. ;;=============================================================================
  133. ;;                    X resource management for the standard profile
  134. ;;=============================================================================
  135. ;;
  136.  
  137. (defun std-resource-get args
  138.   (with (resource-class (# 0 args) resource-name (# 1 args) Name () Class ())
  139.     (: Name (+ -screen-name '.
  140.     window-client-class '.
  141.     (make-string-usable-for-resource-key-non-nil window-client-name) '.
  142.     (make-string-usable-for-resource-key-non-nil window-name) '.
  143.     screen-type '.
  144.     window-machine-name '.
  145.     (if resource-name resource-name resource-class)
  146.     ))
  147. ;;    (: Class (+ "S......" resource-class)) ;; makes Xrm crash on sun4s
  148.     (: Class (+ "S.any.any.any.any.any.any" resource-class))
  149. ;;    (? "resource-get " Name " " Class " = " (resource-get Name Class) "\n")
  150.     (resource-get Name Class)
  151. ))
  152.  
  153. ;; puts resource:
  154. ;; (std-resource-put resource-name
  155. ;;                   [screen-type] clientclass[name[windnowname[machine]]]]
  156. ;;                   value)
  157.  
  158. (defun std-resource-put (Resource args)
  159.   (with (Client-desc () Value () Screen () Name ())
  160.     (if (= 3 (length args))
  161.       (progn
  162.     (: Client-desc (# 1 args))
  163.     (: Value (# 2 args))
  164.     (: Screen (# 0 args))
  165.       )
  166.       (progn
  167.     (: Client-desc (# 0 args))
  168.     (: Value (# 1 args))
  169.     ))
  170.     (: Name (std-resource-expand Client-desc Screen Resource))
  171. ;;    (? "resource-put " Name " " Value "\n")
  172.     (resource-put Name Value)
  173. ))
  174.  
  175. ;; expands class[.name[.wname[.machine]]] visual Resource
  176. ;; into ScreenNumber.class.name.wname.visual.machine.Resource
  177.  
  178. (defun std-resource-expand (desc visual resource)
  179.   (if (match "[*]" desc)
  180.     (+ -screen-name
  181.       (if (match "^[*]" desc) () '.)
  182.       desc
  183.       (if (match "[*]$" desc) () '.)
  184.       resource)
  185.     (with (tmp (match
  186.       "^\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)$"
  187.       desc 1 2 3 4
  188.       ))
  189.       (make-resource-string -screen-name (# 0 tmp) (# 1 tmp) (# 2 tmp)
  190.     visual (# 3 tmp) 'any resource
  191. ))))
  192.  
  193. ;; appends list elements with '.', collapsing consecutive void (or any) 
  194. ;; elements into *
  195.  
  196. (defun make-resource-string l
  197.   (with (star () first t l2 
  198.       (mapfor elt l
  199.     (if (or (= "any" elt) (not elt))
  200.       (if star
  201.         ""
  202.         (progn
  203.           (setq star t)
  204.           "*"
  205.         )
  206.       )
  207.       (progn
  208.         (setq star ())
  209.         (if first (progn (setq first ()) elt)
  210.         (+ "." elt)
  211.     )))))
  212.     (eval (+ '(+) l2))
  213. ))
  214.   
  215.  
  216. ;(trace-func std-resource-put)
  217.  
  218. ;; customisation of decos by context
  219. ;; (customize deco screen application context...)
  220.  
  221. (defun customize-usage (string)
  222.   (? "USAGE: (customize deco screen application context...),\n"
  223.     "error was: " string "\n"
  224.     (exit customize)
  225. ))
  226.  
  227. (defunq customize args
  228.   (tag customize
  229.     (with (Deco (# 0 args)
  230.     Screen (# 1 args)
  231.     Application (# 2 args)
  232.     Context (if (and (=  4 (length args)) (= 'list (type (# 3 args))))
  233.       (# 3 args)
  234.       (sublist 3 (length args) args)
  235.     )
  236.     l (length Context)
  237.     i 1
  238.       )
  239.       (while (< i l)
  240.     (## i Context (eval (# i Context)))
  241.     (setq i (+ 2 i))
  242.       )
  243.       (std-resource-put Deco (list Screen Application Context))
  244. )))
  245.   
  246. ;; recursively evaluates till we obtain a context
  247.  
  248. (defun get-context (name)
  249.   (do-get-context name 0)
  250. )
  251.  
  252. (defun do-get-context (name level)
  253.   (if (> level max-autoload-evaluation) name
  254.     (progn
  255.       (setq name
  256.     (if (# (type name) string-types)
  257.       (progn            ; atoms:
  258.         (if (= 'string (type name))
  259.           (: name (atom name)))    ; string->atom to test if defined
  260.         (if (boundp name)
  261.           (eval name)        ; defined: eval
  262.           (progn
  263.         (load name)        ; undefined, load and returns itself
  264.         name
  265.       )))
  266.       (# (type name) func-types)    ; function: called without args
  267.       (eval (list name))
  268.       (= (type name) 'list)
  269.       (if (= (% (length name) 2) 0) ; if even list, its a context
  270.         name
  271.         (= 1 (length name))        ; if one element, return it
  272.         (# 0 name)
  273.         (eval name)            ; if odd list, eval
  274.       )
  275.       (eval name)            ; others: eval
  276.       ))
  277.       (if (or (not name)
  278.       (and (= (type name) 'list)(= (% (length name) 2) 0)))
  279.     name
  280.     (do-get-context name (+ 1 level)
  281. )))))
  282.  
  283.  
  284. ;;=============================================================================
  285. ;;                    user-callable resource settings
  286. ;;=============================================================================
  287.  
  288. (defname '-screen-name screen.)
  289. (for screen (list-of-screens)
  290.   (: -screen-name (+ "S" (itoa screen)))
  291.   (std-resource-put 'GwmWindow (list screen-type ()))
  292.   (std-resource-put 'GwmIconWindow (list screen-type ()))
  293.   (std-resource-put 'GwmIconPixmap (list screen-type ()))
  294.   (std-resource-put 'GwmPlacement (list screen-type ()))
  295.   (std-resource-put 'GwmIconPlacement (list screen-type ()))
  296. )
  297.  
  298. (: string-types '(string t atom t pointer t active t))
  299. (: func-types '(expr t fexpr t subr t fsubr t))
  300.  
  301. (setq max-autoload-evaluation 10)
  302.  
  303. (defun autoload-description (name)
  304.   (with (level 0) 
  305.     (do-autoload-description name level)
  306. ))
  307.  
  308. ;; recursively evaluates or load description to obtain a wl_client
  309.  
  310. (defun do-autoload-description (name level)
  311.   (if (> level max-autoload-evaluation) name
  312.     (progn
  313.       (setq name
  314.     (if (# (type name) string-types)
  315.       (progn            ; atoms:
  316.         (if (= 'string (type name))
  317.           (: name (atom name)))    ; string->atom to test if defined
  318.         (if (boundp name)
  319.           (eval name)        ; defined: eval
  320.           (progn
  321.         (load name)        ; undefined, load and returns itself
  322.         name
  323.       )))
  324.       (# (type name) func-types)    ; function: called without args
  325.       (eval (list name))
  326.       (eval name)            ; others: evalb
  327.       ))
  328.       (if (= 'client (type name)) name
  329.     (do-autoload-description name (+ 1 level)
  330. ))))))
  331.  
  332. (defun autoload-description (name)
  333.   (do-autoload-description name 0)
  334. )
  335.  
  336. (defunq set-window args (std-resource-put 'GwmWindow args))
  337.  
  338. (defunq set-icon-window args (std-resource-put 'GwmIconWindow args))
  339.  
  340. (defunq set-icon args
  341.   (## (- (length args) 1) args (expand-pixmap (# (- (length args) 1) args)))
  342.   (std-resource-put 'GwmIconPixmap args)
  343. )
  344.  
  345. (defun expand-pixmap (obj)
  346.     (if (and obj (# (type obj) string-types))
  347.     (pixmap-make obj)
  348.     (eval obj)))    
  349.  
  350. (defunq set-placement args (std-resource-put 'GwmPlacement args))
  351.  
  352. (defunq set-icon-placement args (std-resource-put 'GwmIconPlacement args))
  353.  
  354. ;;=============================================================================
  355. ;;                    automatic placement
  356. ;;=============================================================================
  357.  
  358. (de apply1 (func arg)
  359.     (eval (list (eval func) arg)))
  360.  
  361. (: opening 
  362.   '(progn
  363.     (apply1 (if (= window-status 'icon)
  364.     (std-resource-get 'GwmIconPlacement)
  365.     (= window-status 'window)
  366.     (std-resource-get 'GwmPlacement)
  367.       )
  368.       t)))
  369.  
  370. (: closing 
  371.   '(progn 
  372.     (apply1 (if (= window-status 'icon)
  373.     (std-resource-get 'GwmIconPlacement)
  374.     (= window-status 'window)
  375.     (std-resource-get 'GwmPlacement)
  376.       )
  377.       ())
  378. ))
  379.  
  380. ; default placement make title bar in screen
  381. (defun default-placement (flag)
  382.     (if flag
  383.     (if (< window-y 0) (move-window window-x 0))))
  384.  
  385. (load "placements")
  386.  
  387. ;;=============================================================================
  388. ;;                    std-... wrappers for raise-current flag
  389. ;;=============================================================================
  390.  
  391. (if (not (boundp 'std-move-window))
  392.   (progn
  393.     (: raise-on-move t)
  394.     (defun std-move-window ()
  395.       (if raise-on-move (raise-window))
  396.       (move-window)
  397.     )
  398.     (: raise-on-resize t)
  399.     (defun std-resize-window ()
  400.       (if raise-on-resize (raise-window))
  401.       (resize-window)
  402.     )
  403.     (: raise-on-iconify t)
  404.     (defun std-iconify-window ()
  405.       (iconify-window)
  406.       (if raise-on-iconify (raise-window))
  407. )))
  408.  
  409. ;;=============================================================================
  410. ;;                    default behaviors
  411. ;;=============================================================================
  412.  
  413. ;; standard-behavior is the default actions for all items
  414. ;; to make a fsm for a window or icon, do a
  415. ;; (fsm-make (state-make <your-actions> window-behavior standard-behavior)
  416. ;; (fsm-make (state-make <your-actions> icon-behavior standard-behavior)
  417.  
  418. (: standard-behavior
  419.   (state-make
  420.     (on (buttonpress select-button alone)
  421.       (std-move-window))
  422.     (on (button select-button with-shift) (lower-window))
  423.     (on (buttonpress select-button with-alt)
  424.       (std-move-window))
  425.     (on (button select-button (together with-shift with-alt))
  426.       (lower-window))
  427.     (on (buttonpress menu-button alone)
  428.       (progn (set-colormap-focus ()) (std-pop-menu)))
  429.     (on (buttonpress menu-button with-alt) 
  430.       (progn (set-colormap-focus ()) (std-pop-menu)))
  431. ))
  432.  
  433. ;; actions specific to window titles. should be used before 
  434. ;; standard-behavior in further fsms
  435.  
  436. (: standard-title-behavior
  437.   (state-make
  438.     (on (buttonpress action-button alone)
  439.       (std-resize-window))
  440.     (on (buttonpress action-button with-alt)
  441.       (std-resize-window))
  442. ))
  443.  
  444. ;; actions specific to windows
  445.  
  446. (: window-behavior
  447.   (state-make
  448.     (on (buttonpress action-button alone)
  449.       (std-resize-window))
  450.     (on (buttonpress action-button with-alt)
  451.       (std-resize-window))
  452.     (on name-change (send-user-event 'name-change))
  453.     (on focus-in (progn (if autoraise (raise-window))
  454.     (send-user-event 'focus-in)))
  455.     (on focus-out (send-user-event 'focus-out))
  456.     (if no-set-focus
  457.       (on enter-window (progn (if autoraise (raise-window))
  458.       (if autocolormap (set-colormap-focus))))
  459.       (on enter-window (progn (if autoraise (raise-window))
  460.       (set-focus)
  461.       (if autocolormap (set-colormap-focus)))))
  462.     (if (not no-set-focus)
  463.       (on leave-window (set-focus ())))
  464.     (on name-change (send-user-event 'name-change))
  465.     (on (property-change 'WM_ICON_NAME)
  466.       (if (window-icon?)
  467.     (send-user-event 'get-icon window-icon)))
  468.     (on window-icon-pixmap-change 
  469.       (if (window-icon?)
  470.     (send-user-event 'icon-pixmap-change window-icon)))
  471. ))
  472.  
  473. ;; icon-specific actions
  474.  
  475. (: icon-behavior
  476.   (state-make
  477.     (on (buttonrelease action-button any)
  478.       (std-iconify-window))
  479. ))
  480.  
  481. ;; root-window actions
  482. ;; make root menu appear on any modifier combinations in case of problems
  483.  
  484. (: root-behavior
  485.   (state-make
  486.     (on (buttonpress menu-button any) (pop-root-menu))
  487. ))
  488.  
  489. (: old-standard-behavior ())
  490. (: old-standard-title-behavior ())
  491. (: old-window-behavior ())
  492. (: old-icon-behavior ())
  493. (: old-root-behavior ())
  494.  
  495. (: grabs (: root-grabs (: window-grabs (: icon-grabs (list
  496.       (button any with-alt)
  497.       (button select-button (together with-shift with-alt))
  498. )))))
  499.  
  500. ;; the function to call when redefining behaviors, to re-create fsms
  501. ;;==================================================================
  502.  
  503. (defun reparse-standard-behaviors ()
  504.   (if (not (and
  505.     (eq window-behavior old-window-behavior)
  506.     (eq standard-behavior old-standard-behavior)
  507.     ))
  508.     (progn
  509.       (: window-fsm (fsm-make (state-make window-behavior standard-behavior)))
  510.       (: old-window-behavior window-behavior)
  511.   ))
  512.   (if (not (and
  513.     (eq icon-behavior old-icon-behavior)
  514.     (eq standard-behavior old-standard-behavior)
  515.     ))
  516.     (progn
  517.       (: icon-fsm (fsm-make (state-make icon-behavior standard-behavior)))
  518.       (: old-icon-behavior icon-behavior)
  519.   ))
  520.   (if (not (eq root-behavior old-root-behavior))
  521.     (progn
  522.       (: root-fsm (fsm-make (state-make root-behavior)))
  523.       (: old-root-behavior root-behavior)
  524.   ))
  525.   (: old-standard-behavior standard-behavior)
  526.  
  527.   ;; some sensible defaults for buggy decos
  528.   (: fsm window-fsm)
  529.   (: grabs window-grabs)
  530. )
  531.  
  532. (reparse-standard-behaviors)
  533.  
  534.  
  535. ;;=============================================================================
  536. ;;                    User Profile
  537. ;;=============================================================================
  538.  
  539. ; Pop-ups
  540. ; =======
  541.  
  542. (load "std-popups.gwm")        ; default: the standard menu package
  543.  
  544. (for screen (list-of-screens) (: menu 'window-pop)))
  545.  
  546. ; read user customizations in .profile.gwm, once per screen
  547. ; =========================================================
  548.  
  549. (if (= 0 gwm-quiet) (? "["))
  550. (for screen (list-of-screens) 
  551.     (load ".profile.gwm")
  552.     (if (= 'string (type screen-tile))
  553.     (: screen-tile (pixmap-make screen-tile)))
  554. )
  555. (if (= 0 gwm-quiet) (? "]"))
  556.     
  557. (load menu.builder)            ; build menus from set-up descs
  558.  
  559. ; The simplest window: no-decoration
  560. ; ==================================
  561.  
  562. (defun simple-window-decoration ()
  563.       (with (fsm window-fsm
  564.              borderwidth 0
  565.              inner-borderwidth any
  566.              menu window-pop)
  567.         (window-make () () () () ())))
  568. (: no-frame-no-borders (: simple-icon-decoration
  569.     (: no-decoration simple-window-decoration))
  570. )
  571.  
  572. ; no-decoration by a small border
  573.  
  574. (df no-frame () (window-make ()()()()()))
  575.  
  576. ;;=============================================================================
  577. ;;                    DESCRIBE-SCREEN & DESCRIBE-WINDOW
  578. ;;=============================================================================
  579.  
  580. (de describe-screen ()
  581.   (with (fsm root-fsm cursor root-cursor menu root-pop tile screen-tile
  582.       grabs root-grabs
  583.       opening '(progn (eval to-be-done-after-setup)
  584.     (eval screen-opening)
  585.     (if (= 0 gwm-quiet) 
  586.       (? "Screen #" screen " ready.\n")))
  587.       closing '(eval screen-closing)
  588.     )
  589.     (window-make () () () () ()))))
  590.  
  591. (de describe-window ()
  592.   (list
  593.     (autoload-description
  594.       (if (: tmp (std-resource-get 'GwmWindow))
  595.     tmp
  596.     'simple-win)
  597.     )
  598.     '(autoload-description        ; defer evaluation till iconification
  599.       (if (: tmp (std-resource-get 'GwmIconWindow))
  600.     tmp
  601.     'simple-icon)
  602. )))
  603.  
  604. ;  Bye bye
  605. ; ========
  606.  
  607. (if (= 0 gwm-quiet)
  608.   (progn
  609.     (setq load original-load)
  610.     (print "...done\n")
  611.   )
  612.   (bell)
  613. )
  614.  
  615. ;(trace-func do-autoload-description name)
  616.