home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / term-icon-xpm.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  3KB  |  97 lines
  1. ; ICON with window name embedded into 8 XPM pixmaps
  2. ; =================================================
  3.  
  4. ;;File: term-icon-xpm.gwm
  5. ;; usage:
  6. ;;     (term-icon-xpm name-radix font text-background-color text-color)
  7. ;; builds an icon by adding 8 xpm files around the name of the icon
  8. ;; xpm files are built by appending to "name-radix" the strings
  9. ;; "-nw.xpm", "-n.xpm", "-ne.xpm", "-e.xpm" "-se.xpm", "-s.xpm", "-sw.xpm",
  10. ;; "-w.xpm" in clockwise order from top left.
  11. ;; the global variable  term-icon:background can be set to a color that would 
  12. ;; override the symbolic color "background" in the xpm files if present
  13. ;; text-background-color and text-color are used to create the text colors, 
  14. ;; but override also the symbolic color names "fore" and "back" in the
  15. ;; pixmaps
  16.  
  17.  
  18. ;;=============================================================================
  19. ;;                    define the screen-dependent resources
  20. ;;=============================================================================
  21.  
  22.  
  23. ;; fsm
  24. ;;====
  25.  
  26. (: term-icon-xpm:plug-fsm
  27.   (fsm-make
  28.     (state-make
  29.       icon-behavior
  30.       (on (user-event 'get-title)
  31.     (term-icon-xpm:update-plug update-icon.title))
  32.       (on (user-event 'get-icon)
  33.     (term-icon-xpm:update-plug window-icon-name))
  34.       standard-behavior
  35. )))
  36.  
  37. (de term-icon-xpm:update-plug (string)
  38.   (with-eval (wob-property)
  39.     (wob-tile (label-make string))
  40.     (update-placements)
  41. ))
  42.  
  43. (if (not (boundp 'term-icon:background))
  44.   (setq term-icon:background black)
  45. )
  46.  
  47. ;;=============================================================================
  48. ;;                    The deco
  49. ;;=============================================================================
  50.  
  51. (defun term-icon-xpm (term-icon:name term-icon:font term-icon:back
  52.     term-icon:fore
  53.   )
  54.   (with-eval
  55.     (get-context (std-resource-get 'TermIconXpm 'term-icon-xpm))
  56.     (with (fsm icon-fsm
  57.     grabs icon-grabs menu 'icon-pop
  58.     bar-min-width 0 bar-max-width 100
  59.     borderwidth 0
  60.       )
  61.       (window-make 
  62.     (with (tile (term-icon:tile "n"))
  63.       (bar-make   
  64.         (plug-make (term-icon:tile "nw"))
  65.         ()
  66.         (plug-make (term-icon:tile "ne"))
  67.     ))
  68.     (with (tile (term-icon:tile "w")) (bar-make  ))
  69.     (with (tile (term-icon:tile "e")) (bar-make  ))
  70.     (with (tile (term-icon:tile "s"))
  71.       (bar-make   
  72.         (plug-make (term-icon:tile "sw"))
  73.         ()
  74.         (plug-make (term-icon:tile "se"))
  75.     ))
  76.     (with (fsm term-icon-xpm:plug-fsm
  77.         property (list 'font term-icon:font 'foreground term-icon:fore
  78.           'background term-icon:back
  79.           'label-horizontal-margin 0
  80.           'label-vertical-margin 0)
  81.         font term-icon:font
  82.         foreground term-icon:fore
  83.         background term-icon:back
  84.         label-horizontal-margin 0
  85.         label-vertical-margin 0
  86.       )
  87.       (plug-make 
  88.         (label-make window-icon-name))))
  89. )))
  90.  
  91. (defun term-icon:tile (name)
  92.   (pixmap-load (+ term-icon:name "-" name ".xpm")
  93.     'back term-icon:back
  94.     'fore term-icon:fore
  95.     'background term-icon:background
  96. ))
  97.