## popup-menu.pkg
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# A simple menu package.
#
# TODO:
# defaults for submenus XXX BUGGO FIXME
### "The Macintosh uses an experimental pointing
### device called a mouse. There is no evidence
### that people want to use these things."
###
### -- John Dvorak 1984
stipulate
include threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package wg = widget; # widget is from src/lib/x-kit/widget/basic/widget.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg #
package xg = xgeometry; # xgeometry is from src/lib/std/2d/xgeometry.pkgherein
package popup_menu
: (weak) Popup_Menu # Popup_Menu is from src/lib/x-kit/widget/menu/popup-menu.api {
Popup_Menu(X)
=
POPUP_MENU List( Popup_Menu_Item(X) )
also
Popup_Menu_Item(X)
= POPUP_MENU_ITEM (String, X)
| POPUP_SUBMENU (String, Popup_Menu(X))
;
Popup_Menu_Position
= PUT_POPUP_MENU_UPPERLEFT_ON_SCREEN xg::Point # Position the popup menu's upper-left corner at this screen coordinate.
| PUT_POPUP_MENU_ITEM_BENEATH_MOUSE Int # Position the popu menu with mouse cursor centered over given item (0 is first item).
;
Where_Info
=
WHERE_INFO
{
mouse_button: xc::Mousebutton,
window_point: xg::Point,
screen_point: xg::Point,
timestamp: xc::xserver_timestamp::Xserver_Timestamp
};
menu_font = "8x13";
padding = 1; # padding between window border and actual menu items
border_thickness = 1; # Border width
inset = 1; # Add'l x padding to ensure highlighting encloses text and icon.
vspace = 1; # y padding per item, for same reason as above.
total_padding = padding+padding;
no_buttons
=
xc::make_mousebutton_state [];
Label = LABEL { box: xg::Box,
text_pos: xg::Point,
text: String
};
Menu_Representation(X)
=
MENU_REPRESENTATION
{
size: xg::Size,
item_high: Int,
font: xc::Font,
label: Null_Or( Label ), # note: only top-level menus have labels
items: List( Item_Representation(X) )
}
also
Item_Representation(X)
#
= ITEM_REPRESENTATION
{ label: Label,
item: X
}
#
| SUB_MENU_REPRESENTATION
{ label: Label,
menu_pos: xg::Point, # obsolete - position relative to parent menu
menu: Menu_Representation(X)
};
icon_high = 12;
icon_wide = 12;
icon_sp = 1; # minimum space between text and icon
submenu_image
=
xc::CS_PIXMAP
{
size => xg::SIZE { wide=>icon_wide, high=>icon_high },
#
data => [ map byte::string_to_bytes [
"\127\192", "\064\064", "\064\096", "\078\096",
"\064\096", "\078\096", "\064\096", "\078\096",
"\064\096", "\064\096", "\127\224", "\031\224"
]]
};
fun layout_menu (font, menu, label)
=
layout (menu, label)
where
my { ascent, descent }
=
xc::font_high font;
text_wide = xc::text_width font;
fun menu_geometry (POPUP_MENU items, label)
=
{ fun max_w (m, has_subm, nitems, [])
=>
(total_padding + 2*inset + m, nitems, has_subm);
max_w (m, has_subm, nitems, POPUP_MENU_ITEM (s, _) ! r)
=>
max_w (int::max (m, text_wide s), has_subm, nitems+1, r);
max_w (m, has_subm, nitems, POPUP_SUBMENU (s, _) ! r)
=>
max_w (int::max (m, (text_wide s) + icon_wide + icon_sp), TRUE, nitems+1, r);
end;
case label
#
NULL => max_w (0, FALSE, 0, items);
THE s => max_w (text_wide s, FALSE, 1, items);
esac;
};
fun layout (menu as (POPUP_MENU items), label)
=
{ my (max_wid, item_high, tot_ht)
=
{ my (max_wid, n, has_subm)
=
menu_geometry (menu, label);
fonth = ascent+descent;
item_high = if has_subm int::max (fonth+vspace, icon_high); else fonth+vspace;fi;
(max_wid, item_high, n*item_high+total_padding);
};
fun make_center_label (y_pos, item_label)
=
{ wide = text_wide item_label;
LABEL {
box => xg::BOX { col=>0, row=>y_pos, wide=>max_wid, high=>item_high },
text_pos => xg::POINT { col=>(max_wid - wide) / 2, row=>y_pos+ascent },
text => item_label
};
};
fun make_label (y_pos, item_label)
=
{ wide = text_wide item_label;
LABEL
{ box => xg::BOX { col=>padding, row=>y_pos, wide=>max_wid-total_padding, high=>item_high },
text_pos => xg::POINT { col=>padding+inset, row=>y_pos+ascent },
text => item_label
};
};
fun do_items (_, [])
=>
[];
do_items (y_pos, item ! r)
=>
item_representation ! do_items (y_pos+item_high, r)
where
item_representation
=
case item
#
POPUP_MENU_ITEM (s, v)
=>
ITEM_REPRESENTATION { label => make_label (y_pos, s),
item => v
};
POPUP_SUBMENU (s, m)
=>
{ my menu as MENU_REPRESENTATION { size=> xg::SIZE { wide, ... }, ... }
=
layout (m, NULL);
SUB_MENU_REPRESENTATION
{
label => make_label (y_pos, s),
# menu_pos = xg::POINT { col=>maxWid-(wide / 3), row=>yPos },
menu_pos => xg::point::zero,
menu
};
};
esac;
end;
end;
my (label, items)
=
case label
#
NULL => (NULL, do_items (padding, items));
THE s => (THE (make_center_label (0, s)), do_items (padding+item_high, items));
esac;
MENU_REPRESENTATION
{
size => xg::SIZE { wide=>max_wid, high=>tot_ht },
item_high,
font,
label,
items
};
}; # fun layout
end; # fun layout_menu
Mitem(X)
=
{ id: Int,
draw_on: Void -> Void,
draw_off: Void -> Void,
rep: Item_Representation(X)
};
# Create a menu window.
#
# This involves creating and mapping
# the window and setting up the code
# for drawing the items.
#
# "menu_position" gives the position to place
# the menu in screen coordinates.
#
fun create_menu_window (screen, submenu_icon, mrep, menu_position as xg::POINT { col=>menu_x, row=>menu_y } )
=
{ box => menu_box,
in_menu,
select => select_item,
close
}
where
mrep -> MENU_REPRESENTATION { size, font, item_high, label, items, ... };
size -> xg::SIZE { wide=>menu_wide, high=>menu_high };
white = xc::white;
black = xc::black;
my (window, in_dictionary)
=
xc::make_simple_popup_window screen
{
background_color => xc::rgb8_white,
border_color => black,
#
site => xg::WINDOW_SITE
{ upperleft => xg::point::subtract (menu_position, xg::POINT { col=>border_thickness, row=>border_thickness } ),
size,
border_thickness
}
};
xc::ignore_all in_dictionary;
xc::show_window window;
my (items_box as xg::BOX { row=>items_y, ... } )
=
{ my (x, y, w, h)
=
case label
#
NULL => (menu_x, menu_y, menu_wide, menu_high );
THE _ => (menu_x, menu_y+item_high, menu_wide, menu_high-item_high);
esac;
xg::BOX
{ col => x+padding,
row => y+padding,
#
wide => w-total_padding,
high => h-total_padding
};
};
# Geometry of menu window:
#
menu_box
=
xg::BOX
{ col => menu_x,
row => menu_y,
#
wide => menu_wide,
high => menu_high
};
# Geometry of menu window including border
#
all_box
=
xg::BOX
{ col => menu_x - border_thickness,
row => menu_y - border_thickness,
#
wide => menu_wide + 2*border_thickness,
high => menu_high + 2*border_thickness
};
fun in_menu p
=
xg::point::in_box (p, all_box);
fun close ()
=
xc::destroy_window window;
fore_pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb black), xc::p::BACKGROUND (xc::rgb8_from_rgb white) ];
back_pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb white), xc::p::BACKGROUND (xc::rgb8_from_rgb black) ];
fun draw_item (LABEL { text_pos, text, ... } ) pen
=
xc::draw_transparent_string
#
(xc::drawable_of_window window)
pen
font
(text_pos, text);
fun clear_item (LABEL { box, ... } ) pen
=
xc::fill_box
#
(xc::drawable_of_window window)
pen
box;
fun draw_submenu (LABEL { box, text_pos, text }) pen
=
{ icon = the submenu_icon;
#
box -> xg::BOX { col=>x, row=>y, wide, ... };
xc::draw_transparent_string
#
(xc::drawable_of_window window)
pen
font
(text_pos, text);
xc::texture_blt
#
(xc::drawable_of_window window)
pen
{ from => icon,
to_pos => xg::POINT { col => (x + wide) - (icon_wide+inset),
row => y+1
}
};
};
fun make_items ([], _) => [];
make_items (item ! r, n)
=>
{ my (draw, label)
=
case item
ITEM_REPRESENTATION { label, ... } => (draw_item label, label);
SUB_MENU_REPRESENTATION { label, ... } => (draw_submenu label, label);
esac;
clear = clear_item label;
fun draw_on () = { clear fore_pen; draw back_pen; };
fun draw_off () = { clear back_pen; draw fore_pen; };
draw fore_pen;
{ id => n, draw_on, draw_off, rep => item } ! make_items (r, n+1);
};
end;
items = make_items (items, 0);
fun select_item (pt as xg::POINT { col=>x, row=>y } )
=
xg::point::in_box (pt, items_box) ?? THE (list::nth (items, int::quot (y - items_y, item_high)))
:: NULL;
case label
#
THE title => { clear_item title fore_pen;
draw_item title back_pen;
};
_ => ();
esac;
end; # fun create_menu
# NB: The "X menu_rep" constraint is
# because of a bug in the typechecker. XXX BUGGO FIXME
#
fun pop_menu (menu_rep: Menu_Representation(X), mbut, screen, icon, menupt, pos, mouse)
=
{ my xg::SIZE { wide=>screen_wide, high=>screen_high }
=
xc::size_of_screen screen;
# Adjust the position of a menu
# to insure that it will fit
# on the screen:
#
fun clip_menu (xg::POINT { col=>x, row=>y }, MENU_REPRESENTATION { size=> xg::SIZE { wide, high }, ... } )
=
xg::POINT { col => int::max (border_thickness, if (x+wide < screen_wide - border_thickness) x; else (screen_wide - (wide+border_thickness));fi),
row => int::max (border_thickness, if (y+high < screen_high - border_thickness) y; else (screen_high - (high+border_thickness));fi)
};
m_mailop
=
mouse ==> xc::envelope_contents;
fun popup (menu_rep, menupt, mouse_pos as xg::POINT { col=>mx, row=>m_y }, leave_pred)
=
{ menu_rep -> MENU_REPRESENTATION { size as xg::SIZE { wide, ... }, item_high, ... };
# Calculate menu origin based
# on mouse position:
#
menu_pt
=
case menupt
#
PUT_POPUP_MENU_UPPERLEFT_ON_SCREEN p => p;
PUT_POPUP_MENU_ITEM_BENEATH_MOUSE 0 => xg::POINT { col=>mx-(wide / 2), row=>m_y-(item_high / 2) };
PUT_POPUP_MENU_ITEM_BENEATH_MOUSE n => xg::POINT { col=>mx-(wide / 2), row=>m_y-(item_high / 2)-(item_high * n) };
esac;
menu_pos = clip_menu (menu_pt, menu_rep);
my { box as xg::BOX { col=>menu_x, ... }, in_menu, select, close }
=
create_menu_window (screen, icon, menu_rep, menu_pos);
fun flip_on ( { draw_on, ... }: Mitem(X)) = draw_on ();
fun flip_off ( { draw_off, ... }: Mitem(X)) = draw_off ();
fun same_item
( { id => a, ... }: Mitem(X),
{ id => b, ... }: Mitem(X)
)
=
a == b;
fun track_mouse (cur_item, pt)
=
{ cur_item
=
case (cur_item, select pt)
#
(NULL, NULL ) => NULL;
(THE a, NULL ) => { flip_off a; NULL;};
(NULL, THE b) => { flip_on b; THE b;};
#
(THE a, THE b) => if (same_item (a, b))
#
cur_item;
else
flip_off a;
flip_on b;
THE b;
fi;
esac;
fun next_mouse_mailop (cur_item, screen_pt)
=
case (block_until_mailop_fires m_mailop)
#
xc::MOUSE_MOTION { screen_point, ... }
=>
track_mouse (cur_item, screen_point);
xc::MOUSE_LAST_UP { mouse_button, screen_point, ... }
=>
case (cur_item: Null_Or( Mitem(X) ))
#
THE { rep=>ITEM_REPRESENTATION { item, ... }, ... }
=>
{ close();
(THE item, FALSE, screen_point);
};
_ => { close();
(NULL, FALSE, screen_point);
};
esac;
xc::MOUSE_UP { mouse_button, screen_point, ... }
=>
track_mouse (cur_item, screen_point);
xc::MOUSE_DOWN { screen_point, ... }
=>
track_mouse (cur_item, screen_point);
_ => track_mouse (cur_item, screen_pt);
esac;
case cur_item
#
THE { rep=>SUB_MENU_REPRESENTATION { menu, ... }, ... }
=>
{ pt -> xg::POINT { col => x, ... };
# If item has a submenu and mouse is on or to the
# right of the icon, put up submenu.
# If second field of answer is FALSE, user is done,
# so close up shop. Otherwise, some button is still
# down, so continue to track the
# mouse. If the mouse is really in one of our
# ancestors, this will be caught in trackMouse.
# This latter case could be short-circuited by
# checking here that the mouse is in our box,
# and, if not, returning directly.
#
if (x + (icon_wide+padding+inset) >= menu_x + wide)
#
fun prior pt
=
(leave_pred pt) or xg::point::in_box (pt, box);
answer = popup (menu, PUT_POPUP_MENU_ITEM_BENEATH_MOUSE 0, pt, prior);
if (#2 answer)
#
track_mouse (cur_item, #3 answer);
else
close ();
answer;
fi;
else
next_mouse_mailop (cur_item, pt);
fi;
};
# If the mouse is not on a menu item, and is not
# even in the menu window (including border), and
# is in some ancestor menu, then close up and return.
NULL => if (not (in_menu pt) and (leave_pred pt))
close();
(NULL, TRUE, pt);
else
next_mouse_mailop (cur_item, pt);
fi;
_ => next_mouse_mailop (cur_item, pt);
esac;
};
track_mouse (NULL, mouse_pos);
}; # fun popup
xsession = xc::xsession_of_screen screen;
menu_cursor
=
xc::get_standard_xcursor
xsession
xc::cursors::sb_left_arrow;
xc::change_active_grab_cursor
xsession
menu_cursor;
#1 (popup (menu_rep, menupt, pos, fn _ = FALSE));
}; # fun pop_menu
# Return TRUE iff the menu has a sub-menu:
#
fun has_submenu (POPUP_MENU items)
=
f items
where
fun f [] => FALSE;
f ((POPUP_MENU_ITEM _) ! r) => f r;
f _ => TRUE;
end;
end;
fun attach (selection_channel, widget, mbuts, menu, label, pos)
=
{ root_window = wg::root_window_of widget;
xsession = wg::xsession_of root_window;
screen = wg::screen_of root_window;
font = xc::open_font xsession menu_font;
menu_rep
=
layout_menu (font, menu, label);
icon = has_submenu menu ?? THE (xc::make_readonly_pixmap_from_clientside_pixmap screen submenu_image)
:: NULL;
fun realize { window, window_size, kidplug as xc::KIDPLUG { from_mouse', ... } }
=
{ m_slot = make_mailslot ();
menu_mbs = xc::make_mousebutton_state mbuts;
make_thread "popup_menu" loop
where
fun loop ()
=
{ envelope
=
block_until_mailop_fires from_mouse';
case (xc::envelope_contents envelope)
#
xc::MOUSE_FIRST_DOWN (arg as { screen_point, mouse_button, ... } )
=>
if (xc::mousebutton_is_set (menu_mbs, mouse_button))
#
case (pop_menu (menu_rep, mouse_button, screen, icon, pos (WHERE_INFO arg), screen_point, from_mouse'))
#
THE v =>
{ make_thread "popup_menu pop menu" .{
#
put_in_mailslot (selection_channel, v);
};
();
};
NULL => ();
esac;
else
put_in_mailslot (m_slot, envelope);
fi;
_ => put_in_mailslot (m_slot, envelope);
esac;
loop ();
};
end;
wg::realize_fn widget
{ window,
window_size,
kidplug => xc::replace_mouse (kidplug, take_from_mailslot' m_slot)
};
();
}; # fun realize
wg::make_widget
{ root_window,
realize,
args => fn () = { background => NULL },
size_preference_thunk_of
=>
wg::size_preference_thunk_of widget
};
}; # fun attach
fun attach_menu_to_widget (widget, mbuts, menu)
=
{ selection_slot = make_mailslot ();
( attach (selection_slot, widget, mbuts, menu, NULL, fn _ = PUT_POPUP_MENU_ITEM_BENEATH_MOUSE 0),
take_from_mailslot' selection_slot
);
};
fun attach_labeled_menu_to_widget (widget, mbuts, label, menu)
=
{ selection_slot = make_mailslot ();
( attach (selection_slot, widget, mbuts, menu, THE label, fn _ = PUT_POPUP_MENU_ITEM_BENEATH_MOUSE 0),
take_from_mailslot' selection_slot
);
};
fun attach_positioned_menu_to_widget (widget, mbuts, menu, pos)
=
{ selection_slot = make_mailslot ();
( attach (selection_slot, widget, mbuts, menu, NULL, pos),
take_from_mailslot' selection_slot
);
};
fun make_lowlevel_popup_menu (root_window, menu, label)
=
do_pop
where
xsession = wg::xsession_of root_window;
screen = wg::screen_of root_window;
font = xc::open_font xsession menu_font;
menu_rep = layout_menu (font, menu, label);
icon = has_submenu menu ?? THE (xc::make_readonly_pixmap_from_clientside_pixmap screen submenu_image)
:: NULL;
fun do_pop (mbut, menupt, screen_pt, m)
=
{ slot = make_mailslot ();
fun do_it ()
=
put_in_mailslot (slot, pop_menu (menu_rep, mbut, screen, icon, menupt, screen_pt, m));
make_thread "popup_menu popup_menu" do_it;
take_from_mailslot' slot;
};
end;
}; # package popup_menu
end;