home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / profile-colas.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  34KB  |  1,074 lines
  1. ; GWM: an exemple of a user customisation file for the standard profile
  2. ; =====================================================================
  3. ;; code indented by the amc-lisp package of epoch
  4.  
  5. ; How to add code to each window decoration
  6. ;(setq opening
  7. ;  (+ opening '((? "Decorating " window-status " " window-name "\n"))))
  8.  
  9. ;;=============================================================================
  10. ;;                    Colas: My personal profile for gwm-1.7
  11. ;;=============================================================================
  12.  
  13. ;; You may want to put this profile as "site-defs.gwm", and make users include
  14. ;; it in their smaller profiles...
  15.  
  16. ;;=============================================================================
  17. ;;                    general setup: menus, cursors
  18. ;;=============================================================================
  19.  
  20.                     ; global flags
  21. (setq confine-windows t)        ; windows stay on screen
  22.                     ; cursors
  23.  
  24. ;; for me only: how to set the background pattern to a screen-dependent value
  25.  
  26. (setq screen-background (color-make "lightseagreen"))
  27. (if (not (= 0 (length (getenv "HOSTNAME"))))
  28.   (setq hostname (getenv "HOSTNAME"))
  29.   (setq hostname "local")
  30. )
  31.  
  32. (if (= (getenv "USER") "colas")        
  33.   (progn
  34.     (setq USER 'colas)
  35.     ;; (setq root-cursor  (cursor-make 2))
  36.     (with (background (color-make 'DeepPink)
  37.     foreground (color-make 'DeepPink4))
  38.       (setq cursor  (cursor-make "arrow3d-f" "arrow3d-m"))
  39.     )
  40.     (with (background (color-make 'HotPink)
  41.     foreground (color-make 'HotPink4))
  42.       (setq root-cursor  (cursor-make "arrow3d-f" "arrow3d-m"))
  43.     )
  44.         ;; (setq cursor root-cursor)
  45.     (if (> screen-depth 2)
  46. ;;      (: screen-tile (pixmap-make (color-make "#aee")
  47. ;;      "grainy" (color-make "#7bb")))
  48.       (: screen-tile ())
  49.       (> screen-depth 1)
  50.       (: screen-tile (pixmap-make white "back" grey))
  51.       (: screen-tile (pixmap-make "back")))
  52.     
  53.     (set-threshold 1)
  54.     (set-acceleration 2 1)
  55.     (stack-print-level 1000)
  56.   )
  57.   ;; general code for non-me users
  58.   (progn
  59.     (setq USER 'other)
  60.     (stack-print-level 3)
  61.   )
  62. )
  63.  
  64.                     ; menus colors & fonts
  65.  
  66. (setq pop-label.font (font-make "*-helvetica-bold-o-normal--18-*"))
  67. (setq pop-item.font (font-make "*-helvetica-medium-r-normal--14-*"))
  68. (setq pop-item.background (color-make "pink"))
  69. (setq pop-item.foreground (color-make "NavyBlue"))
  70. (setq name-font (font-make "*-times-bold-r-normal--18-*"))
  71. (setq fixed-font (font-make "fixed"))
  72.  
  73.                     ;insert a menu item to root menu
  74. (insert-at '(item-make
  75.     "reset backgrnd" (! "xsetroot" "-solid" "lightseagreen")
  76.       )
  77.       root-pop-items
  78.     6
  79. )
  80.     
  81.  
  82.  
  83.  
  84. ; if you do not see the grid lines when moving/resizing, do a:
  85. ; (setq grid-color (bitwise-xor (color-make "fore") (color-make "back")))
  86. ; with fore and back being the predominant colors on your screen
  87. ; do the same thing with invert-color if you have problems with menus
  88.  
  89. ;;=============================================================================
  90. ;;                    general packages
  91. ;;=============================================================================
  92.  
  93. ;;=============================================================================
  94. ;; NOTE: put here all behavior (fsm) modifications, before loading decorations
  95. ;;=============================================================================
  96.  
  97. ;; how to add a function (iconify on control-alt clik-right) to windows,
  98. ;; and a delta functionality to raise/move windows on button 1:
  99. ;; first, define what to do on these events
  100.  
  101. (load 'deltabutton)
  102.  
  103. (: standard-behavior
  104.    (state-make
  105.     (on (buttonpress 1 alone)
  106.     (if (deltabutton) (progn (raise-window)(move-window))
  107.       (raise-window)))
  108.     (on (buttonpress 1 with-alt)
  109.     (if (deltabutton) (progn (raise-window)(move-window))
  110.       (raise-window)))
  111.     (on (buttonrelease 3 (together with-alt with-control))
  112.     (progn (iconify-window) (raise-window)))
  113.     standard-behavior
  114.     ))
  115.  
  116. ;; second, "grab" these events to prevent them to go to the decorated 
  117. ;; application
  118.  
  119. (setq window-grabs 
  120.     (+ window-grabs 
  121.        (list (buttonpress 3 (together with-alt with-control)))))
  122.  
  123. ;; I also like to be able to do "Exec Cut" anywhere by Ctrl-Alt-F1
  124. ;;================================================================
  125. ;; first abbrev for the event
  126. (setq CtrlAltF1 (key "F1" (together with-alt with-control)))
  127.  
  128. ;; second, put the transition in the concerned behaviors
  129. (: standard-behavior (state-make    ; for windows & icons
  130.     standard-behavior
  131.     (on CtrlAltF1 (execute-string (+ "(? " cut-buffer ")")))
  132. ))
  133. (: root-behavior (state-make        ; root window only
  134.     root-behavior
  135.     (on CtrlAltF1 (execute-string (+ "(? " cut-buffer ")")))
  136. ))   
  137.  
  138. (: window-grabs (+ window-grabs (list CtrlAltF1)))
  139. (: icon-grabs (+ icon-grabs (list CtrlAltF1)))
  140. (: root-grabs (+ root-grabs (list CtrlAltF1)))
  141.  
  142. ;; then register these changes
  143. (reparse-standard-behaviors)
  144.  
  145. ;; load misc little packages
  146. ;;==========================
  147.  
  148. (load 'float)                ; to make sticky windows
  149. (load 'unconf-move)            ; to allow control-moving out of screen
  150. ;(load 'suntools-keys)            ; to add L7 for iconify
  151. (load 'move-opaque)            ; to move windows in real time (NeXT)
  152. ;(load 'mon-keys)            ; M.Newton functions key bindings
  153.  
  154. ;;=============================================================================
  155. ;;                    virtual screen
  156. ;;=============================================================================
  157.  
  158. (setq std-virtual.doors '(
  159.     ("Home" screen-background)
  160.     ("Comp" "LightBlue3")
  161.     ("Mail" 
  162.       (pixmap-make (color-make "seagreen3") "grainy" (color-make "seagreen2"))
  163.       background (color-make "seagreen3"))    
  164.     ("WWW" lightgrey door-icon (pixmap-load "netscape-small.xpm"))
  165.     ("Text" "LightYellow3")
  166.     ("Games" grey)
  167. ))
  168.  
  169. (load "std-virtual.gwm")
  170.  
  171. ;;=============================================================================
  172. ;;                    menus
  173. ;;=============================================================================
  174.  
  175. (if (not (boundp 'Screensaver.menu-added)) (progn
  176.     (setq Screensaver.menu-added t)
  177.  
  178.     (insert-at '(item-make "Screensaver" (! "xscreensaver-command" "-activate"))
  179.       root-pop-items
  180.       6
  181.     )
  182. ))
  183.  
  184.  
  185. ;;=============================================================================
  186. ;; NOTE: Now we can actually load decorations, the fsms have been updated
  187. ;;=============================================================================
  188.  
  189. ;;=============================================================================
  190. ;;                    simple-ed-win
  191. ;;=============================================================================
  192.  
  193. (: edit-keys.backspace "Delete")
  194. (: edit-keys.delete "Escape")
  195.  
  196. ;; My Bull Icon... comment out this code to get rid of my company's logo :-)
  197.  
  198. (setq icon-pixmap         ; put the BULL logo in the upper left corner
  199.   (if (= screen-depth 1)
  200.     (pixmap-make white "bull_1" black "bull_2" white)
  201.       (= screen-depth 2)
  202.     (pixmap-make white "bull_1" darkgrey "bull_2" grey)
  203.       (pixmap-make white "bull_1" (color-make "DarkSlateBlue")
  204.              "bull_2" (color-make "Green")))))
  205.  
  206. ;;=============================================================================
  207. ;;                    windows
  208. ;;=============================================================================
  209.  
  210. (customize simple-win any Xmemuse.xmemuse.xmemuse.aye
  211.   font fixed-font
  212.   active.font fixed-font
  213.   active.label.background grey
  214.   label (lambda (s) window-machine-name)
  215.   tile t
  216.   label.background screen-background
  217.   legend "right"
  218.   lpad 0
  219.   rpad 4
  220. )
  221. (customize simple-win any Xmemuse.xmemuse.xmemuse.lemur
  222.   font fixed-font
  223.   active.font fixed-font
  224.   active.label.background grey
  225.   label (lambda (s) window-machine-name)
  226.   tile t
  227.   label.background screen-background
  228.   legend "right"
  229.   lpad 1
  230.   rpad 3
  231. )
  232. (customize simple-win any Xmemuse.xmemuse.xmemuse.maki
  233.   font fixed-font
  234.   active.font fixed-font
  235.   active.label.background grey
  236.   label (lambda (s) window-machine-name)
  237.   tile t
  238.   label.background screen-background
  239.   legend "right"
  240.   lpad 2
  241.   rpad 2
  242. )
  243. (customize simple-win any Xmemuse
  244.   font fixed-font
  245.   active.font fixed-font
  246.   active.label.background grey
  247.   label (lambda (s) window-machine-name)
  248.   tile t
  249.   label.background screen-background
  250.   legend "right"
  251.   lpad 4
  252.   rpad 0
  253. )
  254.  
  255. ;;=============================================================================
  256. ;;                    icon groups
  257. ;;=============================================================================
  258.  
  259. ;; I don't want to have only one icon for all my epoch screens!
  260.  
  261. (setq icon-groups.excluded '(Emacs Xmh XRn MinibufferScreen))
  262. (load "icon-groups")        ; iconify groups as a whole
  263.  
  264. ;;=============================================================================
  265. ;;                    icons
  266. ;;=============================================================================
  267.  
  268. (setq simple-icon.legend ())        ; no title under icons
  269.  
  270. ;; How to have different icon colors. as you can see, customize is quite
  271. ;; flexible on how to specify arguments
  272.  
  273. (customize simple-icon any Xman
  274.   background (color-make "MistyRose")
  275. )
  276. (customize simple-icon any Xedit
  277.   background (color-make "thistle2")
  278. )
  279. (customize simple-icon any Xdir
  280.   (background (color-make "LightSeaGreen"))
  281. )
  282. (customize simple-icon any Xarchie
  283.   (background (color-make "yellow3"))
  284. )
  285. (customize simple-icon any Xls
  286.   (background (color-make "aquamarine1"))
  287. )
  288. (customize simple-icon any Emacs 
  289.   background (color-make "wheat1")
  290.   label 
  291.   (lambdaq (s) 
  292.     (with (ss (match "^\\([^ ]*\\) @ \\([a-z][a-z]*\\)[.].*$" s 1 2)) 
  293.       (if (or (= "" ss)(= '("" "") ss)) s 
  294.     (if (= hostname (# 1 ss)) (# 0 ss) ;omit host name on local host
  295.       (+ (# 0 ss) " @" (# 1 ss)))
  296.   )))
  297. )
  298.  
  299. (customize simple-icon any MinibufferScreen
  300.   background (color-make "wheat1"))
  301. (customize simple-icon any Xmh
  302.   background (color-make "LightCyan2")
  303.   foreground (color-make "DeepPink2")
  304. )
  305. (customize simple-icon any XRn
  306.   background (color-make "aquamarine2")
  307.   foreground (color-make "DarkSeaGreen4")
  308.   borderwidth 0
  309. )
  310. (customize simple-icon any XRn.xrncma
  311.   background (color-make "LightGoldenrod2")
  312. )
  313. (customize simple-icon any XPostit
  314.   background (color-make "Red")
  315.   foreground (color-make "Yellow")
  316. )
  317. (customize simple-icon any XClipboard
  318.   background (color-make "IndianRed2")
  319. )
  320. (customize simple-win any XClipboard
  321.   font small-font
  322.   background (color-make "IndianRed2")
  323.   active.background (color-make "IndianRed4")
  324.   label.background (color-make "IndianRed2")
  325. ))
  326.  
  327. ;; note that you can specify a client by its class.name.windowname.machine
  328.  
  329. (customize term-icon any XTerm.Console.Console.any
  330.   '(background (color-make "LightSkyBlue2"))
  331. )
  332. (customize term-icon any XTerm.xterm.any.opossum
  333.   background (color-make "PowderBlue")
  334. )
  335. (customize term-icon any XTerm
  336.   background "none"
  337. )
  338.  
  339. (customize term-icon any XTerm.hobbes
  340.   '(background (color-make "LightGoldenRod3"))
  341. )
  342. (customize simple-icon any Xmh.any.any.lemur
  343.   background (color-make "LightGoldenRod3")
  344.   foreground (color-make "MidnightBlue")
  345. )
  346. (customize simple-icon any Tk.zircon
  347.   background (color-make "yellow2")
  348. )
  349. (customize simple-icon any Zircon
  350.   background (color-make "yellow2")
  351. )
  352. (customize simple-icon any XLess
  353.   background (color-make "LavenderBlush2")
  354. )
  355. (customize simple-icon any Zircon.@info
  356.   simple-icon.plug-name "Zircon info"
  357.   background (color-make "yellow2")
  358. )
  359. (customize simple-icon any Tk.zircon.Zircon_Control_Panel
  360.   simple-icon.plug-name "Zircon MAIN"
  361.   background (color-make "yellow2")
  362. )
  363.  
  364. (defun xpm-icon-zircon (init?)
  365.   (if ( = window-icon-name "*#koala*")
  366.     (pixmap-load (+ window-client-class "-icon." "yes"))
  367.     (pixmap-load (+ window-client-class "-icon." "no"))))
  368. (require 'near-mouse)
  369. (set-placement Zircon near-mouse)
  370.  
  371. (set-icon-window any Zircon*IRC_Channel_#koala (xpm-icon xpm-icon-zircon))
  372. (set-icon-window any Zircon.channel16.IRC_Channel_#koala (xpm-icon xpm-icon-zircon))
  373. (set-icon-window any Zircon.any.IRC_Channel_#koala (xpm-icon xpm-icon-zircon))
  374.  
  375. (set-icon XPostit (pixmap-load "xpostit-icon"))
  376. (set-icon-window XTerm.Console ())
  377. (set-icon XTerm.Console (pixmap-load "xterm.xpm"))
  378. (set-icon Pixmap (pixmap-load "pixmap.xpm"))
  379.  
  380. ;;=============================================================================
  381. ;;                    affectation of decorations to windows
  382. ;;=============================================================================
  383.  
  384. (set-window any simple-win)    ; Any X Client
  385.  
  386. ;; how to fully customize decos: define a Lisp function to choose the
  387. ;; deco for the client with full lisp power, then affect it as a deco to 
  388. ;; clients
  389.  
  390. (defun xterm-deco ()
  391.   (if (= window-client-name "test") 'test-win ; atoms
  392.     (= window-client-name "vb") "vb-term"     ; or strings are equivalent
  393.       'simple-ed-win                  ; means load file & execute func
  394. ))
  395.  
  396. (set-window XTerm.Console vb-term)    ; XTERM
  397. (set-window XTerm simple-ed-win)    ; XTERM
  398.  
  399. (setq term-icon:background "none")
  400. (load 'term-icon-xpm.gwm)
  401.  
  402. (set-icon-window XTerm
  403.   (term-icon-xpm "xterm3" pop-item.font
  404.   (color-make "#73737F7F8A8A")
  405.   (color-make "yellow")))
  406.  
  407. (setq xterm-decos.sony 
  408.   '(term-icon-xpm "xterm3" pop-item.font
  409.   (color-make "green4")
  410.   (color-make "yellow")))
  411. (set-icon-window XTerm*maki xterm-decos.sony)
  412. (set-icon-window XTerm*lemur xterm-decos.sony)
  413.  
  414. (setq xterm-decos.indri 
  415.   '(term-icon-xpm "xterm3" pop-item.font
  416.   (color-make "HotPink4")
  417.   (color-make "yellow")))
  418. (set-icon-window XTerm*indri xterm-decos.indri)
  419.  
  420. (setq xterm-decos.mips 
  421.   '(term-icon-xpm "xterm3" pop-item.font
  422.   (color-make "blue4")
  423.   (color-make "yellow")))
  424. (set-icon-window XTerm*opossum xterm-decos.mips)
  425. (set-icon-window XTerm*aye xterm-decos.mips)
  426. (set-icon-window XTerm*koala xterm-decos.mips)
  427. (set-icon-window XTerm*wombat xterm-decos.mips)
  428.  
  429.  
  430. (set-window XLoad no-frame) ; XLOAD
  431. (set-window XPostit no-frame-no-borders)
  432. (set-window XCal no-frame-no-borders)
  433. (set-window XBiff no-frame-no-borders)
  434. (set-window Sxpm no-frame-no-borders)
  435.  
  436. ;(set-window XClock frame-win)    ; XCLOCK
  437. (set-window XClock no-frame)    ; XCLOCK
  438. (set-window Clock frame-win)
  439.  
  440. (set-window chaos no-frame)
  441.  
  442. (set-icon-window any simple-icon) ; Any icon
  443. (set-window client no-frame-no-borders) ; xwud
  444.  
  445. (set-icon XCol (pixmap-load 'xcol-icon.xpm))
  446.  
  447. ;(load 'waiting-xterm)            ; prepared in advance xterms
  448.  
  449. (set-placement Netrek.wait rows.right-top.placement)
  450. (set-window  Netrek.wait no-frame-no-borders)
  451. (set-window XPmview no-frame-no-borders)
  452. (set-icon TkMan (pixmap-load "LRom1.xpm"))
  453. (set-icon Dayview (pixmap-load "datebook.xpm"))
  454. ;;(set-icon Mosaic (pixmap-load "mosaic.xpm"))
  455. (customize simple-icon any Mosaic
  456.   borderwidth 0
  457. )
  458. (set-icon Xfilemanager (pixmap-load "cdrom1.xpm"))
  459.  
  460. (defun xpm-icon-xrn (init?)
  461.   (if ( = window-icon-name "xrn-nonews")
  462.     (pixmap-load "xrn-nonews")
  463.     (= window-icon-name "xrn-busy")
  464.     (pixmap-load "xrn-busy")
  465.     (pixmap-load "xrn")
  466. ))
  467. (defun xpm-icon-xrn2 (init?)
  468.   (if ( = window-icon-name "xrn2-nonews")
  469.     (pixmap-load "xrn2-nonews")
  470.     (= window-icon-name "xrn-busy")
  471.     (pixmap-load "xrn2-busy")
  472.     (pixmap-load "xrn2")
  473. ))
  474. (set-icon-window any XRn (xpm-icon xpm-icon-xrn))
  475. (set-icon-window any XRn.xrn2 (xpm-icon xpm-icon-xrn2))
  476. (set-icon-window any XRn.Composition ())
  477. (set-icon-window any XRn.Information ())
  478.  
  479. (setq bar-max-width 500)
  480. (set-icon Netscape (pixmap-load "netscape-small.xpm"))
  481. (customize simple-icon any Netscape
  482.   legend "left"
  483.   stretch t
  484.   borderwidth 0
  485.   background screen-background
  486.   label (lambdaq (s) 
  487.     (if (= s "icon") "Bookmarks" (match "Netscape: \\(.*\\)$" s 1)))
  488. )
  489.  
  490. ;;=============================================================================
  491. ;;                    placements
  492. ;;=============================================================================
  493.  
  494. (set-placement XTerm user-positioning)  ; place manually xterms
  495.  
  496. (if (not (= USER 'colas))        ; people other than me like to have 
  497.                     ; interactive placement for all windows
  498.   (set-placement * user-positioning)
  499. )
  500.  
  501. (set-icon-placement any rows.right-top.placement) ; place most icons on right
  502.  
  503. ; xloads, xclocks, etc goes on NE corner
  504.  
  505. (set-placement XLoad.xload rows.top-right.placement) 
  506. (set-placement XPostit.xpostit.xpostit rows.top-right.placement) 
  507. (set-placement XClock rows.top-right.placement) 
  508. (set-placement Clock rows.top-right.placement) 
  509. (set-placement XBiff rows.top-right.placement) 
  510. (set-placement XLogo rows.down-right.placement) 
  511.  
  512. (set-icon-placement Gwm rows.down-right.placement) ; inactive dvrooms
  513. (set-window Gwm no-frame)
  514. (set-placement Gwm            ; active dvrooms
  515.            (lambda (f) (if (= window-name "rmgr")
  516.                      (if f
  517.                    (move-window
  518.                     (- screen-width 175)
  519.                     60)))))))))
  520.  
  521. (set-placement XPostit.xpostit rows.top-right.placement)
  522.  
  523. (set-placement XCal rows.top-right.placement) ; XCal windows
  524.  
  525. ;; specify the ordering of icons
  526.  
  527. (setq icon-order '(Xmh 10 XPostit 5 XRn 20 XClock 2 Clock 2 XBiff 1 XLoad 20
  528.     XTerm 90 Emacs 30 XDvi 250 XCal 1000
  529.     Zircon 15 Tk.zircon 15))
  530.  
  531. (rows.limits rows.right-top 'start 55 'separator 1 'sort sort-icons 'end 1000)
  532. (rows.limits rows.down-right 'start 100 'separator 1 'offset
  533.      (- screen-height 70))
  534. (rows.limits rows.down-left 'start 600 'separator 1 'offset 1)
  535. (rows.limits rows.top-right 'start 55  'sort sort-icons)
  536.  
  537.  
  538. ;; I want my local xload on the top right corner
  539.  
  540. (set-placement XLoad.xloadlocal
  541.   (lambda (f) (if f (progn
  542.     (move-window (- screen-width window-width wob-borderwidth) 0)
  543.     (## 'update-placement window  ())
  544. )))))
  545.  
  546. ;;=============================================================================
  547. ;;                    a better icon sorter, weigths given by customize
  548. ;;=============================================================================
  549.  
  550. (defun pack-icons (w1 w2)
  551.   (with (wob w1 weight1 100 weight2 100 n1 window-icon-name)
  552.     (setq weight1 (# 'weight (std-resource-get 'PackIcons 'pack-icons)))
  553.     (if (not weight1) (setq weight1 100))
  554.     (setq wob w2)
  555.     (setq weight2 (# 'weight (std-resource-get 'PackIcons 'pack-icons)))
  556.     (if (not weight2) (setq weight2 100))
  557.     
  558.     (if (= weight1 weight2)
  559.       (compare n1 window-icon-name)
  560.       (compare weight1 weight2)
  561. )))
  562.  
  563. (customize pack-icons any any weight 100)
  564.  
  565. (rows.limits rows.right-top 'sort pack-icons)
  566.  
  567. ;; my personal weights
  568.  
  569. (customize pack-icons any Xmh weight 10)
  570. (customize pack-icons any XPostit weight 5)
  571. (customize pack-icons any XRn weight 20)
  572. (customize pack-icons any XClock weight 2)
  573. (customize pack-icons any Clock weight 2)
  574. (customize pack-icons any XBiff weight 1)
  575. (customize pack-icons any XLoad weight 20)
  576. (customize pack-icons any XTerm weight 90)
  577. (customize pack-icons any Emacs weight 30)
  578. (customize pack-icons any XDvi weight 250)
  579. (customize pack-icons any XCal weight 1000)
  580. (customize pack-icons any Zircon weight 15)
  581. (customize pack-icons any Tk.zircon weight 15)
  582.  
  583. ;;=============================================================================
  584. ;;                    Misc Examples
  585. ;;=============================================================================
  586.  
  587. ; have a list of machines for xterms and xload alphabetically sorted
  588.  
  589. (setq xload-list (: xterm-list '(
  590.       lemur  aye maki indri
  591.       taquilee noe ganesa cma.cma.fr entropy
  592.       casa
  593.       aenegada capa
  594.       modja crios ploum milos rhea
  595.       babar  paprika trinidad bahia  arthur
  596.       tatoo almeria mbili bagheera falbala
  597.       oaxaca))))
  598.  
  599. ; I sort the list of machines alphabetically
  600.  
  601. (sort xterm-list (lambdaq (atom1 atom2) (compare atom1 atom2)))
  602.  
  603. ;; Example on how to make a window start as iconic: 
  604. ;; first, sets its window-starts-iconic to t,
  605. ;; then return deco
  606.  
  607. (defun no-frame-iconic ()
  608.     '(progn
  609.     (window-starts-iconic t)
  610.     (no-frame)))
  611. ;; we use this for xdvi, which has no -iconic option
  612. (set-window XDvi no-frame-iconic)
  613.  
  614. ; how to affect a decoration by some other criterions:
  615. ; example: set deco of xrn windows by size: small windows (popups) do not
  616. ; have decos, big ones (height > 200) have
  617.  
  618. (setq XRn-deco '(if (> window-height 200)
  619.     (progn
  620.       (require 'simple-win)        ; we must load it if it wasn't here
  621.       (simple-win 'font small-font
  622.     'background (color-make "PaleGreen2")
  623.     'active.background (color-make "PaleGreen4")
  624.     'label.background (color-make "PaleGreen2")
  625.     ))
  626.     no-frame-no-borders            ; no visible frame on popups
  627. ))
  628. (set-window XRn XRn-deco)
  629.  
  630. (setq XRn-deco.xrncma '(if (> window-height 200)
  631.     (progn
  632.       (require 'simple-win)        ; we must load it if it wasn't here
  633.       (simple-win 'font small-font
  634.     'background (color-make "GoldenRod2")
  635.     'active.background (color-make "GoldenRod4")
  636.     'label.background (color-make "GoldenRod2")
  637.     ))
  638.     no-frame-no-borders            ; no visible frame on popups
  639. ))
  640. (set-window XRn.xrncma XRn-deco.xrncma)
  641.  
  642. ;; in fact, you can give customization argiments either to the function itself
  643. ;; or like here by another call to customize...
  644.  
  645. (set-window XTerm.xterm_Lpq simple-win)
  646. (customize simple-win any XTerm.xterm_Lpq font small-font
  647.     background (color-make "Yellow3")
  648.     active.background (color-make "Yellow1")
  649.     label.background (color-make "Yellow3")
  650. )))
  651.  
  652. ;;=============================================================================
  653. ;;                    emacs windows: small-win is a  variant of simple-win
  654. ;;=============================================================================
  655.  
  656. ;; first, we create the variant by calling the simple-win deco with a
  657. ;; context as argument (think of it as a closure made with the simple-win
  658. ;; deco + another environnement)
  659.  
  660. (require 'simple-win)            ; ensure simple-win func is defined
  661. (: small-win '(simple-win 'font small-font
  662.     'background (color-make "BurlyWood")
  663.     'active.background (color-make "orange4")
  664.     'label.background (color-make "BurlyWood")
  665. ))
  666. (: lemacs-win '(with (ignore-take-focus t)
  667.     (simple-win 'font small-font
  668.     'background (color-make "BurlyWood")
  669.     'active.background (color-make "orange4")
  670.     'label.background (color-make "BurlyWood")
  671. )))
  672. ;; then we can use it
  673.  
  674. (set-window Emacs small-win)
  675. (set-window Emacs.emacs lemacs-win)
  676. (set-window emacs (simple-win 'font small-font))
  677. (set-window Emacs.epoch.minibuffer no-frame)
  678. (set-window MinibufferScreen no-frame)
  679.  
  680. ;;=============================================================================
  681. ;;                    xmh
  682. ;;=============================================================================
  683.  
  684. (load 'xpm-icon)
  685. (set-icon-window any Xmh.xmh.xmh:_inbox (xpm-icon xpm-icon-by-size))
  686. (set-icon-window any Xmh ())
  687.  
  688. (set-icon XClipboard (pixmap-load "clipboard.xpm"))
  689. (set-icon XRn.xrn (pixmap-load "Xrn-icon"))
  690. (set-icon XRn.xrn-6_18 (pixmap-load "Xrn-icon"))
  691. (set-window Clock.oclock no-frame-no-borders)
  692.  
  693. ;;=============================================================================
  694. ;;                    epoch placement
  695. ;;=============================================================================
  696.  
  697. ;; this is a code to arrange my epoch window: make new epoch windows occupy
  698. ;; vacant slots in the "Epoch-windows-list"
  699. ;; Sample list is one to the left, and a cascade to the right
  700.  
  701. (if (= USER 'colas) (progn
  702.     (setq Epoch-windows-list '(
  703.     ;; free (width height x-pixel-pos y-pixel-pos ordering-number)    
  704.     free (80 87 0 0 0)
  705.     free (80 87 585 0 1)
  706.     free (80 85 605 22 2)
  707.     free (80 83 625 44 3)
  708.     free (80 81 645 66 4)
  709.     free (80 79 665 88 5)
  710.     free (80 77 685 110 6)
  711.     free (80 75 705 132 7)
  712.     ))
  713.     
  714.     (set-placement Emacs.epoch 
  715.       (lambda (flag)
  716.     (if flag            ; opening: seek free slot
  717.       (if (not window-starts-iconic) ; then put window-id instead of free
  718.         (place-epoch-window)
  719.       )
  720.                     ; closing: put 'free in slot
  721.       (with (e (member window Epoch-windows-list))
  722.         (if e
  723.           (replace-nth e Epoch-windows-list 'free)
  724.     )))))
  725.     
  726. ;; search Epoch-windows-list for free slots, and move & resize window there
  727.     (defun place-epoch-window ()
  728.       (with (geometry (nth 'free Epoch-windows-list))
  729.     (if geometry
  730.       (progn
  731.         (move-window (nth 2 geometry) (nth 3 geometry))
  732.         (setq window-size (sublist 0 2 geometry))
  733.         (replace-nth (* 2 (nth 4 geometry)) Epoch-windows-list window)
  734.     ))))
  735.  
  736.  
  737. ;;; same for lucid emacs
  738.     (setq Emacs-windows-list '(
  739.     ;; free (width height x-pixel-pos y-pixel-pos ordering-number)    
  740.     free (82 88 0 0 0)
  741.     free (82 88 580 0 1)
  742.     free (82 86 600 22 2)
  743.     free (82 84 620 44 3)
  744.     free (82 82 640 66 4)
  745.     free (82 80 660 88 5)
  746.     free (82 78 680 110 6)
  747.     free (82 76 700 132 7)
  748.     ))
  749.     
  750.     (set-placement Emacs.emacs 
  751.       (lambda (flag)
  752.     (if flag            ; opening: seek free slot
  753.       (if (not window-starts-iconic) ; then put window-id instead of free
  754.         (place-emacs-window)
  755.       )
  756.                     ; closing: put 'free in slot
  757.       (with (e (member window Emacs-windows-list))
  758.         (if e
  759.           (replace-nth e Emacs-windows-list 'free)
  760.     )))))
  761.     ;; search Emacs-windows-list for free slots, and move & resize window there
  762.     (defun place-emacs-window ()
  763.       (with (geometry (nth 'free Emacs-windows-list))
  764.     (if geometry
  765.       (progn
  766.         (move-window (nth 2 geometry) (nth 3 geometry))
  767.         (setq window-size (sublist 0 2 geometry))
  768.         (replace-nth (* 2 (nth 4 geometry)) Emacs-windows-list window)
  769.     ))))
  770.  
  771.  
  772. ))
  773.  
  774. ;; Personal clients
  775. (if (= USER 'colas) (progn
  776.     (setq xlpwatch.color (color-make "bisque"))
  777.     (set-icon Tk.xlpwatch (pixmap-make xlpwatch.color "printer.xbm" black))
  778.     (set-window Tk.xlpwatch no-frame-no-borders)
  779.     (set-icon Tk.xlpwatch_#2 (pixmap-make xlpwatch.color "printer.xbm" black))
  780.     (set-window Tk.xlpwatch_#2 no-frame-no-borders)
  781.     (set-icon Tk.xlpwatch_#3 (pixmap-make xlpwatch.color "printer.xbm" black))
  782.     (set-window Tk.xlpwatch_#3 no-frame-no-borders)
  783. ))
  784.  
  785. (set-window XQuery.NewMail no-frame-no-borders)
  786. (set-placement XQuery.NewMail rows.left-top.placement)
  787.  
  788. ;;=============================================================================
  789. ;; buttons for often done actions
  790. ;; button creation must be done at screen-opening-time
  791. ;;=============================================================================
  792.  
  793. (if (and (= USER 'colas) (not (boundp 'TEST)))
  794.   (progn
  795.     (setq screen-opening (+ screen-opening '(
  796.       
  797. ;;      ;; kill all my "new mail" windows
  798. ;;      (place-3d-button "kill-mails"
  799. ;;        black  'CadetBlue
  800. ;;        '(for window (list-of-windows) 
  801. ;;          (if (= window-client-name 'NewMail)(kill-window))
  802. ;;      ))
  803. ;;      
  804. ;;      ;; show/hide my vital postit, determined by its size
  805. ;;      (place-3d-button "admin-post"
  806. ;;        black 'khaki
  807. ;;        '(for window (list-of-windows) 
  808. ;;          (if (and (= window-name 'PostItNote)
  809. ;;          (= window-width 515)(= window-height 191)
  810. ;;        )
  811. ;;        (if window-is-mapped (iconify-window)
  812. ;;          (progn (map-window)(raise-window))
  813. ;;      ))))
  814. ;;      
  815. ;;      ;; toggle on/off all big postits
  816. ;;      (place-3d-button "Post Big"
  817. ;;        black 'thistle
  818. ;;        '(for window (list-of-windows) 
  819. ;;          (if (= window-name 'PostItNoteBig)
  820. ;;        (if window-is-mapped (iconify-window)
  821. ;;          (progn (map-window)(raise-window))
  822. ;;      ))))
  823. ;;      
  824. ;;      ;; toggle on/off all normal postits
  825. ;;      (place-3d-button "Post Norm"
  826. ;;        black 'khaki
  827. ;;        '(for window (list-of-windows) 
  828. ;;          (if (= window-name 'PostItNote)
  829. ;;        (if window-is-mapped (iconify-window)
  830. ;;          (progn (map-window)(raise-window))
  831. ;;      ))))
  832. ;;      
  833. ;;      ;; toggle on/off all small postits
  834. ;;      (place-3d-button "Post Small"
  835. ;;        black 'SpringGreen
  836. ;;        '(for window (list-of-windows) 
  837. ;;          (if (= window-name 'PostItNoteSmall)
  838. ;;        (if window-is-mapped (iconify-window)
  839. ;;          (progn (map-window)(raise-window))
  840. ;;        )))
  841. ;;      )
  842. ;;      
  843.       
  844.       ;; raise/lower/iconify (depending of button) all xterms
  845.       (place-3d-button "XTerms"
  846.         black 'LightBlue
  847.         '(if (= 0 (current-event-modifier))
  848.           (for window (list-of-windows 'window) 
  849.         (if (and (= window-client-class 'XTerm) window-is-mapped)
  850.           (if (= 1 (current-event-code))
  851.             (raise-window)
  852.             (= 2 (current-event-code))
  853.             (lower-window)
  854.             (= 3 (current-event-code))
  855.             (iconify-window)
  856.           )))
  857.           (for window (list-of-windows 'icon)
  858.         (if (and (= window-client-class 'XTerm) window-is-mapped)
  859.           (if (= 1 (current-event-code))
  860.             () ;; to be completed
  861.             (= 2 (current-event-code))
  862.             () ;; to be completed
  863.             (= 3 (current-event-code))
  864.             (iconify-window)
  865.       )))))
  866.       
  867.       ;; forks an lpwatch
  868.       (place-3d-button "lpq"
  869.         black 'bisque
  870.         '(! "/net/koala/bin/sun4/lpwatch" "-geometry" "+750+900")
  871.       )
  872.  
  873.       ;; resets the selection state of the server
  874.       (place-3d-button "blank" black 'pink
  875.         '(! "xscreensaver-command" "-activate")
  876.       )
  877.     )))
  878.     
  879.     (set-placement Gwm.button rows.right-down.placement)
  880.     (set-window Gwm.button no-frame-no-borders)
  881. ))
  882.  
  883. ;;=============================================================================
  884. ;; some little modifications after modules have been loaded
  885. ;;=============================================================================
  886. ;; a bit of a hack. just to show it can be done.
  887.  
  888. ;; change font of first item of window menu
  889. (## 0 window-pop-items
  890.   (list 'with '(pop-item.font (font-make "*-helvetica-bold-r-normal--14-*"))
  891.     (# 0 window-pop-items)
  892. ))
  893.  
  894. (setq old-get-x-resource resource-get)
  895. ;(defun resource-get (class name)
  896. ;;  (? "GET [" class "] [" name "]\n")
  897. ;  (old-get-x-resource class name)
  898. ;)
  899. (setq reenter-on-opening ())
  900.  
  901. ;; idraw: place pop-up on left top
  902.  
  903. (set-placement Dialog.idraw26
  904.   (lambda (f) (if f (progn (move-window 0 0) (resize-window 210 800)
  905. ))))
  906.  
  907. ;;=============================================================================
  908. ;; framemaker windows
  909. ;;=============================================================================
  910. (load 'framemaker)
  911.  
  912. (setq frame-icon-color.1 (color-make "LightYellow2"))
  913. (setq frame-icon-font.1 pop-item.font)
  914. (setq frame-icon-color.2 (color-make "LightYellow3"))
  915. (setq frame-icon-font.2 small-font)
  916. (setq frame-inactive-color frame-icon-color.1)
  917. (setq frame-active-color (color-make "LightYellow4"))
  918.  
  919. (set-icon Maker.makerkit (pixmap-load "App_write.xpm"))
  920. (set-icon-window Maker
  921.   (if (= "makerkit" window-client-name) ; top window(menu): use frame pixmap
  922.     (simple-icon 'background frame-icon-color.2)
  923.  
  924.     (match ".*kit" window-client-name)
  925.     (progn                ; main edit windows: icon name
  926.       (simple-icon 'background frame-icon-color.1
  927.     'simple-icon.plug-name (+ "[ " window-icon-name " ]")
  928.     'simple-icon.no-center-plug t
  929.     'font frame-icon-font.1
  930.       )
  931.     )
  932.  
  933.                     ; all popups, use a smaller name
  934.     (with (name (match "FrameMaker - \\(.*\\)$" window-name 1))
  935.       (if (= name "")
  936.     (setq name window-name)
  937.       )
  938.       (if
  939.     (= name "Character Format") (setq name "Format Chr")
  940.     (= name "Paragraph Format") (setq name "Format Par")
  941.     (= name "\xB6 Catalog") (progn
  942.       (setq window-name "Par Catalog")
  943.       (setq name "Catalog Par")
  944.     )
  945.     (= name "C Catalog") (setq name "Catalog Chr")
  946.     (= name "Spelling Checker") (setq name "Spell")
  947.       )
  948.       (simple-icon 'background frame-icon-color.2
  949.     'font frame-icon-font.2
  950.     'simple-icon.plug-name name)
  951. )))
  952.  
  953. (setq icon-order (+ icon-order '(Maker 210)))
  954.  
  955. ;; experimental epoch menus
  956.  
  957. (setq epoch-color "bisque")
  958.  
  959. (for i '("1" "2" "3" "4")
  960.   (set (atom (+ "epoch-color" i))
  961.     (color-make (+ epoch-color i))
  962. ))
  963.  
  964. (: widget.Bfont  (font-make "*clean-medium*--10*c-60*"))
  965. (: widget.font (font-make "*clean-bold*--10*c-60*"))
  966. (setq widget.foreground epoch-color4)
  967. (setq widget.background epoch-color1)
  968. (setq widget.name-font (font-make "fixed"))
  969. (setq widget.name-foreground black)
  970.  
  971. (: widget.weave (pixmap-make
  972.     epoch-color4
  973.     "/usr/include/X11/bitmaps/cross_weave"
  974.     epoch-color1
  975. ))
  976. (: widget.black (pixmap-make
  977.     black
  978.     "/usr/include/X11/bitmaps/black"
  979.     epoch-color4
  980. ))
  981. (: widget.gray (pixmap-make
  982.     black
  983.     "/usr/include/X11/bitmaps/black"
  984.     epoch-color4
  985. ))
  986. (: widget.lt-gray (pixmap-make
  987.     black
  988.     "/usr/include/X11/bitmaps/black"
  989.     epoch-color2
  990. ))
  991.  
  992. (load "em-widgets.gwm")
  993. (load "em-drop-menus.gwm")
  994. (set-window Emacs.epoch style:select)
  995.  
  996. (Dmenu: Dmenu.fonts
  997.    '("fonts" (
  998.       ("screen-11" "(progn (font \"screen.r.11\") (redraw-display))")
  999.       ("screen-12" "(progn (font \"screen.r.12\") (redraw-display))")
  1000.       ("screen-12-Bold" "(progn (font \"screen.b.12\") (redraw-display))")
  1001.       ("screen-13" "(progn (font \"screen.r.13\") (redraw-display))")
  1002.       ("screen-14" "(progn (font \"screen.r.14\") (redraw-display))")
  1003.       ("screen-14-Bold" "(progn (font \"screen.b.14\") (redraw-display))")
  1004.       ("screen-7" "(progn (font \"screen.r.7\") (redraw-display))")
  1005.       ("fixed" "(progn (font \"fixed\") (redraw-display))")
  1006.       )))
  1007.  
  1008. (Dmenu: Dmenu.buffers 
  1009.    '("buffers" (
  1010.       ("list of buffers"
  1011.     "(progn \
  1012. (list-buffers) \
  1013. (switch-to-buffer \"*Buffer List*\") \
  1014. (delete-other-windows) \
  1015. (if (not (boundp 'mouse-Buffer-menu-select)) (progn \
  1016.     (setq mouse-Buffer-menu-select t)\
  1017.     (defun mouse-Buffer-menu-select (&optional mdata) (interactive) \
  1018.       (Buffer-menu-select) \
  1019. ))) \
  1020. (if (boundp 'imouse-version)\
  1021.   (local-set-mouse mouse-middle mouse-down 'mouse-set-point-or-select) \
  1022.   (local-set-mouse mouse-middle mouse-down 'mouse::set-point)) \
  1023. (local-set-mouse mouse-middle mouse-up 'mouse-Buffer-menu-select) \
  1024. )")
  1025.       ("other buffer" "(switch-to-buffer (other-buffer))")
  1026.       ("*scratch* buffer" "(switch-to-buffer \"*scratch*\")")
  1027.       ("-" (bell))
  1028.       ("kill buffer" "(kill-buffer (current-buffer))")
  1029.       )))
  1030.  
  1031. (Dmenu: Dmenu.files 
  1032.    '("files" (
  1033.       ("list of directory"
  1034.     "(progn \
  1035. (dired \".\") \
  1036. (delete-other-windows) \
  1037. (if (not (boundp 'mouse-dired-find-file)) (progn \
  1038.     (setq mouse-dired-find-file t)\
  1039.     (defun mouse-dired-find-file (&optional mdata) (interactive) \
  1040.       (dired-find-file) \
  1041. ))) \
  1042. (if (boundp 'imouse-version)\
  1043.   (local-set-mouse mouse-middle mouse-down 'mouse-set-point-or-select) \
  1044.   (local-set-mouse mouse-middle mouse-down 'mouse::set-point)) \
  1045. (local-set-mouse mouse-middle mouse-up 'mouse-dired-find-file) \
  1046. )")
  1047.     (" - - - " "")
  1048.     (".Xdefaults" "(find-file \"~/.Xdefaults\")")
  1049.     ("profile-epoch" "(find-file \"~/el/profile-epoch-4.0.el\")")
  1050.     ("wool TODO" "(find-file \"~/Wool2/src/TODO\")")
  1051.     ("wool Log" "(find-file \"~/Wool2/src/Log\")")
  1052.     ("gwm-talk" "(find-file \"~/mailist/gwm-talk\")")
  1053.     ("gwm-welcome" "(find-file \"~/mailist/newusers-gwm\")")
  1054.  
  1055.       )))
  1056.  
  1057. (Dmenu: Dmenu.db
  1058.     '("db" 
  1059.      (
  1060.       (" " "")
  1061.       ("byte-compile-current-file" "(byte-compile-current-file)")
  1062.       ("toggle debug" "(setq debug-on-error (not debug-on-error))")
  1063.       ("debug on" "(setq debug-on-error t)")
  1064.       ("debug off" "(setq debug-on-error f)")
  1065.       )))
  1066.  
  1067. (: Dmenu.epoch-menus
  1068.    (list 
  1069.     Dmenu.fonts
  1070.     Dmenu.files
  1071.     Dmenu.buffers
  1072.     Dmenu.db
  1073.     ))
  1074.