| View script | License | Download script | History | Other scripts by: christian |
4-Oct 22:02 UTC
[0.053] 86.198k
[0.053] 86.198k
 | Archive version of: menu-system.r ... version: 1 ... christian 9-Jun-2005Amendment note: new script || Publicly available? Yes REBOL [
Title: "Menu-System"
Name: 'Menu-System
File: %menu-system.r
Version: 0.1.6
Date: 10-Jun-2005
Author: "Christian Ensel"
Email: christian.ensel@gmx.de
Owner: "Christian Ensel"
Rights: "Copyright (c)2005 Christian Ensel"
Purpose: {
Pre-Alpha of a pretty complete REBOL menu system.
Have menus in your REBOL apps, finally.
}
History: {
0.1.6 • Shortcut keys are now dialected as TAG! instead of ISSUE!,
TAG! is way more flexible.
• Styling with LAYOUT-MENU/STYLE works.
• Styling MENU-BAR and DROP-MENU with MENU-STYLE works.
• Correction of layout algorithm, still somewhat problematic.
0.1.5 • MENU-BAR style now with full keyboard support, but still
"menubar" and "baritems" aren't configurable.
• DROP-MENU now works again.
0.1.4 • Experimental MENU-BAR VID style now works.
It isn't configurable much and there are some really annoying bugs.
• Drop-Menu is broken for now.
0.1.3 • Experimental DROP-MENU VID-style.
0.1.2 • Dialect changes.
0.1.1 • Dialect changes.
0.1.0 • Refactored earlier prototype.
}
Credits: {
Originally this script evolved from trying to understand the inner
workings of Cyphre's menu system sketch, without that I would by
no means have come as far as shown here.
}
Library: [
level: 'intermediate
platform: 'all
type: [module demo]
code: 'module
domain: [user-interface vid gui]
tested-under: [view 1.2.119.3.1 on "WinXP"]
support: none
license: none ;-- Not bothered with licensing stuff yet, but most likely BSD
see-also: none
]
]
ctx-menus: context [
shadow-image: use [reset image] [
reset: system/options/binary-base
system/options/binary-base: 64
image: load 64#{
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+g
vaeTAAAACXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1QQUCzYGyPaalQAAAINJ
REFUeNrd0qEOwjAUBdADDIJDIYaZWPjJfSZuAo2bQiybKKZLmqUzRcE1TZO+U3Ef
P59DwUyHCwKGqgBocFou+wLghhptKVDjjGMpkOb6LeAPgCqzJE1SVS4vjJgR1sAj
WZJhAxgj8sS0Bvp4tkvPmcxxeEC/yzy4Lx1vAAFT/Oz9ASj/FhDibXHbAAAAAElF
TkSuQmCC
}
system/options/binary-base: reset
image
]
;======================================================= helper functions ==
;
cast: func [value cases] [switch type?/word :value cases]
text-size?: func ["Returns a face's text size or 0x0." face /local size result] [
size: face/size
face/size: 10000x10000
result: size-text face
face/size: size
result
]
image-size?: func ["Returns a face's image size or 0x0." face [object!]] [
any [all [face/image face/image/size] 0x0]
]
;=========================================================== detail-faces ==
;
; Detail faces are the inner faces of menu-item, each item uses five
; of them:
;
; - MARK: The radio- or check-mark
; - ICON: The item's icon image
; - BODY: The item's body text and/or image
; - KEY: The item's shortcut-key text
; - ARROW: The item's arrow (only for item's with sub-menu)
;
detail-face: make system/view/vid/vid-face [ ;-- Notice that details have no feel, all item actions are triggered by
edge: color: effect: effects: none ; item's feel/detect.
offset: size: 0x0
feel: make face/feel [
redraw: func [detail offset /local item] [
item: detail/parent-face
if detail/effects [
detail/effect: pick detail/effects item <> item/menu/actor
]
]
]
]
;============================================================= draw-radio ==
;
;view layout [box 100x100 effect [draw [push [translate 50x50 pen black box 10x10 20x20]]]]
draw-radio: func [item /local color y] [
color: item/options/key/font/color
item/mark/effect: compose/deep: [
draw [
push [
pen (color) fill-pen (color)
circle (as-pair 7 item/mark/size/y / 2 - 1) 3
]
]
]
]
;---------------------------------------------------------------------------
;============================================================= draw-mark ==
;
draw-mark: func [item /local color unit] [
color: item/options/key/font/color
unit: item/mark/size / 16x16
item/mark/effect: compose/deep: [
draw [
pen (none) fill-pen (color) anti-alias (none)
polygon
(3x9 * unit) (4x8 * unit) (6x10 * unit)
(11x5 * unit) (12x6 * unit) (6x12 * unit)
]
]
item/mark/effect: compose/deep: [
draw [
pen black line-width 2 line-cap square line-join bevel fill-pen black ;anti-alias (none)
line (3x8 * unit) (6x11 * unit) (12x5 * unit)
]
]
]
;---------------------------------------------------------------------------
;============================================================= draw-arrow ==
;
draw-arrow: func [item /local color y] [
color: item/options/key/font/color
item/arrow/effect: compose/deep [
draw [
pen (color) fill-pen (color)
polygon
(as-pair item/arrow/size/x - 8 item/arrow/size/y / 2 - 1)
(as-pair item/arrow/size/x - 11 item/arrow/size/y / 2 - 4)
(as-pair item/arrow/size/x - 11 item/arrow/size/y / 2 + 2)
(as-pair item/arrow/size/x - 8 item/arrow/size/y / 2 - 1)
]
]
]
;---------------------------------------------------------------------------
;============================================================== draw-knob ==
;
draw-knob: func [menu dir /local knob color y] [
knob: select reduce ['less menu/less 'more menu/more] dir
color: either menu/options/item/body/font/colors [
menu/options/item/body/font/colors/1
][
menu/options/item/body/font/color
]
y: pick [[5 8] [8 5]] dir = 'less
knob/effect: compose/deep [
draw [
pen (color) fill-pen (color)
polygon
(as-pair knob/size/x / 2 y/1)
(as-pair knob/size/x / 2 - 3 y/2)
(as-pair knob/size/x / 2 + 3 y/2)
(as-pair knob/size/x / 2 y/1)
]
]
]
;---------------------------------------------------------------------------
;============================================================== knob-feel ==
;
knob-feel: make face/feel [
over: func [knob over? offset] [
knob/rate: all [over? knob/parent-face/parent-face/options/menu/rate]
show knob ;************ Is this necessary? ***************
]
engage: func [knob action event /local menu] [
if event/type = 'time [
menu: knob/parent-face/parent-face
menu/feel/scroll menu knob
]
]
]
;============================================================== item-feel ==
;
; Initiating drawing the AWAY state of an item is exclusivly
; done by one of it's siblings; i.e. whenever a sibling is
; hovered, sibling forces the active item to unhover and
; then becomes the active item itself.
;
; This is used to differentiate between wandering through menus with mouse and
; keyboard. Whilst hovering items with sub-menus with the mouse, sub-menus are
; opened immediatly, whereas when navigating a menu with the keyboard, that doesn't
; open sub-menus (to not steal the keyboard focus).
;
item-feel: make face/feel [
detect: func [item event] [
if within? event/offset win-offset? item item/size [
item/menu/feel/visit item/menu item
item/feel/enter item
event
]
]
redraw: func [
"Draws item (cares for left, visited and disabled state)."
item [object!]
offset [pair!]
/local
active? color details
][
active?: item = item/menu/actor
details: item/pane
either item/state [
if item/mark <> item/pane/1 [insert item/pane item/mark]
][
if item/mark = item/pane/1 [remove item/pane]
]
item/color: either active? [item/options/highlight] [item/options/color]
if item/options/icons [item/icon/image: pick item/options/icons not active?]
item/body/font/color: any [
all [in item/body/font 'colors pick item/body/font/colors not active?]
]
if item/edge [
if in item/edge 'colors [
item/edge/color: pick item/edge/colors not active?
]
if in item/edge 'effects [
item/edge/effect: pick reduce item/edge/effects not active?
]
]
either item/disabled? [ ;-- Hardcoded DISABLE state here. Has to be dialected!
item/body/font/color: silver
either item/icon/effect [
if not find item/icon/effect 'grayscale [
insert tail item/icon/effect [grayscale luma 25]
]
][
item/icon/effect: copy [grayscale luma 25]
]
][
if item/icon/effect [remove/part any [find item/icon/effect 'grayscale []] 3]
]
]
visit: func [
"Visits item (draws it's hover state)."
item [object!]
][
show item ;-- Show that we're visited
]
enter: func [
"Enters item (shows it's sub-menu)."
item [object!]
/new
"Returns immediately from showing."
][
if all [ ;-- Show the own sub-menu, if there's one and if it's not
item/sub ; popped up already
none? find system/view/pop-list item/sub
][
either new [
show-menu/new find-window item item/sub ;-- Keyboard entered sub-menu
][
show-menu find-window item item/sub ;-- Mouse opened sub-menu
]
]
]
leave: func [ ;-- What's normal, anyway? Normal can be disabled, REDRAW cares for that.
"Leaves item (draws it's normal state and closes it's sub-menu)." ;
item [object!] ;
][ ;
all [item/sub item/sub/feel/close item/sub]
show item
]
engage: func [
item action event
/local root popup start end items state
][
either all [action = 'up none? item/sub not item/disabled?] [ ;-- We act only on 'UP events for nothing but enabled items without sub-menus.
all [
logic? item/state
case [
'radio = item/mark/type [
if off = item/state [
item/state: true
items: item/menu/list/pane
foreach sibling items [
if all [
sibling <> item
item/group = get in sibling 'group
][
sibling/state: false
show sibling/mark
]
]
]
]
'check = item/mark/type [
item/state: not item/state
]
]
]
either not event/shift [ ;-- SHIFT enables multi-selection, otherwise the whole menu closes.
root: item/menu/feel/root-of item/menu
root/feel/close root
][
show item
]
do func [item] bind any [item/options/action []] in item 'self item ;-- Should I allow for functions here, too?
][
;-- no op
]
none
]
]
;=========================================================== baritem-feel ==
;
baritem-feel: make item-feel [
super: item-feel
over: none
engage: none
redraw: func [item offset] [
item/color: pick item/menu/colors item <> item/menu/actor
]
detect: func [item event /local actor] [
case [
none? item/menu/actor [
item/menu/state: 'down-to-enter
item/menu/feel/visit item/menu item
focus/no-show item/menu
]
'down-to-enter = item/menu/state [
item/menu/feel/visit item/menu item
focus/no-show item/menu
if 'down = event/type [
item/menu/state: 'hover-to-enter
item/feel/enter item
]
]
'hover-to-enter = item/menu/state [
if 'move = event/type [
item/menu/feel/visit item/menu item
item/feel/enter item
]
]
]
none
]
enter: func [
"Enters item (shows it's sub-menu)."
item [object!]
/new
"Returns immediately from showing."
][
if all [ ;-- Show the own sub-menu, if there's one and if it's not
item/sub ; popped up already
none? find system/view/pop-list item/sub
][
either new [
show-menu/offset/new find-window item/menu item/sub item/offset + (0x1 * item/size) ;-- Keyboard entered sub-menu
][
show-menu/offset find-window item/menu item/sub item/offset + (0x1 * item/size) ;-- Mouse opened sub-menu
]
]
]
]
;============================================================= build-item ==
;
build-item: func [
"Builds an item, together with all it's sub-faces."
parent [object!] "the item's menu"
word [word! none!] "the item's identifier"
desc [block!] "an items description"
/local
item
][
item: make face [
type: 'menu-item
var: word ;-- VAR holds the word by which we later refer to the item.
menu: parent ;-- MENU is always the menu the item belongs to, it is *not* the
; sub-menu an item may have (thats in SUB).
color: colors: none ;-- COLORS allows for multiple activation-state dependend colors
; (normal, actor, disabled).
effect: effects: none ;-- EFFECTS allows for multiple activation-state dependend effects
; (normal, actor, disabled).
highlight: none ;-- I have to get rid of that in favour of COLORS.
text: none ;-- TEXT is actually BODY/TEXT, REDRAW changes this on-the-fly.
font: none ; Whereas FONT is unused; BODY/FONT is OPTIONS/BODY/FONT.
image: images: none ;-- Same with IMAGE, which is drawn as BODY/IMAGE.
; IMAGES allows for multiple activation-state dependend images
; (normal, actor, disabled).
shortcut: none ;-- And dito here: SHORTCUT is KEY/TEXT.
; BTW, how's about having images for keys? Can think of e.g. shift-arrow ...
; Would be fun implementing that.
options: none ;-- All the item related options.
; I'm concerned with this being an OBJECT!, whilst VID usually keeps a BLOCK! here.
feel: item-feel ;-- See detailed comments on ITEM-FEEL.
edge: make face/edge [size: 0x0 color: image: effect: none] ;## I'm not satisfied with having that here, should rather be an option.
edges: none
data: desc ;-- The item's sub-menu's description, if any.
sub: none ;-- The item's sub-menu object itself, if any.
disabled?: no ;-- The enabled/disabled state.
state: none ;-- Toggles the radio- or check-mark state.
group: none ;-- GROUP is used for mark-items. Each menu starts which one initial group,
; implicit groups are set up by menu-dividers and additional, more complex
; groups can be explicitly specified in the setup dialect.
mark: icon: body: key: arrow: none ;-- Just some shortcuts to the details in item's pane.
pane: reduce [
mark: make detail-face []
icon: make detail-face []
body: make detail-face [para: parent/para]
key: make detail-face [para: parent/para]
arrow: make detail-face []
]
]
item/options: make object! [ ;## ALL THIS OPTION STUFF IS REALLY, REALLY CONFUSING. MAP OUT A WORKING STRATEGY! #####
color: parent/options/item/color
colors: none
highlight: parent/options/item/highlight
image: none
action: parent/options/item/action
icons: none
body: make object! [
font: parent/options/item/body/font
para: parent/options/item/body/para
]
key: make object! [font: parent/options/item/key/font]
edge: parent/options/item/edge
]
item/body/font: item/options/body/font
item/body/para: item/options/body/para
item/key/font: item/options/key/font
item/edge: item/options/edge
item
]
;========================================================== build-divider ==
;
; DIVIDER needs to be reworked, I guess. Currently, there are absolutely
; no config options.
;
build-divider: func [
"Builds a menu divider."
parent [object!] "the divider's parent menu"
][
make face [
type: 'menu-divider
var: none
menu: parent
color: 172.168.153 ;-- Win XP Silver; hardcoded for now
edge: make face/edge [ ;-- Ditto, look like Win XP Silver.
size: 1x2
color: image: effect: none
]
]
]
;---------------------------------------------------------------------------
;============================================================== menu-feel ==
;
; The MENU-FEEL is used to the support keyboard-handling solely,
; all mouse related behaviour is done one ITEM-FEEL level.
;
; WARNING: I don't care about not selecting DIVIDER-ITEMS for
; HOME and END keys, when wrapping with UP and DOWN and
; when entering a sub-menu; so, for now, better not let
; a DIVIDER-ITEM be the first or last item in a menu
; (looks ugly, anyway ;-)
;
menu-feel: make system/view/popface-feel-win-away [
super: none
inside-menu?: func [menu event] [
within? event/offset win-offset? menu menu/size
]
inside-menu-tree?: func [menu event] [
any [
menu/feel/inside-menu? menu event
all [
menu/parent
menu/feel/inside-menu-tree? menu/parent/menu event
]
]
]
pop-detect: func [menu event] [
case [
menu/feel/inside-menu-tree? menu event [
if find [down up move time key alt-down alt-up scroll-line] event/type [
event
]
]
true [
either not find [up move time scroll-line key] event/type [
menu: menu/feel/root-of menu
menu/feel/close menu
][
event
]
]
]
]
close: func [ ;-- CLOSE actually impements a custom HIDE-POPUP, if you like, call it a hack.
"Closes a menu (and all of it's items' sub-menus)." ; I simply couldn't cope with that one.
menu [object!]
/local ;-- NO-SHOW hinders multiple window refreshing closing nested menus.
/no-show ; Hidden, callers shouldn't have to care about that.
][
if all [menu/actor menu/actor/sub] [
menu/actor/sub/feel/close/no-show menu/actor/sub ;-- MENU/ACTOR/SUB may have a different FEEL
; (even though, for now, none are implemented).
]
if find system/view/pop-list menu [
unfocus menu ;
remove find menu/parent-face/pane menu ;-- Most likely to be a window, but I hope it can also be another non-menu popup :-)
remove find system/view/pop-list menu
menu/actor: none
unless no-show [show menu/parent-face]
]
if menu/parent [focus/no-show menu/parent/menu]
]
visit: func [ ;-- Visiting items may require revealing these items, which definitly is
"Visits menu item, making it the new actor." ; a job under responsibility of menus.
menu [object!] item [object!] ; Hence visiting items is implemented here instead on item level only.
][
if menu/actor <> item [
menu/feel/leave menu
menu/feel/reveal menu item
menu/actor: item
item/feel/visit item
]
]
leave: func ["Leaves menu actor, if any." menu [object!] /local item] [ ;-- Leaving an item should never be called explicitly, since it's done
if item: menu/actor [ ; implicitly by visiting another
menu/actor: none
item/feel/leave item ;-- Only if there was an actor, there is a item to leave (and to redraw).
]
]
root-of: func ["Returns menu's root menu." menu] [
forever [
if none? menu/parent [break/return menu]
menu: menu/parent/menu
]
]
first-of: func ["Returns first item." menu [object!]] [
foreach item menu/list/pane [
if 'menu-item = item/type [break/return item]
]
]
prev-page-of: func ["Returns previous item." menu [object!] /local extra other] [
extra: any [menu/actor menu/feel/last-of menu]
foreach item next find reverse copy menu/list/pane extra [ ;-- This results in other being the last visble item or
if 'menu-item = item/type [ ; none, if extra itself is the last visible one.
if menu/feel/visible? menu item [other: item]
if not menu/feel/visible? menu item [break/return other]
]
]
either other [
other ;-- Returns first item on page
][
menu/actor: extra
while [
all [
menu/actor <> menu/feel/first-of menu
menu/feel/visible? menu extra
]
][
menu/feel/visit menu menu/feel/prev-of menu
]
menu/actor
]
]
next-page-of: func ["Returns next item." menu [object!] /local extra other] [
extra: any [menu/actor menu/feel/first-of menu]
foreach item next find menu/list/pane extra [ ;-- This results in other being the last visble item or
if 'menu-item = item/type [ ; none, if extra itself is the last visible one.
if menu/feel/visible? menu item [other: item]
if not menu/feel/visible? menu item [break/return other]
]
]
either other [
other ;-- Returns last item on page
][
menu/actor: extra
while [
all [
menu/actor <> menu/feel/last-of menu
menu/feel/visible? menu extra
]
][
menu/feel/visit menu menu/feel/next-of menu
]
menu/actor
]
]
prev-of: func ["Returns previous item." menu [object!] /wrap "Wrap at menu's top."] [
either none? menu/actor [
menu/feel/last-of menu
][
any [
foreach item next find reverse copy menu/list/pane menu/actor [
if 'menu-item = item/type [break/return item]
]
either wrap [menu/feel/last-of menu] [menu/feel/first-of menu]
]
]
]
next-of: func ["Returns next item." menu [object!] /wrap "Wrap at menu's top."] [
either none? menu/actor [
menu/feel/first-of menu
][
any [
foreach item next find menu/list/pane menu/actor [
if 'menu-item = item/type [break/return item]
]
either wrap [menu/feel/first-of menu] [menu/feel/last-of menu]
]
]
]
next-char-of: func [
"Returns next item starting with char (or NONE)."
menu [object!] char [char!] /local items
][
items: either menu/actor [
items: next find menu/list/pane menu/actor
append copy items copy/part menu/list/pane items
][
menu/list/pane
]
foreach item items [
if all [
'menu-item = item/type
item/body/text
equal? uppercase char uppercase item/body/text/1
][
break/return item
]
]
]
last-of: func ["Returns menu's last item." menu [object!]] [
foreach item reverse copy menu/list/pane [
if 'menu-item = item/type [break/return item]
]
]
visible?: func ["Returns TRUE if is fully visible." menu [object!] item [object!]] [
not any [
menu/list/offset/y + item/offset/y < 0 ;-- Item is (partially) above the clipping region
menu/list/offset/y + item/offset/y + item/size/y > menu/clip/size/y ;-- Item is (partially) below the clipping region
]
]
show-less?: func [menu [object!]] [menu/list/offset/y < 0]
show-more?: func [menu [object!]] [menu/list/offset/y + menu/list/size/y > menu/panel/size/y]
hide-less?: func [menu [object!]] [menu/list/offset/y >= - menu/less/size/y]
hide-more?: func [menu [object!]] [menu/list/offset/y + menu/list/size/y <= (menu/clip/size/y + menu/more/size/y)]
show-less: func [menu [object!]] [
if not menu/less/show? [
menu/clip/offset/y: menu/clip/offset/y + menu/less/size/y
menu/clip/size/y: menu/clip/size/y - menu/less/size/y
menu/list/offset/y: menu/list/offset/y - menu/less/size/y
show menu/less
]
]
show-more: func [menu [object!]] [
if not menu/more/show? [
menu/clip/size/y: menu/clip/size/y - menu/more/size/y
show menu/more
]
]
hide-less: func [menu [object!]] [
if menu/less/show? [
menu/clip/offset/y: menu/clip/offset/y - menu/less/size/y ;-- Move clip to top and
menu/clip/size/y: menu/clip/size/y + menu/less/size/y ; grow it.
menu/less/rate: none
hide menu/less
]
]
hide-more: func [menu [object!]] [
if menu/more/show? [
menu/clip/size/y: menu/clip/size/y + menu/more/size/y ;-- Grow clip.
menu/list/offset/y: menu/list/offset/y + menu/more/size/y
menu/more/rate: none
hide menu/more
]
]
scroll: func [menu [object!] knob [object!]] [
case [
menu/less = knob [
menu/list/offset/y: menu/list/offset/y + menu/steps
menu/feel/show-more menu
if menu/feel/hide-less? menu [menu/feel/hide-less menu]
]
menu/more = knob [
menu/list/offset/y: menu/list/offset/y - menu/steps
menu/feel/show-less menu
if menu/feel/hide-more? menu [menu/feel/hide-more menu]
]
]
show menu/panel
]
reveal: func [
"Reveals the item (by scrolling the smallest amount necessary)."
menu [object!] item [object!]
/no-show
"Don't show the changes."
/local
delta clip list
][
delta: 0x0 clip: menu/clip list: menu/list
if any [
if 0 > delta/y: list/offset/y
+ item/offset/y [ ;-- Item is (maybe only partially) above the clipping region
menu/feel/show-more menu
list/offset/y: list/offset/y - delta/y
if menu/feel/hide-less? menu [menu/feel/hide-less menu]
true
]
if 0 < delta/y: list/offset/y
+ item/offset/y
+ item/size/y
- clip/size/y [ ;-- Item is (maybe onle partially) below the clipping region
menu/feel/show-less menu
list/offset/y: list/offset/y - delta/y
if menu/feel/hide-more? menu [menu/feel/hide-more menu]
true
]
][
if not no-show [show menu/panel]
]
]
map-key: func [
"Returns mapped EVENT/KEY."
menu [object!] event [event!] /local key
][
key: event/key
if event/control [
key: any [select [up page-up home home down page-down end end] key key] ;-- Control key increases key effect.
]
key
]
engage: func [menu action event /local actor item key] [
if event/type = 'key [
actor: menu/actor
key: menu/feel/map-key menu event
case [
'right = key [
if all [actor actor/sub] [
actor/feel/enter/new actor
item: actor/sub/feel/first-of actor/sub
item/menu/feel/visit item/menu item
wait []
]
]
#" " = key or
(#"^M" = key) [
if actor [
either actor/sub [
actor/feel/enter actor
][
actor/feel/engage actor 'up event
]
]
]
escape = key or
('left = key) or
('backspace = key) [menu/feel/close menu]
'home = key [menu/feel/visit menu menu/feel/first-of menu]
'page-up = key [menu/feel/visit menu menu/feel/prev-page-of menu]
'up = key [menu/feel/visit menu menu/feel/prev-of/wrap menu]
'down = key [menu/feel/visit menu menu/feel/next-of/wrap menu]
'page-down = key [menu/feel/visit menu menu/feel/next-page-of menu]
'end = key [menu/feel/visit menu menu/feel/last-of menu]
/default [
use [item] [if item: menu/feel/next-char-of menu key [menu/feel/visit menu item]]
]
]
]
]
]
;=========================================================== menubar-feel ==
;
; The MENUBAR-FEEL remaps cursor keys a bit to adjust them to the needs
; of horizontally layouted menubar-items.
;
menubar-feel: make menu-feel [
super: menu-feel
detect: func [menubar event][
menubar/feel/super/pop-detect menubar event
]
close: func [menubar] [
if menubar/actor [
if menubar/actor/sub [
menubar/actor/sub/feel/close menubar/actor/sub
]
menubar/feel/leave menubar
menubar/state: 'click-to-enter
unfocus
]
]
reveal: none
next-page-of: :last-of
prev-page-of: :first-of
map-key: func [ ;** Overwriting feel/super/map-key, menubars behave different than menus. Hack?
"Returns mapped EVENT/KEY."
menu [object!] event [event!] /local key
][
key: any [
select [left up up right down right] event/key
event/key
]
if event/control [
key: any [select [up page-up home home down page-down end end] key key] ;-- Control key increases key effect.
]
key
]
pop-detect: none
over: none
reveal: none
]
;============================================================= build-menu ==
;
build-menu: func [
"Builds a menu and it's sub-faces."
item [object! none!] "the menu's parent item or NONE"
desc [block!] "the menu description"
/local
menu options parent
][
menu: make system/view/vid/vid-face [
;==================================================== menu-access ==
;
; Not delegating SET or GET to a method object is a waste of
; memory, but I'd really prefer the ease of directly envoking the
; functions over the cluttered delagation syntax here.
;
; Compare:
;
; • app-menu/access/set app-menu 'file/recent/1 [text: "menus.r"]
; • app-menu/set 'file/recent/1 [text: "menus.r"]
;
; Funny though, that in any case there isn't a difference
; between SETting or GETting, since I'm only DOing code here.
;
set: get: func [
"Set or get item values (executes code in item's context)."
path [path! word!] "Path to an item anywhere down in the tree"
code [block!] "Code executed in item's context"
/local
item
][
item: select items first path: to path! :path
either empty? next path [
do bind :code in item 'self
][
item/sub/set next path :code
]
]
;
;-------------------------------------------------------------------
type: 'menu
feel: menu-feel
flags: [field]
color: none
font: none
edge: make face/edge [
size: 1x1
color: none
colors: reduce [178.180.191 none]
effect: none
]
para: make para [origin: 2x3 wrap?: no]
highlight: 187.183.199 ;-- Win XP Silver, hardcoded default
anchor: none ;-- ANCHOR is used to anchor a menu to an on-screen UI element.
;
parent: item
data: desc
steps: 4 ;-- Dialect this!
actor: none
groups: none
items: make block! [] ;-- ITEMS holds the menu's items, the block consits
; of ID / ITEM pairs for easy selection of items
shadow: panel: less: clip: list: more: none ;-- Accessors for the various sub-faces of a menu.
; The actual items are to be found in LIST's pane,
; but clients should use ITEMS.
pane: reduce [
shadow: make face [
color: edge: none
image: shadow-image
effect: [extend alphamul 32]
]
panel: make face [
color: white ;######################
edge: none
effect: copy [extend 13x33]; merge]
pane: reduce [
less: make face [
color: edge: none
feel: knob-feel
]
clip: make face [
color: edge: none
pane: reduce [
list: make face [
color: edge: none
pane: make block! []
]
]
]
more: make face [ ;--
color: edge: none
feel: knob-feel
]
]
]
]
]
either menu/parent [
parent: menu/parent/menu
menu/options: make object! [
menu: make object! [
edge: parent/options/menu/edge
rate: parent/options/menu/edge
color: parent/options/menu/color
]
item: make object! [
action: parent/options/item/action
color: parent/options/item/color
highlight: parent/options/item/highlight
body: make object! [
font: parent/options/item/body/font
para: parent/options/item/body/para
]
key: make object! [font: parent/options/item/key/font]
edge: parent/options/item/edge
]
]
][
menu/options: make object! [
menu: make object! [
edge: system/standard/face/edge
rate: 64 ;-- Dialect this
color: none
]
item: make object! [
action: none
color: none
image: none
highlight: none
body: make object! [font: para: none]
key: make object! [font: none]
edge: make face/edge [
size: 1x1
color: effect: none
colors: reduce [none 178.180.191] ;-- Win XP Silver, hardcoded default.
]
]
]
menu/options/item/body/font:
menu/options/item/key/font: make system/standard/face/font [align: 'left valign: 'middle colors: none]
]
menu
]
;---------------------------------------------------------------------------
;============================================================ layout-menu ==
;
set 'layout-menu func [
"Returns a menu (face) built from style/content description dialect."
desc [block!] "Dialect block of styles, attributes, and layouts"
/parent
"Bind menu to an item as it's sub-menu."
item [object!] "A menu-item face"
/style
"Base menu on existing style sheet."
sheet [block!] "A style sheet of menu and item styles."
/local
menu
value
mark-size icon-size body-size key-size arrow-size height
divider item-offset item-size
][
menu: build-menu item desc
;-- Default values are set now to eventually be overwritten by menu spec
;
menu/options/item/action: all [menu/parent menu/parent/menu/options/item/action]
menu/panel/edge: any [ ;-- Setting the menu's edge:
all [menu/parent menu/parent/menu/panel/edge] ; A menu inherits it's edge from it's parent menu.
face/edge
]
menu/font: any [ ;-- Setting the menu's font:
all [menu/parent menu/parent/menu/font] ; A menu inherits it's font from it's parent menu.
face/font
]
if all [ ;-- Setting the menu's panel color:
menu/parent ; A menu inherits it's color from it's parent menu.
value: menu/parent/menu/options/menu/color ; Actually, it's not the PANEL-face's color, it's colorized instead.
][
;insert tail menu/panel/effect reduce ['colorize value]
menu/panel/color: value
]
if menu/parent [ ;-- Setting a menu's watermark:
menu/panel/image: menu/parent/menu/panel/image ; A menu inherits it's watermark from it's parent menu.
]
if style [insert desc sheet]
parse desc [
any [
'menu 'style some [
'color set value [word! | tuple!] (
insert tail menu/panel/effect reduce [
'colorize value: cast value [
word! [get value]
tuple! [value]
]
]
menu/options/menu/color: value
)
| 'edge set value ['none | none! | block!] (
if value = 'none [value: none]
menu/panel/edge:
menu/options/menu/edge: make all [value menu/options/menu/edge] value
)
| ['backdrop | 'image] set value [word! | file! | image!] (
menu/panel/image: cast value [
word! [get value]
file! [load value]
image! [value]
]
)
| 'effect set value [lit-word! | block!] (
menu/panel/effect: compose [(value)]
)
]
| 'item 'style some [
'highlight set value set value [word! | path! | tuple!] (
menu/options/item/highlight: cast value [
word! [get value]
path! [do value]
tuple! [value]
]
)
|
'font set value block! (
menu/options/item/body/font:
menu/options/item/key/font: make menu/options/item/body/font value
)
| 'edge set value ['none | none! | block!] (
if value = 'none [value: none]
menu/options/item/edge: make all [value menu/options/item/edge] value
)
|
'action set value block! (menu/options/item/action: value)
]
]
desc:
to end
]
layout-items menu desc
menu/list/pane: head menu/list/pane
menu
]
;---------------------------------------------------------------------------
;=========================================================== layout-items ==
;
set 'layout-items func [
"Layouts items."
menu [object!]
desc [block!]
/local
value item
][
parse desc [
some [
[ ['divider | 'bar | '---] (
item: build-divider menu
menu/list/pane: insert menu/list/pane item
insert tail menu/items reduce [none item]
)
|
set value opt set-word! (
value: all [:value to word! value]
)
'item (
item: build-item menu value desc
menu/list/pane: insert menu/list/pane item
insert tail menu/items reduce [item/var item]
)
any [
set value string! (
item/body/text: value
)
| ['action set value block! | set value block!] (
item/options/action: value
)
| 'icon set value [image! | word! | file! | path! | block!] (
item/icon/image: cast value [
word! [get value]
file! [load value]
image! [value]
path! [do value]
]
if block? value [
item/icon/image: first value: reduce value
item/options/icons: value
]
)
| 'highlight set value set value [word! | path! | tuple!] (
item/options/highlight: cast value [
word! [get value]
path! [do value]
tuple! [value]
]
)
| 'font set value [block!] (
;make error! "item font set!"
)
| 'body [
'font set value [block!] (
item/body/font: item/options/body/font: make item/options/body/font value
)
| 'para set value [block!] (
item/body/para: item/options/body/para: make item/options/body/para value
)
]
| 'key 'font set value [block!] (
item/key/font: item/options/key/font: make item/options/key/font value
)
| 'edge set value ['none | none! | block!] (
if value = 'none [value: none]
item/edge: item/options/edge: make all [value item/options/edge] value
)
| set value ['radio | 'check] (
item/mark/type: value
item/state: off
)
any [
'of [opt 'group] set value [lit-word!] (
item/group: value
)
| set value [
'on | 'true | 'yes | true |
'off | 'false | 'no | false
](
item/state: do value
)
]
| 'menu copy value block! (
item/data: first value ;-- Remember a sub-menu's description
item/sub: layout-menu/parent item/data item ;-- And set up the sub-menu's faces
)
| 'image set value [image! | file! | word! | path!] (
item/options/image: cast value [
file! [load value]
word! [get value]
path! [do value]
image! [value]
]
)
| set value ['disable | 'enable] (
item/disabled?: value = 'disable
)
| set value tag! (
item/key/text: to string! value
)
]
]
]
]
menu
]
;---------------------------------------------------------------------------
;=========================================================== adjust-items ==
;
; ADJUST-ITEMS' job is to establish consistent item sizes within one
; menu. It makes all items the same width (which may be a fixed width
; or the width of the widest item). It further aligns the details of
; one item to be in column with the corresponding details of other items.
;
adjust-items: func [
"Adjust the menu-items widths."
items [block!]
/width
w
/local
item mark icon body key arrow
item-size mark-size icon-size body-size key-size arrow-size
][
;-- Measure the items to find the maximums
;
; Two pass: First loop adjusts the height of items while collecting
; information about their widths.
; The second loop applies the maximas to align the detail faces.
;
item-size: mark-size: icon-size: body-size: key-size: arrow-size: 0x0
foreach item items [
set [mark icon body key arrow] reduce bind [mark icon body key arrow] in item 'self
item-size/y: 0
edge-size: edge-size? item
switch item/type [
menu-item [
mark-size: max mark-size mark/size: 16x0
icon-size: max icon-size icon/size: image-size? icon
body-size: max body-size body/size: max 0x4 + text-size? body any [all [item/options/image item/options/image/size] 0x0]
key-size: max key-size key/size: max text-size? key image-size? key
arrow-size: max arrow-size arrow/size: 16x0
item/size/y: mark/size/y: ;icon/size/y:
body/size/y: key/size/y: arrow/size/y: first maximum-of reduce [
mark/size/y icon/size/y body/size/y key/size/y arrow/size/y
]
item-size: first maximum-of reduce [mark-size icon-size body-size key-size arrow-size]
icon/offset/y: max item/size/y - icon/size/y / 2 0
body/size/y:
key/size/y: item/size/y
]
menu-divider [ ] ;-- For now, dividers are somewhat static, so currently this is a no-op.
]
item/size/y: item/size/y + second edge-size? item
]
;-- Apply those maximums to the smaller ones
;
item-offset: 0x0
item-size/x: mark-size/x + icon-size/x + body-size/x + key-size/x + arrow-size/x + 2
foreach item items [
set [mark icon body key arrow] reduce bind [mark icon body key arrow] in item 'self
item/offset/y: item-offset/y
item/size/x: item-size/x + first edge-size? item
switch item/type [
menu-item [
mark/size/x: mark-size/x
icon/size/x: icon-size/x
body/size/x: body-size/x
key/size/x: key-size/x
mark/offset/x: 0
icon/offset/x: mark/offset/x + mark/size/x
body/offset/x: icon/offset/x + icon/size/x
key/offset/x: body/offset/x + body/size/x
arrow/offset/x: key/offset/x + key/size/x
if item/options/image [
if none? item/body/effect [item/body/effect: copy []]
insert item/body/effect compose/deep [
draw [image (as-pair 0 item/body/size/y - item/options/image/size/y / 2) (item/options/image)]
]
]
if logic? item/state [ ;-- Wouldn't this better be ITEM/MARK/STATE ?
mark/size/y: item/size/y
either item/mark/type = 'check [draw-mark item] [draw-radio item]
]
if item/sub [ ;-- Obscured for LAYOUT-MENU/SELECTED purposes :(
arrow/size/y: item/size/y
draw-arrow item
]
item/size/y: item/size/y + second edge-size? item
]
menu-divider [
item/size/x: item-size/x
item/size/y: 5 ;-- This will change with dividers become arrow configurable
]
]
item-offset/y: item/offset/y + item/size/y
]
item-size
]
;---------------------------------------------------------------------------
;============================================================ adjust-menu ==
;
adjust-menu: func ["Adjusts the menus size." menu [object!]] [
adjust-items menu/list/pane
]
;============================================================== show-menu ==
;
; SHOW-MENU
set 'show-menu func [
window [object!]
menu [object!]
/offset
at [pair!]
/size
"Restrict menu's size"
max-size [pair!]
/new
"Opens a new window and returns immediately." ;-- Works like in VIEW.
/local
value
item divider item-offset item-size
][
max-size: any [max-size window/size]
menu/actor: none ;-- Reset ACTOR (may still be set from last time the menu has been shown)
; **************************** Really? ********************************
item-size: adjust-items menu/list/pane
;-- Preparation of the less- and more-knobs, we'll may need them.
;
menu/less/size: menu/more/size: 1x0 * item-size/x + 0x12
draw-knob menu 'less
draw-knob menu 'more
;-- Let's see how big the menu may get.
;
menu/list/offset: 0x0
menu/list/size: second span? menu/list/pane
menu/clip/size/x: menu/list/size/x
menu/panel/offset: 0x0
menu/shadow/offset: 0x0
menu/less/offset:
menu/clip/offset:
menu/more/offset: 2x2
either (second menu/list/size + (edge-size? menu/panel) + 4x4 + 4x4) > max-size/y [
menu/less/show?: no menu/more/show?: yes
menu/clip/size/y: max-size/y ;-- of course this is only correct for offset/y = 0 and max-size/y = window/size/y
][
menu/less/show?: menu/more/show?: no
menu/clip/size/y: menu/list/size/y
]
menu/more/offset/y: menu/clip/offset/y + menu/clip/size/y
menu/panel/size: 4x4 + menu/clip/size + edge-size? menu/panel
if menu/less/show? [menu/panel/size/y: menu/panel/size/y + menu/less/size/y]
if menu/more/show? [menu/panel/size/y: menu/panel/size/y + menu/more/size/y]
menu/panel/effect
menu/shadow/size: menu/panel/size + 4x4 ;-- The additional 4x4 pixels increase in size is a hardcoded
; value depending of the shadow.png-image used to draw the shadow.
; It may vary if other images will be allowed for the menu shadow,
; but how and where account for that?
;-- Calculating offset --
;
; Position the sub-menu at the right edge on the same line with
; the actor.
;
at: any [
at
if menu/parent [
at: win-offset? menu/parent
at/x: at/x + menu/parent/size/x
if menu/parent/menu/edge [
at/x: at/x + menu/parent/menu/edge/size/x
]
if menu/panel/edge [
at/y: at/y - menu/panel/edge/size/y
]
at/y: at/y + (menu/parent/size/y - menu/list/pane/1/size/y / 2)
at/y: at/y - 2
at
]
0x0
]
menu/size: menu/shadow/size
;-- Right border check --
;
if at/x + menu/size/x > window/size/x [
either menu/parent [
at/x: max 0 at/x - menu/panel/size/x - menu/parent/size/x
][
at/x: max 0 window/size/x - menu/size/x
]
]
;-- Bottom border check --
;
if at/y + menu/size/y > window/size/y [
at/y: max 0 window/size/y - menu/size/y
]
;-- Size check, again --
;
if at/y + menu/size/y > window/size/y [
menu/size/y: menu/shadow/size/y: window/size/y
menu/panel/size/y: menu/size/y - 4
menu/clip/size/y: menu/panel/size/y - 4 - menu/more/size/y
menu/more/show?: yes
menu/more/offset/y: menu/clip/size/y
]
menu/offset: at
;== Finally, we've done it, so let's start the show
;
show-popup/window/away menu window
focus/no-show menu
unless new [wait []]
]
;---------------------------------------------------------------------------
;======================================================== remove-items-of ==
;
set 'add-menu func [
menu [object!] "The menu to remove from"
item [object!] "The item to remove"
][
remove any [find menu/list/pane item []]
]
;---------------------------------------------------------------------------
{
add-items-to app-menu 'file/recent [recent-5: item "www.rebol.org"]
remove-items-of app-menu 'file/recent/recent-5 ;-- Identifies item by VAR word.
remove-items-of app-menu 'file/recent/5 ;-- Identifies item by position in menu
}
;=========================================================== add-items-to ==
;
set 'insert-menu func [
"Inserts a menu item (even some) into an existing menu."
menu [object!] "The menu to add to"
desc [block!] "Description of one or more menu items"
/head
"Add item at the head of the menu."
/before
"Inserts item before the specified successor."
succ [object!]
/after
"Inserts item after the specified predecessor"
pred [object!]
/tail
"Inserts item at the tail of the menu (default)."
/local
pane new
][
menu/list/pane: any [
if head [menu/list/pane]
if before [find menu/list/pane succ]
if after [next find menu/list/pane pred]
system/words/tail menu/list/pane
]
type? menu/list/pane
new: build-menu none desc
insert menu/list/pane new/list/pane
layout-items menu desc
menu/list/pane: head menu/list/pane
]
;---------------------------------------------------------------------------
;=============================================================== menu-bar ==
;
stylize/master [
menu-bar: face with [
flags: [field]
type: 'menu-bar
style: none
parent: none
state: 'click-to-enter
list: self ;-- To make all the menu/list/pane paths from menubar/feel/super/... work.
set: get: func [ ;-- Updating e.g. text of menubar-items is problematic, but it would be useful for e.g. disabling these
"Set or get item values (executes code in item's context)."
path [path! word!] "Path to an item anywhere down in the tree"
code [block!] "Code executed in item's context"
/local
item
][
item: select items first path: to path! :path
either empty? next path [
do bind :code in item 'self
show item
][
item/sub/set next path :code
]
]
colors: reduce [none 178.180.191]
font: make font [name: "Tahoma" size: 11 color: black offset: space: 0x0 shadow: none]
color: none edge: none actor: none items: none
words: [
menu [new/data: first next args next args]
menu-style [new/style: first next args next args]
]
init: [
pane: copy []
list: self ;** To make all the menu/list/pane paths from menubar/feel/super/... work. Hack?
items: copy []
feel: ctx-menus/menubar-feel
if all [style data] [insert data style]
use [value menu-bar specs item item-offset actor specs] [
menu-bar: self
parse data [
copy specs to set-word! (
if none? specs [specs: copy [menu style item style]]
)
some [
set value set-word! 'item (
insert tail pane item: make face [
type: 'menu-item
menu: menu-bar
var: to word! value
font: menu-bar/font
offset: size: 0x0
edge: none
sub: none
para: make face/para [origin: 5x4 margin: none wrap?: no align: 'left valign: 'middle]
feel: ctx-menus/baritem-feel
]
insert tail menu-bar/items reduce [item/var item]
)
any [
set value string! (
item/text: value
)
| 'menu set value block! (
item/data: insert value specs
item/sub: layout-menu value
item/sub/parent: item ;-- Is this hack potentially dangerous?
)
]
]
]
item-offset: 0x0
foreach item pane [
item/size: add text-size? item edge-size? item
if all [item/para item/para/origin] [
item/size: item/size + (2 * item/para/origin)
]
item-offset: item/size + item/offset: 1x0 * item-offset
]
]
size: add second span? pane edge-size? self
]
multi: make multi [
file: func [face blk] [
if pick blk 1 [
face/data: load first blk
]
]
]
]
]
;============================================================== drop-menu ==
;
stylize/master [
drop-menu: field with [
style: none
size: 100x21
font: make face/font [offset: 2x6 colors: reduce [black black] name: "Tahoma" size: 11 align: 'left]
edge: make face/edge [size: 1x1 effect: none color: 178.180.191]
para: make face/para [wrap?: no margin: 22x5]
feel: make feel [
redraw: func [face act pos] bind [
if all [in face 'colors block? face/colors] [
face/color: pick face/colors face <> focal-face
]
if all [in face/font 'colors block? face/colors] [
face/font/color: pick face/font/colors face <> focal-face
]
] in system/view 'self
engage: func [face act event] bind [
switch act [
down [
either equal? face focal-face [unlight-text] [focus/no-show face]
caret: offset-to-caret face event/offset
show face
]
over [
if not-equal? caret offset-to-caret face event/offset [
if not highlight-start [highlight-start: caret]
highlight-end: caret: offset-to-caret face event/offset
show face
]
]
key [
either event/key = 'down [
;do in face/pane/feel 'engage face/pane 'up event
face/pane/action
][
ctx-text/edit-text face event get in face 'action
]
]
]
] in system/view 'self
]
menu: none
words: [
menu [new/data: first next args next args]
menu-style [new/style: first next args next args]
]
init: [
if all [style data] [insert data style]
use [anchor parent] [
parent: anchor: self
if not string? text [text: either text [form text] [copy ""]]
;if not flag-face? self hide [data: text]
colors: reduce [white yellow + 64.64.64]
pane: make-face/spec 'btn [
effect: [extend 14 draw [pen 0.0.0 fill-pen 0.0.0 polygon 5x7 11x7 8x10]]
size: 17x17
offset: 1x0 * parent/size - 20x-1
set in parent 'menu layout-menu parent/data
action: [
unfocus
show-menu/offset find-window parent parent/menu (win-offset? parent) + (0x1 * parent/size) - 1x2
]
]
]
]
]
]
;---------------------------------------------------------------------------
]
;------------------------------------------------------------------------------- |