| View script | License | Download script | History | Other scripts by: christian |
4-Oct 22:46 UTC
[0.045] 95.146k
[0.045] 95.146k
 | Archive version of: menu-system.r ... version: 2 ... christian 11-Jun-2005REBOL [
Title: "Menu-System"
Name: 'Menu-System
File: %menu-system.r
Version: 0.1.7
Date: 11-Jun-2005
Author: "Christian Ensel"
Email: christian.ensel@gmx.de
Owner: "Christian Ensel"
Rights: {
Copyright (c) 2005 Christian Ensel
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
• Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
• Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
• Neither the name of the copyright holder nor the names its
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
}
Purpose: {
Alpha of a pretty complete REBOL menu system.
Have menus in your REBOL apps, finally.
}
History: {
0.1.7 • Menu-accessor method object added
• Experimental removing and reinserting of items works.
• Global functions to menu-accessors added
• Dialect is more consistent and allows specification of
normal and hovered enabled and disabled states.
• A couple of layout and style inheritence problems fixed.
• Overall code cleaning.
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.
}
Todo: {
I'd like to get rid of MENU/ITEMS. Keeping it in sync with
MENU/LIST/PANE is annoying, one simple loop thru the latter should
do and won't be noticable slower.
}
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: 'BSD ;-- Not bothered with licensing stuff yet, but most likely BSD
see-also: none
]
]
ctx-menus: context [
;############################################# helper functions and alike ##
;
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
]
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]
]
;############################################################# MENU-ITEMS ##
;
;=========================================================== 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 ==
;
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 ==
;
; The ITEM-FEEL is the central method object for all item related
; functions.
;
; There are, for convience, some shorthands to them build directly into
; menu objects. But users who use them should be aware of losing the
; benefits of additional behaviour that comes with derived / overloaded
; methods.
;
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 an item." ;-- Cares for normal and hovered en- and disabled states.
item [object!] offset [pair!]
/local
state
][
state: pick [2 1] item = item/menu/actor
state: state + pick [2 0] item/disabled?
if item/options/colors [item/color: pick item/options/colors state]
if item/options/icons [item/icon/image: pick item/options/icons state]
item/body/font/color: any [
all [get in item/body/font 'colors pick item/body/font/colors state]
]
any [
all [ item/state item/mark <> item/pane/1 insert item/pane item/mark]
all [not item/state item/mark = item/pane/1 remove item/pane ]
]
if item/edge: item/options/edge [
if get in item/options/edge 'colors [
item/edge/color: pick item/options/edge/colors state
]
if get in item/options/edge 'effects [
item/edge/effect: pick reduce item/options/edge/effects state
]
]
if item/options/effects [item/effect: pick item/options/effects state]
either item/disabled? [ ;-- Hardcoded DISABLE state here. Has to be dialected!
either item/icon/effect [
if not find item/icon/effect 'grayscale [
insert tail item/icon/effect [grayscale luma 25 blur blur blur]
]
][
item/icon/effect: copy [grayscale luma 25]
]
][
if item/icon/effect [remove/part any [find item/icon/effect 'grayscale []] 6]
]
]
visit: func [ ;-- Show that we're visited
"Visits item (draws it's hover state)." item [object!]
][
show item
]
enter: func [
"Enters item (shows it's sub-menu)."
item [object!]
/new ;-- NEW is used to differentiate between wandering through menus with
"Returns immediately from showing." ; 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).
;
][
if all [ ;-- Show the own sub-menu, for enabled item's with sub-menus
item/sub ; not already popped up only
not item/disabled?
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 [
"Leaves item (draws it's unhovered 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
][
if 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
]
if item/options/action [ ;-- Trigger the items action by doing an anonymous function build
do func [item] bind item/options/action in item 'self item ; from the item's action block. Should I allow for functions here, too?
]
]
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: none ;-- COLORS allows for multiple activation-state dependend colors
; (normal, actor, disabled).
effect: none ;-- EFFECTS allows for multiple activation-state dependend effects
; (normal, actor, disabled).
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: 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: 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: face/para [wrap?: no]]
key: make detail-face [para: face/para [wrap?: no]]
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: parent/options/item/colors
effect: parent/options/item/effect
effects: parent/options/item/effects
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
para: parent/options/item/key/para
]
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 ;-- This is necessary for ADJUST-ITEMS to take in account edges, too.
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
]
]
]
;=========================================================== 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
]
)
| 'colors set value ['none | none! | block!] (
if value = 'none [value: none]
item/options/colors: reduce value
)
| '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]
]
)
| 'effect set value [lit-word! | block!] (
item/options/effect: compose [(value)]
)
| 'effects set value block! (
item/effects:
item/options/effects: compose [(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
]
;################################################################### MENU ##
;
;============================================================ menu-access ==
;
menu-access: make system/view/vid/vid-face/access [
get-face: set-face: clear-face: reset-face: none ;-- I'd rather use these, but haven't the slightest idea of what
; e.g. get-face menu should be used for. I therefore come with my own methods ...
exec: func [
"Sets or get item values (i.e. executes code in item's context)."
menu [object!] "The menu to act on"
path [path! word!] "Path to an item anywhere down in the tree"
code [word! path! block!] "Code executed in item's context"
/local
item
][
if word? path [path: to path! path]
if not block? code [code: reduce [code]]
item: first path: copy path
item: either not error? try [to integer! item] [
pick menu/list/pane to integer! item
][
select menu/items to word! item
]
either empty? head system/words/remove path [
do bind :code in item 'self
][
item/sub/access/exec item/sub path code
]
]
insert: func [
"Attaches an item into an existing menu."
root [object!] "The menu root"
path [path! word! none!] "Path to an item to add to it's sub-menu"
item [object!] "Menu item already layouted"
/head "Add item at the head of the menu."
/before "Inserts item before the specified successor." succ [word! object!]
/after "Inserts item after the specified predecessor" pred [word! object!]
/tail "Inserts item at the tail of the menu (default)."
/as
var [word! none!] "Word by which to refer to the item."
/local
new menu
][
menu: either path [root/access/exec root path [self/sub]] [root]
menu/list/pane: case [
head [ menu/list/pane ]
before [ find menu/list/pane succ: either object? succ [succ] [select menu/items succ]]
after [ next find menu/list/pane pred: either object? pred [pred] [select menu/items pred]]
/default
[system/words/tail menu/list/pane ]
]
menu/items: case [
head [ menu/items ]
before [ back find menu/items succ]
after [ next find menu/items pred]
/default
[system/words/tail menu/items ]
]
case [
object! = type? item [
case [
any [
'menu-item = item/type
'menu-divider = item/type
][
if as [item/var: var]
system/words/insert menu/list/pane item
system/words/insert menu/items reduce [item/var item]
item/menu: menu
]
'menu [ "N/A" ]
]
]
block! = type? item [ "N/A" ]
]
menu/list/pane: system/words/head menu/list/pane
menu/items: system/words/head menu/items
adjust-menu menu
]
remove: func [
"Detaches an item from the menu and returns it."
root [object!] "The menu to remove from"
path [path! word!] "Path to an item anywhere down in the tree"
/local
item
][
item: root/access/exec root path [self]
system/words/remove find item/menu/list/pane item
system/words/remove/part back find item/menu/items item 2
item/menu: none
item
]
set 'get-menu func [
"Returns a value of menu item."
root [object!] "The menu to act on"
path [path! word!] "Path to an item anywhere down in the tree"
word [word! path! block!] "Word in item"
][
root/access/exec root path word
]
set 'set-menu func [
"Returns a value of menu item."
root [object!] "The menu to act on"
path [path! word!] "Path to an item anywhere down in the tree"
code [block!] "Word: Value"
][
root/access/exec root path code
]
set 'remove-menu func [
"Detaches an item from the menu and returns it."
root [object!] "The menu to remove from"
path [path! word!] "Path to an item anywhere down in the tree"
][
root/access/remove root path
]
set 'insert-menu func [
"Attaches an item into an existing menu."
root [object!] "The menu root"
path [path! word! none!] "Path to an item to add to it's sub-menu"
item [object!] "Menu item already layouted"
/head "Add item at the head of the menu."
/before "Inserts item before the specified successor." succ [word! object!]
/after "Inserts item after the specified predecessor" pred [word! object!]
/tail "Inserts item at the tail of the menu (default)."
/as
var [word! none!] "Word by which to refer to the item."
][
var: any [var item/var]
case [
head [root/access/insert/head/as root path item var]
before [root/access/insert/before/as root path item var]
after [root/access/insert/after/as root path item var]
/default [root/access/insert/as root path item var]
]
]
]
;========================================================= menubar-access ==
;
menubar-access: make menu-access [
super: menu-access
remove: func [ ;-- This change in the methods signature is to reflect the fact, that
"Detaches an item (sub-item only) from the menu and returns it." ; adding menubar-items currently isn't possible
menubar [object!] "The menubar to remove from"
path [path!]
][
menubar/access/super/remove menubar path
]
]
;============================================================== menu-feel ==
;
; The MENU-FEEL is the central method object for all menu related
; functions.
;
; There are, for convience, some shorthands to them build directly into
; menu objects. But users who use them should be aware of losing the
; benefits of additional behaviour that comes with derived / overloaded
; methods.
;
menu-feel: make system/view/popface-feel-win-away [
super: none
redraw: func [menu offset] [ ;-- Why not put the inheritet-options stuff here?
menu/panel/color: menu/options/menu/color
]
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
]
redraw: none
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 [
type: 'menu
flags: [field]
feel: menu-feel
access: menu-access
parent: item
color: none
edge: none
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: none
edge: none
effect: none
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! [
image: parent/options/menu/image
effect: parent/options/menu/effect
spacing: parent/options/menu/spacing
edge: parent/options/menu/edge
rate: parent/options/menu/rate
color: parent/options/menu/color
]
item: make object! [
action: parent/options/item/action
effect: parent/options/item/effect
effects: parent/options/item/effects
color: parent/options/item/color
colors: parent/options/item/colors
body: make object! [
font: parent/options/item/body/font
para: parent/options/item/body/para
]
key: make object! [
font: parent/options/item/key/font
para: parent/options/item/key/para
]
edge: parent/options/item/edge
]
]
menu/panel/effect: parent/options/menu/effect
menu/panel/edge: parent/options/menu/edge
][
menu/options: make object! [
menu: make object! [
image: none
effect: none
spacing: 0x0
edge: make face/edge [
size: 0x0
color: none
colors: none ;reduce [178.180.191 none]
effect: none
effects: none
]
rate: 64 ;-- Dialect this
color: none
]
item: make object! [
action: none
color: none
colors: none
image: none
effect: none
effects: none
body: make object! [font: para: none]
key: make object! [font: para: none]
edge: make face/edge [
size: 1x1
color: effect: none
colors: none
;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
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
]
if menu/options/menu/edge [
menu/panel/edge: menu/options/menu/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] ;-- Include the stylesheet applied and then
parse desc [ ; go and look for style refinements
any [
'menu 'style some [
'color set value [word! | tuple!] (
menu/options/menu/color: cast value [
word! [get value]
tuple! [value]
]
)
| 'spacing set value [integer! | pair!] (
menu/options/menu/spacing: to pair! 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:
menu/options/menu/effect: compose [(value)]
)
]
| 'item 'style some [
'colors set value ['none | none! | block!] (
if value = 'none [value: none]
menu/options/item/colors: reduce value
)
| 'font set value block! (
menu/options/item/body/font:
menu/options/item/key/font: make menu/options/item/body/font value
)
| 'effect set value [lit-word! | block!] (
menu/options/item/effect: compose [(value)]
)
| 'effects set value block! (
menu/options/item/effects: compose [(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
]
;============================================================ adjust-menu ==
;
; ADJUST-MENU calculates all values (offsets and such) that are subject
; to change between to shows of the menu.
;
; COMMENT: Currently, the responsibilities of ADJUST-MENU, ADJUST-ITEMS
; and SHOW-MENU aren't defined very clear, here's room for
; improvements.
;
adjust-menu: func ["Adjusts the menus size." menu [object!]] [ ;-- BUG: Actually, this never get's called.
adjust-items menu/list/pane
]
;############################################# PUBLIC INTERFACE FUNCTIONS ##
;
;============================================================== show-menu ==
;
; The SHOW-MENU actually does all the work of showing a previously set up
; menu. Client scripts that only use MENUBAR and/or DROP-MENU don't
; need to call this, they just LAYOUT-MENU their menus and feed those
; VID-Styles with them.
;
set 'show-menu func [
"Shows a menu."
window [object!]
menu [object!]
/offset ;-- This is of use only for top-level menus, positions of further nested
"Prescribes where to open the menu." ; menu are calculated automatically depending of WIN-OFFSET of the parent item
at [pair!] ; they're bound to.
/size
"Restrict menu's size"
menu-size [pair!]
/new
"Opens a new window and returns immediately." ;-- Works like in VIEW.
/local
value
item divider item-offset item-size shadow-size
][
shadow-size: 4x4 ;-- For now, prescribe that shadows have to be 4x4 pixels wide!
menu-size: any [menu-size window/size]
item-size: adjust-items menu/list/pane
menu/less/size: menu/more/size: 1x0 * item-size/x + 0x12 ;-- Preparation of the less- and more-knobs, we'll may need them.
draw-knob menu 'less ;
draw-knob menu 'more ; This is somewhat strange, but may it be.
menu/list/offset: 0x0 ;-- Let's see how big the menu want's to be get.
menu/list/size: second span? menu/list/pane ;
menu/clip/size/x: menu/list/size/x
menu/panel/offset: menu/shadow/offset: 0x0
menu/less/offset: menu/clip/offset: menu/more/offset: menu/options/menu/spacing
either menu/list/size/y ;-- If it's bigger than it's allowed to get,
+ (second edge-size? menu/panel) ; we need the more button
+ (2 * menu/options/menu/spacing/y)
+ shadow-size/y
> menu-size/y [
menu/less/show?: not menu/more/show?: yes
menu/clip/size/y: menu-size/y ;-- of course this is only correct for offset/y = 0 and menu-size/y = window/size/y
- (second edge-size? menu/panel)
- (2 * menu/options/menu/spacing/y)
- shadow-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: (2 * menu/options/menu/spacing) + 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/shadow/size: menu/panel/size + shadow-size
at: any [ ;-- Calculating offset: Where are we supposed to open?
at ;
if menu/parent [ ; If caller made no suggestion, we position the menu at the right edge
at: win-offset? menu/parent ; vertically centered with the actor.
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/y: max 0 at/y
at
]
0x0
]
menu/size: menu/shadow/size
if at/x + menu/size/x > window/size/x [ ;-- Right border check --
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
]
]
if at/y + menu/size/y > window/size/y [ ;-- Bottom border check --
at/y: max 0 window/size/y - menu/size/y
]
if at/y + menu/size/y > window/size/y [ ;-- Size check, again --
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
show-popup/window/away menu window ;-- Finally, let's start the show
focus/no-show menu
unless new [wait []]
]
;############################################################# VID-Styles ##
;
;=============================================================== MENU-BAR ==
;
; The VID-style MENU-BAR. Supports easy integration of menus into a
; VID layout.
;
; Regarding customization: MENU-BAR is, by it's nature, available for
; styling through the usual VID dialect.
;
; Whereas menubar-items are not!
;
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
access: ctx-menus/menubar-access
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 ==
;
; Much like menu-bars, but different in that the DROP-MENU actually is
; nothing but a shorthand for binding a menu to a button, with the
; one speciality that it auto-inserts the chosen items body-text
; into the containing field.
;
; The insertion is done in the item's action block, hence, DROP-MENU
; is currently still experimental, as it would be difficult if possible
; for clients to modify that behaviour.
;
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
]
]
]
]
]
]
] |