home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / simple-win.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  9KB  |  293 lines
  1. ; SIMPLEST DECORATION
  2. ; ===================
  3.  
  4. ;;File: simple-win.gwm -- simple window decoration
  5. ;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
  6. ;;Revision: 1.6 -- Aug 13 1991
  7. ;;State: Exp
  8. ;;GWM Version: 1.7
  9.  
  10. ;;============================================================================
  11. ;; INITS
  12. ;;============================================================================
  13.  
  14. ;; first we declare as screen-dependent all the screen-dependent values we will
  15. ;; use (i.e. colors, pop-ups, pixmaps and cursors)
  16. ;; this file will normally be loaded once.
  17.  
  18. (declare-screen-dependent
  19.   simple-win.active.background
  20.   simple-win.background
  21.   simple-win.active.label.background
  22.   simple-win.label.background
  23.   simple-win.active.label.foreground
  24.   simple-win.label.foreground
  25.   simple-win.active.label.border
  26.   simple-win.label.border
  27. )
  28.  
  29.  
  30. ;; We set to their default values all the simple-win.* customizable
  31. ;; values that the user hadn't set
  32. ;; here we say that some values can be nil, to mean: just use the same value
  33. ;; as the inactive value
  34. ;; tile can also be given
  35.  
  36. ;; first, the screen-independent ones:
  37.  
  38. (defaults-to
  39.   simple-win.active.font ()
  40.   simple-win.font name-font
  41.   simple-win.active.label.borderwidth ()
  42.   simple-win.label.borderwidth 1
  43.   simple-win.label ()
  44.   simple-win.legend "top"
  45.   simple-win.lpad 1
  46.   simple-win.rpad 1
  47. )
  48.  
  49. ;; then the screen-dependent:
  50. ;; (we protect the value of the current wob which will be modified by the loop)
  51.  
  52. (with (wob wob) (for screen (list-of-screens) (defaults-to
  53.     simple-win.active.background darkgrey
  54.     simple-win.background grey
  55.     simple-win.active.label.background ()
  56.     simple-win.label.background white
  57.     simple-win.active.label.foreground ()
  58.     simple-win.label.foreground black
  59.     simple-win.active.label.border ()
  60.     simple-win.label.border black
  61. )))
  62.  
  63. ;; we declare the the context (pairs of variables/values) that will be inbedded
  64. ;; into the window, accessible in the window wool property of key 'context.
  65. ;; these get initilized from their global defaults.
  66.  
  67. (setq simple-win.context (list
  68.     'active-label? ()
  69.     'active.background  simple-win.active.background 
  70.     'background simple-win.background
  71.     'active.font  simple-win.active.font 
  72.     'font simple-win.font
  73.     'active.label.background  simple-win.active.label.background 
  74.     'label.background simple-win.label.background
  75.     'active.label.foreground  simple-win.active.label.foreground 
  76.     'label.foreground simple-win.label.foreground
  77.     'active.label.borderwidth  simple-win.active.label.borderwidth 
  78.     'label.borderwidth simple-win.label.borderwidth
  79.     'active.label.border  simple-win.active.label.border 
  80.     'label.border simple-win.label.border
  81.     'label ()
  82.     'legend "top"
  83.     'lpad 1
  84.     'rpad 1
  85. ))
  86.  
  87. ;;============================================================================
  88. ;; FSMs
  89. ;;============================================================================
  90. ;; here we declare the fsms of the deco. 
  91. ;; the idea is that all window-dependent values should be accessed through the
  92. ;; 'context property-list in the window property-list where they have been
  93. ;; put at built tiome, by the main simple-win function.
  94.  
  95. ;; the title bar: will change background color with focus
  96.  
  97. (: simple-win.titlebar-fsm
  98.   (fsm-make
  99.     (state-make
  100.       (on (user-event 'focus-in)
  101.     (wob-background (# 'active.background (# 'context window)))
  102.       )
  103.       (on (user-event 'focus-out)
  104.     (wob-background (# 'background (# 'context window)))
  105.       )
  106.       standard-title-behavior
  107.       standard-behavior))
  108. )
  109.  
  110. ;; here we process optionnaly the window-name by an optional "label"
  111. ;; customisation argument that can be a function
  112.  
  113. (de simple-win.name ()
  114.   (with (new-label
  115.       (if label
  116.     (if 
  117.       (= (type label) 'string)
  118.       label
  119.       (eval (list label window-name))
  120.     )
  121.     window-name
  122.     ))
  123.     (if (and (= (type new-label) 'string) (not (= "" new-label)))
  124.       new-label
  125.       window-name
  126.     )
  127. ))
  128.  
  129.     
  130. ;; the window name plug: may change with focus (two different fsms in each 
  131. ;; case to make less X calls), and must update name when window name is changed
  132. ;; which is forwarded to us by the standard-behavior in the form of a 
  133. ;; (user-event 'name-change) event
  134.  
  135. (: simple-win.label-fsm
  136.   (fsm-make
  137.     (state-make
  138.       (on (user-event 'name-change)
  139.     (with (context (# 'context window)
  140.         label (# 'label context)
  141.         font (# 'font context)
  142.         background (# 'label.background context)
  143.         foreground (# 'label.foreground context)
  144.       )
  145.       (wob-tile (label-make (simple-win.name)))))
  146.       standard-title-behavior
  147.       standard-behavior)))
  148.  
  149. (: simple-win.active.label-fsm
  150.   (fsm-make
  151.     (setq inactive (state-make
  152.     (on (user-event 'focus-in)
  153.       (wob-tile (# 'active-label window-property))
  154.       active
  155.     )
  156.     (on (user-event 'name-change)
  157.       (with (context (# 'context window)
  158.           label (# 'label context)
  159.           font (# 'font context)
  160.           background (# 'label.background context)
  161.           foreground (# 'label.foreground context)
  162.           tile (label-make (simple-win.name))
  163.           font (# 'active.font context)
  164.           background (# 'active.label.background context)
  165.           foreground (# 'active.label.foreground context)
  166.           atile (label-make (simple-win.name))
  167.         )
  168.         (## 'inactive-label window tile)
  169.         (## 'active-label window atile)
  170.         (wob-tile tile)))
  171.     standard-title-behavior
  172.     standard-behavior))
  173.     (setq active (state-make
  174.     (on (user-event 'focus-out)
  175.       (wob-tile (# 'inactive-label window-property))
  176.       inactive
  177.     )
  178.     (on (user-event 'name-change)
  179.       (with (context (# 'context window)
  180.           label (# 'label context)
  181.           font (# 'font context)
  182.           background (# 'label.background context)
  183.           foreground (# 'label.foreground context)
  184.           tile (label-make (simple-win.name))
  185.           font (# 'active.font context)
  186.           background (# 'active.label.background context)
  187.           foreground (# 'active.label.foreground context)
  188.           atile (label-make (simple-win.name))
  189.         )
  190.         (## 'inactive-label window tile)
  191.         (## 'active-label window atile)
  192.         (wob-tile atile)))
  193.     standard-title-behavior
  194.     standard-behavior))
  195. ))
  196.   
  197. ;;============================================================================
  198. ;; The actual decoration
  199. ;;============================================================================
  200. ;; for customisation: we build a context as the sum of :
  201. ;; - the global defaults: simple-win.context
  202. ;; - the value stored by customize under the 'simple-win resource
  203. ;; - the arguments passed to simple-win
  204. ;; the we obtain a context, that we snapshot by context-save, that we will put
  205. ;; on the window itself (via property) for later use by the fsms
  206.  
  207. (defun simple-win args
  208.   (if (= window root-window)        ; trap user errors
  209.     (trigger-error "Decoration function \"simple-win\" called on root window")
  210.   )
  211.   (setq simple-icon.oldfont font)    ;hack due to bug, we save this value...
  212.   (with-eval (+ simple-win.context
  213.       (get-context (std-resource-get 'SimpleWin 'simple-win))
  214.       args
  215.     )                    ; concatenates the context
  216.     ;; fix default values which are still ()
  217.     (default-if-nil
  218.       active.background background
  219.       active.font font
  220.       active.label.background label.background
  221.       active.label.foreground label.foreground
  222.       active.label.borderwidth label.borderwidth
  223.       active.label.border label.border
  224.     )
  225.     ;; we compute this value to know if we can have a simple fsm if the
  226.     ;; the title plug isn't supposed to change.
  227.     (setq active-label? (not (and
  228.       (= active.background background)
  229.       (= active.font font)
  230.       (= active.label.background label.background)
  231.       (= active.label.foreground label.foreground)
  232.       (= active.label.borderwidth label.borderwidth)
  233.       (= active.label.border label.border)
  234.     )))
  235.     (with (
  236.     fsm window-fsm
  237.     context (context-save simple-win.context) ; snapshot
  238.     grabs window-grabs
  239.     inactive-label (with (
  240.         background label.background
  241.         foreground label.foreground
  242.         borderwidth label.borderwidth
  243.         borderpixel label.border
  244.       )
  245.       (label-make (simple-win.name))
  246.     )
  247.     ;; put context in window property list
  248.     property (+ property (list 'context context)
  249.       (list
  250.         'label label
  251.         'inactive-label (if active-label? inactive-label ())
  252.         'active-label (if active-label? (with (
  253.           font active.font
  254.           background active.label.background
  255.           foreground active.label.foreground
  256.           borderwidth active.label.borderwidth
  257.           borderpixel active.label.border
  258.         )
  259.         (label-make (simple-win.name))
  260.           )
  261.           ()
  262.       ))))
  263.       ;; then build the window
  264.       (setq simple-win.result (window-make
  265.       (if (= legend "top") (simple-win.bar-make))
  266.       (if (= legend "left") (simple-win.bar-make))
  267.       (if (= legend "right") (simple-win.bar-make))
  268.       (if (= legend "base") (simple-win.bar-make))
  269.       ()
  270.   ))))
  271.   (setq font simple-icon.oldfont)    ;hack due to bug
  272.   simple-win.result
  273. )
  274.  
  275. (defun simple-win.bar-make ()
  276.   (with (
  277.       borderwidth (if (= tile t) 0 1)
  278.       fsm simple-win.titlebar-fsm
  279.       expr (+ 
  280.     (list 'bar-make)
  281.     (list-make lpad)
  282.     '((with (
  283.           fsm (if active-label? simple-win.active.label-fsm
  284.         simple-win.label-fsm
  285.         ))
  286.         (with (borderwidth label.borderwidth)
  287.           (plug-make inactive-label)
  288.     )))
  289.     (list-make rpad)
  290.     ))
  291.     (eval expr)
  292. ))
  293.