306 lines
13 KiB
Plaintext
306 lines
13 KiB
Plaintext
;; fvwm-icon.gwm --- FVWM style icons.
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1996 Anders Holst
|
|
;; Last change: 26/2 1996
|
|
;;
|
|
;; This file is copyrighted under the same terms as the rest of GWM
|
|
;; (see the X Inc license for details). There is no warranty that it
|
|
;; works.
|
|
;;
|
|
;; ---------------------------------------------------------------------
|
|
;;
|
|
;; This file defines FVWM style icons that goes with the FVWM style
|
|
;; windows in "fvwm-window.gwm".
|
|
;;
|
|
;; You can set 'fvwm-pixmap-path' to point where the "real" fvwm keeps
|
|
;; its icon files, just to make them look more similar.
|
|
;;
|
|
|
|
(declare-screen-dependent
|
|
fvwm-icon-action
|
|
fvwm-icon-assoc-list
|
|
fvwm-pixmap-path
|
|
)
|
|
|
|
;;
|
|
;; USER CUSTOMIZABLE VARIABLES
|
|
;; ---------------------------
|
|
;; Adjust these in your own profile
|
|
;;
|
|
(with (wob wob)
|
|
(for screen (list-of-screens)
|
|
(defaults-to
|
|
fvwm-icon-action '(iconify-window)
|
|
; Action to execute when pressing the icon title.
|
|
; Can also be a list of ( <button-spec> <action>
|
|
; [<action-type>] ) specifications.
|
|
fvwm-pixmap-path '("/usr/X11R6/include/X11/pixmaps/")
|
|
; Where it is likely to find some good icon pixmaps.
|
|
fvwm-icon-assoc-list '(Emacs "emacs")
|
|
; Mapping between window-client-class and icon file name when
|
|
; the simple window-client-name heuristic does not work.
|
|
; Also, the variable 'fvwm-window-styles' from "fvwm-window.gwm"
|
|
; can contain these additional properties: icon-color,
|
|
; active-icon-color, icon-title-color, active-icon-title-color,
|
|
; icon-action, icon-outer-border.
|
|
)))
|
|
|
|
|
|
(require 'fvwm-window)
|
|
|
|
; THE ICON :
|
|
; ==========
|
|
|
|
|
|
(defun fvwm-inner-iconbar ()
|
|
(with (
|
|
fsm (fsm-make (state-make fvwm-title-behavior
|
|
(fvwm-button-behavior fvwm-icon-action 'release)))
|
|
lseam (fvwm-title-seam-pixmap (# 0 color-scheme) title-width)
|
|
rseam (fvwm-title-seam-pixmap (# 2 color-scheme) title-width)
|
|
alseam (fvwm-title-seam-pixmap (# 0 active-color-scheme) title-width)
|
|
arseam (fvwm-title-seam-pixmap (# 2 active-color-scheme) title-width)
|
|
lredo '(fvwm-title-seam-pixmap
|
|
(# (if pressed 2 0)
|
|
(if active active-color-scheme color-scheme)) title-width)
|
|
rredo '(fvwm-title-seam-pixmap
|
|
(# (if pressed 0 2)
|
|
(if active active-color-scheme color-scheme)) title-width)
|
|
redo-expr '(if pressed
|
|
(with (active-color-scheme
|
|
(list (# 2 active-color-scheme)
|
|
(# 1 active-color-scheme)
|
|
(# 0 active-color-scheme)))
|
|
(fvwm-hbar-tile title-width active 'title))
|
|
(fvwm-hbar-tile title-width active 'title))
|
|
tile (with (active () pressed ()) (eval redo-expr))
|
|
atile (with (active t pressed ()) (eval redo-expr))
|
|
ptile (with (active t pressed t) (eval redo-expr))
|
|
property (list 'pixmap tile
|
|
'activepixmap atile
|
|
'pressedpixmap ptile
|
|
'redo-expr redo-expr)
|
|
bar-min-width title-width
|
|
bar-max-width bar-min-width
|
|
plug-separator 4
|
|
)
|
|
(bar-make
|
|
(with (property (list 'pixmap lseam 'activepixmap alseam
|
|
'pressedpixmap arseam 'redo-expr lredo))
|
|
(plug-make lseam))
|
|
(fvwm-title-plug '(if (= window-icon-name "icon") window-name window-icon-name))
|
|
(with (property (list 'pixmap rseam 'activepixmap arseam
|
|
'pressedpixmap alseam 'redo-expr rredo))
|
|
(plug-make rseam))
|
|
)))
|
|
|
|
(defun fvwm-iconbar (outer-border)
|
|
(with (menu ()
|
|
tile ()
|
|
fsm (fsm-make fvwm-frame-behavior)
|
|
plug-separator 0
|
|
cursor fvwm-frame-cursor
|
|
borderwidth 0
|
|
bar-min-width 0
|
|
bar-max-width 1000
|
|
lseam-expr '(fvwm-title-seam-pixmap
|
|
(# 0 (if active active-color-scheme color-scheme))
|
|
(+ title-width 2))
|
|
rseam-expr '(fvwm-title-seam-pixmap
|
|
(# 2 (if active active-color-scheme color-scheme))
|
|
(+ title-width 2))
|
|
lseam (with (active ()) (eval lseam-expr))
|
|
alseam (with (active t) (eval lseam-expr))
|
|
rseam (with (active ()) (eval rseam-expr))
|
|
arseam (with (active t) (eval rseam-expr))
|
|
lseam-prop (list 'pixmap lseam 'activepixmap alseam
|
|
'redo-expr lseam-expr)
|
|
rseam-prop (list 'pixmap rseam 'activepixmap arseam
|
|
'redo-expr rseam-expr)
|
|
redo-expr '(fvwm-hbar-tile (+ title-width 2) active ())
|
|
tile (with (active ()) (eval redo-expr))
|
|
atile (with (active t) (eval redo-expr))
|
|
property (list 'pixmap tile 'activepixmap atile
|
|
'redo-expr redo-expr)
|
|
bar-min-width (+ title-width 2)
|
|
bar-max-width bar-min-width
|
|
params1 (+
|
|
(with (property lseam-prop)
|
|
(list (plug-make lseam)))
|
|
(with (bar-max-width 10000)
|
|
(list (bar-make () (fvwm-inner-iconbar) ())))
|
|
(with (property rseam-prop)
|
|
(list (plug-make rseam)))))
|
|
(with (borderwidth outer-border)
|
|
(eval (+ '(bar-make) params1)))))
|
|
|
|
;; Test if file exists. This is an ugly hack. Pure luck if it works.
|
|
(defun check-pixmap-file (file)
|
|
(with (res t)
|
|
(error-occurred
|
|
(if (load file)
|
|
(setq res t)
|
|
(setq res ())))
|
|
res))
|
|
|
|
(defun load-pixmap-in-path (file path)
|
|
(if (match "^/" file)
|
|
(if (check-pixmap-file file)
|
|
(pixmap-load file))
|
|
(with (i 0
|
|
len (length path))
|
|
(while (and (< i len) (not (check-pixmap-file (+ (# i path) file))))
|
|
(setq i (+ i 1)))
|
|
(if (< i len)
|
|
(pixmap-load (+ (# i path) file))))))
|
|
|
|
(setq fvwm-icon-pixmap-behavior
|
|
(state-make
|
|
(on (user-event 'focus-in)
|
|
(wob-tile (# 'activepixmap wob-property)))
|
|
(on (user-event 'focus-out)
|
|
(wob-tile (# 'pixmap wob-property)))
|
|
(on (user-event 're-color)
|
|
(with (background (# 1 active-color-scheme)
|
|
foreground (# 3 active-color-scheme)
|
|
apm (window-icon-pixmap)
|
|
background (# 1 color-scheme)
|
|
foreground (# 3 color-scheme)
|
|
npm (window-icon-pixmap))
|
|
(wob-tile (if (eq (wob-tile) (# 'activepixmap wob-property))
|
|
apm npm))
|
|
(## 'pixmap wob npm)
|
|
(## 'activepixmap wob apm)
|
|
(## 'bg wob (# 1 color-scheme))
|
|
(## 'abg wob (# 1 active-color-scheme))
|
|
(## 'fg wob (# 3 color-scheme))
|
|
(## 'afg wob (# 3 active-color-scheme))))
|
|
(on (user-event 'icon-pixmap-change)
|
|
(with (background (# 'abg wob-property)
|
|
foreground (# 'afg wob-property)
|
|
apm (window-icon-pixmap)
|
|
background (# 'bg wob-property)
|
|
foreground (# 'fg wob-property)
|
|
npm (window-icon-pixmap))
|
|
(wob-tile (if (eq (wob-tile) (# 'activepixmap wob-property))
|
|
apm npm))
|
|
(## 'pixmap wob npm)
|
|
(## 'activepixmap wob apm)))))
|
|
|
|
(defun fvwm-iconcenter ()
|
|
(or (with (fsm ())
|
|
(window-icon-window))
|
|
(with (borderwidth 0
|
|
background (# 1 active-color-scheme)
|
|
foreground (# 3 active-color-scheme)
|
|
apm (window-icon-pixmap)
|
|
background (# 1 color-scheme)
|
|
foreground (# 3 color-scheme)
|
|
npm (window-icon-pixmap)
|
|
fsm (fsm-make fvwm-icon-pixmap-behavior)
|
|
property (list 'pixmap npm
|
|
'activepixmap apm
|
|
'bg (# 1 color-scheme)
|
|
'abg (# 1 active-color-scheme)
|
|
'fg (# 3 color-scheme)
|
|
'afg (# 3 active-color-scheme)))
|
|
(if npm (plug-make npm)))
|
|
(with (fsm ()
|
|
file (+ (or (# (atom window-client-class) fvwm-icon-assoc-list)
|
|
window-client-name) ".xpm")
|
|
pmap (load-pixmap-in-path file fvwm-pixmap-path))
|
|
(if pmap (plug-make pmap)))))
|
|
|
|
(setq fvwm-icon-behavior
|
|
(state-make
|
|
(on focus-out (send-user-event 'focus-out window))
|
|
(on focus-in (send-user-event 'focus-in window))
|
|
(on leave-window-not-from-grab (send-user-event 'focus-out window))
|
|
(on enter-window (send-user-event 'focus-in window))
|
|
(on (user-event 'update-color)
|
|
(with (props (matches-cond-all fvwm-window-styles)
|
|
cols (fvwm-get-icon-colors (matches-cond fvwm-color-styles) props)
|
|
title-width (# 'title-width window)
|
|
color-scheme (make-color-scheme (# 0 cols) (# 2 cols))
|
|
active-color-scheme (make-color-scheme (# 1 cols) (# 3 cols)))
|
|
(send-user-event 'pre-color window)
|
|
(send-user-event 're-color window)))
|
|
(on name-change
|
|
(progn
|
|
(send-user-event 'name-change)
|
|
(if (boundp 'update-placements)
|
|
(update-placements))
|
|
(if (boundp 'icon-mgr-update)
|
|
(icon-mgr-update))))
|
|
(on (property-change "WM_ICON_NAME")
|
|
(progn
|
|
(if (window-icon?)
|
|
(send-user-event 'name-change window-icon))
|
|
(if (boundp 'update-placements)
|
|
(update-placements))
|
|
(if (boundp 'icon-mgr-update)
|
|
(icon-mgr-update))))
|
|
(on window-icon-pixmap-change
|
|
(send-user-event 'icon-pixmap-change window-icon))
|
|
)
|
|
)
|
|
|
|
(defun fvwm-get-icon-colors (styles props)
|
|
(with (col (or (fvwm-get-style props 'icon-color
|
|
(fvwm-get-style props 'color ()))
|
|
(# 0 styles)
|
|
fvwm-color)
|
|
acol (or (fvwm-get-style props 'active-icon-color
|
|
(fvwm-get-style props 'active-color
|
|
(or (# 1 styles)
|
|
fvwm-active-color)))
|
|
col)
|
|
tcol (or (fvwm-get-style props 'icon-title-color
|
|
(fvwm-get-style props 'title-color ()))
|
|
(# 2 styles)
|
|
fvwm-title-color
|
|
"black")
|
|
atcol (or (fvwm-get-style props 'active-icon-title-color
|
|
(fvwm-get-style props 'active-title-color
|
|
(or (# 3 styles)
|
|
fvwm-active-title-color)))
|
|
tcol))
|
|
(list col acol tcol atcol)))
|
|
|
|
(defun fvwm-icon ()
|
|
(with (fsm (fsm-make (state-make icon-behavior fvwm-icon-behavior standard-behavior))
|
|
cursor fvwm-frame-cursor
|
|
props (matches-cond-all fvwm-window-styles)
|
|
cols (fvwm-get-icon-colors (matches-cond fvwm-color-styles) props)
|
|
title-font (fvwm-get-style props 'title-font fvwm-title-font)
|
|
fonthgt (with (font title-font
|
|
label-vertical-margin 0
|
|
label-horizontal-margin 0)
|
|
(# 3 (dimensions " ")))
|
|
title-width (or (fvwm-get-style props 'title-width fvwm-title-width)
|
|
(+ 4 fonthgt))
|
|
fvwm-icon-action (fvwm-get-style props 'icon-action fvwm-icon-action)
|
|
outer-border (fvwm-get-style props 'icon-outer-border
|
|
(fvwm-get-style props 'outer-border
|
|
fvwm-outer-border))
|
|
color-scheme (make-color-scheme (# 0 cols) (# 2 cols))
|
|
active-color-scheme (make-color-scheme (# 1 cols) (# 3 cols))
|
|
borderwidth 0
|
|
inner-borderwidth 0
|
|
borderpixel black
|
|
property (list 'title-width title-width)
|
|
center (fvwm-iconcenter)
|
|
label (fvwm-iconbar (if outer-border
|
|
(if (= (type outer-border) 'number)
|
|
outer-border 1) 0)))
|
|
(if center
|
|
(with (tile t)
|
|
(window-make ()
|
|
(with (fsm ()) (bar-make ()))
|
|
(with (fsm ()) (bar-make ()))
|
|
(with (fsm ()) (bar-make () (bar-make label) ()))
|
|
center))
|
|
(window-make () () () label ()))))
|
|
|