home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 22 gnu
/
22-gnu.zip
/
gwm18a.zip
/
data
/
mwm-menus.gwm
< prev
next >
Wrap
Lisp/Scheme
|
1995-07-03
|
32KB
|
1,183 lines
;;File: std-popups.gwm --
;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
;;Author: Frederic CHARTON
;;Revision: 1.0 -- Sep 12 1989
;;State: Exp
;;GWM Version: 1.4
; Pop-ups
; =======
(defname 'pop-item-font screen. menuFontList)
(defname 'pop-item-height screen. 18)
(defname 'pop-label-font screen. menuFontList)
(with (font menuFontList) (: item-height (+ 4 (height "A"))))
; Offset for cascading menus :
(: menu.offset.x 8)
(: menu.offset.y -4)
(: menu-right-arrow
(with (
borderwidth 0
fsm ()
)
(plug-make
(pixmap-make menuBackground "right-arrow" menuForeground)
)
)
)
; Left and right plugs for items (-> 3D look)
(de border-plug-make (top h)
(with ( foreground (if top menuTopShadowColor menuBottomShadowColor)
fsm ()
borderwidth 0
)
(plug-make (pixmap-make 2 h) )
)
)
(: border-plug-right (border-plug-make () item-height))
(: border-plug-left (border-plug-make t item-height))
(: corner-plug (with (borderwidth 0 fsm ())
(plug-make (pixmap-make menuTopShadowColor
"cornerPlug" menuBottomShadowColor) ) ))
(: top-bar-menu
(with (fsm () borderwidth 0 background menuTopShadowColor
bar-min-width 2
bar-max-width 2)
(bar-make () corner-plug)
)
)
(: bottom-bar-menu
(with (fsm () borderwidth 0 background menuBottomShadowColor
bar-min-width 2
bar-max-width 2)
(bar-make corner-plug ())
)
)
;-------------------------------------------------------------------------
; MENU.MAKE : args = list of items obtained by item-make or pop-label-make
; =========
(df menu.make args
(with (
borderwidth 0
menu ()
cursor menu-cursor
myMenu (eval (+ '(menu-make)
(+
'(top-bar-menu)
'(blank-item-separator)
args
'(blank-item-separator)
'(bottom-bar-menu))))
)
(send-user-event 'make-opened-tile (menu-wob myMenu))
myMenu
)
)
;-------------------------------------------------------------------------
; MENU.MOVE : places the menu inside the screen
; =========
(de menu.move (theMenu x y)
(with (theMenuWob (menu-wob theMenu)
w (width theMenuWob)
h (height theMenuWob)
)
(if (> (+ y h) screen-height)
(: y (- screen-height h)))
(if (> (+ x w) screen-width)
(: x (- screen-width w)))
(move-window theMenuWob x y)
)
)
;-------------------------------------------------------------------------
; MENU.POP : "pop" of a menu : args = (menu-to-pop button-to-use <'here>)
; ========
(de menu.pop args
(with (menu-to-pop (if args (# 0 args) wob-menu)
window-of-menu window)
(if (# 1 args) (: button-menu (# 1 args)))
(send-user-event 'update-items (menu-wob menu-to-pop))
(send-user-event 'activate-menu (menu-wob menu-to-pop))
(## 'current-valid-item (menu-wob menu-to-pop) 0)
(if (> (current-event-code) 5)
(send-user-event 'select-item (# 0 (# 'valid-items
(menu-wob menu-to-pop)))))
(## 'menu-son wob (menu-wob menu-to-pop))
(## 'already-popped (menu-wob menu-to-pop) t)
(## 'father (menu-wob menu-to-pop) wob)
(setq popping-window window)
(with (grab-keyboard-also t)
(if (member 'here args)
(pop-menu menu-to-pop 'here)
(pop-menu menu-to-pop)
))
(send-user-event 'set-grabs (menu-wob menu-to-pop))
))
;-------------------------------------------------------------------------
; Borders plugs of item separators
(: separator-plug-left
(with (
fsm ()
borderwidth 0
foreground menuBackground
plug-tile (pixmap-make 4 3)
foreground menuTopShadowColor
)
(draw-line plug-tile 0 0 0 2)
(draw-line plug-tile 1 0 1 2)
(plug-make plug-tile)
)
)
(: separator-plug-right
(with (
fsm ()
borderwidth 0
foreground menuBackground
plug-tile (pixmap-make 4 3)
foreground menuBottomShadowColor
)
(draw-line plug-tile 2 0 2 2)
(draw-line plug-tile 3 0 3 2)
(plug-make plug-tile)
)
)
; Blank item separator (space between two consecutive items)
(: blank-item-separator
(with (fsm () borderwidth 0
background menuBackground
bar-min-width 3 )
(bar-make separator-plug-left () separator-plug-right )
)
)
; Item separator (line between two consecutive items)
(: item-separator
(with (fsm () borderwidth 0
tile (pixmap-make menuBackground "itemSep" menuForeground)
bar-min-width 3 background menuBottomShadowColor)
(bar-make separator-plug-left () separator-plug-right )
)
)
;-------------------------------------------------------------------------
; VARIOUS UTILITIES :
; =-=-=-=-=-=-=-=-=
; Good button checking :
(df check-button ()
(= button-menu (current-event-code))
)
(df valid-items eventual-wob
(if eventual-wob
(with (wob (eval (# 0 eventual-wob)))
(# 'valid-items wob)
)
(# 'valid-items wob)
)
)
(df set-valid-items args
(with (item-nb (eval (# 0 args)) eventual-wob (eval (# 1 args)))
(if eventual-wob
(with (wob (eval eventual-wob))
(## 'valid-items wob item-nb)
)
(## 'valid-items wob item-nb)
)
)
)
(df nb-valid-items ()
(length (# 'valid-items wob))
)
(df current-valid-item eventual-wob
(if eventual-wob
(with (wob (eval (# 0 eventual-wob)))
(# 'current-valid-item wob)
)
(# 'current-valid-item wob)
)
)
(de set-current-valid-item (item-nb)
(## 'current-valid-item wob item-nb)
)
; Is the action "f.menu" ?
(df action-is-f.menu ()
(= 'f.menu (# 0 (# 'action wob)))
)
(df menu-wob-of-action ()
(menu-wob (eval (# 1 (# 'action wob))))
)
(df menu-of-action ()
(eval (# 1 (# 'action wob)))
)
; The oldest menu father of the menu
(de menu-oldest-father (theWob)
(with (father (or (# 'father theWob) root-window))
(if (with (wob father) (= 'menu wob-status))
(menu-oldest-father father)
theWob
)
)
)
; The oldest father of the menu to grab
(de oldest-father-for-grab (theWob)
(with (father (or (# 'father theWob) root-window))
(if (with (wob father) (= 'menu wob-status))
(menu-oldest-father father)
(if (# 'is-button-menu father) father theWob)
)
)
)
; Setting of the current item :
(df fix-current-item ()
(with (i 0 listOfValidItems (valid-items wob-parent)
current-item (# i listOfValidItems))
(while current-item
(if (= wob current-item)
(progn
(with (wob wob-parent)
(## 'current-valid-item wob i)
)
(: current-item ())
)
(progn
(: i (+ i 1))
(: current-item (# i listOfValidItems))
)
)
)
)
)
(: menus-basic-state
(state-make
(on (user-event 'select-item)
(wob-tile (# 'opened-tile wob)))
(on (user-event 'goto-opened) () opened)
(on (user-event 'goto-activable) () activable)
(on (user-event 'depop) (: wob-background menuBackground) activable)
(on (user-event 'unselect-item)
(progn
(with (wob wob-parent)
(if (# 'item-menu-son wob)
(send-user-event 'depop (# 'menu-son wob)))
)
(: wob-background menuBackground)
)
)
(on (user-event 'test-item-menu-popped)
(if (action-is-f.menu)
(: in-item-menu-popped
(and (> cerx 0)
(> cery 0)
(< cerx wob-width)
(< cery wob-height)
)
)
)
)
)
)
;-------------------------------------------------------------------------
; ========================================================================
; ITEMS' FSM : 4 states : activable / non-activable / closed / opened
; ========================================================================
(setq menus.fsm
(fsm-make
;-----------------------------------------------------------ACTIVABLE
(: activable
(state-make
(on (buttonpress any any)
(if (check-button)
(progn
(if (# (current-valid-item wob-parent) (valid-items wob-parent))
(send-user-event
'unselect-item
(# (current-valid-item wob-parent) (valid-items wob-parent))
)
)
(if (action-is-f.menu)
(if (# 'already-popped wob)
(progn
(send-user-event 'unselect-item
(# (current-valid-item (menu-wob-of-action))
(valid-items (menu-wob-of-action)))
)
)
(progn
(with (theWob wob wob wob-parent)
(## 'item-menu-son wob theWob)
)
(menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x)
(+ wob-y menu.offset.y))
(with (theMenu (menu-of-action) wob wob-parent)
(menu.pop theMenu button-menu 'here))
)
)
)
(wob-tile (# 'opened-tile wob))
(send-user-event 'activate-menu (menu-oldest-father wob-parent))
(send-user-event 'goto-opened wob)
)
)
)
(on (user-event 'update-items)
(if (not
(with (condition (# 'enable-condition wob )
wob window-of-menu)
(eval condition))
)
(send-user-event 'disable-item wob)
(set-valid-items (+ (valid-items wob-parent) (list wob)) wob-parent)
)
)
(on (user-event 'disable-item) () non-activable)
(on (user-event 'activate-menu)
(if (= wob (# (current-valid-item wob-parent) (valid-items wob-parent)))
(if (or (not (action-is-f.menu))
(not (= wob (with (wob wob-parent) (# 'item-menu-son wob)))))
(: wob-background menuBackground)
)
)
closed)
(on (user-event 'make-opened-tile)
(## 'opened-tile wob (item-tile.make wob-width wob-height))
)
menus-basic-state
)
)
;-----------------------------------------------------------NON-ACTIVABLE
(: non-activable
(state-make
(on (buttonpress any any)
(if (check-button)
(send-user-event 'activate-menu (menu-oldest-father wob-parent))
)
)
(on (buttonrelease any any)
(if (check-button)
(send-user-event 'depop (menu-oldest-father wob-parent))
)
)
(on (user-event 'update-items)
(if
(with (condition (# 'enable-condition wob)
wob window-of-menu)
(eval condition))
(progn
(send-user-event 'enable-item wob)
(set-valid-items (+ (valid-items wob-parent) (list wob))
wob-parent)
)
)
)
(on (user-event 'enable-item) () activable)
)
)
;-----------------------------------------------------------CLOSED
(: closed
(state-make
(on enter-window
(progn
(: wob-tile (# 'opened-tile wob))
(if (action-is-f.menu)
(if (not (# 'already-popped wob))
(progn
(with (theWob wob theMenu (menu-wob-of-action) wob wob-parent)
(## 'item-menu-son wob theWob)
)
(menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x)
(+ wob-y menu.offset.y))
(with (theMenu (menu-of-action) wob wob-parent)
(menu.pop theMenu button-menu 'here))
(fix-current-item)
)
)
)
)
opened)
menus-basic-state
)
)
;-----------------------------------------------------------OPENED
(: opened
(state-make
(on (buttonpress any any)
(if (and (check-button) (action-is-f.menu))
(send-user-event 'activate-menu (menu-oldest-father wob-parent))
)
)
(on (buttonrelease any any)
(if (check-button)
(if (action-is-f.menu)
(progn
(fix-current-item)
(with (wob (menu-wob-of-action))
(## 'current-valid-item wob 0))
(with (theWob (oldest-father-for-grab wob-parent))
(if (# 'is-button-menu theWob)
(send-user-event 'button-release theWob))
)
(send-user-event 'goto-activable (menu-oldest-father wob-parent))
(send-user-event 'select-item
(# 0 (valid-items (menu-wob-of-action))) )
)
(progn
(setq std-popups.action (# 'action wob))
(send-user-event 'goto-activable (menu-oldest-father wob-parent))
(send-user-event 'depop (menu-oldest-father wob-parent))
(: wob-background menuBackground)
(wob wob-parent)
(wob (# 'father wob))
(with (window popping-window action-by-menu t) (eval std-popups.action))
)
)
)
)
(on leave-window
(if (action-is-f.menu)
(with (cerx (current-event-relative-x)
cery (current-event-relative-y))
(if (not
(and (> cerx 0)
(> cery 0)
(< cerx wob-width)
(< cery wob-height)
) )
(with (cex (current-event-x) cey (current-event-y)
in-menu-son ())
(send-user-event 'in-menu-son-test (menu-wob-of-action))
(if (not in-menu-son)
(progn
(: wob-background menuBackground )
(send-user-event 'goto-activable (menu-wob-of-action))
(send-user-event 'unselect-item
(# (current-valid-item (menu-wob-of-action))
(valid-items (menu-wob-of-action))))
(send-user-event 'depop (menu-wob-of-action))
(send-user-event 'goto-closed wob)
)
)
)
)
)
(progn
(: wob-background menuBackground )
(send-user-event 'goto-closed wob)
)
)
)
(on (user-event 'goto-closed) () closed)
(on (user-event 'unselect-item) (: wob-background menuBackground))
menus-basic-state
)
)
)
)
;-------------------------------------------------------------------------
; MNEMO-LABEL-MAKE : making of a label with is underlined mnemonic
; ================ or of the pixmap designed by the file "@file" .
(de mnemo-label-make (label mnemo)
(if (eq 0 (member "@" label))
(with ( pixmapFile (match "@\\(.*\\)" label 1))
(pixmap-make menuBackground pixmapFile menuForeground)
)
(if mnemo
(with (
foreground menuForeground
background menuBackground
before-mnemo (match (+ "\\(.*\\)" mnemo) label 1)
after-mnemo (match (+ "\\(.*" mnemo "\\)") label 1)
font menuFontList
x1 (if (and before-mnemo
(not (= before-mnemo "")))
(- (width before-mnemo) label-horizontal-margin)
label-horizontal-margin)
x2 (- (width after-mnemo) label-horizontal-margin)
y (- item-height 6)
)
;(? before-mnemo "!!" after-mnemo "!!" x1 "!!" x2 "\n")
(draw-line (label-make label) (- x1 1) y (- x2 2) y)
)
(with (
foreground menuForeground
background menuBackground
font menuFontList
)
(label-make label)
)
)
)
)
;-------------------------------------------------------------------------
; ITEM-TILE.MAKE : making of the selected framework of an item
; ==============
(de item-tile.make (w h)
(with (
foreground menuBackground
item-tile (pixmap-make (+ w (* 2 plug-separator)) h)
item-xmax (- w 5)
item-ymax (- h 1)
)
(with (foreground menuTopShadowColor)
(draw-line item-tile 4 0 item-xmax 0 )
(draw-line item-tile 4 1 item-xmax 1 )
(draw-line item-tile 4 0 4 item-ymax)
(draw-line item-tile 5 0 5 item-ymax)
)
(with (foreground menuBottomShadowColor)
(draw-line item-tile 4 item-ymax item-xmax item-ymax )
(draw-line item-tile 5 (- item-ymax 1) item-xmax (- item-ymax 1))
(draw-line item-tile item-xmax 0 item-xmax item-ymax )
(draw-line item-tile (- item-xmax 1) 1 (- item-xmax 1) item-ymax )
)
item-tile
)
)
;-------------------------------------------------------------------------
; ITEM-MAKE :
; =========
; args : (label mnemonic action enable-condition blank-plug accelerator)
(df item-make args
(with (
label (+ (# 0 args) "") ; assure que 'label' est une string
label-is-bitmap (eq 0 (member "@" label))
mnemo (# 1 args) action (# 2 args)
blank-plug (# 4 args) accelerator (# 5 args)
property (+
'(opened-tile ())
(list 'enable-condition (if (> (length args) 3) (# 3 args) t))
(list 'action action)
(list 'mnemonic mnemo)
'(already-popped ())
)
borderwidth 0
enable-pixmap (mnemo-label-make label mnemo)
bar-min-width (+
(if label-is-bitmap 8 4)
(height enable-pixmap))
plug-separator 4
fsm menus.fsm
background menuBackground
)
(bar-make
(if label-is-bitmap (border-plug-make t bar-min-width)
border-plug-left)
(with (borderwidth 0 font pop-item-font
menuForeground ; Dynamic binding hack--boo hiss
(if shadeDisabled
menuShadeColor
menuForeground)
background menuBackground
disable-pixmap (mnemo-label-make label mnemo)
property (list 'item-label label 'mnemo mnemo
'enable-pixmap enable-pixmap
'disable-pixmap
(if shadeDisabled disable-pixmap
(with (foreground menuForeground)
(draw-line disable-pixmap
0 (/ (height disable-pixmap) 2)
(width disable-pixmap)
(/ (height disable-pixmap) 2))))
)
fsm
(fsm-make (state-make
(on (user-event 'enable-item)
(: wob-tile (# 'enable-pixmap wob))
)
(on (user-event 'disable-item)
(: wob-tile (# 'disable-pixmap wob))
)
)
))
(plug-make enable-pixmap)
)
blank-plug
(if (not (= (# 0 action) 'f.menu)) accelerator)
()
(if (= (# 0 action) 'f.menu) menu-right-arrow)
(if label-is-bitmap (border-plug-make () bar-min-width) border-plug-right)
) )
)
;-------------------------------------------------------------------------
; POP-LABEL-MAKE : making of the menu's title
; ==============
(df pop-label-make (label)
(with (fsm ()
background menuBackground
foreground menuForeground
borderwidth 0
bar-min-width item-height bar-max-width item-height
plug-separator 4
)
(bar-make
border-plug-left
()
(with (borderwidth 0 font pop-label-font
background menuBackground foreground menuForeground)
(plug-make (mnemo-label-make label ())))
()
border-plug-right
)
)
)
;-------------------------------------------------------------------------
(de youngest-son (theWob)
(with (wob theWob son (# 'menu-son wob))
(if son (youngest-son son) wob)
)
)
(de propagate-key-event (user-evt-name)
(if (# 'menu-son wob)
(send-user-event user-evt-name (youngest-son wob))
(send-user-event user-evt-name wob)
)
)
; UPDATE-GRAB : grabs the server with flag "grab-keyboard-also" to true
; =========== on the menu oldest father of the wob, then grabs the server
; on the oldest father with flag "grab-keyborad-also" to false.
(de update-grab ()
(with (
o-father (oldest-father-for-grab wob)
m-o-father (menu-oldest-father wob)
)
(with (grab-keyboard-also t) (grab-server m-o-father))
(if (not (= o-father m-o-father)) (grab-server o-father))
)
)
; MENUS' FSM :
; ==========
(: pop-fsm
(fsm-make
(: pop-state (state-make
(on enter-window
(progn
(if (and (not (current-event-from-grab)) (# 'active wob))
(progn
(if (# 'menu-son wob)
(progn
(: in-item-menu-popped ())
(with (
cerx
(current-event-relative-x)
cery
(- (+ (current-event-relative-y) wob-y)
(with (wob (# 'item-menu-son wob)) wob-y))
)
(send-user-event 'test-item-menu-popped (# 'item-menu-son wob))
)
(if (not in-item-menu-popped)
(progn
(send-user-event 'goto-closed (# 'item-menu-son wob))
(send-user-event 'unselect-item (# 'item-menu-son wob))
;(send-user-event 'depop (# 'menu-son wob))
)
)
)
)
)
) )
)
(on (buttonpress any any)
(if (check-button)
(progn
(if (and double-click-required (= button-menu 1))
(progn
(if (< (- (current-event-time) time-of-last-release)
doubleClickTime)
(send-user-event 'double-click double-click-required)
)
(: double-click-required ())
)
)
(send-user-event 'activate-menu (menu-oldest-father wob))
)
)
)
(on (buttonrelease any any)
(if (check-button) (send-user-event 'depop (menu-oldest-father wob))) )
(on (user-event 'depop)
(progn
(if (# 'menu-son wob)
(send-user-event 'depop (# 'menu-son wob))
)
(update-grab)
(unpop-menu)
(with (father (or (# 'father wob) root-window))
(with (wob father)
(## 'already-popped wob ())
(## 'menu-son wob ())
(## 'item-menu-son wob ())
)
(send-user-event 'button-release father)
(with (wob father)
(if (not (= wob-status 'menu)) (ungrab-server))
)
)
(## 'menu-son wob ())
(## 'item-menu-son wob ())
)
)
(on (user-event 'activate-menu)
(progn
(## 'active wob t)
(if (# 'menu-son wob)
(send-user-event 'activate-menu (# 'menu-son wob))
)
)
)
(on (user-event 'goto-activable)
(progn
(## 'active wob ())
(if (# 'menu-son wob)
(send-user-event 'goto-activable (# 'menu-son wob))
)
)
)
(on (user-event 'update-items) (set-valid-items ()))
(on (user-event 'set-grabs) (update-grab))
(on (user-event 'in-menu-son-test)
(: in-menu-son (and (> cex wob-x) (> cey wob-y)
(< cex (+ wob-x wob-width))
(< cey (+ wob-y wob-height)))))
;--Keys Events :
;--UP------------------------------------------------
(on (keypress (key-make "Up") alone)
(propagate-key-event 'Up)
)
(on (user-event 'Up)
(if (valid-items)
(progn
(send-user-event 'unselect-item (# (current-valid-item) (valid-items)))
(set-current-valid-item (% (-
(if (> (current-valid-item) 0) (current-valid-item) (nb-valid-items))
1) (nb-valid-items))
)
(send-user-event 'select-item (# (current-valid-item) (valid-items)))
)
)
)
;--DOWN----------------------------------------------
(on (keypress (key-make "Down") alone)
(propagate-key-event 'Down)
)
(on (user-event 'Down)
(if (valid-items)
(progn
(send-user-event 'unselect-item (# (current-valid-item) (valid-items)))
(set-current-valid-item (% (+ (current-valid-item) 1) (nb-valid-items)))
(send-user-event 'select-item (# (current-valid-item) (valid-items)))
)
)
)
;--RIGHT---------------------------------------------
(on (keypress (key-make "Right") alone)
(propagate-key-event 'Right)
)
(on (user-event 'Right)
(with (wob (# (current-valid-item) (valid-items)))
(if (action-is-f.menu)
(with (theMenu (menu-wob-of-action))
(with (theWob wob wob wob-parent)
(## 'item-menu-son wob theWob)
)
(menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x)
(+ wob-y menu.offset.y))
(with (theMenu (menu-of-action) wob wob-parent)
(menu.pop theMenu button-menu 'here))
(send-user-event 'goto-activable theMenu)
(send-user-event 'select-item (# 0 (valid-items theMenu)) )
)
)
)
)
;--LEFT----------------------------------------------
(on (keypress (key-make "Left") alone)
(propagate-key-event 'Left)
)
(on (user-event 'Left)
(if (not (= wob (menu-oldest-father wob)))
(progn
(send-user-event 'goto-activable wob)
(send-user-event 'depop wob)
(update-grab)
)
)
)
(on (keypress (key-make "Return") alone)
(propagate-key-event 'Return)
)
;--RETURN--------------------------------------------
(on (user-event 'Return)
(if (valid-items)
(if (with (wob (# (current-valid-item) (valid-items)) )
(action-is-f.menu) )
(with (wob (# (current-valid-item) (valid-items)))
(if (action-is-f.menu)
(with (theMenu (menu-wob-of-action))
(with (theWob wob wob wob-parent)
(## 'item-menu-son wob theWob)
)
(menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x)
(+ wob-y menu.offset.y))
(with (theMenu (menu-of-action) wob wob-parent)
(menu.pop theMenu button-menu 'here))
(send-user-event 'goto-activable theMenu)
(send-user-event 'select-item (# 0 (valid-items theMenu)) )
)
)
)
(progn
(send-user-event 'unselect-item (# (current-valid-item) (valid-items)))
(with (wob (# (current-valid-item) (valid-items)))
(setq std-popups.action (# 'action wob))
(send-user-event 'depop (menu-oldest-father wob-parent))
(: wob-background menuBackground)
(wob wob-parent)
(wob (# 'father wob))
(with (action-by-menu t) (eval std-popups.action))
(send-user-event 'goto-activable wob)
)
)
)
)
)
;--ESCAPE--------------------------------------------
(on (keypress (key-make "Escape") alone)
(propagate-key-event 'Escape)
)
(on (user-event 'Escape)
(if (valid-items)
(with (wob (# (current-valid-item) (valid-items)))
(send-user-event 'unselect-item wob)
(send-user-event 'depop (menu-oldest-father wob-parent))
)
)
)
;--ANY KEY-------------------------------------------
(on (keypress any any)
(with (cec (current-event-code) cem (current-event-modifier))
(send-user-event 'keypress-any-any (menu-oldest-father wob))
)
)
(on (user-event 'keypress-any-any)
(progn
(with (theKey cec
theAcceleratorItem
(# (atom (+ "key"
(itoa
(keycode-to-keysym theKey alone))
"m" (itoa cem)))
(# 'accelerator-list wob))
theMnemonicItem
(# (atom (+ "key"
(itoa
(keycode-to-keysym theKey alone))))
(# 'mnemonic-list wob))
theItem
(if theAcceleratorItem theAcceleratorItem
theMnemonicItem)
enable (# 0 theItem)
action (# 1 theItem)
)
(if theItem
(if (eval enable)
(progn
(send-user-event 'Escape wob)
(wob (# 'father wob))
(with (action-by-menu t) (eval action))
(send-user-event 'goto-activable wob)
)
)
(if (# 'menu-son wob)
(send-user-event 'keypress-any-any (# 'menu-son wob))
)
)
)
)
)
)
)
)
)
;-------------------------------------------------------------------------
; MK-BLANK-PLUG : making of a "blank" pixmap
; =============
(de mk-blank-plug (w)
(with (fsm () foreground menuBackground borderwidth 0)
(plug-make (pixmap-make (+ 1 w) 1))
)
)
;-------------------------------------------------------------------------
;*******************************
(load "mwm-functions")
;*******************************
;-------------------------------------------------------------------------
(de modifier-string.make (theModifiers)
(with (theRes ""
i 0 l (length theModifiers)
)
(while (< i l)
(with (modifier (# i theModifiers))
(: theRes (+ theRes
(if (= modifier 'any) ""
(= modifier 'alone) ""
(= modifier 'with-alt) "Alt+"
(= modifier 'with-shift) "Shift+"
(= modifier 'with-control) "Ctrl+"
(= modifier 'with-lock) "Lock+"
(= modifier 'with-modifier-1) "Mod1+"
(= modifier 'with-modifier-2) "Mod2+"
(= modifier 'with-modifier-3) "Mod3+"
(= modifier 'with-modifier-4) "Mod4+"
(= modifier 'with-modifier-5) "Mod5+"
(= modifier 'with-button-1) "But1+"
(= modifier 'with-button-2) "But2+"
(= modifier 'with-button-3) "But3+"
(= modifier 'with-button-4) "But4+"
(= modifier 'with-button-5) "But5+"
""
)
))
)
(: i (+ i 1))
)
theRes
)
)
;============================================================================
; MWM-MENU.MAKE
;============================================================================
(df mwm-menu.make args
(with
(state pop-state
mnemonic-list ()
accelerator-list ()
wgrabs window-grabs
wbeh ()
args-for-menu.make ()
max-width-label 0
max-width-acc 0
)
(with (font menuFontList)
(for item args
(with (label (# 0 item)
acc (# 2 item))
(if (eq 0 (member "@" label))
(with ( pixmapFile (match "@\\(.*\\)" label 1))
(: label (pixmap-make menuBackground pixmapFile menuForeground))
)
)
(if label
(if (> (width label) max-width-label)
(: max-width-label (width label))))
))
)
(for item args
(with (
label (# 0 item)
mnemo (# 1 item)
acc (# 2 item)
key (# 0 acc)
modifier (# 1 acc)
fctn (# 3 item)
fctn.name (# 0 fctn)
fctn.name.string (match "[.]\\(.*\\)" fctn.name 1)
transition ()
acc-string
(+
(if (= 'atom (type modifier))
(modifier-string.make (list modifier))
(modifier-string.make (sublist 1 (length modifier)
modifier) )
)
key)
)
(if (= fctn.name 'f.separator)
(: args-for-menu.make (+ args-for-menu.make '(item-separator)))
(= fctn.name 'f.title)
(: args-for-menu.make (+ args-for-menu.make '(item-separator item-separator)
(list (list 'pop-label-make label))
'(item-separator item-separator) ))
; else
(progn
(: args-for-menu.make
(+ args-for-menu.make
(list (list
'item-make
label
mnemo
fctn (eval (atom (+ "e." fctn.name.string)))
(if acc (mk-blank-plug
(with (font menuFontList)
(- max-width-label (width label)))))
(if acc
(with (borderwidth 0
fsm ()
font menuFontList
foreground menuForeground
background menuBackground
)
(plug-make (active-label-make acc-string)))
)
))
)
)
(if (= fctn.name 'f.menu)
(progn
(: wgrabs (+ wgrabs
(with (wob (menu-wob (eval (# 1 fctn)))) (# 'wgrabs wob))))
(: wbeh (state-make wbeh
(with (wob (menu-wob (eval (# 1 fctn)))) (# 'wfsm wob))))
)
)
(if acc
(progn
(: transition
(list 'on (list 'keypress (key-make key) modifier)
(list 'if (eval (atom (+ "e." fctn.name.string)))
(list 'with '(action-by-menu t) fctn))
)
)
(: wgrabs (+ wgrabs (list (eval (list 'keypress (key-make key) modifier)))))
(: wbeh (eval (list 'state-make transition 'wbeh)))
(## (atom (+ "key" (itoa (key-make
(if (# (atom key) to-lower-case-list)
(# (atom key) to-lower-case-list) key
)
)) "m" (itoa (eval modifier))) )
'accelerator-list
(list (eval (atom (+ "e." fctn.name.string))) fctn) )
)
)
(if mnemo
(with (key mnemo modifier with-alt)
(## (atom (+ "key" (itoa (key-make (setq key
(if (# (atom mnemo) to-lower-case-list)
(# (atom mnemo) to-lower-case-list) mnemo))))))
'mnemonic-list
(list (eval (atom (+ "e." fctn.name.string))) fctn) )
(: transition
(list 'on (list 'keypress (key-make key) modifier)
(list 'if (eval (atom (+ "e." fctn.name.string)))
(list 'with '(action-by-menu t) fctn))
)
)
(: wgrabs
(+ wgrabs (list (eval
(list 'keypress (key-make key) modifier)))))
(: wbeh (eval (list 'state-make transition 'wbeh)))
(## (atom (+ "key" (itoa
(key-make
(if (# (atom key) to-lower-case-list)
(# (atom key) to-lower-case-list) key)
)) "m" (itoa (eval modifier))) )
'accelerator-list
(list (eval (atom (+ "e." fctn.name.string))) fctn) )
))
)
)
)
)
(with (
fsm (fsm-make state)
property '(father () valid-items () menu-son () item-menu-son () active ()
current-valid-item 0 wgrabs () wfsm () )
property (+ (list 'mnemonic-list mnemonic-list
'accelerator-list accelerator-list) property)
myMenu (eval (+ '(menu.make) args-for-menu.make))
wob (menu-wob myMenu)
)
(## 'wfsm wob wbeh)
(## 'wgrabs wob wgrabs)
myMenu
)
))
;------------------------------------------------------------Fin----------
