197 lines
6.4 KiB
Plaintext
197 lines
6.4 KiB
Plaintext
; SIMPLE ICON DECORATION
|
|
; =======================
|
|
|
|
;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
|
|
;;Revision: 1.6 -- Mar. 1, 1990
|
|
|
|
; A simple icon "a la Mac", following fully the ICCCs
|
|
|
|
(declare-screen-dependent
|
|
simple-icon.screen-data
|
|
simple-icon.foreground
|
|
simple-icon.background
|
|
simple-icon.borderpixel
|
|
simple-icon.context)
|
|
|
|
(defaults-to
|
|
simple-icon.legend ()
|
|
simple-icon.borderwidth 1
|
|
simple-icon.plug-name ()
|
|
simple-icon.no-center-plug ()
|
|
simple-icon.label ()
|
|
simple-icon.stretch ()
|
|
simple-icon.font small-font
|
|
)
|
|
|
|
;; define here the screen-dependent resources
|
|
(if (not (boundp 'simple-icon)) ;define only once
|
|
(with (wob wob)
|
|
|
|
;; user-settable defaults
|
|
(for screen (list-of-screens)
|
|
(defaults-to
|
|
simple-icon.foreground black
|
|
simple-icon.background white
|
|
simple-icon.borderpixel black)
|
|
|
|
(setq simple-icon.context
|
|
'(font simple-icon.font
|
|
legend simple-icon.legend
|
|
foreground simple-icon.foreground
|
|
background simple-icon.background
|
|
borderwidth simple-icon.borderwidth
|
|
borderpixel simple-icon.borderpixel
|
|
label simple-icon.label
|
|
stretch simple-icon.stretch
|
|
)))
|
|
|
|
))
|
|
|
|
(: simple-icon.title-fsm
|
|
(fsm-make
|
|
(state-make
|
|
icon-behavior
|
|
(on (user-event 'get-title) (update-plug-in-icon update-icon.title))
|
|
(on (user-event 'get-icon) (update-plug-in-icon window-icon-name))
|
|
;; if icon pixmap set after creation, redecorate.
|
|
(on (user-event 'icon-pixmap-change)
|
|
(if (# 'no-center-plug window)
|
|
(re-decorate-window)))
|
|
standard-behavior
|
|
)))
|
|
|
|
(de simple-icon.center-plug ()
|
|
(if (not simple-icon.no-center-plug)
|
|
(or (window-icon-window)
|
|
(with (tmp (std-resource-get 'GwmIconPixmap))
|
|
(if (not (= (type tmp) 'pixmap))
|
|
(progn
|
|
(: tmp (eval tmp))
|
|
(if (and tmp (# (type tmp) string-types))
|
|
(: tmp (pixmap-make tmp)))))
|
|
(if (and tmp (= (type tmp) 'pixmap))
|
|
(plug-make tmp)))
|
|
(with (tmp (window-icon-pixmap)
|
|
fsm icon-center-plug-with-pixmap-hint-fsm)
|
|
(if tmp
|
|
(plug-make tmp))))
|
|
(window-icon-window)))
|
|
|
|
(: icon-center-plug-with-pixmap-hint-fsm (fsm-make
|
|
(state-make
|
|
(on (buttonrelease 2 any) (progn (iconify-window)(raise-window)))
|
|
(on (user-event 'icon-pixmap-change)
|
|
(with-eval (# 'context wob)
|
|
(wob-tile (window-icon-pixmap))
|
|
(update-placements)))
|
|
icon-behavior
|
|
standard-behavior
|
|
)))
|
|
|
|
(de update-plug-in-icon (string)
|
|
(with-eval (# 'context wob)
|
|
(wob-tile (label-make (simple-icon.process-label string)))
|
|
(update-placements)
|
|
))
|
|
|
|
(de simple-icon.process-label (text)
|
|
(with (new-label
|
|
(if label
|
|
(if
|
|
(= (type label) 'string)
|
|
label
|
|
(eval (list label text))
|
|
)
|
|
text
|
|
))
|
|
(if (and (= (type new-label) 'string) (not (= "" new-label)))
|
|
new-label
|
|
text
|
|
)
|
|
))
|
|
|
|
(de simple-icon.label-plug ()
|
|
(with (borderwidth 0
|
|
fsm simple-icon.title-fsm)
|
|
(plug-make
|
|
(label-make (if simple-icon.plug-name
|
|
simple-icon.plug-name
|
|
(simple-icon.process-label window-icon-name))))))
|
|
|
|
|
|
(de simple-icon args
|
|
(with-eval
|
|
(+ simple-icon.context
|
|
(get-context (std-resource-get 'SimpleIcon 'simple-icon))
|
|
args
|
|
)
|
|
(with (fsm icon-fsm
|
|
context (context-save simple-icon.context)
|
|
menu 'icon-pop
|
|
grabs icon-grabs
|
|
center-plug (simple-icon.center-plug)
|
|
property (+ (list 'context context
|
|
'no-center-plug (not center-plug)) property)
|
|
label-plug (if (or legend (not center-plug))
|
|
(simple-icon.label-plug))
|
|
inner-borderwidth 0
|
|
)
|
|
(if (not center-plug)
|
|
(window-make () () () () label-plug)
|
|
(not legend)
|
|
(window-make () () () () center-plug)
|
|
(not stretch)
|
|
(with (bar (with (borderwidth 0) (bar-make () label-plug ())))
|
|
(if (= legend "top")
|
|
(window-make bar () () () center-plug)
|
|
(= legend "left")
|
|
(window-make () bar () () center-plug)
|
|
(= legend "right")
|
|
(window-make () () bar () center-plug)
|
|
(window-make () () () bar center-plug)))
|
|
(or (= legend "left") (= legend "right"))
|
|
(with (inner-borderwidth borderwidth
|
|
borderwidth 0
|
|
plug-separator 0
|
|
tile t ;transparent background for stretch
|
|
lab (if (= stretch "down")
|
|
(bar-make label-plug ())
|
|
(= stretch "up")
|
|
(bar-make () label-plug)
|
|
(bar-make () label-plug ()))
|
|
cent (if (= stretch "down")
|
|
(bar-make center-plug ())
|
|
(= stretch "up")
|
|
(bar-make () center-plug)
|
|
(bar-make () center-plug ()))
|
|
bar (if (= legend "left")
|
|
(bar-make lab cent)
|
|
(bar-make cent lab)))
|
|
(if (not (= (type center-plug) 'plug))
|
|
(window-make ()
|
|
(if (= legend "left") lab)
|
|
(if (= legend "right") lab)
|
|
()
|
|
center-plug)
|
|
(window-make bar () () () ())))
|
|
t
|
|
(with (inner-borderwidth borderwidth
|
|
borderwidth 0
|
|
tile t ;transparent background for stretch
|
|
bar (if (= stretch "left")
|
|
(bar-make () label-plug)
|
|
(= stretch "right")
|
|
(bar-make label-plug ())
|
|
(bar-make () label-plug ())))
|
|
(window-make (if (= legend "top") bar ())
|
|
(if (not (= stretch "right"))
|
|
(bar-make ())
|
|
())
|
|
(if (not (= stretch "left"))
|
|
(bar-make ())
|
|
())
|
|
(if (not (= legend "top")) bar ())
|
|
center-plug))))))
|
|
|
|
|