SETL's Interactive Graphical Interface; Sockets and Internet-Programming Basics
SETL's Interactive Graphical Interface, which is built upon the powerful and widely used Tk widget library developed by John Osterhout, provides a full set of interactive graphical widgets, including buttons, menus, editable text entry and display areas of one or more lines, sliders, listboxes, 'labels' and 'messages' for the display of non-editable text, sliders, scrollbars, and 'canvases' in which a variety of geometric objects can be drawn and repositioned. Checkbuttons and radiobuttons are also supported. The geometric objects available within canvases are rectangles, ovals, polygons, lines (open multipoint spline curves), arcs, bitmaps, images, and embedded text. Additionally, any other widget, including subcanvases, can drawn to a canvas, so that canvases can be structured as collages of basic geometric objects and subcanvases.
All widgets are sensitive to a wide variety of events, including mouse clicks and mouse motion, making it easy to support many kinds of draggable objects. The text area widget is particularly powerful, in that it supports fully fonted and hotworded text, and allows embedding of images, and, indeed, of any other widget.
The facilities provided allow any number of self-standing windows, called 'toplevels', to be opened, displayed or temporarily hidden, positioned, and resized. Within these windows one can hierarchically arrange rectangular 'frames', subframes, canvases, and text areas, with other widgets placed in them. The detailed arrangement of all these items can either be calculated automatically (allowing for easy, and often adequate, response to window resizing), or can be brought under detailed program control. The two forms of automatic placement provided are called the 'pack geometry manager' (which tries to fit items as close as it can to a specified frame edge), and the 'grid geometry manager' (which places elements in row-and-column arrays.) The third and last of 'geometry manager', provided, the 'place geometry manager', allows detailed program control of placement.
To use the interactive graphical interface, one simply includes the declaration
use tkw;
in one's program or package; this loads the tkw class, supplied with SETL, which provides all the interactive graphical interface facilities. Use of the interactive graphical interface is then initiated by executing the single statement
master_window_name := tkw();
which performs all necessary initializations and opens a first toplevel window. This is followed by a block of code which creates all desired additional windows and widgets which are to open immediately.
Once all initially desired windows and widgets have been created, event-driven execution of the interface system, and of the SETL system backing it up, is initiated by making the call
Tk.mainloop();
(Other windows and widgets can then be created dynamically whenever desired). This enters Tk's main loop, to which the SETL interpreter is subsequently subordinate, in the sense that it will only receive control via event-driven callbacks from Tk set up by the initial 'Setup' code.
Here is a small "Hello World" example, which simply displays "Hello World" inside a window in large-size red type. We will shortly detail the all the operations and conventions which it uses.
program test; -- SETL interactive interface example 1
use tkw; -- use the standard graphical interface package
Tk := tkw(); -- create the Tk interpreter
txt := Tk("text","20,3"); txt("side") := "top";
-- create a 'text area' widget, 20 characters by 3 lines in size
txt(OM) := "Hello World"; -- insert text into it
txt("font,foreground") := "{Times 48},red";
-- set the text font and color
Tk.mainloop(); -- enter the main Tk loop
end test;
'Toplevel' widgets are self-standing windows of whatever kinds are available in the system under which SETL and Tk are running. They are created by commands of the form
toplevel_name := master_window_name("toplevel","initial_width,initial_height");
where 'tkw_name' is the name of the master widget object. (This is generally the object 'Tk' created by the initiating call
Tk := tkw(); -- create the Tk interpreter
All other widgets are then created and arranged hierarchically within the toplevel' widgets opened. Each toplevel can have its own menubar.
'Frames' are rectangular areas within toplevel windows or other frames, within which other widgets can be arranged. They are created by commands of the form
frame_name := parent_frame_or_window("frame","initial_width,initial_height");
Other widgets can then be created and arranged hierarchically within such frames.
A frame or other widget created within a toplevel window or another frame only becomes visible when it has been assigned a place, either explicitly or by defining the 'geometry manager' responsible for placing it. For example, once can write
frame_name("side") := "top";
This use of "side" implies that the frame is to be placed within its parent P by the 'pack geometry manager', which in our example is instructed to position the frame toward the top of P. Instead of "top", one could use "bottom", "left", or "right".
The same rules apply to other widgets created within frames. Once such a widget has been created, it can be made visible by positioning it within its parent frame, e.g. by writing
widget_name("side") := "top";
A widget with a given parent is created by writing
widget_name := parent_frame(widget_type,main_parameter);
for example
button_name := parent_frame("button","Please Click Me Right Now!");
as seen in this example, the 'main parameter' used when creating a button is the button text. The following table shows the main parameters used in creating other kinds of widgets:
button parent("button",button_text)
menu parent("menu",descriptor)
-- the structure of 'descriptor' is detailed below
one-line text parent("entry",width_in_characters)
text area parent("text",width_in_characters_and_height_in_lines)
slider parent("scale",least_value_and_greatest_value)
listbox parent("listbox",number_of_items)
label parent("label",label_text)
message parent("message",message_text_and_width)
scrollbar parent("scrollbar",orientation_and_width)
-- e.g. "horizontal,16" or "vertical,10"
canvas parent("canvas",width_and_height)
subframe parent("frame",width_and_height)
Examples are
one-line text parent("entry",50)
text area parent("text","50,10")
slider parent("scale","-100,100")
listbox parent("listbox",15)
canvas parent("canvas","640,480")
subframe parent("frame","320,240")
The second parameter supplied can either be a string, an integer, or a tuple of appropriate length. For example, the preceding examples can instead be written as
one-line text parent("entry","50")
text area parent("text",[50,10])
slider parent("scale",[-100,100])
listbox parent("listbox",15)
canvas parent("canvas",[640,480])
subframe parent("frame",[320,240])
Each kind of widget has a variety of additional attributes which can be set to define various details of the widget's geometry and behavior. For example, the attributes available for button widgets are:
text - button caption state - 'normal' or 'disabled' (if disabled, text is greyed out) width - button width, in characters height - button height, in characters borderwidth - button border width, in pixels image - image to display instead of text caption font - text font anchor - caption anchor point: n,ne,e,se,s,sw,w,nw, center justify - caption justification in its rectangle: - left, right, or center foreground - text color background - background color activeforeground - text color when mouse is pressed over button activebackground - background color when mouse is pressed over button disabledforeground - text color when button is disabled cursor - cursor to display when mouse is over button default - if true, button is emphasized padx,pady - size of extra padding space around text highlightthickness - thickness of additional border used to indicate focus highlightbackground - color of additional border when widget - does not have focus highlightcolor - color of additional border when widget has focus takefocus - command to be executed when widget receives focus via tab textvariable - if non-null, names a Tk variable holding - the button's string underline - index of text character to underline wraplength - maximum line length before caption text wrapsComprehensive lists of attributes for all the other kinds of widgets appear later in this chapter. Note that not every Tk implementation actually supports all the effects of all widget attributes. In such situations, setting unsupported widget attributes simply has no effect.
Widget attributes are set by writing assignments of the form
widget(attribute_list) := attribute_value_list;
An example is
button_obj("foreground,background,cursor") := "red,yellow,crosshair";
or equivalently
button_obj("foreground,background,cursor") := "red;yellow;crosshair";
or
button_obj("foreground,background,cursor") := ["red","yellow","crosshair"];
as these examples indicate, the parameter attribute_list can be either a single attribute name or a comma-separated list of attribute names, and the attribute_value_list can be either (i) a single attribute value, or (ii) a comma-separated list of attribute values, given as a string, or (iii) a semicolon-separated list of attribute values, given as a string, or (iv) a tuple of attribute values. Also, whenever an integer-valued attribute appears, it can be given either as a SETL integer, or as the corresponding string. Plainly, assignment forms like those seen above facilitate simultaneous modification of multiple widget attributes.
'Principal' Attributes. As a matter of convenience, many kinds of widgets w are considered to have one 'principal' attribute, which can be retrieved/set by writing
x := w(OM) and w(OM) := x; respectively.
This simply makes it unnecessary to remember any more detailed name for the attribute. The 'principal' attributes available in this way are as follows:
Widget Type Principal Attribute TextLine String contents Label String contents Message String contents Text String contents Slider Numerical slider value Listbox List of all currently selected items (Read only) Menubutton The associated menu (Write only) Canvas Tuple of all canvas items (Read only) Toplevel Window title
Attributes available for all widgets. The following attributes are available for all widgets (some are read-only):
children tuple of widgets which are children of given widget showing true if widget is currently showing on screen, false otherwise manager geometry manager for window: pack, place, grid, canvas, or text parent parent widget of given widget rect rectangle of given widget: [r,t,l,b] wincoords corner of toplevel window containing widget toplevel toplevel window containing widget mouse current position of the mouse screendepth number of bits used to store screen colors screensize size of screen, in pixels screenmm size of screen, in millimeters
Items placed by 'packing'. The positions and sizes of items 'packed' into a frame are calculated using a set of placement attributes associated with each such object; side, padx, pady, ipadx, ipady, expand, fill, and anchor. All objects to be packed into a frame (or window) appear in an ordered 'packing list' associated with the frame. Objects appear on such a list when their "side" attribute is set, and can be removed either by setting this attribute to OM or by setting an attribute which transfers control of the object to one of the other geometry managers. The packing list can also be manipulated by setting the an object's 'in' attribute (which can move it to another frame or window), by making assignments to its 'after' or 'before' attribute (which moves it on the packing list), or by setting the 'children' attribute of the frame originally containing the object. Aside from this, the general rule is that
(i) objects obj appear on the packing list of their parent frame or window, that is, the frame or window fw using which the object was created by a statement like
obj := parent_frame(widget_type,main_parameter);
(ii) unless moved by assignments to their 'after' or 'before' attributes, objects appear on a frame's packing list in the order in which the operations
obj("side") := "left"; -- or "right", "top", or "bottom"
that put them there are executed.
The detailed placement within a frame F of all the objects on F's packing list is worked out by processing them in the order of that list. The algorithm used is roughly as follows. Let the objects to be packed be o1,o2,...olast. If the first few objects being packed are packed toward the left or right edge, break the list just before the first oj which is packed toward the top or bottom, then subsequently before the first oj which is packed toward the left or right, etc. This breaks the packing list into runs of objects, each consisting of objects which are all packed either in the vertical or all in the horizontal direction. Recursively pack oj,...olast into a large enough rectangle R; then pack o1,o2,...o(j - 1) and R horizontally into the frame F, placing all elements packed to the left (resp. right) in an initial (resp. final) sequence, with R in the middle. The frame F can then shrink to the minimum size needed to hold all the elements packed into it.
Note that if, in our example, the objects o1,o2,...o(j - 1) are of different heights, there may be unoccupied space above or below them. If this is the case each object will be placed in the center of the space assigned to it, except that (i) it can be moved to another position in this space if its 'anchor' attribute is set (to one of the positions n, s, e, w, ne, se, nw, sw), and (ii) it can be enlarged to fill the available space if its 'fill' attribute, which designates the directions in the object is allowed to expand (none, x, y, or both), is appropriately set.
If a rectangle like R is packed into the middle of a run of objects taller (or wider) than itself, then more space may be available to R than it would occupy if minimized. In such cases, if the 'expand' attribute of some of the objects packed into R has been set to true, the additional space available to R will be divided between them, each such object being placed either in the center of its available space, or at the position (n, s, e, w, ne, se, nw, sw, or center) determined by its 'anchor' attribute.
Sometimes one wants to hold some of the intermediate frames of a placement hierarchy at their stated sizes rather than allowing them to shrink to fit their contents. This can be done by setting their 'adjust' attribute to 'false'.
Objects are placed by default into their parent frame. This default action can be over-ridden by setting their 'in' attribute to ay other window descended from the same ancestral toplevel window (but no other, since an object always can become invisible when this ancestral window does.
Additional internal space, into which an object will always expand, can be reserved for it by setting its ipadx and ipady attributes to the desired number of pixels.
The above remarks should clarify the meaning of the packing-control attributes listed below. However, since the action of the packing algorithm is not always intuitive, its is generally better to control packing explicitly by introducing as may intermediate frames as necessary to make packing at any one level of the hierarchy of frames introduced run either horizontally or vertically. (In any case, the packing algorithm does this implicitly.)
The attributes involved in widget placement by 'packing' are:
side - edge (top, bottom, left, right) toward which widget is packed in - widget, other than parent, in which this widget should be packed - Note: can only pack into frame belonging to same toplevel after - widget that this should follow in packing order before - widget that this should precede in packing order anchor - position in available space that item should occupy: - (n, s, e, w, ne, se, nw, sw, or center) expand - if true, widget will claim available space - in its packing direction fill - none, x, y, or both: widget fills available space - in that direction ipadx,ipady - size of extra internal padding space within item packed children - ordered list of items packed within a frame adjust - if true, frame will adjust to minimum size required for children
The following example illustrates the use of placement by packing.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
msg := Tk("message","A first message"); msg("side") := "top";
-- create and place a first message
but := Tk("button","You can click this"); but("side,fill") := "top,y";
-- create and place a first button
msg2 := Tk("message","A second message"); msg2("side") := "bottom";
-- create and place a second message
but2 := Tk("button","Or click this"); but2("side,fill") := "bottom,both";
-- create and place a second button
Tk.mainloop(); -- enter the Tk main loop
end test;
We now give a series of small examples illustrating the use of the 'pack'-related attributes listed above. In all the examples, two thin colored frames are inserted into a window as 'supports' to keep it from shrinking to a smaller size dictated by its contents (this will be discussed below), and one or two buttons are inserted into the remaining space. Our first example is
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Scan to (4,4)"); but("side") := "left";
-- create and pack a button
but("pack,anchor") := "nw"; print(but("pack"));
-- set some of its packing attributes, print all of them
Tk.mainloop(); -- enter the Tk main loop
end test;
Note the placement of the packed button, and the fact that it fills only a small part of the available space. In this and our next few examples, we use the expression
obj("pack")
to retrieve the list of all widgets packed into a given object. The output produced is
{["in", "."], ["padx", "0"], ["ipadx", "0"], ["expand", "0"], ["side", "left"],
["fill", "none"], ["pady", "0"], ["ipady", "0"], ["anchor", "nw"]}
[frame:.w1, frame:.w2, button:.w3]
Changing the 'side' and the 'anchor' attributes leads to the alternate placement generated by the following example.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Scan to (4,4)"); but("side") := "right";
-- create and pack a button
but("pack,anchor") := "sw"; print(but("pack"));
-- set some of its packing attributes, print all of them
print(Tk("children"));
-- print the list of items packed into the window
Tk.mainloop(); -- enter the Tk main loop
end test;
By setting the 'fill' attribute to 'y' we cause the button to expand vertically into all the space available to it.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Scan to (4,4)"); but("side") := "left";
-- create and pack a button
but("pack,anchor,fill") := "nw,y"; print(but("pack"));
-- set some of its packing attributes, print all of them
Tk.mainloop(); -- enter the Tk main loop
end test;
In our next example we introduce a second button and set the 'fill' attribute of both buttons to 'both', but the 'expand' attribute of only the first button. This causes the first, but not the second button, to expand in its horizontal packing direction, to fill all available space. Both buttons then expand vertically, so all the frame space is filled, but the first button is wider.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Button1"); but("side") := "left"; -- create a button
but("pack,anchor,expand,fill") := "nw,1,both";
-- set some of its packing attributes
but := Tk("button","Button2"); but("side") := "left";
-- create a second button
but("pack,anchor,fill") := "nw,both";
-- set some of its packing attributes
Tk.mainloop(); -- enter the Tk main loop
end test;
The next example is almost identical with the preceding one, but does not set the 'expand' attribute of the first button, so the available space is filled only vertically, but not horizontally.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Button1"); but("side") := "left"; -- create a button
but("pack,anchor,fill") := "nw,both"; -- set some of its packing attributes
but := Tk("button","Button2"); but("side") := "left";
-- create a second button
but("pack,anchor,fill") := "nw,both"; -- set some of its packing attributes
Tk.mainloop(); -- enter the Tk main loop
end test;
If, as seen in the next example, we set the 'expand' attribute of both buttons, they expand equally to fill all available space.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Button1"); but("side") := "left"; -- create a button
but("pack,anchor,expand,fill") := "nw,1,both";
-- set some of its packing attributes
but := Tk("button","Button2"); but("side") := "left";
-- create a second button
but("pack,anchor,expand,fill") := "nw,1,both";
-- set some of its packing attributes
Tk.mainloop(); -- enter the Tk main loop
end test;
Yet another possibility, shown in the following example, is to set the 'expand' attribute of both buttons, but to give the second button additional 'internal padding space' by setting its 'ipadx' attribute. This causes the buttons to expand to fill all available space, but now the second button is 40 pixels wider.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
frtop := Tk("frame","200,10"); -- put in two frames as 'supports'
frtop("side") := "top"; frtop("background") := "yellow";
fleft := Tk("frame","10,190");
fleft("side") := "left"; fleft("background") := "red";
but := Tk("button","Button1"); but("side") := "left";
-- create a button
but("pack,anchor,expand,fill") := "nw,1,both";
-- set some of its packing attributes
but := Tk("button","Button2"); but("side") := "left";
-- create a second button
but("pack,anchor,expand,fill,ipadx") := "nw,1,both,20";
-- set some of its packing attributes
Tk.mainloop(); -- enter the Tk main loop
end test;
When items are packed into a frame (or window), the frame adjusts by default to the minimum size required to hold all the items packed into it, and this adjustment process carries recursively through all frames packed within frames. To turn this adjustment action off (resp. back on), one can use the operation
frame_or_window("propagate") := true; or frame_or_window("propagate") := false;The related expression
frame_or_window("propagate")
returns the propagation status of a frame or window.
These operations are seen in the following small program.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,ca,parent;
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
Tk("propagate") := false; -- turn off size-on-contents dependency
print(Tk("propagate"));
but := Tk("button","Propagate"); but("side") := "top";
-- create and pack a button
but{OM} := lambda();
Tk("propagate") := true; print(Tk("propagate")); end lambda;
-- the button turns on size-on-contents dependency
but := Tk("button","Don't propagate"); but("side") := "top";
-- create and pack a second button
but{OM} := lambda(); Tk("width,height") := "300,300";
Tk("propagate") := false; end lambda;
-- the button turns off size-on-contents dependency,
-- and sets window size
Tk.mainloop(); -- enter the Tk main loop
end test;
Items placed by 'gridding'. Grid-placement of objects into a frame works much like packing, except that the items 'grid-placed' into a frame are arranged in a grid rather than being packed into a tighter arrangement. Each grid-placed object is assigned to a particular row and column, either by explicitly setting its 'row' and 'column' attributes, or implicitly, by setting one of these attributes and using the rule that items are then placed into the first unused row or column. (One should ordinarily avoid assigning two objects to the same row and column, as is this case they will simply be superimposed.)
All objects to be gridded into a frame appear in an ordered 'grid list' associated with the frame. Objects appear on such a list when their "row" or "column" attribute is set, and can be removed either by setting both these attributes to OM or by setting an attribute which transfers control of the object to one of the other geometry managers. The grid list can also be manipulated by setting the an object's 'in' attribute (which can move it to another frame or window.)
Once the grid list for a frame has been set up, the minimum row and column sizes needed to hold all the gridded objects are worked out, and the objects placed in their grid positions. The grid box allocated to an object can be larger than is needed to hold it. If this is the case each object will be placed in the center of the space assigned to it, except that (i) it can be moved to another position in this space or enlarged to fill the available space horizontally or vertically if its 'sticky' attribute, which designates the edges of its box to which it must 'stick' is set (to one or more of n, s, e, w).
Additional internal space, into which an object will always expand, can be reserved for it by setting its ipadx and ipady attributes to the desired number of bits. Additional external space, into which an object will never expand, can be reserved for it by setting its padx and pady attributes.
The above remarks should clarify the meaning of all the grid-placement control attributes, which are:
row, column - row and column in which widget is placed rowspan - number of rows occupied by widget columnspan - number of columns occupied by widget in - widget, other than parent, in which this widget should be placed - Note: can only placed in frame belonging to same toplevel sticky - edges in available space to which item should adhere, - by enlarging the item if necessary (n, e, s, and w, e.g 'news') padx,pady - size of extra padding space around item packed ipadx,ipady - size of extra internal padding space around item packed children - ordered list of items grid-placed within a frame adjust - if true, frame will adjust to minimum size required for children
The following example shows the gridding of widgets.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
msg := Tk("message","A first message"); msg("row,column") := "1,1";
-- create a first message and place it in the grid
but := Tk("button","You can click this"); but("row,column") := "1,2";
-- create a first button and place it in the grid
msg2 := Tk("message","A second message"); msg2("row,column") := "2,2";
-- create a second message and place it in the grid
but2 := Tk("button","Or click this"); but2("row,column,sticky") := "2,1,news";
-- create a second button and place it in the grid
Tk.mainloop(); -- enter the Tk main loop
end test;
We can use the 'columnspan' attribute of a gridded item to cause it to occupy more than one column (or its 'rowspan' attribute to cause it to occupy more than one row). This is shown in our next example, in which the button in the first row is seen not to expand in size, but to sit in the middle of the two columns it occupies.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Button1"); but("row,column,sticky") := "1,1,news";
-- create and "grid' a button
but("grid,columnspan") := "2"; print(but("grid"));
-- set its columnspan to 2, printing grid attributes
but := Tk("button","Button2"); but("row,column,sticky") := "2,1,news";
-- create and "grid' a second button
but := Tk("button","Button3"); -- create and "grid' a third button
but("row,column,ipadx,ipady,padx,pady") := "2,2,20,20,20,20";
print(Tk("children"));
-- print the list of widgets gridded into toplevel window
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
{{["in", "."], ["padx", "0"], ["ipadx", "0"], ["columnspan", "2"],
["pady", "0"], ["ipady", "0"], ["row", "1"],
["sticky", "nesw"], ["column", "1"], ["rowspan", "1"]}
[button:.w1, button:.w2, button:.w3]
A more acceptable appearance results if we set the 'sticky' attribute of the 'double columned' button in the first row, causing it to fill all the space reserved for it. This is shown in our next example.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Button1"); but("row,column") := "1,1";
-- create and 'grid' a button
but("grid,columnspan,sticky") := "2,ew";
-- set its columnspan to 2, and make it east set its columnspan to 2,
-- and make it east-west 'sticky'
but := Tk("button","Button2"); but("row,column") := "2,1";
-- create and "grid' a second button
but("grid,padx,pady,") := "5,5";
but := Tk("button","Button3"); but("row,column") := "2,2";
-- create and "grid' a third button
but("grid,ipadx,ipady") := "10,10";
Tk.mainloop(); -- enter the Tk main loop
end test;
As in the case of items packed into a frame (or window), when items are 'gridded' into a frame the frame adjusts by default to the minimum size required to hold all the items packed into it, and this adjustment process carries recursively through all frames packed within frames. To turn this adjustment action off (resp. back on), one can use the same operation as in the 'pack' case. This is seen in the following example, which also shows the use of the 'gridbox' expression that returns the containing rectangle of a gridded item.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,ca,parent;
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
Tk("propagate") := false; -- turn off size-on-contents dependency
print(Tk("manager"));
print(Tk("propagate"));
but := Tk("button","Propagate"); but("row,column") := "1,1";
-- create and grid a button
but{OM} := lambda();
Tk("propagate") := true; print(Tk("propagate")); end lambda;
-- the button turns on size-on-contents dependency
but := Tk("button","Don't propagate"); but("row,column") := "1,2";
-- create and grid a second button
but{OM} := lambda();
Tk("width,height") := "300,300"; Tk("propagate") := false; end lambda;
-- the button turns off size-on-contents dependency, and sets window size
but := Tk("button","Dead Button"); but("row,column") := "2,1";
-- create and grid two more buttons
but{OM} := lambda();
Tk("width,height") := "300,300"; Tk("propagate") := false; end lambda;
-- the third button prints various gridbox boundaries
but := Tk("button","Dead Button"); but("row,column") := "2,2";
Tk.mainloop(); -- enter the Tk main loop
end test;
Explicitly placed items. Items are explicitly placed into a given frame by being assigned a position, height, and width. The attributes used for this are:
x,y - x and y pixel positions of anchor point relx,rely - x and y positions of anchor point, as fraction of frame width,height - pixel width and height of widget relwidth,relheight - width and height of widget, as fraction of parent frame anchor - 'key' point in widget occupying stated position: - (n, s, e, w, ne, se, nw, sw corner, or center) in - widget, other than parent, in which this widget should be placed - Note: can only placed in frame belonging to same toplevel children - ordered list of items manually placed within a frame
The following examples shows the positioning of widgets by explicit placement.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
msg := Tk("message","A first message"); msg("place,x,y") := "1,1";
-- create and place a first message
but := Tk("button","You can click this"); but("place,x,y") := "60,20";
-- create and place a first button
msg2 := Tk("message","A second message"); msg2("place,x,y") := "100,100";
-- create and place a second message
but2 := Tk("button","Or click this"); but2("place,x,y") := "80,80";
-- create and place a second button
Tk.mainloop(); -- enter the Tk main loop
end test;
Our next example illustrates the fact that explicitly placed items can overlap, and also shows the use of fractional' placement of an item relative to its containing frame. We create two buttons in a frame, and place them in overlapping positions. The second button is placed using the 'place,relx,rely', 'fractional' placement, command.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Button1"); but("place,x,y") := "5,5";
-- create a first button
print(but("place")); -- print its placement attributes
but := Tk("button","Button2"); but("place,x,y") := "15,15";
-- create a second button
but := Tk("button","Button3"); but("place,relx,rely") := "0.25,0.25";
-- create a button, giving it 'fractional' placement it its containing window
print(Tk("children")); -- print the list of items placed in the master window
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
{["y", "5"], ["relx", "0"], ["x", "5"], ["rely", "0"], ["anchor", "nw"]}
[button:.w1, button:.w2, button:.w3]
The next example is very similar to the preceding, but shows the result of using the 'anchor' attribute of the first button to move its placement anchor from a corner point to the button's center. Note that the centered anchoring of the first button placed causes it to move up and to the left relative to its previous position.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Button1"); but("place,x,y,anchor") := "5,5,center";
-- create a button and place it
but := Tk("button","Button2"); but("place,x,y") := "15,15";
-- create a second button and place it
but := Tk("button","Button3"); but("place,relx,rely") := "0.25,0.25";
-- create a third button and place it
Tk.mainloop(); -- enter the Tk main loop
end test;
Each kind of widget and or text canvas item is sensitive to a variety of events (e.g. button clicks, key-presses, mouse motions), among which one particular type of event is designated as the widget's 'principal' event. The following table shows these principal events:
button - (first) button up (i.e. 'click') menu - (first) button up menubutton - (first) button down radiobutton - (first) button up checkbox - (first) button up frame - mouse motion with (first) button down toplevel - mouse motion with (first) button down textline - loss of focus listbox - (first) button up text - loss of focus canvas - mouse motion with (first) button down arc - (first) button down bitmap - (first) button down image - (first) button down line - (first) button down oval - (first) button down polygon - (first) button down rectangle - (first) button downTags in canvases or text (see below) can also be event sensitive; their 'principal' event is (first) button down.
Parameterless callbacks to designated SETL procedures can be associated in a particularly easy way with each of these principal events. (This is a special case of the more general event-binding capability discussed in section XXX below.) To set up such an association, we simply write
widget_name{OM} := SETL_procedure_value;An example is
mybutton{OM} := print_primes_till_100;
After this is executed, and assuming that the procedure print_primes_till_100 has been supplied and does what its name implies, clicking on 'mybutton' will cause the primes up to be printed.
The example below shows the bidding of actions to button clicks. When clicked both of the buttons print appropriate messages. The code also binds an action to a click on each of the messages. When clicked the first message will beep once and the second message will beep twice.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk; -- globalize Tk for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
msg := Tk("message","A first message"); msg("place,x,y") := "1,1";
-- create and place a first message
but := Tk("button","You can click this"); but("place,x,y") := "60,20";
-- create and place a first button
msg2 := Tk("message","A second message"); msg2("place,x,y") := "100,100";
-- create and place a second message
but2 := Tk("button","Or click this"); but2("place,x,y") := "80,80";
-- create and place a second button
msg{OM} := Tk.beeper;
msg2{OM} := lambda(); Tk.beeper(); Tk.beeper(); end lambda;
but{OM} := lambda(); print("Clicked button 1"); end lambda;
but2{OM} := lambda(); print("Clicked button 2"); end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The expression
Tk.win_of_pt(x,y)
returns the Tk widget underneath the point [x,y] (in absolute screen coordinates), or, if there is no such widget, returns OM. Its use is illustrated by the following short program. We create two frames, each 500 pixels wide and 250 high. Two buttons are added, each of which shows the widget containing a particular screen point when clicked depending on where the master window containing all of these items is placed on the screen. This will be one or another widget, or will be undefined. You can experiment with this program by moving the window that it brings up.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
parent := Tk("frame","500,250"); parent("side") := "top";
-- create a grey 500 by 250 frame
parent("background") := "#aaaaaa"; -- grey background
parent := Tk("frame","500,250"); parent("side") := "top";
-- create a pink 500 by 250 frame under it
parent("background") := "#ccaaaa"; -- pink-grey background
but := Tk("button","Show widget containing 200,200"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(Tk.win_of_pt(200,200)); end lambda;
-- when clicked, shows the widget containing 200,200
but := Tk("button","Show widget containing 200,400"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(Tk.win_of_pt(200,400)); end lambda;
-- when clicked, shows the widget containing 200,400
Tk.mainloop(); -- enter the Tk main loop
end test;
id := Tk.createtimer(interval,SETL_fun);
Here 'interval' is the time, in milliseconds, before the parameterless SETL function 'SETL_fun' is to be invoked. This call returns an identifier for the pending timer event, which can be cancelled any time before it has taken place by writing
Tk.cancel_event(id);
The following small program shows the use of timer-driven events. It uses a procedure which causes itself to be called once each second beeping each time and then triggering another timed call to itself. This endless beeping can be stopped by clicking on the button shown which cancels any outstanding beep event.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,id; -- globalize Tk and the timer id for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Click this to stop the beeping");
-- create and place a first button
but("row,column,sticky") := "1,1,news";
but{OM} := cancel_beeps;
-- bind beep cancellation action to click on this button
id := Tk.createtimer(1000,beep_and_beep_again);
-- schedule a beep one second later
Tk.mainloop(); -- enter the Tk main loop
procedure beep_and_beep_again();
-- beep, then schedule another beep 1 second later
Tk.beeper(); -- beep
id := Tk.createtimer(1000,beep_and_beep_again);
-- reschedule a beep one second later
end beep_and_beep_again;
procedure cancel_beeps(); -- cancel any scheduled beep
Tk.cancel_event(id); -- cancel any scheduled beep
end cancel_beeps;
end test;
To set up a 'when-idle' call that will be triggered when the interface quiesces, write
id := Tk.createtimer(OM,SETL_fun);
The following example which is a variant of the example shown just above illustrates the use of 'idle calls' to trigger actions whenever the interactive interface is idle. Note once more that calls of this kind are indicated by giving an OM first parameter to the 'createtimer' procedure. In the code shown we trigger a printing routine which causes itself to be called repeatedly whenever the interactive interface quiesces. The high-speed printing that results can be stopped by clicking on the button shown, which cancels any outstanding 'on idle' call.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,id; -- globalize Tk and the timer id for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Click this to stop the printing");
-- create and place a first button
but("row,column,sticky") := "1,1,news";
but{OM} := cancel_beeps;
-- bind beep cancellation action to click on this button
id := Tk.createtimer(OM,beep_and_beep_again);
-- schedule a beep one second later
Tk.mainloop(); -- enter the Tk main loop
procedure beep_and_beep_again();
-- beep, then schedule another beep 1 second later
print("Hello World"); -- print something
id := Tk.createtimer(OM,beep_and_beep_again);
-- reschedule a beep one second later
end beep_and_beep_again;
procedure cancel_beeps(); -- cancel any scheduled beep
Tk.cancel_event(id); -- cancel any scheduled beep
end cancel_beeps;
end test;
Note that each timer 'rings' just once, and so must be rescheduled, as in the above examples, if a repeating action is desired.
Much of the text widget's power derives from the system of tags and marks which can be associated with the string text held in such a widget. Tags mark ranges of characters of the string held within a text widget, and marks attach to positions between characters. If t is a text widget, the operation
lis := t("tag",tg);
maps each of the tags tg associated with t into the ordered list [[start_ix_1,end_ix_1],[start_ix_2,end_ix_2],..] of text ranges which carry the tag tg, and assignments of the form
t("tag",tg) := [[start_ix_1,end_ix_1],[start_ix_2,end_ix_2],..];
can be used to manipulate these lists. The operation t("tags") retrieves the list of all tags associated with t.
The code shown below creates a text widget containing three lines of text and then adds two tags to this text by explicitly calling the 'tag_' routine. Font and color attributes are set for each of these tags. These are automatically applied to the character ranges carrying the indicated tags and so become visible. We also print the range of text carrying the first of the tags added and the list of all tags present in the text widget.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","10,10"); txt("side") := "left";
-- create and place a text widget
txt(OM) := "Type\ntext\nhere"; -- put some text into it
print(txt("1.0".."2.1")); -- print a range of this text
txt.tag_add("my_tag","1.1,1.1,2.1,3.3");
-- add a tag to two disjoint character ranges
txt.tag_add("my_tag2","1.3,1.5"); -- add a second tag to a character range
-- set tag attributes, to make tagged ranges visible
txt("my_tag","font,background,foreground")
:= "{times 24 bold italic},red,yellow";
txt("my_tag2","font,background,foreground")
:= "{times 36 bold},blue,white";
print(txt.tag_names(OM));
-- print ordered list of tags associated with widget
Tk.mainloop(); -- enter the Tk main loop
end test;
The output printed is
Type t ["sel", "my_tag", "my_tag2"]
The first two lines of this output represent the first line and first character of the second line of the text in the text area of our example. The third line of output shows the tags present in the text widget: two that we have set up, and a third (the 'selection'), always present, that represent whatever range of characters may have been selected using the mouse.
Similarly, the operation t("marks") retrieves the list of all marks 'mrk' associated with t, while
pos := t.index(mrk);
returns the character position before which mrk appears, and
t.mark_set(mrk,ix);
can be used to define or modify this position. Marks are removed by writing
t.mark_unset(mrk) := OM;
Marks are invisible items inserted between two characters of text that can be used for searching and positioning the text. When additional characters are inserted into text the 'marks' and 'tags' in the text automatically reposition themselves properly, similarly when text is deleted. If a range of text containing a 'mark' is deleted the 'mark' disappears.
The following variant of the 'tags' program shown above inserts 'marks' rather than 'tags' into text. This is done using the 'mark_set' primitive. One of these marks is subsequently removed using ''mark_unset'. The inserted 'marks' are then listed.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","10,10"); txt("side") := "left";
-- create and place a text widget
txt(OM) := "Type\ntext\nhere"; -- put some text into it
print(txt("1.0".."2.1")); -- print a range of this text
txt.mark_set("my_mark","2.2"); -- place a named mark at the specified index
txt.mark_set("my_mark2","3.2"); -- place a named mark at the specified index
print(txt("marks")); -- show the marks present in the text
print(txt.index("my_mark")); -- show the location of my_mark
txt.mark_set("my_mark","3.1"); -- move the location of my_mark
print(txt.index("my_mark")); -- show the location of my_mark
txt.mark_unset("my_mark"); -- remove the mark
print(txt("marks")); -- show the marks present in the text
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
Type t ["my_mark", "insert", "my_mark2", "current"] 2.3 3.2 ["insert", "my_mark2", "current"]
showing the insertion of a mark, how a mark is moved, and its removal.
Tags in text (tags can also be associated with canvas items) are used for several critical purposes: (i) event sensitivities can be bound to tags. Text for which this has been done becomes 'hotworded.' (ii) fonts and other typographical characteristics can be associated with text tags.
To set the attributes of a tag associated with one or more a text ranges in a text area, write
text_area(tag_name,list_of_attributes) := list_of_values;
To bind an event response to such a tag, write
text_widget{"tag_name","event_descriptor:event_fields_signature"} := SETL_procedure;
As for other widgets the 'principal event' (i.e. a click, that is 'ButtonRelease-1") associated with a text tag can be set by an attribute-like assignment of the special form
text_area{tag_name,OM} := SETL_procedure;
Examples are
texta_1("Coloredtext","foreground,background") := "yellow,blue";
texta_1{"RolloverSensitive_text","Enter"} := display_help_caption;
and
texta_2{"Coloredtext",OM} := open_aux_window;
One special built-in tag, 'sel', designating the current selection in a text widget, is always available. The operation t("tag","sel") returns the boundary of the selection as a list containing one pair; the operation
t("tag","sel") := [[start,fin]];
can be used to set the selection boundary. If no selection has been made the 'sel' tag will still exist but will cover no range, so the operation t("tag","sel") will return an empty list of pairs.
The following program illustrates the use of the selection tag 'sel'. It creates a text widget containing three lines of text but with space for two additional lines and an auxiliary button to which a click procedure is bound. A tag is added to the first line of text and made visible by setting its font and color attributes. The callback procedure invoked when the button is clicked reads the selection tag and copies the starting and ending positions of the selections to an auxiliary tag which carries the foreground color magenta. The net effect is as follows. If text is selected and the button then clicked the characters in the selected range will take on the color magenta. If this is repeated with a different range of characters selected then the new range becomes magenta and the previous range reverts to black. (Reversion to black is forced by the fact that we remove the temporary tag from the entire text area. This is done by the first line of 'click' procedure.) Note that if this line were deleted clicking would extend the auxiliary tag to larger and larger portions of the text, so more and more characters would become magenta.
Note also that we cannot simply assign the color magenta to the 'sel' tag since if we did the magenta color would disappear whenever we clicked in the text area since such a click causes the range of characters selected to become null. It is worth experimenting with this and other variants of the following code to become familiar with the finer details of text tagging.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "interactive interface example 1";
-- create the Tk interpreter
txt := Tk("text","10,5"); txt("side") := "top";
-- create and place a text widget
txt(OM) := "Type\ntext\nhere"; -- put some text into it
txt("font") := "{times 24 bold}"; -- set the text font
button := Tk("button","Select Some Text,\nThen Click Me");
button("side") := "top";
button{OM} := Click_procedure;
txt.tag_add("my_tag","1.1,1.5");
txt("my_tag","font,background,foreground,justify")
:= "{times 24 bold italic},green,yellow,center";
Tk.mainloop(); -- enter the Tk main loop
procedure Click_procedure(); -- response to button click
txt.tag_remove("temp_tag","1.1,end");
txt.tag_add("temp_tag",join(txt("tag","sel")(1),","));
-- copy selection to auxiliary tag
txt("temp_tag","foreground"):= "magenta"; -- color this magenta
end Click_procedure;
end test;
Tags and marks can be inserted into and removed in fully dynamic fashion from the text in a text widget, using the operations described above. However, it is more common to set up event-sensitive text statically (but then to use it dynamically.) To make this easy, SETL provides a special utility setup operation, having the syntax
text(OM) := descriptor_string;
Here, the descriptor_string required is a mixture of the visible text which is to appear in the text widget, along with a series of special 'tag marks' of the form <`ccctag_stringccc`> and <``ccctag_stringccc`> which respectively open and close tagged ranges.
The auxiliary string ccc.. will ordinarily be empty, so opening and closing tags will generally have the form <`tag_string`> and <``tag_string`>.
The short program seen below illustrates the declarative insertion of tags into text using the 'description_string' conventions that we have just explained. It sets up a text widget containing text carrying two tags, the first of these extending over two disjoint character ranges. Tag attributes are set to make the tag ranges visible.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "interactive interface example 1";
-- create the Tk interpreter
txt := Tk("text","15,10"); txt("side") := "top";
-- create and place a text widget
-- put some tagged text into it
txt(OM) := "<`my_tag`>Sample\nte<``my_tag`>x<`my_tag`>t"
+ "<``my_tag`>\n<`my_tag2`>here<``my_tag2`>\nPlease";
txt("my_tag","font,background,foreground")
:= "{times 24 bold italic},green,red";
-- set the first tag's attributes
txt("my_tag2","font,background,foreground")
:= "{times 24 bold italic},red,green";
-- set the second tag's attributes
Tk.mainloop(); -- enter the Tk main loop
end test;
To change the auxiliary string from this default (empty string) value, we simply use it in a null tag, e.g. can write <`ccc`><``ccc`> at the very start of a string s if we want to use <`ccctag_stringccc`> rather than the default <`tag_string`> for tags. This eases the writing of text in which character sequences like <`tag_string`> must be used for some other purpose.
Tag strings can never include end-of-line or carriage-return characters, so the appearance of any such character before the closing ..ccc`> of what might otherwise be a tag designator reduces this suspected designator to an ordinary string. The auxiliary strings ccc.. are not allowed to contain either the ` character or an end-of-line or carriage return.
The following variant of the preceding program shows the use of the alternative form of tag descriptor just explained. Using the convention explained, we introduce the question mark '?' as an additional portion of the tag marks which follow.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "interactive interface example 1";
-- create the Tk interpreter
txt := Tk("text","15,10"); txt("side") := "top";
-- create and place a text widget
txt(OM) := -- put some tagged text into it
"<`?`><``?`><`?my_tag?`>Sample\nte<``?my_tag?`>x<`?my_tag?`>t"
+ "<``?my_tag?`>\n<`?my_tag2?`>here<``?my_tag2?`>\nPlease";
txt("my_tag","font,background,foreground")
:= "{times 24 bold italic},green,red";
-- set the first tag's attributes
txt("my_tag2","font,background,foreground")
:= "{times 24 bold italic},red,green";
-- set the second tag's attributes
Tk.mainloop(); -- enter the Tk main loop
end test;
A tag closing ends all identical open tags; superfluous tag closings are ignored.
Tag openings never subsequently closed are treated as marks.
The tags in a text widget have a 'priority' order, and where tags have conflicting attributes or bindings, the highest priority tag will dominate. For example, the following short program sets up a text widget with two overlapping tags 'x' and 'y' and assigns them conflicting colors.
program test; -- text setup utility
use tkw; -- use the standard graphical interface package
var Tk;
Tk := tkw(); -- create the Tk interpreter
txt := Tk("text","80,30"); txt("side") := "top";
-- create and place a text widget
txt(OM) := "<`x`>Sample <`y`>Text<``x`><``y`>";
-- put some tagged text into it
txt("x","foreground") := "red"; txt("y","foreground") := "blue";
-- set the tag color attributes
print(txt("tags"));
Tk.mainloop(); -- enter the main Tk loop
end test;
Since later-defined tags are given higher default priority than earlier-defined tags. the list of tags printed in priority order by this program is 'sel,x,y' (the special 'sel' tag, which represents the range of characters currently selected in the text widget, is always defined first and always has lowest priority.) Since y has higher priority than x, the color assigned to it dominates in the overlap region, so only the word 'Sample' appears in red, and 'Text' appears in blue. However, we can rearrange the priority list by changing the program to read
program test; -- text setup utility
use tkw; -- use the standard graphical interface package
var Tk;
Tk := tkw(); -- create the Tk interpreter
txt := Tk("text","80,30"); txt("side") := "top";
-- create and place a text widget
txt(OM) := "<`x`>Sample <`y`>Text<``x`><``y`>";
-- put some tagged text into it
txt("x","foreground") := "red"; txt("y","foreground") := "blue";
-- set the tag color attributes
txt("tags") := "y,x";
Tk.mainloop(); -- enter the main Tk loop
end test;
in which case the tag x will dominate everywhere, so both words will appear in red.
The expressions
textwidget.mark_next(n) and textwidget.mark_prev(n)
return the first and the last mark after text position n respectively. The expressions
textwidget.tag_nextrange(tag,n,m) and textwidget.tag_prevrange(tag,n,m)
respectively return the first and the last subrange of the specified range that carries the specified tag. Their use is shown in the following program, which uses a descriptor to set up a line of text containing tags and marks. Six buttons bound to actions which show the use of the operations described above are added. The comments contained in the program give additional detail.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","10,10"); txt("side") := "top";
txt(OM) := "<`my_tag`>Sam<`mark1`>ple\nte<``my_tag`>x<`my_tag`>t<``my_tag`>"
+ "\n<`my_tag2`>he<`mark2`>re<``my_tag2`>\nPlease";
txt("my_tag","font,background,foreground")
:= "{times 24 bold italic},green,red";
-- set the first tag's attributes
txt("my_tag2","font,background,foreground")
:= "{times 24 bold italic},red,green";
-- set the second tag's attributes
but := Tk("button","First mark after 1.1"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(txt.mark_next("1.1")); end lambda;
-- when clicked, prints the first mark after 1.1
but := Tk("button","First mark after 1.4"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(txt.mark_next("1.4")); end lambda;
-- when clicked, prints the first mark after 1.4
but := Tk("button","Last mark before 1.1"); but("side") := "top";
-- create a button
but{OM} := lambda(); print("*",txt.mark_prev("1.1"),"*"); end lambda;
-- when clicked, prints the last mark before 1.1
but := Tk("button","Last mark before 1.4"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(txt.mark_prev("1.4")); end lambda;
-- when clicked, prints the last mark before 1.4
but := Tk("button","First 'my_tag' in range"); but("side") := "top";
-- create a button
but{OM} := lambda();
print(txt.tag_nextrange("my_tag","1.1","4.5")); end lambda;
-- when clicked, prints the first subrange of 1.1-4.5 that carries the tag 'my_tag'
but := Tk("button","Last 'my_tag2' in range"); but("side") := "top";
-- create a button
but{OM} := lambda();
print(txt.tag_prevrange("my_tag2","1.1","4.5")); end lambda;
-- when clicked, prints the last of subrange 1.1-4.5 that carries the tag 'my_tag2'
Tk.mainloop(); -- enter the Tk main loop
end test;
Text-tags have the following attributes:
| font | font of tagged zone |
| background | background color of tagged zone |
| foreground | foreground color of tagged zone |
| bgstipple | background stipple pattern |
| fgstipple | foreground stipple pattern |
| justify | justification of tagged lines: left, right, or center |
| wrap | none, char, or word |
| overstrike | 1 if tagged zone carries overstrike, else 0 |
| underline | 1 if tagged zone is underlined, else 0 |
| relief | flat, raised, sunken,ridge, or groove relief for tagged zone |
| borderwidth | borderwidth of tagged zone, in pixels |
| offset | vertical offset of tagged zone from baseline, in pixels |
| lmargin1 | left indent of first line in tagged zone, in pixels |
| lmargin2 | left indent of following lines in tagged zone, in pixels |
| rmargin | right indent of lines in tagged zone, in pixels |
| spacing1 | extra vertical space before first line in tagged zone, in pixels |
| spacing2 | extra vertical space between lines in tagged zone, in pixels |
| spacing3 | extra vertical space after last line in tagged zone, in pixels |
| tabs | comma-separated list of tab positions used for tagged lines, in pixels |
Many, but not all of these attributes can also be attributes of an entire text widget, and so control the appearance of all the text in a widget, rather than applying only to tagged text ranges within it. The tag attributes which can apply to all the text in a text widget are font, background, foreground, wrap, relief, borderwidth, spacing1, spacing2, spacing3, and tabs, but not bgstipple, fgstipple, justify, overstrike, underline, offset, lmargin1, lmargin2, or rmargin. As shown in the following table, text widgets also have various other attributes, not available for restricted text ranges.
Text widgets have the following attributes:
| font | text font |
| width | text width, in characters |
| height | text height, in number of lines |
| state | normal (editable) or disabled |
| background | background color |
| foreground | foreground color |
| wrap | none, char, or word |
| relief | flat, raised, sunken,ridge, or groove relief for text |
| cursor | cursor to use over text area |
| padx | extra space to left and right of text |
| pady | extra space above and below text |
| borderwidth | borderwidth of text, in pixels |
| exportselection | if true, export selected text to Unix selection |
| highlightthickness | thickness of border used to indicate active state of text |
| highlightbackground | color used to indicate inactive state of text |
| highlightcolor | color used to indicate active state of text |
| insertwidth | width of insertion mark |
| insertbackground | background color of insertion mark |
| insertborderwidth | border width of insertion mark |
| insertofftime | time that insertion mark remains off while blinking |
| insertontime | time that insertion mark remains on while blinking |
| selectbackground | background color of selected text |
| selectforeground | foreground color of selected text |
| selectborderwidth | border width of selected text |
| takefocus | command to be executed when text area receives focus via tab |
| setgrid | if true, items are constrained to implicit grid positions |
| spacing1 | extra vertical space before first line in text, in pixels |
| spacing2 | extra vertical space between lines in text, in pixels |
| spacing3 | extra vertical space after last line in text, in pixels |
| tabs | comma-separated list of tab positions, in pixels |
@x,y - the character at screen point x,y end - last character insert - position of insertion cursor tag_name.first - first character in the range tagged by "tag" tag_name.last - first character after the range tagged by "tag" mark_name - first character after the indicated mark current - the character under the mouse some_image - character position of an embedded image some_widget - character position of an embedded widgetThese index expressions can be modified by the addition of the following suffixes:
wordstart - start of word containing character wordend - start of word containing character linestart - start of line containing character lineend - start of line containing character +nchars - n characters forward, same line (e.g. "current+15chars") -nchars - n characters previous, same line +nlines - n lines forward, same character position (e.g. "current+5lines") -nlines - n lines previous, same character position
The following program illustrates the use of these index expressions and modifiers, by setting up a text area and printing out various sections of text.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Indexing Example"; -- create the Tk interpreter
txt := Tk("text","20,10"); txt("side") := "left";
-- set up a text widget
txt(OM) := "Type\ntext or stuff\nhere";
-- put some text into it
print(txt("1.0".."2.2")); print();
print(txt("1.0".."2.2+1chars")); print();
print(txt("1.0".."2.2-1chars")); print();
print(txt("1.0".."2.2+1lines")); print();
print(txt("1.0".."2.2-1lines")); print();
print(txt("1.0".."2.2wordstart")); print();
print(txt("1.0".."2.2wordend")); print();
print(txt("1.0".."2.2linestart")); print();
print(txt("1.0".."2.2lineend")); print();
Tk.mainloop(); -- enter the Tk main loop
end test;
Note that single-character retrievals from a text area or textline must be written as
txt(index..index),
since the form would be confused with an attribute retrieval. The expression
txt.index(modif_ix),can be used to get the 'numerical' ('i.j') form of text indices, and
txt.compare(op,modif_ix1,modif_ix2);can be used to compare two such indices. (Here, "op" can be "==", "!=", ">", ">=". "<", or "<="). This is shown in or next example.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Indexing Example"; -- create the Tk interpreter
txt := Tk("text","20,10"); txt("side") := "left"; -- set up a text widget
txt(OM) := "Type\ntext or stuff\nhere"; -- put some text into it
print(txt.index("2.2"));
print(txt.index("2.2+1chars"));
print(txt.index("2.2-1chars"));
print(txt.index("2.2+1lines"));
print(txt.index("2.2-1lines"));
print(txt.index("2.2wordstart"));
print(txt.index("2.2wordend"));
print(txt.index("2.2linestart"));
print(txt.index("2.2lineend"));
print(txt.compare("!=","2.2wordstart","2.2linestart"));
-- compare character indices in line.char and other allowed formats
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
2.3 2.4 2.2 3.3 1.3 2.1 2.5 2.1 2.14 FALSEAs illustrated by the following program, widgets of any kind can be inserted into the text of text widgets, where they retain their normal activity. This is done using the operation
txt.insert_widget(character_posn,but);
The expression
txt("widgets")
returns the list of all widgets currently inserted into the text. Widgets inserted into text are treated as if they were characters, and can therefore be deleted by operations of the form
txt(char_loc..char_loc) := "";
The following program sets up a textarea and a canvas containing three graphical items. The canvas is not placed in the master window, but instead is inserted into the text as a text widget. We also set up two buttons and insert them also as text widgets into our line of text. By clicking on these buttons you can see that they remain active in the normal way. We also show the use of the expression 'txt("widgets")', which prints the list of all widgets embedded in a text item. Finally, we set up a self-standing button which, when clicked deletes one of the inserted widgets. From the code bound to this button you can see that a widget embedded in text is treated as a single character of a special kind.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Master"; -- create the Tk interpreter
txt := Tk("text","30,15"); txt("side") := "top"; txt(OM) := "what flat";
-- create a text widget
txt("background") := "green";
ca := Tk("canvas","200,100"); -- create a canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put various items into it
oval := ca("oval","80,20,120,40"); oval("width") := 5;
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
txt.insert_widget("1.6",ca); -- insert it as a text widget
but := Tk("button","Print the time"); -- create a button
but{OM} := lambda(); print("The time is: " + time()); end lambda;
-- bind it to a print action
txt.insert_widget("1.4",but); -- insert it as a text widget
but := Tk("button","Print the time2"); -- create a second button
but{OM} := lambda(); print("The time is: " + time()); end lambda;
-- bind it to a print action
txt.insert_widget("1.8",but); -- insert it as a text widget
print(txt("widgets")); -- print list of all the widgets in the text.
but := Tk("button","Remove item"); but("side") := "top";
-- create a third button, and put it below the canvas
but{OM} := lambda(); txt("1.8".."1.8") := ""; end lambda;
-- bind it to a deletion action
Tk.mainloop(); -- enter the Tk main loop
end test;
Our next small program illustrates the use of the operation
txt.see(char_index);
which shifts the view of a text field too large to be viewed all at once so as to bring a specified character into view. It sets up a textarea containing more text than can be visible at any one time, and two buttons both bound to uses of the 'see' operation. These position the text to make specified characters visible.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","10,5"); txt("side") := "top"; -- create a text area
txt(OM) := "TYPETYPETYPEYYYYTYPETYpe\nTypeTypeTypeTypeType"
+ "\nTypeTypeTypeTypeType\nTypeTypeTypeTypeType\n" +
"texttexttextt*****ext\nherehereherehereherehere";
-- put lots of text into it
but := Tk("button","See 5.10"); but("side") := "top"; -- create two buttons
but{OM} := lambda(); txt.see("5.10"); end lambda;
-- bind view-shift actions to them
but := Tk("button","See 1.1"); but("side") := "top";
but{OM} := lambda(); txt.see("1.1"); end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
Note that the same operation is available for listboxes.
As shown by our next small program, the operation
obj.bbox(item_index)
which is available for text widgets, textlines, and listboxes, returns the coordinates of the smallest rectangular box containing designated item. We also show the use of the
Tk.quit();
command, which exits the Tk interpreter, and illustrate the fact that since listboxes; like menus, are treated as a kind of tuple, slice assignments can be used to edit their list of items.
The operations shown above are illustrated in the following program. In it we set up a textarea, textline, and listbox. Two buttons are added, the first of these prints the bounding boxes of specified lines and characters in the textarea, textline, and listbox. The second button merely quits the application when clicked.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,txt,txtln,lb; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Master"; -- create the Tk interpreter
txt := Tk("text","30,3"); txt("side") := "top"; txt(OM) := "what flat";
-- create a text area
txtln := Tk("entry","30"); txtln("side") := "top"; txtln(OM) := "whot flot";
-- create a text line
lb := Tk("listbox",3); lb("side") := "top";
-- create a listbox, which shows 3 elements
lb(1..0) := "Item1,Item2,Item3,Item4,Item5,Item6,Item7,Item8,Item9,Last Item";
-- put 10 items into it
lb(2..3) := ""; -- delete items 2 and 3
print(lb(2..3)); -- show the new items 2 and 3
but := Tk("button","Show Box"); but("side") := "top"; -- create a button
but{OM} := lambda(); -- bind bounding box display actions to it
print(txt.bbox("1.2")); print(txtln.bbox("1"));
print(lb.bbox("0")," ",lb.bbox("2"));
end lambda;
but := Tk("button","Quit"); but("side") := "top"; -- create a second button
but{OM} := lambda(); Tk.quit(); end lambda; -- bind an exit action to it
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced by the preceding program is:
Item4 Item5 [18, 4, 25, 16] [42, 2, 45, 14] [1, 1, 36, 16] [1, 33, 36, 48]
Our next example shows the creation of 'active' ('hotworded') text by the binding of actions to tags embedded in the text. We also illustrate the 'txt.tag_ranges(tag_name)' operation, which returns the list of all character ranges to which a specified tag attaches; the 'txt.tag_names(char_index)' operation, which returns the list of all tags whose range covers a specified character; and the 'txt.tag_names(OM)' operation, which returns the list of all tags in an entire textarea.
The program shown below sets up a textarea into which text is inserted and then tagged. Information concerning the tags is then printed. We then bind actions to the tags. A pair of actions, one bound to mousedown and the other to mouseup, is attached to the first pair, but only a mouseup action to the second tag. You can click on the colored textareas to see the results of these bindings.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","10,10"); txt("side") := "left";
-- create and place a text widget
txt(OM) := "Type\ntext\nhere"; -- put some text into it
print(txt("1.0".."2.1")); -- print a range of this text
txt.tag_add("my_tag","1.1,1.1,2.1,3.3");
-- add a tag to two disjoint character ranges
txt.tag_add("my_tag2","1.3,1.5");
-- add a second tag to a character range
print(txt.tag_ranges("my_tag"));
-- get list of all ranges for specified tag
print(txt.tag_names("1.1"));
-- get list of all tags covering the specified character
-- set tag attributes, to make tagged ranges visible
txt("my_tag","font,background,foreground")
:= "{times 24 bold italic},red,yellow";
txt("my_tag2","font,background,foreground")
:= "{times 36 bold},blue,white";
txt{"my_tag",OM} := lambda(); print("Clicked yellow text"); end lambda;
-- bind a print action to click on the yellow text
txt{"my_tag","ButtonPress-1"} := lambda();
print("Pressed yellow text"); end lambda;
-- bind a print action to mousedown on the yellow text
txt{"my_tag2",OM} := lambda();
print("Clicked white text"); end lambda;
-- bind a print action to mousedown on the white text
print(txt.tag_names(OM));
-- print ordered list of tags associated with widget
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
Type t ["1.1", "1.1", "2.1", "3.3"] ["my_tag"] ["sel", "my_tag", "my_tag2"]
Note that event bindings like
txt{"my_tag","ButtonPress-1:xyXY"} := proc;
are also possible, in which case 'proc' must be a 1-parameter procedure, to which as many event parameter values as have been requested will be transmitted as a tuple.
Though the previously described scheme for inserting tags into text is quite general, it is rather more intricate than is required for text hotwording in the normal case, since it allows tagged zones in text to overlap in arbitrary fashion, which is rarely done. Normally such zones are disjoint. Our next two examples show a simpler scheme for text hotwording. To use this scheme, one simply takes the text to be tagged and marks the tagged sections in it by putting a back-apostrophe character '`' before and after each tagged section. The text within these sections is then extracted and used to tag itself, blank spaces in such sections being replaced by '~' characters. Thus, for example, a tagged text section consisting of the words 'Hello World' would receive the tag 'Hello~World'. If the same tagged section occurs several times in the text, unique serial numbers are be appended to all occurrences after the first, so that the second occurrence of a tagged section 'xxx' in text will receive the tag 'xxx~2'. The resulting tags can then be assigned attributes,for example color nd font, in the normal way. All these details are illustrated in the example seen below, which uses a simple code package called 'hotword_pak' shown following it. This package provides just one procedure, which has the form
make_hotworded(txt_widget,text,up_proc,down_proc,enter_proc,leave_proc);
Here, the first parameter is a Tk text widget into which the hotworded text is to be placed. The second parameter is the text to be hotworded, marked with back apostrophes in the way just explained. The last four parameters of 'make_hotworded' are all two-parameter procedures, which (if not OM) are called as the mouse moves over and clicks on the hotworded text zones. The first of these procedures, 'up_proc', is called when the mouse button is released on a hotworded zone in text, and the second, 'down_proc', when the mouse is pressed on a hotworded zone in text. The two last parameters, 'enter_proc' and 'leave_proc' are called when the mouse enters and leaves a hotworded text zone respectively. The two parameters passed to these routines when they re called are respectively the text widget containing the hotworded text,and the tag attached to the triggering text zone.
The following example shows how easy it is to use this hotwording scheme. It sets up two text areas in a window, each containing a sample hotworded text. (All four of the procedures then bound to this text are very trivial, and intended for illustration only. The 'up_proc' and 'down_proc' parameters passed merely print the tag associated with the hotworded text section on which a click occurs, the former in lowercase and the latter in uppercase. The 'enter_pro' and 'leave_proc' routines merely change the text color from black to red and back again, giving a 'highlighting' effect. Of course much more sophisticated effects could be obtained by elaborating these procedures.)
program test; -- SETL interactive interface example 1
use tkw,hotword_pak,string_utility_pak;
-- use the main widget class and the hotword_pak
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Hotworded Text"; -- create the Tk interpreter
txt := Tk("text","40,5"); txt("side") := "top"; -- create a text widget
txt("font") := "{Times 18 bold}"; -- set a font
text := "`Now` is the `time` for all `good men` to `time` out.";
-- define the text to be hotworded
make_hotworded(txt,text,printit,printcap,hilite,lolite);
-- put hotworded text into the text widget
txt("now",b := "background") := "yellow"; txt("time",b) := "green";
-- make the tags visible
txt("good~men",b) := "pink"; txt("time~2",b) := "cyan";
txt := Tk("text","40,5"); txt("side") := "top";
-- create a second text twidget
txt("font") := "{Times 18 bold italic}"; -- set a different font
text := "Twas `Brillig` and the `Slithy Toves` "
+ "did `Gyre` and `Gimbal` in the `Wabe`.";
-- define the second text to be hotworded
make_hotworded(txt,text,printit,printcap,hilite,lolite);
-- put hotworded text into the second text widget
txt("brillig",b) := "yellow"; txt("slithy~toves",b) := "green";
-- make the tags visible
txt("gyre",b) := "pink"; txt("gimbal",b) := "cyan"; txt("wabe",b) := "magenta";
Tk.mainloop(); -- enter the Tk main loop
procedure printit(txt,tag); print(tag); end printit;
-- print tag on mouseup
procedure printcap(txt,tag); print(case_change(tag,"lu")); end printcap;
-- print capitalized tag on mousedown
procedure hilite(txt,tag); txt(tag,"foreground") := "red"; end hilite;
-- hilite the tagged text on entry
procedure lolite(txt,tag); txt(tag,"foreground") := "black"; end lolite;
-- hilite the tagged text on exit
end test;
The code shown below is that for the 'hotword_pak' used in the preceding example. Its one procedure, 'make_hotworded' accepts a text widget TW and some text marked in the manner described above, plus the four procedure parameters that we have described. The text is analyzed to find its hotworded zones, and then converted into text tagged in our standard manner, by using the text in each hotworded section as its own tag. This is accomplished by the subprocedure 'self_tag', which you can examine to see the details of this process. The tagged text produced by 'self_tag' is then written to TW. Following this, each of the four procedure parameters passed to 'make_hotworded' is bound to each of the tags found in the text, in such a way as to ensure that then appropriate triggering events will cause these procedures to be called and TW passed to them along with the tag attached to the triggering text section. The preceding example illustrates the use of all of these conventions.
package hotword_pak; -- utility package for Tk text hotwording
procedure make_hotworded(txt_widget,text,up_proc,down_proc,enter_proc,leave_proc); -- put hotworded text into text widget
end hotword_pak;
package body hotword_pak; -- utility package for Tk text hotwording
use string_utility_pak;
var tags_list := [],seen_already := {};
-- tags_list will be collected by self_tag
procedure make_hotworded(txt_widget,text,up_proc,down_proc,enter_proc,leave_proc);
-- put hotworded text into text widget
tags_list := []; -- will be collected by self_tag
pieces := breakup(text,"`");
-- treat as a '`' treat as a '`'-delimited list
-- convert the hotworded sections 'xxx' into <`xxx`>xxx<``xxx`>,
-- i.e. use stringitself as tag
txt_widget(OM) := "" +/ [if odd(j) then piece
else self_tag(piece) end if: piece = pieces(j)];
-- self_tag also collects the tags
for tag in tags_list loop
-- attach four bindings to each of the tags
if up_proc /= OM then
-- bind 'up_proc' to button-up event
txt_widget{tag,"ButtonRelease-1"} := apply(up_proc,txt_widget,tag);
end if;
if down_proc /= OM then
-- bind 'down_proc' to button-up event
txt_widget{tag,"ButtonPress-1"} := apply(down_proc,txt_widget,tag);
end if;
if enter_proc /= OM then
-- bind 'enter_proc' to entry event
txt_widget{tag,"Enter"} := apply(enter_proc,txt_widget,tag);
end if;
if leave_proc /= OM then
-- bind 'leave_proc' to exit event
txt_widget{tag,"Leave"} := apply(leave_proc,txt_widget,tag);
end if;
end loop;
end make_hotworded;
procedure self_tag(stg); -- convert 'stg' a string carrying itself as tag
safe_stg := join(breakup(stg," "),"~");
-- convert " " to "~",which is btter for Tk
sul := case_change(safe_stg,"ul"); -- make case-insensitive
seen_already(sul) := n := (seen_already(sul)?0) + 1;
-- count number of occurneces
tags_list with:= (sul := if n = 1 then sul else sul + "~" + n end if);
-- save the tag in tags_list; keep count if > 1
return "<`" + sul + "`>"+ stg + "<``" + sul + "`>";
-- return'stg' a string carrying itself as tag
end self_tag;
procedure apply(proc,txt,tag); -- procedure binding former
return lambda(); proc(txt,tag); end lambda;
end apply;
end hotword_pak;
Tk absolute Images (and 'absolute bitmaps', which will be described later) can be inserted into text, in which case they behave as single characters of a special kind. The following small program shows this, and also illustrates the use of the 'txt.linebox(n)' operation, which returns a pair of the form [box,baseline], where 'box' is the bounding box of the specified line, and 'baseline' is the position of the baseline of this line, as measured from the top of 'box'. Note also that 'txt("images")' returns the list of all images in a text widget, or, if there is only one, returns that image object.
The program seen below sets up a textarea and then reads in an image which is inserted into the text in the textarea. Two buttons are added, one of which prints the boxes containing two specified lines of text and the other the list of all images in the textarea. Note that, as seen in the code bound to the first button, the 'linebox()' operation assumes that n is given in a 0-based form.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","30,12"); txt("side") := "top";
txt(OM) := "Type\ntext\nhere"; -- create a text area
txt("font,background") := "{Times 18 bold},green";
abs_img := Tk("image","test_files/egyptian.gif");
-- read an image file to create a Tk absolute image
txt.insert_image("1.1",abs_img);
-- insert this into the text area
but := Tk("button","Print lineboxes"); but("side") := "top";
-- create a button
but{OM} := lambda();
print(txt.linebox(0)); print(txt.linebox(2)); end lambda;
-- bind this to a pair of linebox print actions
but := Tk("button","Print images"); but("side") := "top"; -- create a button
but{OM} := lambda(); print(txt("images")); end lambda;
-- bind this to an image_list print action
Tk.mainloop(); -- enter the Tk main loop
end test;
The text widget operations
txt.scan_mark(i,j); and txt.scan_to(i,j);
together allow the view of a text field containing more text than can be viewed at any one time to be shifted. The same operations are available for listboxes. This is demonstrated in the following example, which opens a text area, inserts some text into it, and then sets up buttons which invoke the 'scan_mark' and 'scan_to' operations to reposition the text in the text area. You can experiment with these buttons to verify that the 'scan_to' positions text relative to the point set by last preceding 'scan_mark' operation.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("text","10,2"); txt("side") := "top";
txt("background") := "yellow";
txt(OM) := " (1)Type text here\n (2)Type text here\n "
+ " (3)Type text here\n (4)Type text here";
txt("font") := "{times 36 bold}"; txt("wrap") := "none";
but := Tk("button","Place scan mark at (0,0)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_mark(0,0); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Place scan mark at (-3,-3)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_mark(3,3); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Scan to (-2,-2)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to(-2,-2); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to (-3,-3)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to(-3,-3); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to (-4,-4)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to(-4,-4); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to (2,2)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to(2,2); end lambda;
-- move to left from (0,0)
but := Tk("button","Scan to (3,3)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to(3,3); end lambda;
-- move to left from (0,0)
but := Tk("button","Scan to (4,4)"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to(4,4); end lambda;
-- move to left from (0,0)
Tk.mainloop(); -- enter the Tk main loop
end test;
Next we give a very similar example for listboxes. This sets up a listbox, and then creates buttons which invoke the 'scan_mark' and 'scan_to' operations to repostion the listbox items. You can experiment with these buttons to verify that the 'scan_to' positions the listbox items relative to the point set by last preceding 'scan_mark' operation.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var lb; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
lb := Tk("listbox",3); lb("side") := "top";
-- create a listbox, which shows 3 elements
lb(1..0) := "Item1Item1Item1Item1Item1***********,"
+ "Item2,Item3,Item4,Item5,Item6,Item7,Item8,Item9,Last Item";
-- put 10 elements, the first quite long, into the listbox
lb("font") := "{times 18 bold}";
but := Tk("button","Place scan mark at (0,0)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_mark(0,0); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Place scan mark at (-3,-3)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_mark(3,3); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Scan to (-2,-2)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_to(-2,-2); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to (-3,-3)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_to(-3,-3); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to (-4,-4)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_to(-4,-4); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to (2,2)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_to(2,2); end lambda;
-- move to left from (0,0)
but := Tk("button","Scan to (3,3)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_to(3,3); end lambda;
-- move to left from (0,0)
but := Tk("button","Scan to (4,4)"); but("side") := "top";
-- create a button
but{OM} := lambda(); lb.scan_to(4,4); end lambda;
-- move to left from (0,0)
Tk.mainloop(); -- enter the Tk main loop
end test;
As the following variant example shows, the scan_mark and scan_to operations 1s also available for textlines, but in a '1-dimensional' rather than a '2-dimensional' form, namely as
txt.scan_mark_1(i); and txt.scan_to_1(i);
The following is an example. It sets up a textline, puts text into it, and and then creates buttons which invoke the 'scan_mark_1' and 'scan_to_1' operations to repostion the textline. You can experiment with these buttons to verify that the 'scan_to' positions the text relative to the point set by last preceding 'scan_mark' operation.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("entry","10"); txt("side") := "top";
txt("background") := "yellow";
txt(OM) := " (1)Type text here (2)Type text here "
+ "(3)Type text here (4)Type text here";
txt("font") := "{times 36 bold}";
but := Tk("button","Place scan mark at 0"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_mark_1(0); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Place scan mark at -10"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_mark_1(-10); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Scan to -20"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to_1(-20); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to -30"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to_1(-30); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to -40"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to_1(-40); end lambda;
-- move to right from (0,0)
but := Tk("button","Scan to 10"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to_1(10); end lambda;
-- move to left from (0,0)
but := Tk("button","Scan to 3"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to_1(3); end lambda;
-- move to left from (0,0)
but := Tk("button","Scan to 4"); but("side") := "top";
-- create a button
but{OM} := lambda(); txt.scan_to_1(4); end lambda;
-- move to left from (0,0)
Tk.mainloop(); -- enter the Tk main loop
end test;
rectangle - a rectangular figure oval - a circular or figure polygon - a general closed polygon or spline curve line - a general open polygon or spline curve arc - a circular or elliptical sector or pie-shaped region bitmap - a bitmap, which can be displayed in designated colors image - a photographic image widget - an arbitrary widget canvas_text - non-editable fonted text, with a transparent backgroundCanvas items are created by writing statements of the form
item := canvas("rectangle",descriptor),
item := canvas("polygon",descriptor),
item := canvas("image",descriptor), etc.
As shown in the following table, the kind of descriptor used depends on the kind of item being created
'Descriptors' used with the various kinds of canvas items rectangle - left,top,right,bottom oval - left,top,right,bottom of enclosing rectangle polygon - comma-separated series of x,y positions - for polygon or spline points line - comma-separated series of x,y positions - for polygon or spline points arc - left,top,right,bottom of enclosing rectangle bitmap - x,y coordinates of bitmap corner image - x,y coordinates of image corner widget - widget object canvas_text - string contents of textOnce they have been created within a canvas C, canvas items 'itm' are positioned (and so made visible) by writing
itm("coords") := list_of_coords;
The list_of_coords that must be supplied is generally identical with the descriptor list appearing in the preceding table, except that for widget items in a canvas and for canvas_text items the list_of_coords should be the x,y coordinates of the object corner.
Once positioned in this way any canvas item can be repositioned (and, in some cases, reshaped) at any time by a subsequent
itm("coords") := list_of_coords;
assignments. When repositioned or reshaped, objects move immediately to their new configuration, leaving no trailing artifacts. This make the canvas environment considerably easier to use than a simple 'draw' environment in which one needs to make explicit repairs of the prior positions of moved graphics. For example, the following program creates an animated pair of circles which move past each other.
Here is an example of the use of 'coords'. The code creates a canvas into which two ovals are placed and a button bound to a procedure which shifts the position of these circles every time it is clicked.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,blue_circ,red_circ,num_steps := 0;
-- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
bu := Tk("button","Click to move the circles"); bu("side") := "top";
-- create a button
bu{OM} := advance_animation; -- clicking the button starts the animation
ca := Tk("canvas","640,280"); ca("side") := "top"; -- create a canvas
blue_circ := ca("oval","100,100,140,140"); blue_circ("fill") := "blue";
-- insert the circles
red_circ := ca("oval","400,100,440,140"); red_circ("fill") := "red";
Tk.mainloop(); -- enter the Tk main loop
procedure advance_animation();
-- advance the animation and return true, or false if finished
bcc := [str(unstr(c) + 5.0): c in blue_circ("coords")];
-- reposition the circles
blue_circ("coords") := bcc;
rcc := [str(unstr(c) - 5.0): c in red_circ("coords")];
red_circ("coords") := rcc;
end advance_animation;
end test;
Here is another example: a time-driven animation showing two colored circles. This code is very close to the preceding program but instead of using button clicks to change the position of the circles that appear, they move automatically under timer control once a triggering button is clicked. An additional comment is found below.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,blue_circ,red_circ,num_steps := 0;
-- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
bu := Tk("button","Go"); bu("side") := "top"; -- create a button
bu{OM} := advance_animation; -- clicking the button starts the animation
ca := Tk("canvas","640,280"); ca("side") := "top"; -- create a canvas
blue_circ := ca("oval","100,100,140,140"); blue_circ("fill") := "blue";
-- insert the circles
red_circ := ca("oval","400,100,440,140"); red_circ("fill") := "red";
Tk.mainloop(); -- enter the Tk main loop
procedure advance_animation();
-- advance the animation and return true, or false if finished
if (num_steps +:= 1) > 300 then return; end if;
-- end the animation after 300 steps
blue_circ("coords") := -- reposition the circles
str(100 + num_steps) + ",100," + str(140 + num_steps) + ",140";
red_circ("coords") :=
str(400 - num_steps) + ",100," + str(440 - num_steps) + ",140";
Tk.createtimer(5,advance_animation);
-- start a Tk timer (rings once)
end advance_animation;
end test;
The following comments will aid understanding of the preceding code. The initial lines of code create a button, a canvas, and two canvas items: a red and a blue circle. Clicking the button calls the procedure 'advance_animation', which repositions the two circles and then creates another timed call to itself, unless it has already been called 300 times, in which case it simply returns. Note that the desired animation is created simply by repositioning the two circles.
Note also that the line
Tk.createtimer(5,advance_animation);can be replaced by
Tk.createidle(advance_animation);This will advance the animation as rapidly as possible, rather than after a specified time interval.
Each kind of canvas item has a list of attributes which can be used to control its graphical appearance. The following table lists the attributes for each canvas item type.
rectangle attributes width - width of outline fill - color for interior outline - color for outline stipple - pattern for interior
oval attributes width - width of outline fill - color for interior outline - color for outline stipple - pattern for interior
polygon attributes width - polygon outline width, in pixels smooth - if true, polygon is a spline curve splinesteps - number of intermediate smoothing points to use, if spline fill - color for polygon interior outline - color for polygon outline stipple - pattern for arc interior
line attributes width - curve width, in pixels smooth - if true, curve is a spline curve splinesteps - number of intermediate smoothing points to use, if spline fill - color for curve interior stipple - pattern for arc interior stipple - pattern for arc interior arrow - position to place arrowheads: none, first, last, or both arrowshape - three numerical parameters defining arrowhead shape: - distance from base to point, head length, head width capstyle - line end shape: butt, projecting, or round joinstyle - line join shape: bevel, miter, or round
arc attributes style - pieslice, chord, or arc (circular boundary only) start - starting angle of circular arc, in degrees extent - extent of circular arc, in degrees width - width of outline fill - color for interior outline - color for outline stipple - pattern for interior outlinestipple - pattern for outline
bitmap attributes bitmap - file name or built-in bitmap name defining picture geometry anchor - point from which position is reckoned: n,s,e,w,nw,sw,ne, or se background - display color for bitmap background foreground - display color for bitmap foreground
image attributes image - image object to appear in canvas item anchor - point from which position is reckoned: n,s,e,w,nw,sw,ne, or se
canvas-widget attributes window - widget object to appear in canvas item anchor - point from which position is reckoned: n,s,e,w,nw,sw,ne, or se width - widget width, in pixels or number of characters height - widget height, in pixels or number of characters
canvas-text attributes text - actual text string anchor - point from which position is reckoned: n,s,e,w,nw,sw,ne, or se font - text font, e.g. "Times,20,bold" justify - left, right, or center fill - text color stipple - text pattern width - text area width
See the following section for a discussion of canvas scrolling.
Canvas Widgets. Widgets of any kind can be put directly into a canvas, as 'canvas widgets'. When so placed they retain their normal activity. This is done by creating the widgets w in the normal way, as children of the canvas, except that they are not made visible by packing of gridding them. instead, they are first converted into 'canvas widgets' by writing commands like
canv_w := canvas("widget",w);
The resulting canvas widget is then assigned coordinates by a command like
canv_w(""coords"):= "x,y";
These rules are illustrated by the following program. It sets up a canvas, and inserts three widgets into it, the first a frame containing a scrolling listbox (see the following section for additional details concerning scrollbars and scrolling listboxes) , the second a listbox, and the third a scrollbar widget geometrically disconnected from the other widgets but logically linked to the second. The scrollbar in the frame is given a horizontal orientation but connected to the y-scrolling action of the listbox in the frame (just to demonstrate that this is possible). You can execute this code and experiment with it to verify that all the canvas widgets behave as normally as other widgets.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","300,300"); ca("side") := "left"; -- create a canvas
ca("background") := "green";
fr := ca("frame","100,50"); -- this frame will be put directly into the canvas
fr_incanv := ca("widget",fr); fr_incanv("coords,anchor") := "10,10;nw";
lb := fr("listbox",3); lb("side") := "top";
-- this listbox, placed in the frame, shows 3 elements
lb(1..0) := "Item1,Item2,Item3,Item4,Item5,Item6,Item7,Item8,Item9,Item10";
-- listbox contains 10 elements, so a scrollbar is attached
lb("yscroller") := scrollb := fr("scrollbar","h,10");
-- attach a scrollbar, giving it a somewhat' perverse' orientation
scrollb("side,fill") := "top,x";
-- make the scrollbar visible by putting it into the frame
lb2 := ca("listbox",4); -- this listbox shows 4 elements
lb2(1..0) := "Item1,Item2,Item3,Item4,Item5,Item6,Item7,Item8,Item9,Item10";
-- the listbox contains 10 elements, so a scrollbar is attached
lb2_incanv := ca("widget",lb2); lb2_incanv("coords,anchor") := "50,80;nw";
-- put this listbox directly into the canvas, as a canvas widget
lb2("yscroller") := scrollb := ca("scrollbar","v,10"); -- attach a scrollbar
scrollb_incanv := ca("widget",scrollb);
scrollb_incanv("coords,anchor") := "250,100;nw";
-- put this scrollbar directly into the canvas, as a canvas widget
Tk.mainloop(); -- enter the Tk main loop
end test;
As shown by the following micro-program, the convenience operation
canvas.draw_ovals(descriptor);
can be used to draw a group of any number of ovals in a canvas. Here,the descriptor should be a tuple of pairs [rect,fill], each defining the enclosing rectangle of an oval, and its fill. Each 'rect' should be a comma- or blank-delimited string of coordinates. The operation returns a pair consisting of first and last ovals drawn.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","300,100"); ca("side") := "top";
-- if packed; or left,right,bottom
ca("background") := "#cccccc";
ca.draw_ovals([["5,5,20,20","red"],["25,5,40,20","blue"],
["45,5,60,20","green"],["65,5,80,20","magenta"]]);
Tk.mainloop(); -- enter the Tk main loop
end test;
Converting the contents of a canvas to printable Postscript. The graphical interface provides a means for translating the contents of a canvas into a Postscript file. These Postscript files are can either be printed or viewed a with a Postscript viewer. (A good Postscript viewer is 'GSView', which is free and can be downloaded the from the Web.) Translation to Postscript is the governed the options parameter in the command seen above, which should be supplied in the form of a comma-delimited string in which every in odd numbered element should be a option name, and each following even numbered element should be the corresponding option value. The most commonly used are Postscript option values are shown in the table below. (A few other options are also available; for information about these remaining options, consult one of the Tk references listed above.)
Option Name Use and possible values x left edge of canvas rectangle to be printed. Defaults to left edge of canvas. y top edge of canvas rectangle to be printed. Defaults to top edge of canvas. width width of canvas rectangle to be printed. Defaults to width of canvas. height width of canvas rectangle to be printed. Defaults to width of canvas. pageanchor determines point of printed canvas region used for positioning it on the Postscript page. Must be n,nw,w,sw,s,se, e,of center. Defaults to center. pagex x position on page of canvas anchor point. pagey y position on page of canvas anchor point. pagewidth width on page of canvas rectangle image. Scaling to achieve this is the same in x and y. Defaults to 1.0. pageheight height on page of canvas rectangle image. Scaling to achieve this is the same in x and y. Overrides pagewidth. colormode controls use of color in Postscript translation. Must be color, gray, or mono (black and white). file if given, Postscript output will be written to the file named, and the 'postscript' operation will return an empty string.
The following program illustrates the use of the 'postscript' operation.
program test; -- standard template for interactive programs
use tkw,string_utility_pak; -- use the main widget class
var Tk,global_1,global_2,global_3;
Tk := tkw(); Tk(OM) := "Caption"; -- create the Tk interpreter
ca := Tk("canvas","300,200"); ca("side") := "left"; -- create a canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put some overlapping geometric items and text into the canvas
oval := ca("oval","80,20,120,40"); oval("width") := 5;
line := ca("line","140,20,180,20,180,40,20,40");
line("fill,smooth") := "blue,true";
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
poly := ca("polygon","140,80,180,80,180,120,20,120");
poly("fill,smooth") := "green,true";
oval := ca("oval","80,80,120,100"); oval("width") := 5;
ct := ca("text","Text in the canvas");
ct("coords") := "30,30"; ct("anchor,font") := "nw,{Times 36}";
printa(handl := open("postscript_test","TEXT-OUT"),
ca.postscript("colormode,gray"));
-- generate Postscript for the canvas and write it out
close(handl);
Tk.mainloop();
end test;
Note that the 'postscript' operation returns the Postscript translation of the canvas area contents as a string (Postscript translations have the form of code not involving any special characters) unless the 'file' option is given, in which case the Postscript output will be written to the file named, and the 'postscript' operation will return an empty string. Note that the 'GSView' Postscript viewer is able to export Postscript files in a wide variety of formats, including Adobe PDF (portable document format), EPS (encapsulated postscript), Adobe Illustrator, FAX, Tiff, JPEG, Pict, PNG (portable network graphics image format), PBM (portable bitmap format), and PCF (portable compiled, a format used for fonts) formats. This makes it possible to write the contents of a canvas in most important graphic and image file formats.
(i) In regard to their geometry, scrollbars are treated as independent widgets, created by statements of the form
sc := parent("scrollbar",descriptor);
sc := parent("scrollbar","v,10"); sc("side,fill") := "left,y";
sc("yscroller") := sb;
(ii) Once created, the scrollbar must be made visible by packing, gridding, or placing it into a window or other widget (e.g. frame), in the same way as any other widget would be packed, gridded, or placed.
(iii) To attach a scrollbar to a scrollable widget w, so that the scrollbar will always reflect the current position within w of w's pane of visibility, and so that scrollbar manipulations will cause this pane to scroll in the expected way, one must write an assignment of the form
w("xscroller") := scrollbar; (for a horizontal scrollbar)
or
w("yscroller") := scrollbar; (for a vertical scrollbar)
The following example illustrates these scrollbar conventions. We create a text area within a frame and two scrollbars placed in only rough geometric relationship to the text area, but connected to it so as to have scrollbar dragging scroll the text in the normal way. Note that automatic wrapping of long lines is turned off so that the effect of horizontal scrolling can be seen.
program test; -- illustration of scrollbar usage
use tkw; -- use the main widget class
Tk := tkw(); -- create the Tk interpreter
fr := Tk("frame","1,10"); fr("side") := "top"; -- create a frame
t := fr("text","60,4"); t("side") := "left"; -- create a text area
t("wrap") := "none";
sbv := fr("scrollbar","v,10"); -- create a vertical scrollbar
sbv("side,fill") := "left,y";
t("yscroller") := sbv;
sbh := Tk("scrollbar","h,10"); -- create a horizontal scrollbar
sbh("side,fill") := "top,x";
t("xscroller") := sbh;
Tk.mainloop(); -- enter the Tk main loop
end test;
Scrollbars have the following attributes, most of which affect their appearance only. (Since Tk implementations sometimes give scrollbars their 'native' appearance, not all of these are implemented on every platform.)
orient - 'horizontal' or 'vertical' width - scrollbar width, in pixels, along its narrow dimension cursor - cursor when mouse is over the scrollbar activebackground- color when mouse is over the scrollbar slider or arrows activerelief - slider or arrow relief when scrollbar is over them background - color of scrollbar border borderwidth - width of scrollbar border elementborderwidth - border width of slider and arrows highlightthickness - thickness of scrollbar highlight border highlightbackground - color of scrollbar highlight border - when scrollbar does not have focus highlightcolor - color of scrollbar highlight border - when scrollbar has focus jump - if true, scrolling takes place, not dynamically, - but when scrollbar is released repeatdelay - delay in milliseconds before start of autoscrolling - on arrow or trough press repeatinterval - milliseconds between successive autoscrolling steps - on arrow or trough press troughcolor - color of scrollbar troughScrolling Canvases and Text Widgets. To scroll a canvas, one needs to give it a logical area which is greater than its visible area. The 'width' and 'height' values transmitted in the canvas' creation call 'parent("canvas","width,height")' set the visible area of the canvas; to set its logical area, a separate set of values should be assigned to its 'scrollregion' attribute, by a statement of the form
canv("scrollregion") := "left,top,right,bottom";
To position scrollbars in the conventional way it is best to put them, together with the canvases or the text area to which they attach, into a common frame within which they are positioned using the 'grid' geometry manager, with the canvas/text at the upper left of the grid. This creates a pair of scrollbars having a conventional appearance.
The following example illustrates canvas scrolling. Here we arrange the two scrollbars seen in a more conventional relationship to the scrolling canvas that they control. This is done by putting the canvas and the two scrollbars together into a common window, within which they are placed by gridding to achieve a conventional appearance.
program test; -- canvas scrolling
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,75"); ca("row,column") := "1,1";
-- put a canvas in upper left corner of grid
ca("scrollregion") := "0,0,300,100";
-- give the canvas a larger logical than visible area!
-- put horizontal scrollbar at bottom left of grid
hsb := Tk("scrollbar","h,16"); hsb("row,column,sticky") := "2,1,news";
-- put vertical scrollbar at top right of grid
vsb := Tk("scrollbar","v,16"); vsb("row,column,sticky") := "1,2,news";
ca("xscroller") := hsb; ca("yscroller") := vsb;
-- connect the scrollbars to the canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put a rectangle and an oval into the canvas
oval := ca("oval","80,20,120,40"); oval("width") := 5;
line := ca("line","140,20,180,20,180,40,20,40");
line("fill,smooth") := "blue,true";
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
ct := ca("text","Text in the canvas");
-- put some fonted text into the canvas
ct("coords") := "30,30"; ct("anchor,font") := "nw,{Times 36}";
Tk.mainloop(); -- enter the Tk main loop
end test;
Although a vertical scrollbar can be used with any text widget which contains more text than will be contained in its specified vertical extent, a horizontal scrollbar can only be used if wrapping is suppressed in the widget by setting its "wrap" attribute to "none". The following small program illustrates this. The text area seen is gridded with its scrollbars in the same way as in the previous example, and is made non-wrapping by the 'tx("wrap") := "none";' instruction shown. If you comment out this instruction, you will see that the vertical scrollbar remains active, but the horizontal scrollbar is disabled.
program test; -- canvas scrolling
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
tx := Tk("text","20,5"); tx("row,column") := "1,1";
-- put a text widget in upper left corner of grid
tx("wrap") := "none"; -- turn off text wrapping
-- put horizontal scrollbar at bottom left of grid
hsb := Tk("scrollbar","h,16"); hsb("row,column,sticky") := "2,1,news";
-- put vertical scrollbar at top right of grid
vsb := Tk("scrollbar","v,16"); vsb("row,column,sticky") := "1,2,news";
tx("xscroller") := hsb; tx("yscroller") := vsb;
-- connect the scrollbars to text widget
-- put some text into the text widget
tx(OM) := "To scroll a canvas, one needs to give it a logical area\n" +
" which is greater than its visible area. The 'width'\n" +
" and 'height' values transmitted in the canvas' creation call\n" +
" 'parent(\"canvas\",\"width,height\")' set\n" +
" the visible area of the canvas; to set its logical area,\n" +
" a separate set of values should be \n" +
" assigned to its 'scrollregion' attribute.\n";
Tk.mainloop(); -- enter the Tk main loop
end test;
The view of a canvas large enough to support scrolling (i.e. with a "scrollregion" attribute larger than its size) can also be shifted using the operations 'canvas.xview_percent(float_precent)', 'canvas.yview_percent(float_precent)', 'canvas.xview_scroll(n,what)', 'canvas.yview_scroll(n,what)' (where 'what' can be either 'units' or 'pages'. This is shown in the following adaptation of the scrolling canvas program shown above. Note that these same operations are available for listboxes, and for text widgets if their 'wrap' attribute is turned off. The 'horizontal' operations 'xview_percent' and 'xview_scroll' are also available for text lines.
program test; -- canvas scrolling
use tkw; -- use the main widget class
var ca; -- globalize for use in procedures below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,75"); ca("side") := "top";
-- put a canvas in upper left corner of grid
ca("scrollregion") := "0,0,300,100";
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put a rectangle and an oval into the canvas
oval := ca("oval","80,20,120,40"); oval("width") := 5;
line := ca("line","140,20,180,20,180,40,20,40");
line("fill,smooth") := "blue,true";
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
ct := ca("text","Text in the canvas");
-- put some fonted text into the canvas
ct("coords") := "30,30"; ct("anchor,font") := "nw,{Times 36}";
fr := Tk("frame","100,75"); fr("side") := "top";
-- create frame for the next two buttons
but := fr("button","View right"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.xview_percent(0.5); end lambda;
-- bind it to a rightwards view-shift operation
but := fr("button","View left"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.xview_percent(0.0); end lambda;
-- bind it to a leftwards view-shift operation
fr := Tk("frame","100,75"); fr("side") := "top";
-- create frame for the next two buttons
but := fr("button","Scroll right"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.xview_scroll(4,"units"); end lambda;
-- bind it to a rightwards view-shift operation
but := fr("button","Scroll left"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.xview_scroll(-4,"units"); end lambda;
-- bind it to a leftwards view-shift operation
fr := Tk("frame","100,75"); fr("side") := "top";
-- create frame for the next two buttons
but := fr("button","View bottom"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.yview_percent(0.5); end lambda;
-- bind it to a downwards view-shift operation
but := fr("button","View top"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.yview_percent(0.0); end lambda;
-- bind it to a upwards view-shift operation
fr := Tk("frame","100,75"); fr("side") := "top";
-- create frame for the next two buttons
but := fr("button","Scroll down"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.yview_scroll(1,"units"); end lambda;
-- bind it to a downwards view-shift operation
but := fr("button","Scroll up"); but("side") := "left";
-- create a button
but{OM} := lambda(); ca.yview_scroll(-1,"units"); end lambda;
-- bind it to a upwards view-shift operation
Tk.mainloop(); -- enter the Tk main loop
end test;
The following program shows the use of the 'scale_item' operation, which rescales canvas objects (but not canvas text) around a specified center by specified x and y amounts. We also show the use of slice-assignment operations to edit canvas text, which behaves like all other text in this regard.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ct,rect,poly; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","300,100"); ca("side") := "top";
-- create a canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put some graphic objects into the canvas
oval := ca("oval","80,20,120,40"); oval("width") := 5;
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
ct := ca("text","Text in the canvas");
-- put some canvas text into the canvas
ct("coords") := "30,30"; ct("anchor,font") := "nw,{Times 36}";
ct(1..1) := "XXX"; ct(4..6) := ""; -- edit the canvas text
but := Tk("button","Scale"); but("side") := "top";
-- create a button
but{OM} := lambda();
-- bind rescaling actions for the geometric and text objects to it
rect.scale_item(30,30,1.5,2.0);
poly.scale_item(30,30,0.5,1.0);
ct.scale_item(30,30,1.5,2.0);
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
Even though regions in canvas text cannot be selected with the mouse in the same direct way that text in text widgets can,it is still possible to set selection regions in such text under program control; this gives the selected region a subtly 'highlighted' appearance. This is done using the operation
canvas.set_select(tag_name,from,to);
which assumes that the canvas text item in which a selection is to be set has been given a tag 'tag_name'. 'from' and 'to' are integer character numbers designating the range to be selected. The related expression
canvas.get_select(tag_name)
returns the selection boundaries in the canvas text item with the indicated tag. The following program illustrates the use of these operations. It sets up a canvas into which a canvas text widget is placed. Three buttons are also set up of which the first two, show and set the selection in the canvas text widget respectively. The third button shows the use of the 'move' operation which shifts a text item by a specified amount.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var ca,ct; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Selection in a tagged text widget";
-- create the Tk interpreter
ca := Tk("canvas","300,100"); ca("side") := "top";
-- if packed; or left,right,bottom
ca("background") := "#cccccc";
ct := ca("text","Text in the \ncanvas");
ct("coords") := "30,30"; ct("anchor,font") := "nw,{Times 36}";
print(ca.addtag_in("ttag",OM));
but := Tk("button","Set select in tagged canvas text");
-- create a button
but("side") := "top";
but{OM} := lambda(); ca.set_select("ttag",2,20); end lambda;
-- when clicked, prints the first mark after 1.1
but := Tk("button","Get select in tagged canvas text");
but("side") := "top"; -- create a button
but{OM} := lambda(); print(ca.get_select("ttag")); end lambda;
-- when clicked, prints the first mark after 1.4
but := Tk("button","Move tagged text"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(ct("tags")); print(ca.move("ttag",5,5)); end lambda;
-- bind it to a 'move' action
Tk.mainloop(); -- enter the Tk main loop
end test;
The expression
canvas.bbox_tags(tags_list)
returns the bounding box of all the items in a canvas which carry any of he tags in the indicated 'tags_list'. This must be a comma- or semicolon-delimited list of tag names. The expressions
canvas.canvasx(x,roundto) and canvas.canvasy(y,roundto)
respectively return the offset x and y locations corresponding to their screen x any y positions, in a scrolled canvas. If the 'roundto' parameter is not OM, it should be an integer, in which case the value returned will be rounded to the nearest multiple of this integer.
These operations are applied in the following program, which first forms a scrolling canvas containing a few tagged objects.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ca; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
fr := Tk("frame","30,30"); fr("side") := "top";
-- create a frame for a canvas and its scrollbars
ca := fr("canvas","100,100"); ca("row,column") := "1,1";
-- create a canvas
ca("background") := "green";
ca("scrollregion") := "0,0,300,300";
-- give the canvas a larger logical than visible area!
-- put horizontal scrollbar at bottom left of grid
hsb := fr("scrollbar","h,16"); hsb("row,column,sticky") := "2,1,news";
-- put vertical scrollbar at top right of grid
vsb := fr("scrollbar","v,16"); vsb("row,column,sticky") := "1,2,news";
ca("xscroller") := hsb; ca("yscroller") := vsb;
-- connect the scrollbars to the canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put some shapes in the canvas
oval := ca("oval","80,20,120,40"); oval("width") := 5;
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
rect.addtag("thing"); oval.addtag("thing"); poly.addtag("ping");
-- add tags to the shapes
print(ca.bbox_tags("thing,ping"));
-- print the bounding boxes of the tagged items
print(ca.bbox_tags("thing"));
print(ca.bbox_tags("ping"));
but := Tk("button","Canvas Location"); but("side") := "top";
-- create a button
but{OM} := lambda();
mouseloc := Tk("mouse"); print();
print("mouseloc is: ",mouseloc," canvas loc is: ",
[ca.canvasx(mouseloc(1),5),ca.canvasy(mouseloc(2),5)]);
end lambda; -- click on prints the mouse and canvas locations
Tk.mainloop(); -- enter the Tk main loop
end test;
{font_name font_size font_style} for example {Times 24 bold}
The font_style and/or font_size can be omitted, as in {Times 24} or simply {Times}. A list of font_style parameters chosen from the list 'bold, italic, normal, roman, underline, and overstrike' can be given, as in
{Times 24 {bold italic underline}} or {{Zapf Dingbats} 24 {bold underline}}
The fonts Times, Courier, and Helvetica are built into the Graphical interface, and so are always available. Other fonts are available only if they have been installed using whatever system conventions apply to the platform being used.
The available font attributes, set by these designators, are family (e.g. Sabon or {Zapf Dingbats}), size, weight ('bold' or 'normal'), slant ('roman' or 'italic'), underline ('true' or 'false'), overstrike ('true' or 'false').
A level of indirection, facilitating font substitution where desired, is available through the use of defined fonts. To define a font and set its attributes, we write
Tk("font","new_name,attributes") := attribute_vals;
where 'attributes' is a comma-separated list of attribute names, and 'attribute_vals' is a list of corresponding values. An example is
Tk("font","my_favorite_font,family,size,weight") := "Sabon,18,roman";
Font names introduced in this way can be used in the place of ordinary fonts, e.g. given a message object 'mes' we can write
mes("font") := my_favorite_font;
Here is an example. We set up a message and then designate a specific font as 'my_favorite_font'. The font is then assigned the message under this name. Our example shows all the attributes that can be assigned to fonts.
The expression Tk("fonts") returns a list of all the currently available fonts (not including the defined fonts.) The expression Tk("definedFonts") returns a list of all the currently defined fonts.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
msg := Tk("message","Messages\ncan\noccupy\nmany lines");
msg("side") := "left";
Tk("font","my_favorite_font,family,size,weight,slant,underline,overstrike")
:= "Times,36,bold,italic,1,0";
msg("font") := "my_favorite_font";
print(Tk("fonts")); print(Tk("definedFonts"));
-- print information on fonts available in Tk
-- and on user-defined font names
Tk.mainloop(); -- enter the Tk main loop
end test;
The expression
Tk.measure_fonted(stg,font)
returns the pixel width of the string 'stg' when set in the font 'font' (ignoring the special effects of tabs and linebreaks.)
font_metrics(font)
returns a SETL map which gives the ascent, descent, and line spacing of a font, and which indicates whether it is a fixed-width font.
font_families()
returns the list of fonts available in Tk. The following program shows the use of these operations. It puts a series of lines into a test area. Each line contains a font name followed by the string 'Hello World' tagged with a uniquely assigned 2-character tag. The font named in the line is assigned to the tag, causing the following 'Hello World' to appear in this font. A textline containing text in a larger font size is placed at the top of the window containing the list of fonts, and an action changing the font in this textline and printing its font metrics, together with the pixel size of the string 'Hello World' in the given font, is bound to click on the 'Hello World' string in each line. By clicking on these lines you can examine the sample text in each of the fonts listed, and get some sense of how string width varies as the font used for a string is changed. P>Note (program line 8) that the names of fonts with multi-word names should be given in curly brackets, and that fonts (like 'Wingdings') available in the operating system but not directly in Tk can also be named and will be handled properly. A default font will be substituted for fonts that are not available from either source.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,txt; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
txt := Tk("entry","15"); txt("side") := "top"; \txt(OM) := "Hello World";
-- create a textline
txt("font") := "{{Times New Roman} 36 bold}"; -- initialize its font
-- set up list of fonts and abbreviations
abbrevs_fonts := "am,{Andale Mono},ac,{Apple Chancery},ar,Arial,ab,"
+ "{Arial Black},ca,Capitals,cl,Charcoal,ch,Chicago,cs,{Comic Sans MS}," +
"co,Courier,cn,{Courier New},fs,FrenchScript,gt,Gadget,ge,Geneva,ga,Georgia,"
+ "he,Helvetica,ht,{Hoefler Text},ho,{Hoefler Text Ornaments}," +
"im,Impact,kp,Kidprint,ly,{Lydian MT},mo,Monaco,ms,{Monotype Sorts},"
+ "me,{MT Extra},ny,{New York},pa,Palatino,sa,Sand,sk,Skia,sw,Swing,sy,Symbol," +
"te,Techno,tt,Textile,ti,Times,tnr,{Times New Roman},tb,{Trebuchet MS},"
+ "ve,Verdana,we,Webdings,wi,Wingdings";
-- convert list of fonts and abbreviations to list of pairs,
-- and build tagged string
abbrevs_fonts := breakup(abbrevs_fonts,",");
af_pairs := [[ab,abbrevs_fonts(j + 1)]: ab = abbrevs_fonts(j) | odd(j)];
abbrevs_fonts := join(["{" + font + "} <`"
+ ab + "`>Hello World<``" + ab + "`>":
[ab,font] in af_pairs],"\n");
ta := Tk("text","60,45"); ta("side") := "top"; ta(OM) := abbrevs_fonts;
-- set up a text area, inserting the tagged texts
for [ab,fnt] in af_pairs loop
ta(ab,"font") := fnt; ta{ab,OM} := setfont(fnt);
end loop;
-- bind font change and fonted string measurement action to each tag
Tk.mainloop(); -- enter the Tk main loop
procedure setfont(fnt); -- returns hotword response action as a closure
return lambda(); txt("font") := bo36 := "{" + fnt + " 36 bold}";
print(Tk.font_metrics(bo36)," ",
Tk.measure_fonted("Hello World",bo36));
-- font change and fonted string measurement
end lambda;
end setfont;
end test;
Cursors. As shown by the following program, Tk provides many built-in cursors which can be displayed by setting the cursor attribute of a window or widget to the cursor name. The program reads the names of all available cursors from the comma-delimited 'cursors_stg' constant provided by the tkw class, and converts this to tagged text which is displayed, two items per line, in a text area surrounded by two non-text areas. Each tag introduced into the text is bound to a procedure which sets the cursor for the window to that named in the text, so by clicking on any cursor name one can switch to the indicated cursor. Note that this change only becomes visible when the mouse moves into one of the two non-text areas, since within the text area the standard insertion cursor is preemptively displayed.
Additional cursors can be read from files; to see how this is done,consult one of the Tk reference works listed later in this chapter.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Try the Tk Cursors"; -- create the Tk interpreter
frl := Tk("frame","50,600"); frl("side") := "left";
frl("background") := "#eeeeee"; -- create a left-hand frame
frr := Tk("frame","50,600"); frr("side") := "right";
frr("background") := "#eeeeee"; -- create a right-hand frame
ncl := #(cursors_list := breakup(cursors_stg,","));
-- convert the list of all builtin Tk cursors to a tuple
-- arrange them by pairs, and tag each cursor name with itself as tag
cursors_by_2s := "" +/ [self_tag(cnam) +
if j = ncl then "" elseif odd(j) then (25 - #cnam) * " "
else "\n" end if: cnam = cursors_list(j)];
txt := Tk("text","50,40"); txt("side") := "left"; txt(OM) := cursors_by_2s;
-- create a text area, and insert the taggesd string
txt("font,background") := "{Monaco 12 bold},green";
for c in cursors_list loop txt{c,OM} := set_cursor(c); end loop;
-- bind each tagged string to a cursor-setting routine
Tk.mainloop(); -- enter the Tk main loop
procedure self_tag(stg); -- convert 'stg' a string carrying itself as tag
return "<`" + stg + "`>"+ stg + "<``" + stg + "`>";
end self_tag;
procedure set_cursor(cursor); -- set the cursor to that named by 'cursor'
return lambda(); Tk("cursor") := cursor; end lambda;
end set_cursor;
end test;
Widgets of all kinds can be sensitive to many events, as can the 'tags' associated with text ranges and with items in canvases, can be used to trigger SETL callbacks. Callbacks triggered by widget and tag sensitivity are crucial to creation of point-click-drag interactivity, including hotwording of text and interactive use of canvases. Widgets and tags in the interactive interface can be sensitive to the wide variety of events seen in the following list:
ButtonPress - mouse button pressed (equivalent to Button) ButtonRelease - mouse button released KeyPress - keyboard key pressed KeyRelease - keyboard key released Motion - mouse moved Enter - mouse enters widget Leave - mouse leaves widget Double - mouse doubleclick Triple - mouse triple FocusIn - widget gains keyboard focus FocusOut - widget loses keyboard focus Map - window is opened Unmap - window is iconified or withdrawn from visibility Circulate - window stacking order changes Visibility - window visibility has changed Destroy - window is destroyed Expose - window has been exposed Configure - size, position, border, or stacking order has changed - widget has moved because of change in size of its - parent window Colormap - color map has changed Activate - the SETL application has been activated Deactivate - the SETL application has been deactivated Reparent - window has been reparented Property - a window property has been changed or removed Cut - system dependent keypress event designating 'Cut' Copy - system dependent keypress event designating 'Copy' Paste - system dependent keypress event designating 'Paste'Each of these events can generate a callback to SETL when it occurs. Events have various possible attributes, which can be transmitted as parameters to their associated callback procedures. As seen in the following table, every possible event attribute has an associated single-character code.
When we 'bind' events to widgets, canvas tags, text tags, or menu items, i.e. assign event sensitivities to these widgets, tags, or items, the names of event types are used as event descriptors, i.e. we use 'Buttonpress', 'Buttonrelease','Motion', 'FocusIn', etc. Button- and keypress-related descriptors can further be qualified by attaching 'modifier' prefixes and 'detail' suffixes, separated from the main descriptor keyword by dashes. 'Detail' suffixes specify a key symbol for keypress events and button numbers for button events. Thus we can have Keypress-a, Keyrelease-Z, Buttonpress-1 (mousedown with first button), etc. The system allows for up to 5 mouse buttons. 'Modifier' prefixes define keys or buttons that must have been pressed for a modified event to occur, and are also used in a few other special situations. The available modifier prefixes are
# event serial number all events a 'above' field for event configure event b button number buttonpress, buttonrelease c event count field expose, map d event detail field enter, leave, focusin, focusout f focus value established by event enter, leave h height field configure, expose k keycode keypress, keyrelease m mode enter, leave, focusin, focusout o override redirect map, reparent, configure p place placeontop, placeonbottom, circulate s state buttonpress, buttonrelease, enter, leave,
keypress, keyrelease, motiont time all events v value mask configure event w width configure, expose x horizontal position, widget relative all mouse events y vertical position, widget relative all mouse events A printing character keypress, keyrelease B border width configure event E sendevent field all events K key symbol keypress, keyrelease N key symbol in decimal keypress, keyrelease R root window id all events S subwindow id all events T type field all events W 'pathname' of widget receiving the event all events
see 'obj_from_tkname', belowX horizontal position (absolute) buttonpress, buttonrelease,
keypress, keyrelease, motionY vertical position (absolute) buttonpress, buttonrelease,
keypress, keyrelease, motion
Control - control key must be down Shift - shift key must be down Lock - shift lock must be down Command - command (Apple) key must be down (Macintosh only) Mod1 thru Meta 5 - specified one of 5 special keys must be down - (mapped in system-dependent fashion) B1 thru B5 - designated button must be down Double - event must occur twice rapidly, (e.g 'doubleclick') Triple - event must occur three times rapidly, (e.g 'tripleclick') Meta - Key Modj regarded as 'system meta-key' must be down Alt - Key Modj regarded as 'system alt-key' must be downUse of such prefixes (and of 'detail' suffixes if desired) gives us modified event descriptors like B1-motion (drag with first mouse button down), Command-a, Double-Buttonrelease-1 (doubleclick with button 1), etc. Modifier prefixes, but not detail suffixes, can be repeated, in lists separated by the '-' character. This gives us such still more closely specified events as Command-Shift-B1-motion (drag with first mouse button and two additional keys down), Double-B1-Buttonrelease-1 (doubleclick with button 1 while holding first mouse button down), etc.
Event handlers for the various kinds of mouse, keyboard, and other events to which Tk widgets and canvas items are sensitive are set up by writing nominal assignments having one of the two the syntactic forms
widget{"event_descriptor:event_fields_signature"} := SETL_procedure;
text_widget{"tag_name","event_descriptor:event_fields_signature"}
:= SETL_procedure;
canvas{"tag_name","event_descriptor:event_fields_signature"} := SETL_procedure;
(Note the use of curly brackets, characteristic for event bindings in the SETL interface). The first form is used to assign callback procedures to widget-related events, and the second is used to assign callback procedures to tags in text fields and canvases. Examples are:
top_frame{"B1-Move:xy"} := my_drag_procedure;
text_widget{"tag_name","B1-ButtonRelease"} := my_hypertext_click_procedure;
As seen in these examples, the single-character codes for the event parameters to be transmitted to an event's handler are assembled into a string. When an event of the designated type subsequently occurs, the corresponding parameter values are read from the 'event record' always associated with the event, and collected into a single parameter tuple which is transmitted to the callback procedure, which must of course have exactly one parameter (this tuple.)
The colon seen in this event-binding syntax is only required if a trailing event_fields_signature follows. If the event_fields_signature is empty, it can be omitted.
To bind a procedure to the 'principal' event of a canvas or text tag (this is always 'ButtonRelease-1'), write
text_widget{"tag_name",OM} := SETL_proc; etc. If several overlapping event bindings have set up for a widget, item, or tag, the most specific will be used. Suppose, for example, that the bindings
top_frame{"B1-Move:xy"} := my_drag_procedure1;
text_widget{"Shift-B1-Move:xy"} := my_drag_procedure2;
Then my_drag_procedure1 will be called during drags unless the Shift key is down; but if the Shift key is down, my_drag_procedure2 will be called.
The event-binding system allows a sequence of (qualified and detailed) events rather than a single event to trigger a callback. To achieve this effect, simply replace the event_descriptor in the binding operations shown above by a semicolon- or comma-separated sequence of such descriptors. An example is:
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,textline; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
textline := Tk("entry","25"); textline("side") := "top";
-- create an input textline
textline(OM) := "Click twice, then type 'a'";
-- insert text
textline("foreground,font") := "red,{Times 36}"; -- set the text attributes
textline{"ButtonRelease-1,ButtonRelease-1,KeyPress-a"} := do_it;
-- bind a text color change action to an event sequence
Tk.mainloop(); -- enter the Tk main loop
procedure do_it(); textline("foreground") := "blue"; end do_it;
end test;
If the instruction which appears in the input box in this example is followed, the text will turn blue, but this will not happen if one simply types an 'a' without clicking twice.
The code which follows can be used to explore the semantics of the event sensitivities and parameters described in the preceding paragraphs. It sets up one button and the five following event sensitivities
i,ii. the button is click sensitive, and sensitive to mouse-exit eventsWhen any of these events occurs, all event parameters are captured and passed to the 'print_event' procedure, which prints them, along with brief explanatory captions. By triggering them and examining the results produced, one can see which parameters give useful information for each type of event. The program seen creates a button within a frame and then binds two different kinds of events, namely a button clicking event and the event which occurs when the cursor leaves the area of the button. Both of these events are bound to the button. Three other types of events are bound to the window containing the button. These areiii. the master window is sensitive to all keypress events
iv, v. the master window is sensitive to reconfiguration and uncover events.
For all the events considered the binding indicates that every possible event parameter is to be transmitted to the callback routine. This routine simply unpacks the parameter transmitted to it (which is a single tuple) and prints all the parameter values. It therefore gives a way of inspecting all the parameters of the events shown.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
-- create and place a button
but := Tk("button",
"Click, exit, reconfigure window, or expose window to generate event");
but("side") := "top";
-- bind a 'print action' call to each of various events, specifying
-- that all possible event parameters are to be captured
but{"ButtonRelease-1:#abcdefhkmopstvwxyABEKNRSTWXY"}
:= make_print_event("ButtonRelease");
but{"Leave:#abcdefhkmopstvwxyABEKNRSTWXY"}
:= make_print_event("Leave");
Tk{"KeyPress:#abcdefhkmopstvwxyABEKNRSTWXY"}
:= make_print_event("Keypress");
Tk{"Configure:#abcdefhkmopstvwxyABEKNRSTWXY"}
:= make_print_event("Configure");
Tk{"Expose:#abcdefhkmopstvwxyABEKNRSTWXY"} := make_print_event("Expose");
Tk.mainloop(); -- enter the Tk main loop
procedure make_print_event(event_name);
-- bind event_name into inner procedure
return print_event; -- bind 'event_name' into the event-response routine
procedure print_event(params); -- print event_name and data
[num,a,b,c,d,e,f,h,k,m,o,p,s,t,v,w,x,y,AA,BB,EE,KK,NN,RR,SS,TT,WW,XX,YY]
:= params;
-- unpack all the event parameters
event_type := event_name;
-- print all the unpacked event parameters
print("\n\nEvent data for " + event_name);
print("serial number: ",num);
print("'above' field: ",a);
print("button number: ",b);
print("event count: ",c);
print("event detail: ",d);
print("focus value: ",f);
print("height field: ",h);
print("keycode: ",k);
print("mode: ",m);
print("override redirect: ",o);
print("place: ",p);
print("state: ",s);
print("time in millseconds: ",t);
print("value mask: ",v);
print("width: ",w);
print("horizontal position in widget: ",x);
print("vertical position in widget: ",y);
print("printing character: ",aa);
print("border width: ",bb);
print("sendevent field: ",ee);
print("key symbol: ",kk);
print("key symbol in decimal: ",nn);
print("root window id: ",rr);
print("subwindow id: ",ss);
print("type field: ",tt);
print("widget receiving the event: ",ww);
print("horizontal position in window: ",xx);
print("vertical position in window: ",yy);
end print_event;
end make_print_event;
end test;
w{"event_descriptor:event_fields_signature"} := event_parameter_vals;
where 'event_descriptor' and 'event_fields_signature' have the form detailed in the on-line help item 'binding events' and where 'event_parameter_vals' is either a comma-separated string or a tuple of corresponding event parameter values. An example is
top_frame{"B1-Move:xy"} := "25,25";
top_frame{"B1-Move"} := "";
As seen, the colon used in this event-binding syntax is only required if a non-empty event_fields_signature follows it.
The following small program illustrates the generation of events under program control. It creates a first button which beeps three times when clicked, and a second button which 'clicks' the first button twice when the second button is clicked.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,but; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","click"); but("side") := "top"; -- create a button
but{OM} := lambda(); for j in [1..3] loop Tk.beeper(); end loop; end lambda;
-- make it beep 3 times when clicked
but2 := Tk("button","klick"); but2("side") := "top"; -- create a button
but2{OM} := lambda(); -- make it 'click' the first button twice when clicked
but{"ButtonRelease-1"} := "";
-- generate a click event and send it to the first button
but{"ButtonRelease-1"} := "";
-- generate a click event and send it to the first button
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
Here is a second example, which shows the generation of an event with parameters. We set up two buttons. The first simply prints whatever parameter tuple is passed to it. The second button generates a click event with several numerical parameter and sends it to the first button. Note that the parameter values to be passed to a generated event can be set up either as a semicolon- or comma-delimited string, or as a tuple. Parameters are described by the same 1-letter codes used for event bindings.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,but,click_count := 0; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","click"); but("side") := "top"; -- create a button
but{"ButtonRelease-1:#xy"} := lambda(param); print(param); end lambda;
but2 := Tk("button","klick"); but2("side") := "top"; -- create a button
but2{OM} := lambda();
-- make it send a 'click' to the first button when clicked
but{"ButtonRelease-1:#xy"} := str(click_count +:= 1) + ",20,20";
-- generate a click event and send it to the first button
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
In addition to events of the kind described in the preceding pages, which we shall call 'physical' events in what follows, SETL's interactive interface supports a supplementary kind of event called 'virtual events'. A 'virtual event' is simply a utility synonym for any one of a list of 'physical' events. One use for this notion is to enhance the platform independence of code. Suppose,for example, that we want to write a piece of interactive software that can be driven by a mouse, but that might also be driven by a joystick if one is available, or by patterned key strokes or pen-taps on a pocket computer having neither mouse nor joystick. To accomplish this, we can define a virtual event called 'Meaningful_motion', write the bulk of our application code as a set of responses to such events, and then define 'Meaningful_motion' for each platform and environment in whatever way is appropriate.
To define the list of physical events which map to a given virtual event, we write
Tk{"event",virtual_event_name} := physical_event_list;
where, as seen below, 'physical_event_list' is a comma- or semicolon-separated list of physical event names. If 'physical_event_list' is OM or is an empty string, the virtual event named by 'virtual_event_name' is simply deleted. The expression
Tk{"event",virtual_event_name}
returns this list, or, if its second parameter is OM, returns the list of all currently defined virtual events. To bind a response routine (addressed, as a physical event would be, to a particular widget or tag, to a virtual
program test; -- SETL interactive interface example 1
use tkw; -- use the standard graphical interface package
var men;
Tk := tkw(); Tk(OM) := "Popup menus"; -- create the Tk interpreter
print(Tk{"event",OM});
-- print the list of all virtual events currently recognized
-- (these are the 'built-in' virtual events)
print(Tk{"event","Copy"});
-- find the physical meaning(s) of the 'Copy' virtual event
Tk{"event","Catastrophe"} := "Shift-ButtonRelease-1,Shift-ButtonPress-1";
-- define a new virtual event, with the two indicated meanings
print(Tk{"event",OM});
-- print the revised list of all virtual events
print(Tk{"event","Catastrophe"});
-- find the physical meaning(s) of the 'Catastrophe' virtual event
Tk{"<Catastrophe>:xy"} := lambda(params);
print(params); end lambda;
-- set up a binding for the 'Catastrophe' virtual event
Tk.mainloop(); -- enter the main Tk loop
end test;
The output produced is
["Paste", "Clear", "PasteSelection", "Cut", "Copy"] ["Control-Key-c", "Key-F3"] ["Catastrophe", "Paste", "Clear", "PasteSelection", "Cut", "Copy"] ["Shift-ButtonRelease-1", "Shift-Button-1"]
Absolute image objects are generally created by commands of the form
img := tkw_name("image",file_name);
where 'tkw_name' is the name of the master widget object.
Here is an example showing the use of an image file to create an absolute image, followed by the display of this image as a canvas image.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","400,200"); ca("side") := "top";
-- create and place a canvas in the window
abs_img := Tk("image","test_files/orchid_trans.gif"); -- read an absolute image
img := ca("image",abs_img);
-- use the absolute image in a first canvas image
img("coords") := "30,30"; img("anchor") := "nw";
Tk.mainloop(); -- enter the Tk main loop
end test;
An alternative is to give the image data directly, as a base-64 string. This is done by using an empty file name, and then making an attribute assignment like
img("data") := "base64_string_of_image_data";
Images can be given a height and width different from that recorded in the file from which they are read, in which case they will be cropped if necessary. (The default height/width value 0 avoids this, by letting images assume the full size given in their source data). As the following variant of the preceding example shows, Tk can read images in the so-called 'GIF89a' format. This is one of the standard medium-quality formats used for images. It represents images with at most 1 byte of data per pixel, which are then expanded by using this data byte as an index into an RGB color table available within the image file. Transparency is supported by allowing one particular color index to be designated as 'transparent'. Images of this type can be produced with various image tools, including Adobe Photoshop. As seen in our example, which superimposes three copies of such an image on each other and on some simple background shapes, Tk handles GIF89a transparency correctly.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","400,200"); ca("side") := "top";
-- create and place a canvas in the window
ca("background") := "green";
poly := ca("polygon","10,160,50,160,300,10,10,10");
poly("fill,smooth") := "blue,true";
poly := ca("polygon","10,10,50,10,300,150,40,150");
poly("fill,smooth") := "red,true";
abs_img := Tk("image","test_files/orchid_trans.gif"); -- read an absolute image
img := ca("image",abs_img);
-- use the absolute image in a first canvas image
img("coords") := "-30,30"; img("anchor") := "nw";
img := ca("image",abs_img);
-- use the absolute image in a second canvas image
img("coords") := "60,40"; img("anchor") := "nw";
img := ca("image",abs_img);
-- use the absolute image in a third canvas image
img("coords") := "130,50"; img("anchor") := "nw";
Tk.mainloop(); -- enter the Tk main loop
end test;
The alternative photo image format, PPM, handled (and written) by Tk has the file layout shown in the following example. The first line ('P6') identifies the file type; the next gives the image size; the third gives the upper limit of the color data RGB 'image_data' values that follow. The image_data is a sequence of bytes giving RGB values for successive image pixels.
P6 150 150 255 image_data...
The attributes of an absolute image item are:
file - source file containing image data data - alternative to 'file': image data as base 64 string height, width - height and width of image - (these work by cropping, not by scaling, the image) format - data format for file or data string, e.g. GIF, PPM, PGM gamma - decimal value for color-correction exponent. - '1.0' indicates no correction palette - image color paletteSetting the 'file' attribute causes the image to be reread from the designed file.
The following small program illustrates the use of some of these attributes. We create two canvases, into which images derived from two copies of the same image file are placed. The second of these images is given a different appearance by setting its 'gamma-correction' parameter to a high value, and by cropping the image.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","400,200"); ca("side") := "top";
-- create and place a canvas in the window
ca2 := Tk("canvas","400,200"); ca2("side") := "top";
-- create and place a second canvas
abs_img := Tk("image","test_files/orchid_trans.gif"); -- read an absolute image
abs_img2 := Tk("image","test_files/orchid_trans.gif"); -- read a second copy
img := ca("image",abs_img);
-- use the absolute image in a first canvas image
img("coords") := "0,0"; img("anchor") := "nw";
print(abs_img("file,height,width,format,gamma,palette"));
img2 := ca2("image",abs_img2);
-- use the second absolute image in a second canvas image
img2("coords") := "0,0"; img2("anchor") := "nw";
abs_img2("height,width,gamma") := "150,300,3.0";
-- crop and set unrealistic gamma
Tk.mainloop(); -- enter the Tk main loop
end test;
Our next example illustrates the use of an image's 'file' attribute. It shows a window containing an image in a canvas and two buttons, the first of which carries an image rather than a caption. An action which changes the image in the canvas (by setting its 'file' attribute) and on the button (by direct assignment of the button's 'image attribute') is bound to the top button. An image crop action is bound to the second button.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,abs_img,abs_img2,abs_img3,but;
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","200,200"); ca("side") := "top";
-- create and place a canvas in the window
abs_img := Tk("image","test_files/orchid_trans.gif");
-- read an absolute image
abs_img2 := Tk("image","test_files/orchid_trans.gif");
-- read a second copy
abs_img3 := Tk("image","test_files/egyptian.gif");
-- read a second image
img := ca("image",abs_img);
-- use the first absolute image in a first canvas image
img("coords") := "0,0"; img("anchor") := "nw";
but := Tk("button",""); but("side") := "top"; -- create a button
but("image") := abs_img3; -- put an image on the button
but{OM} := lambda;
-- bind an image switch action for upper display and button
if str(but("image"))(1) = "e" then
-- interchange images in upper display and on button
abs_img("file") := "test_files/egyptian.gif"; but("image") := abs_img2;
else
-- interchange images in upper display and on button
abs_img("file") := "test_files/orchid_trans.gif"; but("image") := abs_img3;
end if;
end lambda;
but2 := Tk("button","Crop Image"); but2("side") := "top";
-- create a button
but2{OM} := lambda; abs_img("height,width") := "100,40"; end lambda;
-- bind an image crop action
Tk.mainloop(); -- enter the Tk main loop
end test;
Absolute images can be created as snapshots of the current state of a canvas, and by conversion of by conversion of an image object of the tuple manipulated by the image-analysis object class supplied with SETL (see Chapter YYY, Section aaa.) The operation
canvas.image_of([l,t,r,b]);
captures an absolute image of the canvas sub-rectangle defined by the coordinates [l,t,r,b]. The following small program,which sets up an array of small blue circles in a canvas of which it then takes a snapshot, illustrates this:
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ca; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","200,200"); ca("side") := "top"; -- create a canvas
for j in [1..18], k in [1..18] loop
-- put an array of ovals into the canvas
ov := ca("oval",str(10 * j) + "," + str(10 * k)
+ "," + str(10 * j + 10) + "," + str(10 * k + 10));
ov("fill") := "red";
end loop;
but := Tk("button","click"); but("side") := "top"; -- create a button
-- when clicked, this will take a snapshot of a canvas rectangle
but{OM} := take_snapshot;
-- bind button-clicking to the snapshot action
Tk.mainloop(); -- enter the Tk main loop
procedure take_snapshot(); -- snapshot procedure
image_of_canvas := ca.image_of([10,10,190,190]);
-- capture the contents of the canvas, as an 'absolute' image
ntop := Tk("toplevel","300,300");
-- create a toplevel, and put a canvas into it
ntopca := ntop("canvas","200,200"); ntopca("side") := "top";
imaje := ntopca("image",image_of_canvas);
-- create and place a canvas image
imaje("coords,anchor") := "0,0;nw";
end take_snapshot;
end test;
Using objects of 'image' class ('image-analysis ' images) in SETL's graphical interface. The same operation
parent("image",file_or_image);
which forms an absolute image from an image file name will form an absolute image (of graphical interface type) from an image object of the type used in the 'image' object class supplied with SETL. (These objects are intended for use in elaborate image analysis operations. See Chapter 11 for details concerning this object class, and the extensive native package of image-manipulation routines on which it is based). That is, the 'file_or_image' parameter can either be the name of the file from which the image should be read, or can be an image object of 'image analysis' type. The following example illustrates the use of these 'image' objects. The program seen reads in an image converting it to an 'image' object of the kind described in Chapter 11. This 'image' object is then converted to a Tk 'absolute' image which finally is converted to a canvas image and displayed.
program test; -- SETL interactive interface example 1
use tkw,image;
-- use both the graphic interface and the image-analysis class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
folder_containing_SETL := "HardDisk:DavidPPC:SETL2:FromGiuseppeLATEST:";
-- reference the folder containing SETL
img_analysis_image := image(folder_containing_SETL + "1.jpeg");
-- use a primitive of the GRLIB_PAK 'image' class
-- to read an image file and create an
-- image-analysis class image object from it.
abs_img := Tk("image",img_analysis_image);
-- this is the operation explained above
-- convert this image to a Tk absolute image
canv := Tk("canvas","200,200"); canv("side") := "top";
-- finally, create a canvas, and display abs_img in it
canv_img := canv("image",abs_img); canv_img("coords,anchor") := "0,0;nw";
-- convert the absolute image to a canvas image, to display it
Tk.mainloop();
end test;
Converting canvases into GRLIB_PAK image objects. 'Absolute images' of the SETL graphical interface can be converted into 'image' objects (image-analysis objects, see Chapter 11) by putting them into a canvas 'my_canv' and then applying the operation my_canv("image") to it. This returns an image of the whole canvas, as an object of the image-analysis class. The sophisticated operations of the image-analysis class, detailed in Chapter YYY, Section aaa, can then be used to produce new images, which can be converted back to absolute images and displayed in the way just explained. The following example illustrates this process. In it, two successive images are built in canvases of the same size, one of an array of small red circles, the other a blue text caption. These images are than captured (as 'image-analysis' images) and blended by averaging them with weights of 2 and 3 respectively, and then displayed. The blending step uses some of the operations, detailed in Chapter YYY, Section aaa, which apply to 'image-analysis' images. Specifically, these are multi-plane (e.g. 3-plane RGB) images which can be carried either in a floating-point or fixed-point format. The operations to_float() and to_int()() convert from fixed to floating format and vice-versa. img1 + img2 forms the plane-by-plane, pixel-by-pixel, sum of two images, and operations like [c,c,c] * img can be used to multiply or divide each of the pixels of a 3-plane image by the numerical constant c.
All of this is shown in the following program which takes a snapshot of two separate canvases, converts the resulting images to objects of the 'image' class described in Chapter 11 and uses one of the standard operations on such objects to blend them, which would be impossible in Tk. The blended result is then converted back to a Tk absolute image and then displayed.
program test; -- SETL interactive interface example 1
use tkw,image; -- use the main widget class and the image-object class
var Tk,ca,ca2; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Canvas Snapshots"; -- create the Tk interpreter
but := Tk("button","click"); but("side") := "top"; -- create a button
but{OM} := take_snapshot;
-- this will transform the canvas contents
-- into an 'image' object when clicked
ca := Tk("canvas","200,200"); ca("side") := "left"; -- create two canvases
ca2 := Tk("canvas","200,200"); ca2("side") := "left";
for j in [1..18], k in [1..18] loop -- set up an array of small red circles
ov := ca("oval",str(10 * j) + "," + str(10 * k)
+ "," + str(10 * j + 10) + "," + str(10 * k + 10));
ov("fill") := "red";
end loop;
tex := ca2("text","YES"); -- set up some blue canvas text
tex("coords,anchor,font") := "10,60;nw;{Times 96}";
tex("fill") := "blue";
Tk.mainloop(); -- enter the Tk main loop
procedure take_snapshot();
-- capture and combine the contents of the canvases, as 'image' objects
image_of_canvas := ca("image").to_float();
-- convert to floating format to prepare for averaging
image_of_canvas2 := ca2("image").to_float();
blended_image := -- blend these two images by averaging them
([2.0,2.0,2.0] * image_of_canvas + image_of_canvas2) / [3.0,3.0,3.0];
write_captioned_image(blended_image.to_int()(),"Blended canvas contents");
-- display the blend
end take_snapshot;
procedure write_captioned_image(img_analysis_image,cap);
-- write an 'image-class' image to a Tk window
[height,width,-,-] := #img_analysis_image;
toplev := Tk("toplevel","10,10"); toplev(OM) := cap;
-- enter the window title
newca := toplev("canvas",str(height) + "," + str(width));
newca("side") := "top"; -- create an auxiliary canvas
-- use the 'image-class' image to create a Tk absolute image
abs_image := Tk("image",img_analysis_image);
canv_image := newca("image",abs_image);
-- create as a canvas image and position it
canv_image("coords,anchor") := "0,0;nw";
end write_captioned_image;
end test;
Though the operations it provides are not as powerful as those provided by the GRLIB_PAK image library described in the next chapter, Tk does furnish a few useful operations on absolute images. These are
abs_img.write_im(file_name,options)
target_abs_img.copy_im(target_abs_img,options)
abs_img.stuff_im(color_data_list,target_rect)
and a pixel-extraction operation having the form
abs_img(i,j)
A simple rectangle extraction and insertion operations are also available in the syntactic form
abs_img(ul..lr) and abs_img(ul..lr) := abs_img2;
In these last operations ul and lr, which respectively define the upper left and lower right corners of the desired rectangle, should both be strings of the form x,y.
In the other operations listed above, 'options' should be a semicolon delimited string consisting of alternating option names and option values, which can however be empty or OM. Each of the image operations shown above has its specific list of allowed options. For the 'write_im' operation these are 'format' and 'from'. If used, 'format' can only be 'PPM/PGM', (signifying Portable Pixmap/Graymap format, a flat form of image data), or 'GIF' (explained below). Images written with no output format specified will be written in PPM format.
If used, the 'write_im' 'from' format value must be a comma-delimited list of integers of the form 'x,y,u,v' defining the sub-rectangle of the source image to be written to the file named. 'u,v' can be omitted, in which case it defaults to the lower right-hand corner of the source image.
The 'copy_im' operation has the options 'from', 'to', 'subsample', 'zoom', and 'shrink'. The 'from' option has the same form and meaning as for the 'write_im'. The 'to' option has the same form, but designates the rectangle in the target_abs_img into which the copied data is to be put. If the 'to' value gives both the upper left and lower right coordinates of the target rectangle, then the source rectangle will be tiled as many times as necessary to fill the target rectangle. The 'subsample' option value should have the form x,y, where x and y are integers. If given, it indicates that only every x'th pixel in the horizontal and y'th in the vertical direction is to be copied from the source rectangle. y can be omitted, in which case it defaults to x. The 'zoom' option value as this same form, but here x and y indicate the number of times each pixel in the source image is to be repeated in the target image(in the horizontal and vertical directions respectively). The 'shrink' option has no parameter. If used, it indicates that the source image is to be reduced in size, if necessary, so as not to overstep the boundaries of the target image.
The 'stuff_im' operation has no options. Its color_data_list parameter must be a semicolon- and comma-delimited list of color values. This gif color data for a rectangle. All the semicolon-delimited sections must have the same number of comma-delimited values, which can either be color names like 'red' or hexadecimal color codes like "#ff0000". The target_rect parameter of 'stuff_im' has the same form and meaning as the 'to' option value of 'copy_im'.
The following program illustrates the operations, and some of the options, described in the last few paragraphs. We create three canvases, with differently colored backgrounds, in a window. An image derived from an absolute image is place in te first canvas. Then a sub-rectangle of the absolute image is written out using 'write_im', and immediately read back into a second absolute image which is re-dithered and displayed in the second canvas. A second sub-rectangle of the first absolute image is extracted directly using the 'image(ul..lr)' expression and displayed in the third canvas. A pixel value is read from this extracted sub-image and printed. The 'copy_im' operation is then used to copy a piece of the original absolute image into an area of the extracted sub-image of different size, creating a 'tiling' effect, and a bit of color data written to this same image using 'stuff_im'. Note that these operations change the appearance of the copy of the extracted sub-image displayed in the third canvas, showing that canvas images retain their links to the absolute image from which they are formed, and will display differently if the absolute image is changed. Finally we write the extracted sub-image back to a subregion of the original absolute image using the 'image(ul..lr) := image2;' operation. Note that, for the reason just explained, this changes the appearance of the image seen the first canvas.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","400,150"); ca("side") := "top";
ca("background") := "yellow";
-- create and place a first canvas in the window
ca2 := Tk("canvas","400,150"); ca2("side") := "top";
ca2("background") := "cyan";
-- create and place a second canvas in the window
ca3 := Tk("canvas","400,150"); ca3("side") := "top";
ca3("background") := "green";
-- create and place a third canvas in the window
abs_img := Tk("image","test_files/orchid_trans.gif");
-- read an absolute image
img := ca("image",abs_img);
-- use the absolute image in a first canvas image
img("coords") := "0,0"; img("anchor") := "nw";
abs_img.write_im("orch_copy.PPM","from;50,50,150,150");
-- write subrectangle of absolute image to file
reread_img := Tk("image","orch_copy.PPM");
-- reread the subimage written
img := ca2("image",reread_img);
-- display the reread image
img("coords") := "0,0"; img("anchor") := "nw";
reread_img.dither(); -- dither the reread image
abs_piece := abs_img("10,10".."130,130");
-- extract a subrectangle of the absolute image
print(abs_piece(90,90));
-- print a pixel value
img := ca3("image",abs_piece);
-- display the extracted subrectangle
img("coords") := "0,0"; img("anchor") := "nw";
abs_piece.copy_im(abs_img,"from;50,50,80,80;subsample;2,2;to;50,50,110,110");
-- copy an image portion to the subrectangle image
print(abs_piece(90,90));
-- print the changed pixel value
abs_piece.stuff_im("white,red,white;red,white,red;white,red,white",
"90,90,107,107");
-- write color data to the subrectangle image
print(abs_piece(90,90));
abs_img("25,25".."145,145") := abs_piece;
-- write a subrectangle into the original the absolute image
Tk.mainloop(); -- enter the Tk main loop
end test;
rast.get_img(gr_img,u,v)
which copies the part of the image in the rastport 'rast' that gr_img would overlay if placed in position p to gr_img; and
rast.put_img(gr_img,u,v);
which moves a copy of gr_img to position u, v in rastport. Rastport operations are executed in-place, and efficiently.
The available variants of these basic operations, which combine images gr_img of GRLIB_PAK type with the contents of rastport, are shown in the following table.
| The operations analogous to rast.put_img are | |
| rast.put_add(gr_img,x,y); | inserts the sum of the rastport data and gr_img into rastport |
| rast.put_dif(gr_img,x,y); | inserts difference of the rastport data and gr_img into rastport |
| rast.put_mul(gr_img,x,y); | inserts product the rastport data and gr_img into rastport |
| rast.put_div(gr_img,x,y); | inserts quotient of the rastport data and gr_img into rastport |
| rast.put_min(gr_img,x,y); | inserts the min of the rastport data and gr_img into rastport |
| rast.put_max(gr_img,x,y); | inserts the max of the rastport data and gr_img into rastport |
| rast.put_blend(gr_img,x,y,c1,c2); ( | blends gr_img with underlying rastport data using coefficients c1 and c2, and stuffs the result into rastport |
| The operations analogous to rast.get_img are | |
| rast.get_add(gr_img,x,y); | returns gr_img copy holding sum of rastport data and gr_img |
| rast.get_dif(gr_img,x,y); | returns gr_img copy holding difference of rastport data and gr_img |
| rast.get_mul(gr_img,x,y); | returns gr_img copy holding product of rastport data and gr_img |
| rast.get_div(gr_img,x,y); | returns gr_img copy holding quotient of rastport data and gr_img |
| rast.get_min(gr_img,x,y); | returns gr_img copy holding min of rastport data and gr_img |
| rast.get_max(gr_img,x,y); | returns gr_img copy holding max of rastport data and gr_img |
| rast.get_blend(gr_img,x,y,c1,c2); | blends gr_img with underlying rastport data using coefficients c1 and c2, and returns the result in a copy of gr_img |
A set of rotated versions of the 'put' operations are also provided. These act like put_img, put_add, but rotate gr_img by 90 degrees before combining it with the rastport data and stuffing the result into the rastport. They have forms like rast.put_imgr(gr_img,u,v), and are named put_imgr, put_addr, put_difr, put_mulr, put_divr, put_minr, put_maxr, and put_blendr. The put_blendr operation, like put_blend, has the form
rast.put_blendr(gr_img,x,y,c1,c2).
The following code shows the use of a rastport. Its sets up a rastport surrounded by several checkboxes and buttons. The photographic image is read in and an elliptical image generated (the image operations used here will be described in more detail in the next chapter). The first of the checkboxes selects between rotated and non-rotated writes. The second checkbox chooses between one of two variants of the ellipse image, as described in the next chapter. When clicked the buttons write the elliptical image onto the photographic image with which the rastport is initialized. Writing can be done in any of the modes listed in the preceding table. That is, the ellipse can be written as an opaque image or can be combined with the underlying image by taking minimum pixel values, maximum pixel values, blending pixel values, etc. You can experiment with these options to get a sense of the operations they trigger.
program test; -- Rastport test 1
use tkw,string_utility_pak,image; -- use the main widget class
var Tk,rast,photo,ellipse,orig_ellipse,dense_ellipse,ckbut,flag := false;
-- globalize for use in procedures below
Tk := tkw(); Tk(OM) := "Rastport test 1"; -- create the Tk interpreter
fr0 := Tk("frame","10,10"); fr0("side") := "top";
-- create a frame for the following checkboxes
ckbut := fr0("checkbutton","Rotate"); ckbut("side") := "left";
ckbut("var") := "checked";
-- create a checkbutton
ckbut{OM} := lambda(); -- use it to set a flag
print(flag := Tk.getvar("checked") = "1");
rast.put_img(photo,0,0); -- re-initialize the rastport contents
if flag then
rast.put_imgr(ellipse,0,0); else rast.put_img(ellipse,0,0);
end if;
end lambda;
ckbut := fr0("checkbutton","Dense"); ckbut("side") := "left";
ckbut("var") := "dense"; -- create a checkbutton
ckbut{OM} := lambda();
-- use it to chose an image variant
ellipse := if Tk.getvar("dense") = "1" then dense_ellipse
else orig_ellipse end if;
rast.put_img(photo,0,0);
-- re-initialize the rastport contents
if flag then
rast.put_imgr(ellipse,0,0);
else
rast.put_img(ellipse,0,0);
end if;
end lambda;
fr := Tk("frame","10,10"); fr("side") := "top";
-- create a frame for the following rastport
rast := fr("rastport","300,200"); rast("side") := "top";
-- create a rastport
photo := image("1.jpeg"); -- read in a photographic image
ellipse := orig_ellipse := image(["oval",300,200,2,40,[255,255,0]]);
-- yellow ellipse confined to yellow region
dense_ellipse := ellipse.to_dense();
-- yellow ellipse, black outside yellow region
rast.put_img(photo,0,0); rast.put_img(ellipse,0,0);
fr1 := Tk("frame","10,10"); fr1("side") := "top";
-- create a frame for the buttons
but := fr1("button","Copy"); but("side") := "left";
-- create a button; bind 'put_img' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_imgr(ellipse,0,0);
else rast.put_img(ellipse,0,0);
end if;
end lambda;
-- bind 'put_img' action to button
but := fr1("button","Min"); but("side") := "left";
-- create a button; bind 'put_min' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_minr(ellipse,0,0);
else rast.put_min(ellipse,0,0);
end if;
end lambda;
but := fr1("button","Max"); but("side") := "left";
-- create a button; bind 'put_max' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_maxr(ellipse,0,0);
else rast.put_max(ellipse,0,0);
end if;
end lambda;
but := fr1("button","Blend"); but("side") := "left";
-- create a button; bind 'put_blend' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_blendr(ellipse,0,0,0.5,0.5);
else rast.put_blend(ellipse,0,0,0.5,0.5);
end if;
end lambda;
but := fr1("button","Add"); but("side") := "left";
-- create a button; bind 'put_add' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_addr(ellipse,0,0);
else rast.put_add(ellipse,0,0);
end if;
end lambda;
but := fr1("button","Diff"); but("side") := "left";
-- create a button; bind 'put_dif' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_difr(ellipse,0,0);
else rast.put_dif(ellipse,0,0);
end if;
end lambda;
but := fr1("button","Mult"); but("side") := "left";
-- create a button; bind 'put_mul' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_mulr(ellipse,0,0);
else rast.put_mul(ellipse,0,0);
end if;
end lambda;
but := fr1("button","Divide"); but("side") := "left";
-- create a button; bind 'put_div' action to button-click
but{OM} := lambda(); rast.put_img(photo,0,0);
if flag then rast.put_divr(ellipse,0,0);
else rast.put_div(ellipse,0,0);
end if;
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
Next we show a more typical use of the rastport operations by giving a small skeleton application, a 'photo colorizer' which allows one to draw over a photographic image with a graphical pen of adjustable shape and color, which can draw with a choice of ink effects. Note that without rastports, using only the other facilities of Tk, nothing quite like this would be possible.
Our small application sets up a canvas above a rastport and also makes use of the 'map_slider' or 'multi-slider' widget whose operation is sketched after the code seen. The 'map_slider' can be used to set any one of five brush parameters; its height, width, and RGB intensity values. Four radio buttons are also set up. These allow choice of the mode in which the brush will draw to the underlying photographic image when the mouse, representing the brush position, is dragged over the rastport area. A sample image is loaded into the rastport, and a motion response routine which causes the brush to follow the mouse and to write its color to the underlying image in whatever mode was selected, is bound to motion events taking place over the rastport. The other procedure needed is a simple brush adjustment routine, which reacts to changes in the brush parameters by reading these brush parameters into global variables which the 'painting' (motion response) routine can access.
One additional standard button, bound to an action which simply re-initializes the rastport, is also provided.
program test; -- Paint-window example
use tkw,string_utility_pak,image,map_slider; -- use the main widget class
var Tk,img1,ima,rast,rast2,prior_black_img := OM,
ca,map_slidr,hgt,width,brush,ink,ovim; -- globalize for use below
Tk := tkw(); Tk(OM) := "Photo Colorizer"; -- create the Tk interpreter
brushframe := Tk("frame","160,60"); brushframe("side") := "top";
-- create a frame for setting brush size and color
msg := brushframe("message","Pen Shape: "); msg("place,x,y") := "0,0";
-- put a message into the frame
ca := brushframe("canvas","60,60"); ca("place,x,y") := "70,0";
-- put a canvas into the frame
oval := ca("oval","5,5,55,55"); oval("outline,fill") := "black,black";
-- put an oval 'pen shape' into the canvas
Tk.update(); -- update to ensure that the oval's image is available
ovim := ca("image"); -- capture the oval's image
oval("coords") := OM; -- remove the oval 'pen shape',
-- whose image has now been captured
ovim_new := ovim.scale([10,10]);
-- scale the pen image to its default size
rast2 := brushframe("rastport","60,60");
rast2("place,x,y") := "70,0"; -- over-write the canvas with a rastport
rast2.put_img(image([[235,235,235],[60,60]]),0,0);
-- clear the rastport to light grey by putting a light grey rectangle into it
brush := ovim_new.get_level([0,0,0]); -- restrict oval image to its interior
tk_abs_image := Tk("image",ovim_new);
ima := ca("image",tk_abs_image); ima("coords") := "30,30";
ima("anchor") := "center";
map_slidr := map_slider(Tk,"Hgt@1@25@20;Width@1@25@10;"
+ " R@0@255@200;G@0@255@0;B@0@255@0",makebrush);
-- set up multislider meta-widget, whose value changes
-- trigger brush adjustment procedure
-- set up a frame for the following button and radiobuttons
buts_frame := Tk("frame","100,50"); buts_frame("side") := "top";
-- create 4 radiobuttons, binding each of them to
-- a brush-mode adjustment procedure
radbut1 := buts_frame("radiobutton","Opaque ");
radbut1("side") := "left"; radbut1{OM} := makebrush;
radbut2 := buts_frame("radiobutton","Darkest ");
radbut2("side") := "left"; radbut2{OM} := makebrush;
radbut3 := buts_frame("radiobutton","Lightest ");
radbut3("side") := "left"; radbut3{OM} := makebrush;
radbut4 := buts_frame("radiobutton","Blend ");
radbut4("side") := "left"; radbut4{OM} := makebrush;
but := buts_frame("button","Clear"); but("side") := "left";
-- put a button labeled 'Clear' into it
but{OM} := lambda(); rast.put_img(img1,0,0); end lambda;
-- bind image-re-initialization action to this button
-- set the 'ink' parameter associated with each of these radiobuttons
radbut1("variable,value") := "ink,opaque";
radbut2("variable,value") := "ink,darkest";
radbut3("variable,value") := "ink,lightest";
radbut4("variable,value") := "ink,blend";
-- (Note that the common 'variable' and distinct 'values'
-- puts these radiobuttons into the same 'group')
Tk.setvar("ink","lightest"); -- initialize to "blend" state
parent := Tk("frame","100,50"); parent("side") := "top";
-- create a frame for the following rastport
rast := parent("rastport","320,240"); rast("side") := "top";
-- put a rastport into the frame
rast{OM} := motion_response; -- bind rastport motions to a response routine
img1 := image("1.jpeg"); -- read in a sample image to be colorized
rast.put_img(img1,0,0); -- put the image into the rastport
Tk.mainloop(); -- enter the Tk main loop
procedure motion_response(xy);
-- motion response routine; write brush image to rastport
[x,y] := xy; [x,y] := [unstr(x),unstr(y)];
-- get mouse position within rastport
case ink -- write brush image in mode selected
when "blend" => rast.put_blend(brush,x - width,y - hgt,0.8,0.2);
when "lightest" => rast.put_max(brush,x - width,y - hgt);
when "darkest" => rast.put_min(brush,x - width,y - hgt);
otherwise => rast.put_img(brush,x - width,y - hgt);
end case;
end motion_response;
procedure makebrush(); -- brush adjustment procedure
hgt := map_slidr("Hgt"); width := map_slidr("Width");
-- read height, width, and mode from multi-slider widget
red := map_slidr("R"); green := map_slidr("G"); blue := map_slidr("B");
-- read color intensities from multi-slider widget
ink := Tk.getvar("ink");
-- read pen coloring mode from radiobutton
ovim_new := (black_img := ovim.scale([2 * width,2 * hgt]));
-- scale the brush image to its new size
-- we also create a black version of the pen
-- if this is not the first pen adjustment,
-- clear the background of the pen image in the upper window
if prior_black_img /= OM then
rast2.put_img(prior_black_img + [235,235,235],0,0);
end if;
prior_black_img := black_img;
-- save the current pen shape,for clearing later
brush := ovim_new.get_level([0,0,0]) + [red,green,blue];
-- restrict oval image to its interior, setting color levels
rast2.put_img(brush,0,0); -- show the new pen shape
end makebrush;
-- utilities for conversion of color levels into color codes
procedure chars2(n); return hexy(n/16) + hexy(n mod 16); end chars2;
procedure hexy(n);
return if n < 10 then char(abs("0") + n)
else char(abs("a") + n - 10) end if;
end hexy;
end test;
A map slider can be thought of as a slider-controlled, numerically valued map whole domain is the set of labels associated with the slider. Map sliders are created by calls of the form
ms := map_slider(parent_window_or_frame,"descriptor",response_routine);
The descriptor appearing here must be a semicolon-delimited string consisting of @-delimited quadruples of the form
Label@lower_limit@upper_limit@default value
each defining one slider label, along with the upper and lower limits for the numerical quantity associated with it, and its initial value. The 'response_routine' which will be called whenever a slider-controlled value changes, should be parameterless. To switch the slider to control the value associated with a particular label, we simply click on the label in the visible form of the map_slider. The value currently associated with any label can be retrieved by writing ms("label"), and set by writing ms("label") := val; this last operation also adjusts the visible slider position.
The operations get_img, get_min, get_max, get_blend, get_add, get_mul, and get_div act like their 'put' relatives, except that instead of writing to a rastport they set their second parameter to what the 'put' operations would have written. This is shown in the following example, which creates two rastports in a frame and writes a photograph to the first of them. A grey circle with a black rectangular boundary is then created using the image library described in Chapter 11. Buttons are then created which allow this 'GRLIB_PAK' image to be combined with the circle-in-rectangle image using 'get_min', 'get_max', 'get_blend', etc. and displayed in a second rastport.
program test; -- Rastport test 1
use tkw,string_utility_pak,image;
-- use the main widget class, plus the GRLIB_PAK image-object class
var Tk,rast,rast2,grey_circle; -- globalize for use in procedures below
Tk := tkw(); Tk(OM) := "Rastport test 1"; -- create the Tk interpreter
fr := Tk("frame","10,10"); fr("side") := "top";
-- create a frame for the following rastport
rast := fr("rastport","300,200"); rast("side") := "top";
-- create a rastport in the frame
rast2 := fr("rastport","300,200"); rast2("side") := "top";
-- create a rastport in the frame
photo := image("1.jpeg"); -- read in a photograph as a GRLIB_PAK image
grey_circle := image(["oval",151,151,2,75,[155,155,155]]).to_dense();
-- create a grey circle, but extend it with a black boundary
-- to the square containing it
rast.put_img(photo,0,0); -- put the second image into the rastport
rast.get_min(grey_circle,75,25);
-- read a circular portion of it into the white circle
rast2.put_img(grey_circle,75,25); -- put the first image into the rastport
but := Tk("button","Copy"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle(rast.get_img); end lambda;
-- bind 'get_min' action to button click
but := Tk("button","Min"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle(rast.get_min); end lambda;
-- bind 'get_min' action to button click
but := Tk("button","Max"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle(rast.get_max); end lambda;
-- bind 'get_min' action to button click
but := Tk("button","Blend"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle2(rast.get_blend); end lambda;
-- bind 'get_blend' action to button click
but := Tk("button","Add"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle(rast.get_add); end lambda;
-- bind 'get_add' action to button click
but := Tk("button","Mul"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle(rast.get_mul); end lambda;
-- bind 'get_mul' action to button click
but := Tk("button","Div"); but("side") := "left"; -- create a button
but{OM} := lambda(); fill_circle(rast.get_div); end lambda;
-- bind 'get_div' action to button click
Tk.mainloop(); -- enter the Tk main loop
procedure fill_circle(use_proc);
grey_circle := image(["oval",151,151,2,75,[155,155,155]]).to_dense();
-- create a grey circle, but extend it with a black boundary
-- to the square containing it
use_proc(grey_circle,75,25);
rast2.put_img(grey_circle,75,25);
end fill_circle;
procedure fill_circle2(use_proc);
grey_circle := image(["oval",151,151,2,75,[155,155,155]]).to_dense();
-- create a grey circle, but extend it with a black boundary
-- to the square containing it
use_proc(grey_circle,75,25,0.5,0.5); -- make a 50/50 blend
rast2.put_img(grey_circle,75,25);
end fill_circle2;
end test;
In further illustration of the operations exhibited in the preceding program, we use one of them to rotate a circular portion of a photograph 90 degrees. This is done in the following short program. Following this we test the speed of the image operations involved by adding a slider which allows the position of the rotated image portion to be varied dynamically.
program test; -- Rastport test 1
use tkw,image;
-- use the main widget class, plus the GRLIB_PAK image-object class
Tk := tkw(); Tk(OM) := "Rastport test 1"; -- create the Tk interpreter
fr := Tk("frame","10,10"); fr("side") := "top";
-- create a frame for the following rastport
rast := fr("rastport","300,200"); rast("side") := "top";
-- create a rastport in the frame
photo := image("1.jpeg"); -- read in a photograph as a GRLIB_PAK image
white_circle := image(["oval",151,151,2,75,[255,255,255]]).to_dense();
-- create a white circle, but extend it with a black boundary
-- to the square containing it
black_circle := image(["oval",151,151,2,75,[0,0,0]]);
-- create a black circle, confined to its circular area
rast.put_img(photo,0,0); -- put the image into the rastport
rast.get_min(white_circle,75,25);
-- read a circular portion of it into the white circle
rast.put_img(black_circle,75,25);
-- blot a circular area in its center to black
rast.put_maxr(white_circle,75,25);
-- write the circular portion image back in a rotated orientation
Tk.mainloop(); -- enter the Tk main loop
end test;
The following is a 'double-buffered', slider-controlled dynamic variant of the previous program. Again we use a black circle in a white rectangular frame as 'cookie cutters' to extract a rotated copy of a circular area in our test photograph. This is written back to second, invisible rastport (the 'doubled buffer') to prevent visible flickering when a circular area in the rastport is cleared to black by writing the black circle to it in preparation for re-insertion of the rotated circular part of the original image by the 'put_maxr' operation seen below. (The second rastport, 'rast2', is left invisible simply by not assigning it a 'side', You can add the assignment 'rast2("side") := "top";' to make it visible in order to see the flickering which it serves to suppress.) Finally the modified second rastport is copied to the visible first rastport, via an auxiliary image. All this happens fast enough to give a reasonably smooth sliding motion of the rotated circular image portion over its background image.
program test; -- Rastport test 1
use tkw,image;
-- use the main widget class, plus the GRLIB_PAK image-object class
var rast,rast2,photo,aux_photo,black_circle;
Tk := tkw(); Tk(OM) := "Rastport test 1"; -- create the Tk interpreter
fr := Tk("frame","10,10"); fr("side") := "top";
-- create a frame for the following rastport
rast := fr("rastport","300,200"); rast("side") := "top";
-- create a rastport in the frame
rast2 := fr("rastport","300,200");
-- create a second rastport in the frame, but leave itinvisible
photo := image("1.jpeg"); -- read in a photograph as a GRLIB_PAK image
aux_photo := image("1.jpeg"); -- read in a photograph as a GRLIB_PAK image
black_circle := image(["oval",151,151,2,75,[0,0,0]]);
-- create a black circle, confined to its circular area
slider := Tk("scale","25,125");
-- create a slider with range create a slider with range -50,50
slider("side") := "top"; -- make it visible
slider("length,width,orient") := "350,10,horizontal";
-- set the physical size of the slider
slider{OM} := slider_response; -- bind a response routine to it
slider(OM) := 75;
Tk.mainloop(); -- enter the Tk main loop
procedure slider_response(x);
-- slider response routine; parameter is value as a tuple, string form
circ_posn := unstr(x(1));
white_circle := image(["oval",151,151,2,75,[255,255,255]]).to_dense();
-- create a white circle, but extend it with a black boundary
-- to the square containing it
rast2.put_img(photo,0,0); -- put the image into the rastport
rast2.get_min(white_circle,circ_posn,25);
-- read a circular portion of it into the white circle
rast2.put_img(black_circle,circ_posn,25);
-- blot a circular area in its center to black
rast2.put_maxr(white_circle,circ_posn,25);
-- write the circular portion image back in a rotated orientation
rast2.get_img(aux_photo,0,0);
-- copy the modified invisible rastport to an auxiliary image
rast.put_img(aux_photo,0,0);
-- copy the auxiliary image to the visible rastport
end slider_response;
end test;
Tk bitmap data must have the so-called 'XBM' format first developed for the X-Windows system. Many icons in XBM format can be retrieved form the Web, one good source being http://empyrean.lib.ndsu.nodak.edu/~nem/iconsxbm/. Examples of data in this curious format are seen in the program below. XBM presents its data in a character format, and specifically in a C code form, which is however not compiled as C but simply parsed and transformed by a small XBM reader. XBM-format data begins with three lines of the form
#define icon_name_width n
#define icon_name_height n
static char icon_name_bits[] = {
followed by the successive bytes of the data, represented in the C format '0xff'. The following is an example of this format.
arrow_icon := "define back_width 20" +
"#define back_height 23" +
"static char back_bits[] = {" +
" 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x0f,0x00,0x80,0x0f," +
" 0x00,0x80,0x0f,0x00,0x80,0x0f,0x00,0x80,0x0f,0x00,0x80,0x0f,0x60,0x80,0x0f," +
" 0x70,0x80,0x0f,0x78,0x00,0x00,0xfc,0xff,0x0f,0xfe,0xff,0x07,0xff,0xff,0x03,
" 0xfe,0xff,0x01,0xfc,0xff,0x00,0x78,0x00,0x00,0x70,0x00,0x00,0x60,0x00,0x00,
" 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00};
Note that this data format is roughly ten times as bulky as it needs to be, since five characters are used to represent a single byte of data, and since even if this redundancy is eliminated changed the length of the resulting string can generally be halved using some standard compression scheme.
The program seen below displays two bitmaps collected from the Web. It offers a variety of ways of viewing these icons, since each can be seen with or without mask data, and in any desired foreground and background color. The bitmap data is given in a form which eliminates the XBM redundancies noted above, but then re-expanded into 'official' XBM by the small 'xbm' procedure seen below. Each icon is displayed in two formats, one with a mask plane, the other without. Buttons are provided for turning a magenta background on and off in the two 'abacus' icons displayed. By experimenting with these buttons, you will be able to verify the following facts:
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,icon2,icon4; -- globalize for use in procedure below
const arrow_icon := "20 23 " + -- compressed XBM data for arrow icon
"00000000000000000000800f00800f00800f00800f00800f00800f60800f70800f780000fcff0ffeff07ffff03" +
"feff01fcff00780000700000600000000000000000000000";
const abacus_icon := "64 54 " + -- compressed XBM data for abacus icon
"00000000000000000000000000000000feffffffffffff3f0e00000000000020feffffff"+
"ffffff2ffeffffffffffff2feeffffffffffff2f2e0e8783e070382e2e9d4e87d0e9742e"+
"2e9fcf87f0f97c2e2e0e8783e070382e2e9d0e81d0e9742e2e9f0fc1f1f97c2e2e0e07a1"+
"e370382e2e0402e14320102e2e0482c34120102e2e0442a74320102e3e04c2e74320103e"+
"220482c341201022eaffffffffffff2b020100000000202002ffffffffff3f20eaffffff"+
"ffffff2b22048283402010223e0442874020103e2e04c2874020102e2e0482834020102e"+
"2e0442874020102e2e04c2874020102e2e0482834020102e2e0402814020102e2e0e07c1"+
"e170382e2e9d0ea1d3e9742e2e9f0fe1f3f97c2e2e0e07c1e170382e2e9d0ea1d3e9742e"+
"2e9f0fe1f3f97c2e2e0e87c3e170382e2e9d4ea7d3e9742e2e9fcfe7f3f97c2e2e0e87c3"+
"e170382e2e9d4ea7d3e9742e2e9fcfe7f3f97c2e2e0e87c3e170382e2e9d4ea7d3e9742e"+
"2e9fcfe7f3f97c2e2e0e87c3e170382eeeffffffffffff2f0e0000000000002cfeffffff"+
"ffffff2ffeffffffffffff2ffeffffffffffff3f00000000000000000000000000000000";
const abacus_icon_back := "64 54 " + -- compressed XBM data for abacus icon
"ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+
"ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+
"ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+
"ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+
"000000000000000000000000000000000000000000000000000000000000000000000000"+
"000000000000000000000000000000000000000000000000000000000000000000000000"+
"000000000000000000000000000000000000000000000000000000000000000000000000"+
"000000000000000000000000000000000000000000000000000000000000000000000000"+
"ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+
"e170382e2e9d4ea7d3e9742e2e9fcfe7f3f97c2e2e0e87c3e170382e2e9d4ea7d3e9742e"+
"2e9fcfe7f3f97c2e2e0e87c3e170382eeeffffffffffff2f0e0000000000002cfeffffff"+
"ffffff2ffeffffffffffff2ffeffffffffffff3f00000000000000000000000000000000";
Tk := tkw(); Tk(OM) := "Two Icons"; -- create the Tk interpreter
ca := Tk("canvas","300,100"); ca("side") := "top";
-- if packed; or left,right,bottom
ca("background") := "grey";
rect := ca("rectangle","5,10,260,40"); rect("fill") := "cyan";
print(#abacus_icon,); -- size of abacus_icon is 870 (uncompressed is 2240 bytes),
-- but can be reduced to roughly 220
icon := Tk("bitmap",[arxb := xbm(arrow_icon),arxb]);
-- create an absolute bitmap
icon2 := Tk("bitmap",[abxb := xbm(abacus_icon),xbm(abacus_icon_back)]);
-- create a second absolute bitmap
icon3 := Tk("bitmap",arxb); -- create an absolute bitmap, no mask
icon4 := Tk("bitmap",abxb); -- create a second absolute bitmap, no mask
icon("foreground") :="red"; icon2("foreground,background") :="magenta,magenta";
icon4("foreground,background") :="blue,magenta";
bm := ca("image",icon); -- use the absolute bitmap in a first canvas bitmap
bm2 := ca("image",icon2);
-- use the second absolute bitmap in a first canvas bitmap
bm3 := ca("image",icon3);
-- use the third absolute bitmap in a first canvas bitmap
bm4 := ca("image",icon4);
-- use the fourth absolute bitmap in a first canvas bitmap
bm("coords") := "20,25"; bm("anchor") := "nw"; -- put the icons into the bitmap
bm2("coords") := "60,10"; bm2("anchor") := "nw";
bm3("coords") := "130,25"; bm3("anchor") := "nw";
bm4("coords") := "160,10"; bm4("anchor") := "nw";
txt := Tk("text","30,6"); -- create a text area
txt("side") := "top"; txt(OM) := "Type\ntext\nhere";
txt("font,background") := "{Times 18 bold},green";
txt.insert_image("1.1",icon2);
-- insert absolute bitmap into the text area
txt.insert_image("end",icon);
-- insert another absolute bitmap into the text area
print(txt("images")); -- this expression also retrieves all bitmaps
fr := Tk("frame","30,6"); fr("side") := "top";
-- create a frame for the buttons
but := fr("button","Bgd 1 off"); but("side") := "left";
-- create a button
but{OM} := lambda(); icon2("foreground,background") := "magenta,"; end lambda;
-- bind it to a 'background off' action
but := fr("button","Bgd 1 on"); but("side") := "left";
-- create a button
but{OM} := lambda(); icon2("foreground,background") := "magenta,magenta";
end lambda;
-- bind it to a 'background on' action
but := fr("button","Bgd 2 off"); but("side") := "left";
-- create a button
but{OM} := lambda(); icon4("foreground,background") := "blue,"; end lambda;
-- bind it to a 'background off' action
but := fr("button","Bgd 2 on"); but("side") := "left";
-- create a button
but{OM} := lambda(); icon4("foreground,background") := "blue,magenta"; end lambda;
-- bind it to a 'background on' action
Tk.mainloop(); -- enter the Tk main loop
procedure xbm(compressed); -- decompressor for compressed XBM
i1 := break(compressed," "); match(compressed," ");
i2 := break(compressed," "); match(compressed," ");
dec_data := "" +/ [compressed(j..jp1 := j+ 1)
+ if jp1 = nc then "};" else ",0x" end if:
j in [1,3..nc :=#compressed]];
dec := "#define xbm_width " + i1 + "\n#define xbm_height "
+ i2 + "\nstatic char xbm_bits[] = {\n0x" + dec_data;
return dec;
end xbm;
end test;
As seen in the following program, bitmaps and images can replace the captions on ordinary buttons, checkbuttons, radio buttons, and menu buttons. The program creates objects of these various kinds and puts an imge or icon on each.
program test; -- SETL interactive interface example 1
use tkw; -- use the standard graphical interface package
const arrow_icon := "20 23 " + -- compressed XBM data for arrow icon
"00000000000000000000800f00800f00800f00800f00800f" +
"00800f60800f70800f780000fcff0ffeff07ffff03feff01" +
"fcff00780000700000600000000000000000000000";
Tk := tkw(); -- create the Tk interpreter
Tk(OM) := "Buttons with Images/Bitmps";
abs_img := Tk("image","test_files/orchid_trans.gif");
-- read an image file to create a Tk absolute image
icon := Tk("bitmap",[the_xbm := xbm(arrow_icon),the_xbm]);
-- create an absolute icon
but := Tk("button",""); but("side") := "top"; -- create a button
but("image") := abs_img; -- put the image on the button
fr := Tk("frame","1,1"); fr("side") := "top"; -- create a frame
but := fr("button",""); but("side") := "left"; -- create a button
but("image") := icon; -- put the icon on the button
ckbut1 := fr("checkbutton",""); ckbut1("side") := "left";
-- create a checkbutton
ckbut1("image") := icon; -- put the icon on the checkbutton
rbut1 := fr("radiobutton",""); rbut1("side") := "left";
-- create a radio button
rbut1("image") := icon; -- put the icon on the radio button
mb := fr("menubutton",""); mb("side") := "left";
-- create a menubutton
mb("image") := icon; -- put the icon on the menubutton
descriptor := "b:Item1,b:Item2,s,c:Item3,c:Item4";
-- set up a menu descriptor
mb(OM) := men := mb("menu",descriptor); -- attach a menu
Tk.mainloop(); -- enter the main Tk loop
procedure xbm(compressed); -- decompressor for compressed XBM
i1 := break(compressed," "); match(compressed," ");
i2 := break(compressed," "); match(compressed," ");
dec_data := "" +/ [compressed(j..jp1 := j+ 1)
+ if jp1 = nc then "};" else ",0x" end if:
j in [1,3..nc :=#compressed]];
dec := "#define xbm_width " + i1 + "\n#define xbm_height "
+ i2 + "\nstatic char xbm_bits[] = {\n0x" + dec_data;
return dec;
end xbm;
end test;
Menus are created by operations of the form
parent("menu",descriptor),
where 'descriptor' is a string of comma-separated items of the form 'b:label', 'c:label', 'r:label', 's:label', 's' (a separator), and 't' (a tearoff.) The following code illustrates these conventions. It creates a menubutton to which a menu is then attached. Two levels of submenus are attached hierarchically, each to the sixth item of its parent menu. The menu appears when the button is pressed, and each attached submenu as we roll over its parent item.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); -- create the Tk interpreter
mb := Tk("menubutton","Menu"); mb("side") := "top"; -- create a menubutton
men := mb("menu","b:Button-item,c:Checkbutton-item," +
"r:Radiobutton-item,s,s:Submenu");
-- create a menu to attach to the menubutton
mb(OM) := men; -- attach the menu to the menubutton
sub_men := mb("menu","b:XButton-item,c:XCheckbutton-item," +
"r:XRadiobutton-item,s,s:XSubmenu");
-- create a second menu to attach hierarchically
men(6,"menu") := sub_men; -- attach it to the sixth menu item
sub_sub_men := mb("menu","b:XXButton-item,c:XXCheckbutton-item,r" +
":XXRadiobutton-item");
-- create a third menu to attach hierarchically
sub_men(6,"menu") := sub_sub_men; -- attach it to the sixth submenu item
Tk.mainloop(); -- enter the Tk main loop
end test;
The expression #menu gives the number of items in a menu. If nm is the string name of a menu item, menu.index(nm) will give its numerical position. The numerical position of the currently activated menu item (if any) is available as menu.index("active").
To set the command triggered when a menu item is chosen, we write
menu{item_index,OM} := SETL_proc;
where the SETL_proc should be parameterless. To set the other attributes of a menu item (these are listed below) we write
menu(item_index,attributes) := attribute_vals;
where as usual 'attributes' is a comma- (or semicolon-) separated string of attribute names, and attribute_vals is either a string of the same kind, or a tuple, giving the corresponding attribute values.
The following small program illustrates some of these conventions. It first creates a menubutton and an associated menu. A command which emits j beeps and sets the name of the button to the name of the item is then associated with the j-th menu item.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,mb,men; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
mb := Tk("menubutton","Menu"); mb("side") := "top"; -- create a menubutton
men := mb("menu", -- create a menu
"b:Button-item,c:Checkbutton-item,r:Radiobutton-item,s,s:Submenu");
mb(OM) := men; -- associate the menu with the menubutton
-- assign commands to the menu items
for j in [1..#men] loop men{j,OM} := beeps(j); end loop;
Tk.mainloop(); -- enter the Tk main loop
procedure beeps(k); -- create a procedure (closure) which beeps k times
return lambda(); -- we return a parameterless function
-- get the item label and assign it to the menu button
mb("text") := men(k,"label");
for j in [1..k] loop Tk.beeper(); end loop; -- beep k times
end lambda;
end beeps;
end test;
To attach a submenu 'sub' to an 's'- (submenu-) type item in a menu M, write
M(ix,"menu") := sub;
To bind a callback to the selection event of the j-th menu item, we write
M{j,OM} := callback_proc;
This is seen in the following variant of the preceding code, which creates a menubutton and attaches a menu to it. This first menu has a submenu item, to which a second menu containing its own submenu item is then attached, A third submenu is then attached to this second submenu, creating a 3-level submenu hierarchy. The remaining entries in all of these menus are then set up to beep when selected.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,mb; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
mb := Tk("menubutton","Menu"); mb("side") := "top"; -- create a menubutton
mb("width") := 18; -- allow for 18 characters
men := mb("menu", -- create a menu
"b:Button-item,c:Checkbutton-item,r:Radiobutton-item,s,s:Submenu");
sub_men := mb("menu", -- create a first submenu
"b:SubButton,c:Subcheckbutton,r:Subradiobutton,s,s:Subsubmenu");
sub_men2 := mb("menu", -- create a sub-submenu
"b:SubButton2,c:Subcheckbutton2,r:Subradiobutton2");
mb(OM) := men; -- associate the menu with the menubutton
-- associate the second menu with item 5 of the first menu
men(5,"menu") := sub_men;
-- associate the third menu with item 5 of the second menu
sub_men(5,"menu") := sub_men2;
-- assign commands to the menu items
for j in [1..#men - 1] loop men{j,OM} := beeps(men,j); end loop;
for j in [1..#sub_men - 1] loop sub_men{j,OM} := beeps(sub_men,j); end loop;
for j in [1..#sub_men2] loop sub_men2{j,OM} := beeps(sub_men2,j); end loop;
Tk.mainloop(); -- enter the Tk main loop
procedure beeps(the_menu,k); -- create a procedure (closure) which beeps k times
return lambda(); -- we return a parameterless function
-- get the item label and assign it to the menu button
mb("text") := the_menu(k,"label");
for j in [1..k] loop Tk.beeper(); end loop; -- beep k times
end lambda;
end beeps;
end test;
Menu bars created using the SETL interface can be attached directly to toplevel windows, or can replace the menu bar normally present at the top of the screen. To do this, create a first menu M consisting exclusively of submenu items; this will become the menubar. Then create and attach submenus to each of the items of M; these can be hierarchical if desired. To install M, create the window w with which it is to be associated, and assign M as the 'menu' attribute of w by writing
W("menu") := M;
On the Macintosh, menus M treated in this way replace the standard menu at the top of the screen whenever the window w is active. Under Windows and UNIX, these menus M appear at the top of their associated windows w. To have M replace the standard top-of-screen menu one must then make M the 'menu' attribute of the root window Tk.
The following program illustrates these conventions. It creates a menu M consisting of three submenu items, and attaches hierarchical submenus to each of them. Then it creates a toplevel window w and assigns M as its window attribute, causing M to replace the standard (Macintosh) top-of-screen menubar when w is active. Beeps are attached to the selectable items in all menus.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var tk; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
top := Tk("toplevel","400,100"); top(OM) := "This window carries menu";
men := top("menu","s:Submenu,s:SubmenuA,s:SubmenuB");
-- 3 submenus make the menu bar
sub_men := top("menu", -- create a first hierarchical menu
"b:SubButton,c:Subcheckbutton,r:Subradiobutton,s,s:Subsubmenu");
sub_men2 := top("menu",
"b:SubButton2,c:Subcheckbutton2,r:Subradiobutton2");
sub_menA := top("menu", -- create a second hierarchical menu
"b:SubButtonA,c:SubcheckbuttonA,r:SubradiobuttonA,s,s:SubsubmenuA");
sub_menA2 := top("menu",
"b:SubButtonA2,c:SubcheckbuttonA2,r:SubradiobuttonA2");
sub_menB := top("menu", -- create a third hierarchical menu
"b:SubButtonB,c:SubcheckbuttonB,r:SubradiobuttonB,s,s:SubsubmenuB");
sub_menB2 := top("menu",
"b:SubButtonB2,c:SubcheckbuttonB2,r:SubradiobuttonB2");
top("menu") := men; -- attach the menubar to the window
-- attach the hierarchical menus to the menubar
men(1,"menu") := sub_men; sub_men(5,"menu") := sub_men2;
men(2,"menu") := sub_menA; sub_menA(5,"menu") := sub_menA2;
men(3,"menu") := sub_menB; sub_menB(5,"menu") := sub_menB2;
-- attach beep actions to the menu items
for j in [1..#sub_men - 1] loop sub_men{j,OM} := beeps(j); end loop;
for j in [1..#sub_menA - 1] loop sub_menA{j,OM} := beeps(j); end loop;
for j in [1..#sub_menB - 1] loop sub_menB{j,OM} := beeps(j); end loop;
for j in [1..#sub_men2] loop sub_men2{j,OM} := beeps(j); end loop;
for j in [1..#sub_menA2] loop sub_menA2{j,OM} := beeps(j); end loop;
for j in [1..#sub_menB2] loop sub_menB2{j,OM} := beeps(j); end loop;
Tk.mainloop(); -- enter the Tk main loop
procedure beeps(k); -- create a procedure (closure) which beeps k times
return lambda(); -- we return a parameterless function
-- get the item label and assign it to the menu button
for j in [1..k + 1] loop Tk.beeper(); end loop; -- beep k times
end lambda;
end beeps;
end test;
'Option buttons' are menu buttons of a somewhat special kind created by calls of the form
parent("optionbutton",descriptor);
rather than by the ordinary
parent("menubutton",label);
The 'descriptor' used to create an option button must be a string of the form 'varname;alt,alt,alt...', consisting of the name 'varname' of an auxiliary variable which will be used to store the value of the currently selected option, followed by a comma-separated list alt,alt,alt... of the available options. (The value stored in the special graphical interface variable 'varname' can be fetched/stored using the commands val := getvar(varname); and setvar(varname,val); see Section 14.).
The following small example shows the construction and behavior of an option button. We set up an option button which displays four options. Selection actions are assigned to each of these buttons. This action simply prints the item selected, which is obtained from the variable 'ob_var' associated with the button.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk;
Tk := tkw(); -- create the Tk interpreter
ob := Tk("optionbutton","ob_var;a,b,c,d"); ob("side") := "top";
obmen := ob(OM);
-- get the menu of the option button (which is its 'main' attribute)
for j in [0..3] loop obmen{j,OM} := pick_response; end loop;
Tk.mainloop(); -- enter the Tk main loop
procedure pick_response(); print(Tk.getvar("ob_var")); end pick_response;
end test;
The attributes of menus are:
type - normal, menubar, or tearoff foreground - text color background - background color selectcolor - color for selector in checkbutton and radiobutton entries font - font for entries activeforeground - text color when mouse is over an entry activebackground - background color when mouse is over an entry disabledforeground - text color when entry is disabled borderwidth - menu border width, in pixels activeborderwidth - menu active border width, in pixels cursor - cursor to display when mouse is over menu postcommand - command to execute just before menu is posted tearoffcommand - command to execute when menu is torn off takefocus - command to be executed when menu receives focus - via tabThe attributes of menu items are:
label - label of entry image - image to display instead of label bitmap - bitmap to display instead of label justify - label justification: left, right, or center foreground - text color background - background color accelerator - text for keystroke-binding reminder selectcolor - selection-indicator color for checkbutton - and radiobutton entries state - normal, active, or disabled font - font for entries underline - index of text character to underline activeforeground - text color when mouse is over an entry activebackground - background color when mouse is over an entry columnbreak - start a new menu column with this entry variable - if non-null, names a Tk variable holding selection state value - value for 'variable' when radiobutton is selected onvalue - value for 'variable' when checkbutton is selected offvalue - value for 'variable' when checkbutton is not selected hidemargin - suppress the margin reserved for button indicatorsAs shown by the following, menus need not depend on associated menubuttons to open them: they can be opened, at any desired screen position, under program control. Two nearly synonymous commands,
menu.popup(i,j); and menu.post(i,j);
are available for this. In both these commands, i,j designates an absolute screen position. Menus opened with either of these commands remain open only as long as the mouse button is depressed.
The following program creates two menus, the second tied hierarchically to the first. The first is then opened at a stated position,either by 'popup' or by 'post'. (Either of the two commands shown can be executed, with the other commented out). The 'postcascade' command nominally opens the hierarchical submenu at its appropriate position, but may be unreliable on some platforms.
program test; -- SETL interactive interface example 1
use tkw; -- use the standard graphical interface package
var men;
Tk := tkw(); Tk(OM) := "Popup menus"; -- create the Tk interpreter
descriptor := "b:Item1,r:Item2,s,c:Item3,c:Item4,s:Item5";
-- set up a menu descriptor
men := Tk("menu",descriptor); -- create a menu
descriptor2 := "b:XItem1,b:XItem2,s,c:XItem3";
-- set up another menu descriptor
men2 := Tk("menu",descriptor2); -- create another menu
men(6,"menu") := men2;
Tk{"ButtonPress-1"} :=
lambda(); men.popup(100,100); men.postcascade(6); end lambda;
-- bind buttonpress in the window to menu popup
Tk.mainloop(); -- enter the main Tk loop
end test;
To set the attributes of a menubutton, one uses assignments of the form
menubutton_obj(attribute_list) := attribute_value_list;
where
To set the attributes of a menu item, one uses assignments of the form
menu_obj(attribute) := attribute_value;
where . Note however that
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); -- create the Tk interpreter
mb := Tk("menubutton","Menu"); mb("side") := "top"; -- create a menubutton
mb2 := Tk("menubutton","Menu"); mb2("side") := "top"; -- create a menubutton
abs_img := Tk("image","test_files/egyptian.gif");
-- read an image file to create a Tk absolute image
men := mb("menu","b:Button-item,c:Checkbutton-item," +
"r:Radiobutton-item,s,s:Submenu");
-- create a menu to attach to the menubutton
mb(OM) := men; -- attach the menu to the menubutton
mb("image,cursor") := [abs_img,"Gumby"];
men(2,"state,image") := ["disabled",abs_img];
print(men(2,"state")); print(men(2,"image"));
sub_men := mb("menu","b:XButton-item,c:XCheckbutton-item," +
"r:XRadiobutton-item,s,s:XSubmenu");
-- create a second menu to attach hierarchically
men(6,"menu") := sub_men; -- attach it to the sixth menu item
sub_sub_men := mb("menu","b:XXButton-item,c:XXCheckbutton-item," +
"r:XXRadiobutton-item");
-- create a third menu to attach hierarchically
sub_men(6,"menu") := sub_sub_men; -- attach it to the sixth submenu item
men("foreground,font,tearoff,cursor") := "red,{Tines 48},0,Pirate";
men2 := mb("menu","b:Button-item,c:Checkbutton-item," +
"r:Radiobutton-item,s,s:Submenu");
-- create a menu to attach to the menubutton
Tk.mainloop(); -- enter the Tk main loop
end test;
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ent; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
but := Tk("button","Click Me"); but("side") := "left";
-- create and place a first button
but{OM} := ask; -- bind the 'ask' response to the button
-- create a textline widget for display of the dialog response
ent := Tk("entry","15"); ent("side") := "left";
ent("justify") := "center";
Tk.mainloop(); -- enter the Tk main loop
procedure ask(); -- button response routine;
-- opens a 'yesnocancel' dialog, with 'no' as the default
Tk("ask_ok","type,default,message")
:= "yesnocancel,no,Choose an alternative";
ent(OM) := dialog_response;
end ask;
end test;
The "ask" dialog presents a set of captioned buttons, of which one can be designated as the default, and can include a bit-mapped icon. Its attributes are:
labels - list of labels to appear default - number of default label message - message to appear parent - toplevel in which dialog is to appear title - title of toplevel in which dialog is to appear (Unix and Windows) icon - bitmap to appear, if any
The "ask_ok" dialog is a specialized variant of the "ask" dialogs, which presents one, two, or three buttons, depending on its type, which can be yesno, ok, okcancel, retrycancel, yesnocancel, or abortretrycancel. Its attributes are:
type - dialog type, as just listed default - number of default label message - message to appear icon - bitmap to appear, if any parent - toplevel in which dialog is to appear (Unix and Windows) title - title of toplevel in which dialog is to appear
The "ask_file" dialog opens the standard system 'select/open file' utility. Its attributes are:
filetypes- list of file types to be shown. If empty, all are shown - see the main documentation for the format of this list initialdir- initial directory whose contents shown; current dir if empty parent - toplevel in which dialog is to appear title - title of toplevel in which dialog appears (Unix and Windows)The list (if any) supplied as the value of an "ask_file" dialog's 'filetypes' attribute should be a tuple of items, each of which describes one choice of the file types to be listed. Each of these items should be a semicolon-separated list of 2 or 3 parts, having either the form
caption_for_filetype;extensions_list
or
caption_for_filetype;extensions_list;Macintosh_file_typecodes_list.
If the 'filetypes' attribute is set in this way, an additional popup menu which lists every 'caption_for_filetype' given will appear at the bottom of the "ask_file" dialog; each such 'caption_for_filetype' is simply a string which should be chosen to define the group of filetypes selected by the extensions_list and Macintosh_file_typecodes_list which follow. The extensions_list is a list of all the file extensions which are to be admitted when such a group is chosen. The Macintosh_file_typecodes_list which optionally
An example is
["All Files;*","SETL Files;stl"]
The "ask_save_file" dialog opens the standard system 'save file' utility. Its attributes are:
initialdir- initial directory whose contents shown; current dir if empty initialfile- default file name defaultextension- default file extension, if none given parent - toplevel in which dialog is to appear title - title of toplevel in which dialog appears (Unix and Windows)
The following small program opens a get_file dialog when one of two buttons is clicked, and writes the name of the file chosen to a textline. If the other button is clicked a save_file dialog is opened instead.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ent; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
but := Tk("button","Click Me"); but("side") := "left";
-- create and place a first button
but{OM} := ask; -- bind the 'ask' response to the first button
but2 := Tk("button","Or Click Me"); but2("side") := "left";
-- create and place a second button
but2{OM} := ask2; -- bind the 'ask2' response to the second button
ent := Tk("entry","45"); ent("side") := "left"; ent("justify") := "center";
-- create and insert a text display line
Tk.mainloop(); -- enter the Tk main loop
procedure ask(); -- button response routine; opens get_file dialog,
-- prepared to display either '.stl' or all files
Tk("ask_file","filetypes") := ["{\"SETL Files\" {.stl} {TEXT}}"
,"{\"All Files\" {*} {TEXT}}"];
ent(OM) := dialog_response; -- display the response
end ask;
procedure ask2();
-- button response routine; opens save_file dialog
-- with default name "untitled.stl"
Tk("ask_save_file","initialfile") := ["untitled.stl"];
ent(OM) := dialog_response; -- display the response
end ask2;
end test;
The "ask_color" dialog opens a color picker. Its attributes are:
initialcolor- initial color, when picker dialog opened parent - toplevel in which dialog is to appear title - title of toplevel in which dialog appears (Unix and Windows)
The following program opens an 'ask_color' dialog.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ent; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
but := Tk("button","Click Me"); but("side") := "left";
-- create and place a first button
but{OM} := ask; -- bind the 'ask' response to the first button
ent := Tk("entry","45"); ent("side") := "left"; ent("justify") := "center";
-- create and insert a text display line
Tk.mainloop(); -- enter the Tk main loop
procedure ask(); -- button response routine; opens get_file dialog,
-- prepared to display either '.stl' or all files
Tk("ask_color","initialcolor,title")
:= "red,Buddy: won't you pick a Color";
ent(OM) := dialog_response; -- display the response
end ask;
end test;
Tk's standard color picker is very deluxe. It allows a color to be picked in any one of a wide variety of ways. Note that, like the other selection dialogs described in this section, the color picker returns an empty string if the dialog is cancelled. Otherwise it returns a hex string color representation of the standard form #rrggbb.
lb := parent("listbox",n);
The SETL interface uses a tuple-like syntax for some listbox operations. For example, the items in a listbox lb can be defined by writing
lb(1..0) := tuple_of_strings;
and the same tuple-like syntax can be used to insert additional elements and to delete elements.
The following code creates a listbox of 20 elements with an attached scrollbar. Five of the 20 elements are visible at any one time.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Test Window"; -- caption the main window
lb := Tk("listbox",str(lb_len := 5)); lb("side") := "left";
-- create a listbox
lb(1..0) := ["Item" + str(j): j in [1..4 * lb_len]];
-- create the listbox items
sb := Tk("scrollbar","v,10"); -- create a thin vertical scrollbar
sb("side,fill") := "left,y";
-- pack to the left of the listbox, filling available vertical range
lb("yscroller") := sb; -- attach the scrollbar t the list box
Tk.mainloop(); -- enter the Tk main loop
end test;
Listboxes have the following attributes:
height - number of listbox lines visible width - width of listbox, in characters font - item text font foreground - color of item text background - item background color selectforeground - text color of selected items selectbackground - background color of selected items borderwidth - extra border width, in pixels, around the listbox selectborderwidth - extra border width around listbox text - items for 3D effect selectmode - single, browse, multiple, or extended. - See main documentation setgrid - if true, restrict resizing to whole number - of lines and chars cursor - cursor to display when mouse is over listbox relief - relief for entire listbox highlightthickness - thickness of additional border - used to indicate focus highlightbackground - color of additional border - when listbox does not have focus highlightcolor - color of additional border when listbox has focus takefocus - command to be executed when listbox receives focus yscroller - vertical scrollbar for the listbox, if any exportselection - if true exports selected text (XWindows only)
The following example creates a listbox which displays five items but contains twenty. We set the selectmode of the listbox in such a way as to allow multiple choices and associate a selection action which prints the listbox selection whenever a selection is made. A vertical scrollbar is then associated with the listbox. You can experiment with this small program by making various selections and scrolling the box up and down.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var lb; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Test Window"; -- caption the main window
lb := Tk("listbox",str(lb_len := 5)); lb("side") := "left";
-- create a listbox
lb(1..0) := ["Item" + str(j): j in [1..4 * lb_len]];
-- create the listbox items
lb("selectmode") := "multiple"; -- set listbox to allow multiple choices
lb{OM} := lambda(); print(lb(om)); end lambda;
sb := Tk("scrollbar","v,10"); -- create a thin vertical scrollbar
sb("side,fill") := "left,y";
-- pack to the left of the listbox, filling available vertical range
lb("yscroller") := sb; -- attach the scrollbar t the list box
Tk.mainloop(); -- enter the Tk main loop
end test;
The listbox operations xview_percent, yview_percent, xview_scroll, yview_scroll, xview, yview, and see can be used to adjust the view of a listbox which has too many items for them all to be visible at the same time. This is shown by the following example, which also illustrates the use of the listbox.select function, which sets the item or items in a listbox which are selected, and the listbox.s_select_line(lno)) function, which tests a specified line to determine if it is currently selected.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,lb; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Listbox operations";
-- create the Tk interpreter
lb := Tk("listbox",5); lb("side") := "top";
-- create a listbox, which shows 5 elements
lb(1..0) := "Item1Item1Item1Item1Item1***********,Item2,"
+ "Item3,Item4,Item5,Item6,Item7,Item8,Item9,Last Item";
-- put 10 elements, the first quite long, into the listbox
fr1 := Tk("frame","10,10"); fr1("side") := "top";
-- build and place a frame for first two buttons
but := fr1("button","See 6"); but("side") := "left";
-- put in a button
but{OM} := lambda(); lb.see(6); end lambda; -- click shows line 6
but := fr1("button","See 1"); but("side") := "left";
-- put in a second button
but{OM} := lambda(); lb.see(1); end lambda; -- click shows line 1
but := fr1("button","Select 2"); but("side") := "left";
-- put in a third button
but{OM} := lambda();
-- click selects line 2 and shows the selection state of 2 lines
print(lb.select(2,2));
print(lb.is_select_line(1)); print(lb.is_select_line(2));
end lambda;
fr2 := Tk("frame","10,10"); fr2("side") := "top";
-- build and place a frame for next two buttons
but := fr2("button","View right"); but("side") := "left";
-- put in a button
but{OM} := lambda(); lb.xview_percent(0.50); end lambda;
-- bind a percentage right shift of view
but := fr2("button","View left"); but("side") := "left";
-- put in a second button
but{OM} := lambda(); lb.xview_percent(0.0); end lambda;
-- bind a horizontal shift back to left
fr3 := Tk("frame","10,10"); fr3("side") := "top";
-- build and place a frame for next two buttons
but := fr3("button","Scroll left"); but("side") := "left";
-- put in a button
but{OM} := lambda(); lb.xview_scroll(4,"units"); end lambda;
-- bind a rightward scrolling action
but := fr3("button","Scroll right"); but("side") := "left";
-- put in a second button
but{OM} := lambda(); lb.xview_scroll(-4,"units"); end lambda;
-- bind a leftward scrolling action
fr4 := Tk("frame","10,10"); fr4("side") := "top";
-- build and place a frame for next two buttons
but := fr4("button","View 6"); but("side") := "left";
-- put in a button
but{OM} := lambda(); lb.yview(6); end lambda;
-- bind a percentage downward shift of view
but := fr4("button","View 1"); but("side") := "left";
-- put in a second button
but{OM} := lambda(); lb.yview(1); end lambda;
-- bind a percentage upward shift of view
fr5 := Tk("frame","10,10"); fr5("side") := "top";
-- build and place a frame for next two buttons
but := fr5("button","View bottom"); but("side") := "left";
-- put in a button
but{OM} := lambda(); lb.yview_percent(0.5); end lambda;
but := fr5("button","View top"); but("side") := "left";
-- put in a second button
but{OM} := lambda(); lb.yview_percent(0.0); end lambda;
fr6 := Tk("frame","10,10"); fr6("side") := "top";
-- build and place a frame for next two buttons
but := fr6("button","Scroll down"); but("side") := "left";
-- put in a button
but{OM} := lambda(); lb.yview_scroll(1,"unit"); end lambda;
-- bind a downward scrolling action
but := fr6("button","Scroll up"); but("side") := "left";
-- put in a second button
but{OM} := lambda(); lb.yview_scroll(-1,"unit"); end lambda;
-- bind an upward scrolling action
print("Listbox length: ",#lb); -- get listbox length
Tk.mainloop(); -- enter the Tk main loop
end test;
9.12.B. Messages. Message widgets are used to display multiple lines of non-editable text. Their height is calculated automatically. Their attributes are:
text - text of message font - message text font anchor - message text anchor point: n,ne,e,se,s,sw,w,nw, center aspect - message width, as percentage of height justify - message justif. in its rectangle: left, right, or center textvariable - if non-null, names a Tk variable holding - the message's string - Note: this over-rides the 'text' attribute if it has been set foreground - text color background - background color width - message width, in characters for text borderwidth - message border width, in pixels relief - flat, sunken, raised, groove, or ridge highlightthickness - thickness of additional border - used to indicate focus highlightbackground - color of additional border when - label does not have focus highlightcolor - color of additional border when label has focus cursor - cursor to display when mouse is over message takefocus - see explanation found under the help keyword 'focus'The following mini-program displays a message.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Test Window"; -- caption the main window
msg := Tk("message","Messages\ncan\noccupy\nmany lines");
-- create and place a message
msg("side") := "left";
msg("font") := "{times 96}"; -- display in a large font
Tk.mainloop(); -- enter the Tk main loop
end test;
9.12.C. Labels. Label widgets are used to display multiple lines of non-editable text, images, or bitmaps. Their height in lines is specified explicitly. Their attributes are:
text - text of label font - label text font bitmap - bitmap to display instead of label text image - image to display instead of label text anchor - label text anchor point: n,ne,e,se,s,sw,w,nw, center justify - label justif. in its rectangle: left, right, or center textvariable - if non-null, names a Tk variable holding - the label's string - Note: this over-rides the 'text' attribute if it has been set foreground - text color background - background color width - label width, in characters for text, pixels for image height - label height, in characters for text, pixels for image borderwidth - label border width, in pixels relief - flat, sunken, raised, groove, or ridge highlightthickness - thickness of additional border - used to indicate focus highlightbackground - color of additional border when label - does not have focus highlightcolor - color of additional border when label - has focus cursor - cursor to display when mouse is over label padx,pady - size of extra padding space around label takefocus - see explanation found under the help keyword 'focus' wraplength - width, in pixels, at which wrap beginsHere is a small example showing the use of a label.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Test Window"; -- caption the main window
lab := Tk("label","Messages\ncan\noccupy\nmany lines,"
+ "\nand also display images\n "
+ "their height must be defined explicitly for them to be seen");
-- create and place a message
lab("side") := "left";
lab("height,font") := "6,{Times 36}";
-- their height must be defined explicitly for them to be seen
Tk.mainloop(); -- enter the Tk main loop
end test;
9.12.D. Sliders. Sliders are used to convert positions along a line into numerical values. They consist of a slider bar ('trough') and a sliding element. One can either drag the sliding element, of hold the mouse down in the trough, which causes the sliding element to move toward the mouse position.
The attributes of sliders are:
from,to - minimum and maximum slider values showvalue - display value with sliding element digits - number of digits in display value, if any resolution - round value to a multiple of this element orient - horizontal or vertical length,width - long and short dimensions of the slider trough sliderlength - length of the sliding element troughcolor - color of slider bar background - sliding element and surround color activebackground - color of sliding element when being dragged foreground - color of caption text state - normal, active, or disabled repeatdelay - delay till auto-stepping if click in trough repeatinterval - delay between auto-steps if click in trough bigincrement - slider step in response to command-left, command-up, etc. variable - if non-null, names a Tk variable holding the slider value cursor - cursor to display when mouse is over slider takefocus - see explanation found under the help keyword 'focus' borderwidth - slider additional border width, in pixels relief - flat, sunken, raised, groove, or ridge relief - for slider bar sliderrelief - flat, sunken, raised, groove, or ridge relief, - sliding element highlightthickness - thickness of additional border used - to indicate focus highlightbackground - color of additional border when slider - does not have focus highlightcolor - color of additional border when slider has focus label - label to be displayed with slider bar font - label font tickinterval - if nonzero, interval at which to display ticks command - command to invoke when value changesThe following program shows the dynamic connection of a slider's output value to a message which displays it. We set up a slider, a button and a message. Clicking on the button connects a display action to slider value changes; this display action simply writes the slider value to the message.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var slider,msg; -- globalize for use below
Tk := tkw(); Tk(OM) := "Test Window"; -- caption the main window
but := Tk("button","Connect slider"); but("side") := "top";
but{OM} := connect;
-- button-click calls a routine which connects the slider
-- to the output message
slider := Tk("scale","0,100"); -- create and place a slider
slider("side") := "top";
slider("orient") := "horizontal"; -- can be 'vertical'
slider("length,width") := "350,10"; -- physical size of slider
msg := Tk("message","Slider value appears here");
-- create and place a message widget
msg("side") := "top";
msg("font") := "{Times 96}"; -- set into large font
Tk.mainloop(); -- enter the Tk mailb := parent("listbox",3);
lb("side") := "left"; -- listbox shows 3 elements
procedure connect(); slider{OM} := show_val; end connect;
-- connects the slider to the output message
procedure show_val(v); msg(OM) := slider(OM); end show_val;
-- write the slider value to the output message
end test;
9.12.E. Textline widgets. Textline widgets 'texl' are editable single-line text entry areas. The text in a textline widget can be manipulated using string-like syntax: texl(m..n) designates characters m thru n, texl(OM) all the text in the widget, #texl the number of characters of text. In the expression texl(m..n), m and n can either be integers, or one of the following constants, designating special positions in the text within the widget:
anchor -- the index of the anchor point - (left, right, or center) of the selection end -- last character insert -- position of insertion cursor sel.first -- first selected character sel.last -- last selected characterA negative integer -n can be used to designate the character at horizontal screen position n. The attributes of textline widgets are:
state - normal or disabled (if disabled, text is read-only) font - text font show - character to display in place of contents foreground - text color background - text background color justify - left, right, or center selectbackground - background color for selected text selectforeground - foreground color for selected text selectborderwidth - width of selection border (for 3D selection effect) borderwidth - extra space around edge of text cursor - cursor to display when mouse is over canvas insertwidth - width of insertion cursor insertbackground - color of insertion cursor insertborderwidth - border width for insertion cursor, - if displayed in relief insertofftime,insertontime - blink times for insertion cursor highlightthickness - thickness of additional border used - to indicate focus highlightbackground - color of additional border when - widget does not have focus highlightcolor - color of additional border when - widget has focus relief - flat, sunken, raised, groove, or ridge exportselection - use XWindows selection export mechanism (XWindows only) takefocus - see explanation found under - the help keyword 'focus' textvariable - if non-null, names a Tk variable holding - the widget's string
We set up two textlines, one with a yellow and one with a green background, and one button. Clicking on either of the textlines sets the selection in the first of the textlines to cover characters 2 through 4. Clicking on the button sets the selection, again in the first textline, to cover characters 5 through 12. You can experiment with this program to see how textline selection and keyboard focus relate.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var tline; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Selection in textline";
-- create the Tk interpreter
tline := Tk("entry",30); tline("side") := "top";
-- create a first textline with a yellow background
tline("font,background,selectborderwidth") := "{times 48 bold},yellow,4";
tline(OM) := "Type more text here"; -- put some sample text into it
tline2 := Tk("entry",30); tline2("side") := "top";
-- create a second textline with a green background
tline2("font,background") := "{times 48 bold},green";
tline2(OM) := "Or here"; -- put some sample text into it
but := Tk("button","Or click here"); but("side") := "top";
tline{"ButtonRelease-1"} := set_selection;
-- bind set selection action to click on first textline
tline2{"ButtonRelease-1"} := set_selection;
-- bind identical action to click on second textline
but{OM} := set_selection2; -- bind set selection action to click on button
Tk.mainloop(); -- enter the Tk main loop
procedure set_selection(); -- set the selection in the first text line
tline("sel") := "2,4";
end set_selection;
procedure set_selection2(); -- set the selection in the first text line
tline("sel") := "5,12";
end set_selection2;
end test;
The following small program shows the textline 'xview_percent' and 'xview_scroll' operations, which can be used to shift the view of a long textline right or left; also the 'textline.select(from,to);'operation, which can be used to set the range of characters selected, and 'textline.index(index_name)', which returns the position of any one of a standard list of named indices, e.g. "insert", which names the current position of the insertion mark. We set up a textline and put more text than can be seen at any one time into it. The 'xview_percent' and 'xview_scroll' operations are then bound to buttons which can be used to scroll the textline left and right.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,tl; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Textline scrolling"; -- create the Tk interpreter
tl := Tk("entry","10"); tl("side") := "top"; -- create a textline
tl(OM) := "A0123456789 B0123456789 C0123456789 ";
-- put some text into it
fr1 := Tk("frame","10,10"); fr1("side") := "top";
-- build and place frame for next two buttons
but := fr1("button","View right"); but("side") := "left";
-- create a first button
but{OM} := lambda(); tl.xview_percent(0.5); end lambda;
-- bind jump-to-right action
but := fr1("button","View left"); but("side") := "left";
-- create a seconed button
but{OM} := lambda(); tl.xview_percent(0.0); end lambda;
-- bind jump-to-left action
fr2 := Tk("frame","10,10"); fr2("side") := "top";
-- build and place frame for next two buttons
but := fr2("button","Scroll left"); but("side") := "left";
-- create a third button
but{OM} := lambda();
tl.xview_scroll(1,"unit"); print(tl.index("insert"));
end lambda;
-- bind scroll bind scroll-right and show insertion point actions
but := fr2("button","Scroll right"); but("side") := "left";
-- create a fourth button
but{OM} :=
lambda(); tl.xview_scroll(-1,"unit"); tl.select(1,5); end lambda;
-- bind scroll-left and set selection actions
Tk.mainloop(); -- enter the Tk main loop
end test;
Note that 'xview_scroll' and 'xview_percent' are also available for text widgets, in which case similar 'yview_scroll' and 'yview_percent' operations are also provided. However, the 'wrap' attribute of a text area must be set to 'none' before horizontal changes of view become possible.
As indicated above, most of the vital operations on interface widgets use SETL retrieval and assignment syntax like obj(attrib_list), obj(attrib_list) := att_vals, obj(i..j), obj(i..j) := x, obj(OM) := x, obj(x,y) := x, etc. However, the are various operations for which this is inconvenient, for which a more standard 'object method' syntax is therefore used. This section enumerates all remaining operations of the SETL graphical interface, irrespective of the syntactic form in which they are available.
Attributes and operations available for all widgets.The expression
w("type")
returns the type of any SETL widget w.
Manipulation of the widget rendering order. The operation
obj.raise(after_obj);
raises the 'rendering order' position of the object 'obj' to just after that of 'after_obj', or to the last place in the 'rendering order' if after_obj = OM. Since objects rendered later in this order cover objects rendered earlier if they overlap, this can affect the rendered appearance of a collection of widgets. Similarly, the operation
obj.lower(before_obj);
lowers the rendering order position of the object obj to just before that of 'before_obj', or to the first place in the rendering order if before_obj = OM.
The following program illustrates these operations. It creates two buttons, and forces them to the same position by giving them the same gridded position. Initially the second button is at the top of the 'rendering order', but clicking each button moves the other to the top, and so makes it visible.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var but1,but2; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but1 := Tk("button","Button1"); but1("row,column") := "1,1";
-- create a first button
but1{OM} := lambda(); but2.raise(but1); end lambda;
-- bind a click callback to it
but2 := Tk("button","Button2"); but2("row,column") := "1,1";
-- create a second button, in the same place
but2("font") := "Helvetica"; -- give it a visibly different font
but2{OM} := lambda(); but1.raise(but2); end lambda;
-- bind a click callback to it
Tk.mainloop(); -- enter the Tk main loop
end test;
As the following example shows, the 'raise' and 'lower' operations are also available for Tk toplevel windows. In this context, they are performed by the system window manager, and so will move windows not only with respect to other Tk toplevels, but also with respect to any windows of the SETL IDE that happen to be open. The 'destroy' operation applies both to toplevels and to other widgets, and destroys a widget with all its descendants.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var win,win2; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
win := Tk("toplevel","300,100"); win(OM) := "Another Window";
win2 := Tk("toplevel","300,100"); win2(OM) := "Yet another Window";
but := Tk("button","Destroy Auxiliary window"); but("side") := "top";
-- create a button
but{OM} := lambda(); win.destroy(); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Raise Auxiliary window"); but("side") := "top";
-- create a button
but{OM} := lambda(); win.raise(OM); end lambda;
-- place mark anchoring following offsets
but := Tk("button","Raise Auxiliary window 2"); but("side") := "top";
-- create a button
but{OM} := lambda(); win2.raise(OM); end lambda;
-- move to right from (0,0)
but := Tk("button","Lower Auxiliary window 2"); but("side") := "top";
-- create a button
but{OM} := lambda(); win2.lower(OM); end lambda;
-- move to right from (0,0)
Tk.mainloop(); -- enter the Tk main loop
end test;
Miscellaneous Tk Utilities. The operation
obj.beeper(); -- utility beep procedure
which has been used in many of the preceding examples, beeps once,
obj.stopper(); -- destroys top level window, preliminary to exit
destroys the Tk top level window, and with it all subordinate windows, preliminary to exit. Note that until this is done the SETL interactive development environment remains frozen. The operation
obj.place(); -- returns object x and y coordinates if object was 'placed' in parent
returns the Tk object's x and y coordinates if the object 'ob' was 'placed' in its parent. All these are illustrated in the following short program. We open a new window into which a frame is put. A canvas is then put into this frame and given a green background. Three buttons are put into the main window. The first of these simply beeps when clicked, the second prints the place of the canvas, and the third exits Tk, illustrating the use of the 'stopper' method.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var ca; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- caption the main window
but := Tk("button","Beep"); but("side") := "left"; -- create a button
but{OM} := tk.beeper; -- bind beep action to button
win := Tk("toplevel","200,200"); Tk(OM) := "Has Green Box";
-- create a new window
fr := win("frame","200,200"); fr("side") := "left";
-- create a frame in this new window
ca := fr("canvas","100,100"); ca("place,x,y") := "50,50";
-- create and place a canvas in the frame
ca("background") := "green"; -- color it green
but := Tk("button","Get Place"); but("side") := "left";
-- create a button
but{OM} := lambda(); print(ca.place()); end lambda;
-- bind place display action to button
but := Tk("button","Stop"); but("side") := "left"; -- create a button
but{OM} := Tk.stopper; -- bind stop action to button
Tk.mainloop(); -- enter the Tk main loop
end test;
(A) Tag Manipulation for Canvas Items. The operation
canv_obj.addtag(newtag);
adds a new tag to a canvas item;
canv_obj.addtag_before(newtag);
adds a new tag to the canvas item immediately before canv_obj in the rendering order of canv_obj's parent canvas; and
canv_obj.addtag_after(newtag);
adds a new tag to the canvas item immediately after canv_obj in the rendering order of canv_obj's parent canvas. The following short program illustrates these operations. We set up a canvas and put three colored boxes into it. Several tags are added to the second box using the operations displayed above. Beeping actions are bound to these tags. You can experiment with this program to see how many beeps are produced by clicking on each box.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
-- put 3 colored boxes into the canvas
box2 := ca("rectangle","20,20,50,50"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
box2.addtag("beeping"); box2.addtag_after("beeping2");
-- add several tags to the blue box
box2.addtag_before("beeping3");
-- the 'beeping3' tag precedes the 'beeping' tag
ca{"beeping",OM} := Tk.beeper;
-- bind beep actions to the tags. These may beep multiple times
ca{"beeping2",OM} := lambda(); Tk.beeper(); Tk.beeper(); end lambda;
ca{"beeping3",OM} := lambda();
for j in [1..3] loop Tk.beeper(); end loop;
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The operation
canv_obj.addtag_if(newtag,hastag);
adds a new tag to all canvas items which already have the tag 'hastag'. The operation
canv.addtag_in(newtag,rect);
adds a new tag to all canvas items in the designated rectangle, or to all items in the canvas if rect = OM. This is illustrated by the following program. Again, we set up a canvas and put three colored boxes into it attaching several tags to the first of the boxes. Beeps are then bound to the tags. You can experiment with this to see which boxes have become click sensitive and correlate this with the tags that each box carries.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
-- put 3 colored boxes into the canvas
box2 := ca("rectangle","50,50,90,90"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
box1.addtag("box1_tag"); -- add an additional tag to box1
ca.addtag_if("beeping2","box1_tag");
-- add the tag 'beeping2' to all boxes in the canvas which already
-- carry the tag 'box1_tag'
ca.addtag_in("beeping","40,40,100,100");
-- add a tag ('beeping') to all boxes inside the specified rectangle
ca{"beeping",OM} := Tk.beeper;
-- bind a single beep action to tag 'beeping'
ca{"beeping2",OM} := lambda(); Tk.beeper; Tk.beeper; end lambda;
-- bind a double beep action to tag 'beeping'
Tk.mainloop(); -- enter the Tk main loop
end test;
Note again that
canv_obj("tags");
returns the list of all tags associated with a canvas item.
The operation
canv_obj.deltag(tags);
removes the specified tags from a canvas item. The operation
canv.deltag_if(iftag,tags_or_ids);
removes the specified tags from all items which have the tag 'iftag'. The operation
canv.addtag_nearest(newtag,xy,halo,before_tag);
adds the tag 'newtag' to the canvas object nearest to x,y, if 'halo' is OM, or if halo /= OM to the last canvas object (in the display list of the canvas) within the radius 'halo' of the distance to this nearest object. But if 'start' is not OM, it should be an integer designating a position in the canvas display list, in which case this operation will affect the last such item coming before that carrying the tag 'before_tag' in the canvas display list.
The following example shows the action of 'deltag' and 'deltag_if'. Once more we set up a canvas and put three colored boxes into it. A variety of tags are then attached to these boxes. The 'tags' attribute of canvas objects is then used to display these tags. After this some of the tags are deleted using the operations 'deltag' and 'deltag_if' and the remaining tags displayed.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
-- put 3 colored boxes into the canvas
box2 := ca("rectangle","20,20,50,50"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
box2.addtag("beeping"); box2.addtag_after("beeping2");
-- add several tags to the blue box
box2.addtag_before("beeping3"); -- add the 'beeping3' tag to box 1
box2.addtag_after("beeping2"); -- add the 'beeping2' tag to box 3
ca.addtag_if("weeping2","beeping2");
-- this will add the 'weeping2' tag to box 3
ca.addtag_if("weeping","beeping");
-- this will add the 'weeping' tag to box 2
box3.addtag("beeping4"); -- add the 'beeping4' tag to box 3
box1.addtag("beeping4"); -- add the 'beeping4' tag to box 1
print("box1 tags: ",box1("tags")); -- show the tags for all the boxes
print("box2 tags: ",box2("tags"));
print("box3 tags: ",box3("tags"));
box2.deltag("beeping"); -- delete the 'beeping' tag from box 1
ca.deltag_if("beeping2","beeping4");
-- delete the 'beeping4' tag from all boxes that carry the 'beeping2' tag
print("\nafter deletions - box1 tags: ",box1("tags"));
-- show the tags for all the boxes again
print("after deletions - box2 tags: ",box2("tags"));
print("after deletions - box3 tags: ",box3("tags"));
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
box1 tags: ["beeping3", "beeping4"] box2 tags: ["beeping", "weeping"] box3 tags: ["beeping2", "weeping2", "beeping4"] after deletions - box1 tags: ["beeping3", "beeping4"] after deletions - box2 tags: ["weeping"] after deletions - box3 tags: ["beeping2", "weeping2"]
The following example shows the action of 'addtag_nearest'. We set up the same configuration of colored boxes as before and then use the 'addtag_nearest' operation to attach various tags to them. The attached tags are then displayed. You will want to think through the geometry of this example to understand which of the boxes require tags.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
-- put 3 colored boxes into the canvas
box2 := ca("rectangle","20,20,50,50"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
ca.addtag_nearest("beeping","0,0",OM,OM);
-- add 'beeping' to the box nearest 0,0
print("box1 tags: ",box1("tags")); -- show the tags for all the boxes
print("box2 tags: ",box2("tags"));
print("box3 tags: ",box3("tags"));
ca.addtag_nearest("beeping2","0,0",30,OM);
-- add 'beeping2' to the last box within radius 30 of 0,0
ca.addtag_nearest("beeping3","0,0",20,OM);
-- add 'beeping3' to the last box within radius 20 of 0,0
ca.addtag_nearest("beeping4","0,0",30,"beeping2");
-- 'beeping3' to the last box within radius 30 of 0,0
print("\nbox1 tags after: ",box1("tags"));
-- show the tags for all the boxes again
print("box2 tags after: ",box2("tags"));
print("box3 tags after: ",box3("tags"));
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
box1 tags: ["beeping"] box2 tags: [] box3 tags: [] box1 tags after: ["beeping", "beeping3", "beeping4"] box2 tags after: ["beeping2"] box3 tags after: []
(A) Item deletion from a canvas. The operation
canv_obj.delete();deletes the specified canvas item;
canv.delete_items(tags);
deletes all items which carry any member of the specified list of tags. This is illustrated by the following program, which deletes the blue rectangle when the first button is clicked, but the red rectangle when the second button is clicked.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,box2,ca; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Click"); but("side") := "top";
-- create and place a first button
but{OM} := lambda(); box2.delete(); end lambda;
-- the click deletes box 2
but2 := Tk("button","Click2"); but2("side") := "top";
-- create and place a second button
but2{OM} := lambda(); ca.delete_items("tag1"); end lambda;
-- the click deletes all items carrying 'tag1'
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
-- put 3 colored boxes into the canvas
box2 := ca("rectangle","50,50,90,90"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
ca.addtag_nearest("tag1","10,10","20","1");
-- add 'tag1' to the boxes within distance 20 of the box nearest 10,10
Tk.mainloop(); -- enter the Tk main loop
end test;
Tags attached to canvas items can also be used to organize them into groups which can be moved backwards and forwards in the canvas' rendering order.
This is done using the operations
canvas.raise_tid(tag_name,tag_before); and canvas.lower_tid(tag_name,tag_after);
'raise_tid(tag_name,tag_before);' raises all the items carrying the designated tag_name to the front of the rendering order if tag_before is OM, or otherwise to just before the item tagged with 'tag_before'. 'lower_tid(tag_name,tag_after);' lowers all the items carrying the designated tag_name to the rear of the rendering order if tag_after is OM, or otherwise to just before the item tagged with 'tag_after'. We also show the use of the expressions
canvas_obj.find_after() and canvas_obj.find_before()
which respectively return the object just after and just before the designated canvas_obj. The program which follows sets up a canvas and puts three geometric shapes and some canvas text into it. Separate tags are added to the inserted rectangle and oval, but a common tag is attached to the inserted spline shape and canvas text. Then we set up a set of six buttons which raise and lower the tagged items, either to the very top or bottom of the rendering order, or to a position just before or just after the red box. You can experiment with these buttons to explore the use of the 'raise_tid' and 'lower_tid' operations.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var ca,rect; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Raising and lowering tagged items";
-- create the Tk interpreter
ca := Tk("canvas","300,100"); ca("side") := "top";
-- create a canvas with a grey background
ca("background") := "#cccccc";
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put three items into the canvas
oval := ca("oval","5,20,100,40"); oval("width") := 5;
poly := ca("polygon","60,60,100,60,100,0,40,0");
poly("fill,smooth") := "blue,true";
ct := ca("text","Text in the canvas"); -- put some text into the canvas
ct("coords") := "10,10"; ct("anchor,font,fill") := "nw,{Times 36},yellow";
rect.addtag("box"); -- add identifying tags to the canvas items
oval.addtag("round");
poly.addtag("spline_text");
ct.addtag("spline_text");
but := Tk("button","Move rect forward"); but("side") := "top";
-- create a button
but{OM} := lambda();
ca.raise_tid("box",OM); print("\n",rect.find_after());
print(rect.find_before());
end lambda;
-- when clicked, raises 'rect' to the top, and prints items
-- just before and just after
but := Tk("button","Move rect backward"); but("side") := "top";
-- create a button
but{OM} := lambda();
ca.lower_tid("box",OM); print("\n",rect.find_after());
print(rect.find_before());
end lambda;
-- when clicked, lowers 'rect' to the bottom, and prints items
-- just before and just after
but := Tk("button","Move spline and text forward"); but("side") := "top";
-- create a button
but{OM} := lambda(); ca.raise_tid("spline_text",OM); end lambda;
-- when clicked, raises spline and text to the top
but := Tk("button","Move spline and text backward"); but("side") := "top";
-- create a button
but{OM} := lambda(); ca.lower_tid("spline_text",OM); end lambda;
-- when clicked, lowers spline and text to the bottom
but := Tk("button","Raise oval to just before box"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(ca.raise_tid("round","box")); end lambda;
-- when clicked, raises 'oval' to the position just before 'rect'
but := Tk("button","Lower oval to just after box"); but("side") := "top";
-- create a button
but{OM} := lambda(); print(ca.lower_tid("round","box")); end lambda;
-- when clicked, lowers 'oval' to the position just after 'rect'
Tk.mainloop(); -- enter the Tk main loop
end test;
(A) Tag-based search for Canvas Items. many of the tag manipulation operations described above have 'search' analogs which find the canvas items associated with specified tags.
The operation
canv.find(tag);
returns the list of objects in the specified canvas which carry the specified tag. The operation
canv_obj.find_before();
finds the canvas item immediately before canv_obj in the rendering order of canv_obj's parent canvas; and
canv_obj.find_after();
finds the canvas item immediately after canv_obj in this order. Both these routines return a canvas object. These three operations are illustrated by the following small program, which deletes the red and then the grey rectangle when the first button is clicked, since the have been placed behind the blue rectangle in the canvas shown and so come before the blue rectangle in rendering order. Similarly clicking on the second button deletes the green rectangle, which comes after the blue rectangle in rendering order. Finally, the 'canvas.find(tag_name)' operation, invoked by the third button, is used to locate and then delete the blue rectangle.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ca,box2; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box0 := ca("rectangle","5,5,35,35"); box0("fill") := "grey";
-- put 4 colored boxes into the canvas
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
box2 := ca("rectangle","5,25,90,90"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
box2.addtag("greenbox");
but := Tk("button","Delete behind blue"); but("side") := "top";
-- create and place a button
but{OM} := lambda();
if (b2 := box2.find_before()) /= OM then b2.delete(); end if;
end lambda;
-- bind the button's click event to deletion of the
-- canvas item preceding the green box
but := Tk("button","Delete in front of blue"); but("side") := "top";
-- create and place a button
but{OM} := lambda(); b2 := box2.find_after();
if b2 /= OM then print(b2.delete()); end if;
end lambda;
-- bind the button's click event to deletion of the
-- canvas item preceding the green box
but := Tk("button","Delete blue"); but("side") := "top";
-- create and place a button
but{OM} := lambda(); b2_list := ca.find("greenbox")?[];
for b2 in b2_list loop b2.delete(); end loop;
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The operation
canv.find_in(rect);
returns the list of all items in the specified canvas which are contained in the specified rectangle (or the entire canvas if rect = OM), while
canv.find_touching(rect);
returns the list of all such items which touch the specified rectangle. For example, clicking the first (resp. second) button in the following program deletes the red (resp. red and green) rectangle. To see that this is the case you will want to think through the geometry of the configuration, in particular, the placement of the boxes which appear in the 'find_in' and 'find_touching' operations seen.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ca; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Click"); but("side") := "top";
-- create and place a first button
but2 := Tk("button","Click2"); but2("side") := "top";
-- create and place a second button
but{OM} := lambda();
-- bind its click event to deletion of all items within
-- the specified rectangle
for x in ca.find_in("9,5,45,45") loop
x.delete();
end loop;
end lambda;
but2{OM} := lambda();
-- bind its click event to deletion of all items touching
-- the specified rectangle
for x in ca.find_touching("20,20,45,45") loop
x.delete();
end loop;
end lambda;
ca := Tk("canvas","100,100"); ca("side") := "top";
-- create and place a canvas in the window
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
-- put 3 colored boxes into the canvas
box2 := ca("rectangle","50,50,90,90"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
Tk.mainloop(); -- enter the Tk main loop
end test;
The operation
canv.find_nearest(xy,halo,start);
finds the canvas item nearest to the point xy. If the 'halo' and 'start' parameters are not OM, they have the same effect as in the 'addtag_nearest' operation.
canv.bbox(tags_or_items);
gets the smallest bounding rectangle of the collection of canvas items which carry the tags 'tags_or_items' if this parameter is either a string or a tuple of strings, but of the items listed if tags_or_items is a list of canvas items.
Finally, the operations
canv.canvasx(x,roundto); and canv.canvasy(y,roundto);
map from screen to canvas coordinates, possibly rounded to grid units.Button Operations The operation
but.invoke_button();triggers the designated button's principal command, if any. Note also that
but("selected") := 1; and but("selected") := 0;
respectively select/deselect radio buttons and checkbuttons.
The following small program illustrates the use of 'invoke_button'. We set up a canvas containing three colored rectangles as before. Two buttons are also set up, the first of which merely invokes the action of the second button whereas the second buttons deletes the boxes. You will see that clicking on either button has then the effect of deleting the boxes.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ca,but; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Delete"); but("side") := "top";
-- create and place a first button
but2 := Tk("button","Just flash the Delete button"); but2("side") := "top";
-- create and place a second button
but3 := Tk("button","Invoke the Delete button"); but3("side") := "top";
-- create and place a third button
but{OM} := lambda();
-- bind click action of first button to deletion of all boxes inside
-- the specified rectangle
for x in ca.find_in("9,5,45,45") loop x.delete(); end loop;
end lambda;
but2{OM} := lambda(); but.flash(); end lambda;
-- bind click action of second button to flash of the first button
but3{OM} := lambda(); but.invoke_button(); end lambda;
-- bind click action of second button to invocation of the first button
ca := Tk("canvas","100,100"); ca("side") := "top";
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
box2 := ca("rectangle","50,50,90,90"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
Tk.mainloop(); -- enter the Tk main loop
end test;
Our next example shows the effect of setting the "selected" attribute of radio buttons and checkbuttons. it also illustrates the 'flash' and 'invoke' operations for widgets of this type. We create two radio buttons and two check boxes in a window, along with two sets of four buttons each. These buttons trigger actions which select, deselect, flash, or invoke one of the radio buttons or checkbuttons. By using them you can see what their graphical effects are and verify that only the 'invoke' action triggers the selection response (in this case, a simple print operation) bound to the radio button or checkbutton affected.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,rbut1,rbut2,ckbut1,ckbut2; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Radiobutton Selection Test";
-- create the Tk interpreter
fr1 := Tk("frame","10,10"); fr1("side") := "top";
-- create two frames for the buttons
fr2 := Tk("frame","10,10"); fr2("side") := "top";
rbut1 := fr1("radiobutton","Label1"); rbut1("side") := "left";
-- create two radio buttons in the first frame
rbut2 := fr1("radiobutton","Label2"); rbut2("side") := "left";
rbut1{OM} := lambda(); print("rbut1 changed"); end lambda;
-- bind an output action to the first radio button
rbut1("variable,value") := "xr,r1"; rbut2("variable,value") := "xr,r2";
but := fr1("button","Select"); but("side") := "left";
-- create two ordinary buttons in the first frame
but{OM} := lambda(); rbut1("selected") := "1"; end lambda;
-- click on first ordinary button sets the radio button
but := fr1("button","Deselect"); but("side") := "left";
but{OM} := lambda(); rbut1("selected") := "0"; end lambda;
-- click on second ordinary button drops the radio button
but := fr1("button","Flash"); but("side") := "left";
but{OM} := lambda(); rbut1.flash(); end lambda;
-- click on third ordinary button flashes the radio button
but := fr1("button","Invoke"); but("side") := "left";
but{OM} := lambda(); rbut1.invoke(""); end lambda;
-- click on fourth ordinary button invokes the radio button
ckbut1 := fr2("checkbutton","Label1"); ckbut1("side") := "left";
-- create two checkbuttons in the second frame
ckbut2 := fr2("checkbutton","Label2"); ckbut2("side") := "left";
ckbut1{OM} := lambda(); print("ckbut1 changed"); end lambda;
-- bind an output action to the first checkbutton
ckbut1("variable,offvalue,onvalue") := "x,r1,r2";
ckbut2("variable,offvalue,onvalue") := "y,r1,r2";
but := fr2("button","Select"); but("side") := "left";
-- create two ordinary buttons in the second frame
but{OM} := lambda(); ckbut1("selected") := "1"; end lambda;
-- click on first ordinary button sets the checkbutton
but := fr2("button","Deselect"); but("side") := "left";
but{OM} := lambda(); ckbut1("selected") := "0"; end lambda;
-- click on second ordinary button drops the checkbutton
but := fr2("button","Flash"); but("side") := "left";
but{OM} := lambda(); ckbut1.flash(); end lambda;
-- click on third ordinary button flashes the checkbutton
but := fr2("button","Invoke"); but("side") := "left";
but{OM} := lambda(); ckbut1.invoke(""); end lambda;
-- click on fourth ordinary button invokes the checkbutton
Tk.mainloop(); -- enter the Tk main loop
end test;
The operation
but.flash();
causes the designated button to flash, but does not invoke it. This is seen by clicking on the second button in the following example. The program emphasizes the difference between the 'flash' and the 'invoke' operations. It creates three buttons and a canvas containing three colored rectangles. An action deleting one of the rectangles is bound to the first button. The the second button just 'flashes the first, whereas the third button 'invoke's the first button. By experimenting you can see that 'flash' does not trigger the deletion action of the fist button, but that 'invoke' does.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ca,but; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Delete"); but("side") := "top";
-- create and place a first button
but2 := Tk("button","Just flash the Delete button"); but2("side") := "top";
-- create and place a second button
but{OM} := lambda();
-- bind click action of first button to deletion of all boxes inside
-- the specified rectangle
for x in ca.find_in("9,5,45,45") loop x.delete(); end loop;
end lambda;
but2{OM} := lambda(); but.flash(); end lambda;
-- bind click action of second button to flash of the first button
ca := Tk("canvas","100,100"); ca("side") := "top";
box1 := ca("rectangle","10,10,40,40"); box1("fill") := "red";
box2 := ca("rectangle","50,50,90,90"); box2("fill") := "blue";
box3 := ca("rectangle","30,30,60,60"); box3("fill") := "green";
Tk.mainloop(); -- enter the Tk main loop
end test;
Textline Operations The interface sees the contents of a textline as a kind of string, so operations like
textl(i..j) := stg2; stg := textl(i..j); and #textl
have the expected effects. The operation stg := textl(i..OM); gets all the characters of the textline's contents from the i-th character to the end. various string expressions, namely "sel.anchor", "end", "insert", "sel.first", and "sel.last" designate character positions in a textline; the operation
textl.index(index_key)
gets the numerical value of any such index_key. Here "insert" designates the position of the insert mark, "sel.first", and "sel.last" the position of the first and last selected characters (OM is returned if there is no selection) and "sel.anchor" designates the character position from which a selection would be extended, e.g. by a Shift-click. Integer values of index_key can also be used, in which case the index of the character at the designated horizontal bit-position is returned.
Assignments of the form
textl("sel") := ij;
and
textl("sel.anchor") := k;
can be used to set the selection boundaries and anchor position in a textline. Here ij should either be a pair of integers, an integer i (representing the pair [i,i]), or a comma-separated string representing such a pair.
The following program illustrates these remarks. Note that the selection in a textline only becomes visible when the textline gets the focus, so before clicking on the buttons displayed by the program you should click somewhere in the textline.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ent; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ent := Tk("entry","20"); ent("side") := "top";
-- create and place a text entry line
ent(OM) := "toptoptoptoptop"; ent("font") := "{Times 24}";
-- put some fonted text in it
sc := Tk("scrollbar","h,12"); sc("side,fill") := "top,x";
but := Tk("button","Set the selection to 2,6"); but("side") := "top";
-- create and place a first button
but2 := Tk("button","Set the selection to 14,14"); but2("side") := "top";
-- create and place a second button
but3 := Tk("button","Set the insertion point to 3"); but3("side") := "top";
-- create and place a third button
but{OM} := lambda();
ent(1..1) := "inserted"; ent("sel") := "2,6";
end lambda;
-- bind an insertion and selection-set action to click on
-- the first button
but2{OM} := lambda();
print(ent(5..10)); ent("sel") := "14,14";
end lambda;
-- bind a print and selection-set action to click on the second button
but3{OM} := lambda(); ent("insert") := "3"; end lambda;
-- bind relocation of the insertion point to click on the third button
Tk.mainloop(); -- enter the Tk main loop
end test;
As explained in section AAA and illustrated by the following short program, horizontal (but not vertical) scrollbars can be attached to textline widgets.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
ent := Tk("entry","6"); ent("side") := "top";
-- create and place a text entry line
ent(OM) := "toptoptoptoptop";
ent("font") := "{Sabon 24}";
-- put some fonted text in it
sc := Tk("scrollbar","h,12"); sc("side,fill") := "top,x";
ent("xscroller") := sc; -- attach horizontal scrollbar
Tk.mainloop(); -- enter the Tk main loop
end test;
Textline widgets can also be scrolled under program control. The operation
textl("xview") := n;
scrolls a textline to make its n-th character visible;
textl("xpercent") := p;
positions it so as to place the percentage p of its string contents invisible to the textline's left. The operation
textl.xview_scroll(n,what);
moves the textline contents by n characters if 'what' is OM, but by n 'pages' (textlines full) if 'what' is "pages".
The following short program illustrates these operations. We set up a textline and put more text into it than can be seen at any one time. The view-shift and scrolling operations listed above are then bound to buttons and used to reposition the textline in various ways.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,ent; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
Tk(OM) := "Textline Scrolling Modes";
ent := Tk("entry","20"); ent("side") := "top";
-- create and place a text line widget
ent(OM) := "A123456789B123456789C123456789D123456789";
-- put some text into it
ent("font") := "{Times 24}"; -- use a comfortable font
but := Tk("button","View character 5"); but("side") := "top";
-- create and place six buttons
but2 := Tk("button","View character 15"); but2("side") := "top";
but3 := Tk("button","View character 35"); but3("side") := "top";
but4 := Tk("button","50% offscreen to the left"); but4("side") := "top";
but5 := Tk("button","Scroll 3 units"); but5("side") := "top";
but6 := Tk("button","Scroll -1 page"); but6("side") := "top";
but{OM} := lambda(); ent("xview") := 5; end lambda;
-- bind scrolling actions to first 3 buttons
but2{OM} := lambda(); ent("xview") := 15; end lambda;
but3{OM} := lambda(); ent("xview") := 35; end lambda;
but4{OM} := lambda(); ent("xpercent") := 50; end lambda;
-- bind 'percent' scrolling action to button 4
but5{OM} := lambda(); ent.xview_scroll(3,OM); end lambda;
-- bind 'absolute' scrolling action to button 4
but6{OM} := lambda(); ent.xview_scroll(-1,"pages"); end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The bounding box of the n-th character in a textline is returned by the expression
textl.bbox(n)
Slider Operations. The expression slid(OM) retrieves, and the command
slid(OM) := x;
sets a slider's value, repositioning it appropriately, as shown by the following short program, which creates a slider and two buttons which are bound to operations which set the slider value.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); -- create the Tk interpreter
Tk(OM) := "Interactive interface example 1";
slider := Tk("scale","0,100");
-- parameters are lower and upper limit of slider range
slider("side") := "top";
slider("orient,length") := "horizontal"; -- can be 'vertical'
slider("length,width") := "350,10"; -- physical size of slider
but := Tk("button","Set slider value = 30"); but("side") := "top";
-- create and place a first button
but{OM} := lambda(); slider(OM) := 30; end lambda;
but2 := Tk("button","Reduce slider value by 1"); but2("side") := "top";
-- create and place a second button
but2{OM} :=
lambda(); slider(OM) := slider(OM) - 1; end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The expression
slid.get(ij)
returns the slider value corresponding to the pixel position ij of the slider trough (relative to the toplevel window containing the slider). The related operation
slid.identify(ij)
returns one of the values "trough1", "slider", or "trough2", whichever designates the part of the slider underneath the point at pixel position i (relative to the toplevel window containing the slider). The function
slid.coords(n)
is a near inverse of 'slid.get(ij)'; it returns the geometric position (relative to the toplevel window containing the slider) corresponding to the slider value i.
The following simple program illustrates the use of these three expressions. It creates a slider and three buttons. The first button uses the 'identify' operation three times to print the parts of the slider over which each of three selected points lie. The second gets the slider value corresponding to a given pixel location (relative to the slider). The thirds gets the pixel location corresponding to the slider's current value.
program test; -- SETL interactive interface example 1
use tkw,string_utility_pak; -- use the main widget class
var Tk,slider;
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
slider := Tk("scale","0,100"); slider("side") := "top";
-- create a horizontal slider
slider("orient") := "horizontal";
slider("length,width") := "350,10"; -- set physical size of slider
slider(OM) := 66; -- initialize the slider value
fr := Tk("frame","10,10"); fr("side") := "top";
-- create a frame for the following buttons
but := fr("button","Identify"); but("side") := "left";
-- create a button bound to the 'identify' action
but{OM} := lambda();
print(slider.identify("50,24")," ",slider.identify("250,24")
," ",slider.identify("220,24"));
end lambda;
but := fr("button","Value from Location"); but("side") := "left";
-- create a button bound to the slider 'get' action
but{OM} := lambda(); print(slider.get("150,0")); end lambda;
but := fr("button","Location from Value"); but("side") := "left";
-- create a button bound to the slider 'coords' action
but{OM} := lambda(); print(slider.coords(slider(OM))); end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
Most of the slider operations described in the last few paragraphs apply to scrollbars also.
Listbox Operations. Since the graphical interface treats a listbox as something like a tuple of strings, #listb gives the number of elements of a listbox (i.e. its total number of elements, not the number of visible elements), and listb(i..j) is the tuple of elements i thru j. Also, as the following program shows, elements can be inserted and deleted by writing listb(i..j) := replacement_elements, where 'replacement_elements' is either a tuple of new elements or a comma-separated string of such elements.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,lb; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
Tk(OM) := "Listbox Scrolling Modes";
fr := Tk("frame","1,1"); fr("side") := "top";
lb := fr("listbox",3); lb("side") := "left"; -- listbox shows 3 elements
lb(1..0) := "Item1,Item2,Item3,Item4,Item5,Item6,Item7,Item8,Item9,Item10";
-- listbox contains 10 elements, so a scrollbar is attached
lb("yscroller") := scroller := fr("scrollbar","v,10"); -- attach a scrollbar
lb("width") := 12;
scroller("side,fill") := "left,y";
-- scrollbar fills available vertical space
print(#lb," ",lb(1..#lb),"\n",lb(2..5));
but := Tk("button","Modify listbox"); but("side") := "top";
-- create and place a button
but{OM} := lambda();
lb(2..1) := "Prior to 2";
lb(5..6) := "Replacement 1,Replacement 2,Replacement 3";
end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The program shown above sets up a scrolling listbox and adds a button which modifies the list of items in the listbox by making slice assignments to it. You can experiment with this program to see that item replacements are made independent of the scroll position of the listbox. Listboxes can be scrolled vertically and horizontally under program control. The operation
listb("yview") := n;
scrolls a listbox to make its n-th line visible;
listb("ypercent") := p;
positions it so as to place the percentage p of its elements invisible above the listbox's top. The corresponding horizontal scrolling operations listb("xview") := n; and listb("xpercent") := p; are also available, and, as the following example shows, horizontal scrollbars can also be attached to listboxes. We set up a listbox which shows three items, but then put ten items of which one is too long to see at any one time into the listbox. Horizontal and vertical scrollbars are then attached to the listbox. We also introduce three buttons which use assignments to the special variables 'yview', 'ypercent', and 'xview' to change the listbox position.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,lb; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Listbox Scrolling Modes, Example 2";
fr := Tk("frame","100,100"); fr("side") := "top";
lb := fr("listbox",3); lb("row,column") := "1,1"; -- listbox shows 3 elements
lb(1..0) := "Item1,A very long item that just goes on and on, " +
"Item3,Item4,Item5,Item6,Item7,Item8,Item9,Item10";
-- listbox contains 10 elements, some very wide, so
-- scrollbars are attached
lb("width") := 12;
lb("yscroller") := scroller := fr("scrollbar","v,10"); -- attach a scrollbar
lb("xscroller") := scroller2 := fr("scrollbar","h,10"); -- attach a scrollbar
scroller("row,column,sticky") := "1,2,news";
-- scrollbar fills available vertical space
scroller2("row,column,sticky") := "2,1,news";
-- scrollbar fills available horizontal space
but := Tk("button","View element 8"); but("side") := "top";
-- create and place a first button
but{OM} := lambda(); lb("yview") := 8; end lambda;
-- bind a view change to the button click
but2 := Tk("button","View middle third"); but2("side") := "top";
-- create and place a second button
but2{OM} := lambda(); lb("ypercent") := 0.33; end lambda;
-- bind a percentage view change to the button click
but3 := Tk("button","View character 20"); but3("side") := "top";
-- create and place a third button
but3{OM} := lambda(); lb("xview") := 20; end lambda;
-- bind a horizontal view change to the button click
Tk.mainloop(); -- enter the Tk main loop
end test;
The operation
listb.yview_scroll(n,what);
moves the listbox contents vertically by n lines if 'what' is OM, but by n 'pages' (visible boxes full) if 'what' is "pages".
listb.xview_scroll(n,what);
moves the listbox contents horizontally by n characters if 'what' is OM, but by n 'pages' if 'what' is "pages".
Listboxes can operate in one of several modes, determined by their 'selectmode' attribute, which can have one of the values 'single', 'browse', 'multiple', or 'extended'. When the listbox is in 'single' mode, any one element at a time can be selected. In 'multiple' mode, any subset of elements can be selected; clicking on an element toggles it between selected and unselected status. In 'extended' mode, the selected elements form a contiguous range, extended in the familiar way by shift-clicks. 'browse' mode, which is the default, is like 'single' mode, but allows the selection to be dragged.
Assignments of the form
listb("sel") := ij;
can be used to set the selected elements in a listbox. Here ij should either be a pair of integers, an integer i (representing the pair [i,i]), or a comma-separated string representing such a pair.
The expression
listb(OM)
returns the list of currently selected items in a listbox.
Various special names can be used to designate items in a listbox. These include "active" (a specially designated listbox item, which in some implementation will appear underlined), and "sel.anchor" (the character position from which a selection would be extended, e.g. by a Shift-click.) The 'active' listbox item can be set using the operation
lb("active") := n;
The expression
listb.nearest(n)
returns the index of the visible listbox element nearest to vertical pixel position n (in the listbox's enclosing toplevel window.) These are illustrated in the following example. Again, we create a listbox that displays three items but put ten items including one long item into the list box. The vertical scrolling action 'yview_scroll' is then attached to a pair of buttons and invocation of the 'nearest' function is bound to a third. An assignment to the special listbox attribute 'sel', which sets the selected item of the listbox, is bound to a final button. Experimenting with this program will show the action of all of these operations.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,lb; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Listbox Scrolling Modes, Example 2";
fr := Tk("frame","100,100"); fr("side") := "top";
lb := fr("listbox",3); lb("row,column") := "1,1"; -- listbox shows 3 elements
lb(1..0) := "Item1,A very long item that just goes on and on, " +
"Item3,Item4,Item5,Item6,Item7,Item8,Item9,Item10";
-- listbox contains 10 elements, some very wide, so
-- scrollbars are attached
lb("width") := 12;
lb("yscroller") := scroller := fr("scrollbar","v,10"); -- attach a scrollbar
lb("xscroller") := scroller2 := fr("scrollbar","h,10"); -- attach a scrollbar
scroller("row,column,sticky") := "1,2,news";
-- scrollbar fills available vertical space
scroller2("row,column,sticky") := "2,1,news";
-- scrollbar fills available horizontal space
but := Tk("button","Scroll Down"); but("side") := "top";
-- create and place a first button
but{OM} := lambda(); lb.yview_scroll(1,OM); end lambda;
-- attach scroll down action to button click
but := Tk("button","Scroll Up"); but("side") := "top";
-- create and place a second button
but{OM} := lambda(); lb.yview_scroll(-1,OM); end lambda;
-- attach scroll up action to button click
but2 := Tk("button","Select element 2"); but2("side") := "top";
-- create and place a third button
but2{OM} := lambda(); lb("sel") := 2; end lambda;
-- attach line selection to button click
but3 := Tk("button","Line Nearest Vert. Pixel 40"); but3("side") := "top";
-- create and place a fourth button
but3{OM} := lambda(); print(lb.nearest(40)); end lambda;
-- attach line identification to button click
Tk.mainloop(); -- enter the Tk main loop
end test;
Menu Operations. Since menus, like listboxes, are treated by the SETL graphical interfaces as being tuple-like, #menu gives the number of items in a menu, menu(i..j) returns the list of items i thru j of a menu, and menu(i..j) := item_list; replaces these items with the elements of the specified item_list, which should have the 'descriptor' format used to create menus, as described in See Section AAA, 'Menus and Menu Items'. That Section gives additional information about basic menu operations. As explained there, actions are attached to menu items by writing
men{j,OM} := action;
Such actions, normally triggered by selecting a menu item, can be triggered under program control by writing
men.invoke(j);
The following program illustrates this possibility. We set up a menu button and attach a five-item menu to it. Each of the first three menu items is bound to a beep action, and the last two menu items are bound to actions which change the menu itself, or which invoke the action bound to another menu item. You can experiment with this program to see how these bindings react to menu changes.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,mb,men; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
mb := Tk("menubutton","Pick Something");
-- create and place a menubutton
mb("side") := "left";
descriptor := "b:Item1,b:Item2,b:Item3,s,c:Item4,c:Item5";
-- setup a menu descriptor
mb(OM) := men := mb("menu",descriptor);
-- attach a menu to the menubutton
men{2,OM} := lambda();
for j in [1..3] loop Tk.beeper(); end loop;
end lambda;
-- bind beep actions to the menu items
but := Tk("button","Replace menu elts 3..4"); but("side") := "top";
-- create and place a first button
but{OM} := lambda();
men(3..4) := "b:NewItem2,s,b:NewItem3,s";
end lambda;
-- bind a menu change to the button click
but2 := Tk("button","Trigger Item 2 action"); but2("side") := "top";
-- create and place a second button
but2{OM} := lambda(); men.invoke(2); end lambda;
-- bind a selection action to the button click
Tk.mainloop(); -- enter the Tk main loop
end test;
Menu items can be referenced by name, and few special strings, can be used to refer to menu items. This is accomplished by using the expression
men.index(key).
which returns the numerical position of the menu item designated by "key'. Here, 'key' can either be a menu item's label or a string "@n", where n is an integer. This last form references the menu item at vertical pixel position n relative to the window which contains it when it is visible.
An approximate inverse of the expression men.index("@n") is given by
men.yposition(n),
which returns the vertical position that the top of entry n will have within the menu when posted. The expression
men.entry_type(n),
returns the type of menu entry n.
Menus, like listboxes, record an activated element, which can be set by writing
men("active") := n.
and read by using the expression men.index("active"). (This is not available on the Macintosh.)
The following short program illustrates these operations. We set up a menubutton and a five-item menu as before. The values returned by the four preceding expressions are simply printed.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,mb,men; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
mb := Tk("menubutton","Pick Something"); -- create a menubutton
mb("side") := "left";
descriptor := "b:Item1,b:Item2,b:Item3,s,c:Item4,c:Item5";
mb(OM) := men := mb("menu",descriptor); -- attach a menu
men{2,OM} :=
lambda(); for j in [1..3] loop Tk.beeper(); end loop; end lambda;
print(men.index("Item1"));
print(men.yposition(2));
print(men.entry_type(2));
print(men.entry_type(0));
Tk.mainloop(); -- enter the Tk main loop
end test;
The output produced is
2 31 command tearoff
Note that,as shown by the last two lines of output, item indexing in the 'entry_type' command is 0-based.
procedure postcascade(n); -- display menu in hierarchical position for entry n???Scrollbar Operations. In addition to the basic operations which tie scrollbars to scrollable widgets, described in Section AAA, a few special scrollbar operations are provided. Some scrollbar implementations (but not the Macintosh) allow the position (and in some implementations, the size) of a scrollbar's slider to be modified so as to reflect the currently visible fraction of the widget being scrolled by the scrollbar. Three statements are provided for this.
scrollb("position") := low_hi;
sets the slider's upper and lower limits; the expression scrollb("position") reads these values. Here 'low_hi' should either be a pair of decimal fractions (representing the upper and lower part of the controlled widget's visible extent, as a fraction of its total size), or a comma-delimited string representing such a pair. The expression
scrollb.fraction(x_or_y)
returns the fraction of the (horizontal or vertical) scrollbar that corresponds to the (vertical or horizontal) pixel position x_or_y; the related expression
scrollb.delta(x_or_y)converts a horizontal or vertical position change to a fraction of the scrollbar length. Much as for sliders, the expression
scrollb.identify(i)
returns one of the values "arrow1", "trough1", "slider", or "trough2", "arrow2", or "" (for positions not over the scrollbar) whichever designates the part of the scrollbar underneath the point at pixel position i (relative to the toplevel window containing the scrollbar). [But for horizontal scrollbars there may be a bug in this operation.] Finally, the expression
scrollb("active")and statements like
scrollb("active") := "slider"; -- or "arrow1" or "arrow2"can be used to set a scrollbar's 'active' element, which can be either "slider", "arrow1" or "arrow2". In some implementations of the interface, this can affect the relief of the designated scrollbar element. Note that 'fraction', 'identify', and 'scrollb("position")' can only be used once the window containing a scrollbar has been opened.
9.14. Dragging; Drag-and-drop control.
'Dragging', that is, moving graphic objects with the mouse, and the drag-and-drop control that can be built on top of it, are two of the most important design options afforded by graphical interfaces. As shown in the following program objects are dragged by capturing the mouse position when the mouse is pressed on an object to be dragged, and then by maintaining this object in the same position relative to the mouse as the mouse continues to move with the button held down. Dragging ends as soon as the button comes up.
The following program puts a canvas into the window that it displays, and a rectangle, an oval, and a spline curve into that canvas. All three of these canvas objects are made draggable, the rectangle explicitly, and the oval and spline curve by use of the 'drag_pak' package, discussed below. To make the rectangle draggable, we bind a routine that captures both its position and the position of the cursor when the button is pressed on the rectangle. We also bind a routine to the qualified motion event seen in the code, namely, 'B1-Motion'. The qualifier 'B1' indicates that these motion events are only to be generated while the first mouse button is down. Note also that both bindings carry the specification 'xy' which indicates that the x and y position of the mouse is to be captured at the moment of the event and transmitted to the event handler routine bound to it. As always these coordinates are joined into a single tuple and transmitted as such. The 'make_draggable' and 'make_vert_draggable' routines seen toward the end of the code are supplied by the 'drag_pak' package and make the object transmitted to them as their first parameter draggable (resp. vertically draggable). The three parameters set to OM in this example can represent procedures to be executed at drag start, during drag, and at drag-end respectively. This will be explained in more detail in our next example.
program test; -- SETL interactive interface example 1
use tkw,drag_pak; -- use the main widget class and the drag_pak routines
var Tk,rect; -- globalize for use in procedure below
var starting_posn,rect_coords; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Drag Test"; -- create the Tk interpreter
ca := Tk("canvas","300,300"); ca("side") := "left"; -- create a canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- out a rectangle, oval, and spline into it
oval := ca("oval","80,20,120,40"); oval("fill") := "green";
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
rect{"ButtonPress-1:xy"} := lambda(xy);
-- attach a drag-start action to the rectangle
starting_posn := [unstr(c): c in xy];
rect_coords := [unstr(c): c in rect("coords")];
end lambda;
rect{"B1-Motion:xy"} := lambda(xy);
-- attach a drag-response action to the rectangle
[now_canv_x,now_canv_y] := xy;
now_canv_x := float(unstr(now_canv_x));
now_canv_y := float(unstr(now_canv_y));
delta_x := now_canv_x - starting_posn(1);
delta_y := now_canv_y - starting_posn(2);
now_coords_stg := "" +/
[str(if odd(j) then delta_x
else delta_y end if + x)
+ " ": x = rect_coords(j)];
rect("coords") := now_coords_stg;
end lambda;
make_draggable(oval,OM,OM,OM);
-- use drag_pak to make the oval draggable also
make_vert_draggable(poly,OM,OM,OM);
-- use drag_pak to make the spline vertically draggable
Tk.mainloop(); -- enter the Tk main loop
end test;
Our next example shows the use of the procedural parameters that can be transmitted to the 'make_draggable', 'make_vert_draggable', and 'make_horiz_draggable' routines provided by 'drag_pak'. The first of these is a 'drag_start' procedure which, if not OM, is executed when object dragging begins. The second, if not OM, is executed during drag each time a motion event is detected. The third is executed when the mouse button comes up to end dragging. In our example we set up a canvas containing a rectangle, oval and spline curve as before, but bind them to 'drag_start', 'drag', and 'drag_end' routines which are as follows. 'drag_start' simply captures the object's initial position. 'drag' changes the object color, making it dependent on the x and y positions of the mouse, and 'drag_end' returns the object to its initial position. Note that each of these routines has two parameters. In 'drag' the first parameter is a canvas object or widget which is being dragged. In 'drag_start' and 'drag_end' the first is the list of all canvas objects or widgets which are being dragged. (This corresponds to the fact that the first argument of make_draggable can either be a widget of a tuple of such widgets). In every case the second being the mouse position at the moment that the routine is invoked.
program test; -- SETL interactive interface example 1
use tkw,drag_pak; -- use the main widget class and the drag_pak routines
var Tk; -- globalize for use in procedure below
var start_coords,rect_coords; -- globalize for use in procedure below
-- table of colors for use in procedure below
const colors := ["red","green","blue","yellow","cyan",
"magenta","grey","black","purple"];
Tk := tkw(); Tk(OM) := "Drag Test2"; -- create the Tk interpreter
ca := Tk("canvas","300,300"); ca("side") := "left";
-- create a canvas
rect := ca("rectangle","20,20,60,40"); rect("fill") := "red";
-- put a rectangle, oval, and spline into it
oval := ca("oval","80,20,120,40"); oval("fill") := "green";
poly := ca("polygon","140,60,180,60,180,100,20,100");
poly("fill,smooth") := "blue,true";
make_draggable(rect,drag_start_procedure,drag_procedure,drag_end_procedure);
-- use drag_pak to make the rectangle draggable,
-- and set its drag_start, drag, and drag_end procedures
make_draggable(oval,drag_start_procedure,drag_procedure,drag_end_procedure);
-- use drag_pak to make the oval draggable also
make_vert_draggable(poly,drag_start_procedure,
drag_procedure,drag_end_procedure);
-- use drag_pak to make the spline vertically draggable also
Tk.mainloop(); -- enter the Tk main loop
procedure drag_procedure(obj_being_dragged,posn);
-- object drag procedure
[x,y] := posn; -- unpack the position coordinates
obj_being_dragged("fill") := colors((floor(x + y) mod #colors) + 1);
-- use the position coordinates to set the object's color
end drag_procedure;
procedure drag_start_procedure(objs_being_dragged,place);
-- rectangle drag start procedure
start_coords := objs_being_dragged(1)("coords");
-- note its starting coordinates
end drag_start_procedure;
procedure drag_end_procedure(objs_being_dragged,end_pt);
-- rectangle drag end procedure
obj_being_dragged := objs_being_dragged(1);
obj_being_dragged("coords") := start_coords;
-- return the object to its original position
end drag_end_procedure;
end test;
Next we show the internal details of the 'drag_pak' package used in the two preceding examples. As seen in its specifier, this package provides five routines. These are the 'make_draggable', 'make_horiz_draggable', 'make_vert_draggable' routines seen above, plus two more procedures, namely 'make_drop_sensitive' and 'switch_drag_mode'. The routine 'make_drop_sensitive' has two parameters, the first being a canvas object or widget, and the second being a 'drop_response' procedure. After an object is made drop sensitive by a call to 'make_drop_sensitive', its 'drop_response' routine will be called whenever the drag of an object 'obj' made draggable using 'make_draggable' ends with the mouse position over the drop-sensitive object. As seen in a later example, this gives us an easy way of setting up drag and drop applications.
The routines 'make_draggable', 'make_horiz_draggable', and 'make_vert_draggable' all simply call a composite routine 'gen_draggable' transmitting an identifying mode parameter. 'gen_draggable' examines the Tk name of the object being dragged to determine whether it is a widget or a canvas item and calls the routine appropriate for whatever situation is detected. The canvas-case routines are easiest to follow. Then examine the three procedure parameters transmitted, and depending on whether or not these are actually procedures, call one or another event-attachment routines. If no legal procedure is actually supplied, the event attachment routine for drag start simply posts the starting position of the drag and the initial coordinates of each object being dragged, putting these in global variables which the other routines can read. The objects being dragged are also moved to the top of the canvas rendering order, so that they will not appear to be moving behind other canvas objects that they happen to overlap while being dragged. The same thing is done if a procedure (rather than an OM, or some other illegal value) is actually supplied, but in this case the drag start routine generated also executes the procedure passed to it.
Much the same pattern repeats for canvas drag event and drag-end event attachment routines. The procedure returned by the drag event attachment routine applies the proper adjustments to the canvas positions of all objects being dragged. These are, of course, calculated from the current mouse position, which is passed to the drag routine each time it is called. The drag-end attachment routine posts the position of the mouse at the button-release moment for possible use by the drop sensitivity procedures described below. If procedure parameters are supplied to the drag event attachment and/or drag-end event attachment routines, they are bound into the procedures that these procedures return, and then simply executed each time the relevant event triggers its callback.
Note that all of these attachment routines must return procedures, and so return closures into which all the data and subsidiary procedures that they will need are bound.
The widget-case routines are similar, differing from the canvas-case routines only in coordinate-computation and details and in the instructions needed to move objects to their new positions during drag.
The two parameters of the routine 'make_drop_sensitive' are (i) the object onto which another object may be dropped, and (ii) the routine to be triggered if such a drop actually occurs. 'make_drop_sensitive' generates a closure, which is bound to the mouse-entry event for the target object of a drop. This closure calls the second, 'drop_response' parameter passed to 'make_drop_sensitive', passing the target object of the drop and the dropped object as its two parameters. It is then the responsibility of the 'drop_response' routine to determine how it will react to the drop event, which it can either ignore or handle by reading and combining any/all parameters which can be recovered from the two objects involved. An example showing the use of this facility is found below. Note also that the drop event is actually the mouse entry event that occurs when the object being dragged to another moves from the final mouse position, (or moves down in rendering order) thus allowing the fact that the mouse has entered the targetobject of the drag to be realized.
A final facility provided by 'drag_pak' is the ability to keep track of multiple dragging modes and to switch between them, e.g. in response to button clicks or drag-drop actions. This is done by making various of the key global variables used by the 'drag_pak' routines public, i.e., accessible to procedures outside 'drag_pak'. Of these, the most central is 'ops_in_drag_mode', which must be set up as a mapping from the string names of drag modes to mappings, specifically mappings of widgets or canvas objects to the triples of drag actions that should be associated with them in the specified mode. This publicly accessible global is then read by the procedure switch_drag_mode(new_mode) provided by 'drag_pak'. This routine merely retrieves an object-to-procedure mapping for the specified mode, and installs the procedures found for each object in the domain of the mapping, turning off any such operations that were on in the previous drag mode. A typical use for this capability is to switch the way that a box or other graphic object reacts to drag actions addressing 'drag handles' placed at the corners and on the edges of the box. Depending on which of these handles is selected, the rectangle may pull from one of its corners, or only horizontally or vertically from one of its edges, etc., with the drag handles other than that being dragged following suit. This effect is obtained by switching to a drag mode determined by the handle selected.
An example of the use of switch_drag_mode is given below.
package drag_pak;
-- Drag setup package; also sets up for response to drop-on event.
-- This package provides an easy-use drag or drag-and-drop capability for widgets.
-- Calling the routine make_draggable(the_obj,dg_start,dg,dg_end) makes the widget
-- 'the_obj' draggable. The 3 additional parameters dg_start, dg, and dg_end can
-- be OM, but if not they should all be procedures of one parameter, prepared
-- to receive an integer point [x,y], the location of a mouse point [x,y],
-- the location of a mouse-related event. Then dg_start will be called at
-- the beginning of the drag, immediately after mousedown (whose location will be
-- transmitted to it.) Similarly dg will be called for each mouse_move event, and
-- dg_end will be called on drag dg_end will be called on drag-end.
-- If make_drop_sensitive(the_obj,drop_response) is called, its drop_response
-- parameter should be a procedure drop_response(on_obj,dropped_obj) of two
-- which will be widgets. 'drop_response' will be called whenever the drag of
-- an object's parameters, 'dropped_obj', made draggable by 'make_draggable',
-- ends with the mouse positioned over an object 'on_obj'
-- made drop sensitive. 'drop_response' should then take whatever action
-- is appropriate for a drop of dropped_obj onto on_obj.
-- The test program given below shows how these procedures can be used to create a
-- drag-and-drop oriented variant of the usual pocket calculator.
var was_dragging,dropped_at;
-- the last object being dragged, and its drop point
var start_canv_x,start_canv_y;
-- drag starting point, canvas relative, floating
var start_coords_obj; -- vector of starting coordinates
var ops_in_drag_mode := {};
-- maps objects to their associated actions in specified mode
var current_drag_mode := "edit"; -- current mode
procedure make_draggable(the_obj,dg_start,dg,dg_end);
-- make a widget draggable
procedure make_horiz_draggable(the_obj,dg_start,dg,dg_end);
-- make a widget or widgets horizontally draggable
procedure make_vert_draggable(the_obj,dg_start,dg,dg_end);
-- make a widget or widgets vertically draggable
procedure make_drop_sensitive(the_obj,drop_response);
-- build response for mouse entry event (by drop)
procedure switch_drag_mode(new_mode);
-- switch the draggability mode
end drag_pak;
package body drag_pak; -- drag setup package
use tkw; -- use the basic widget package
var drag_offs_x,drag_offs_y;
-- offset for object being dragged
procedure switch_drag_mode(new_mode); -- switch the draggability mode
if new_mode = current_drag_mode then return; end if;
-- nothing to do, since mode not changed
prior_domain := domain(prior_ops := ops_in_drag_mode(current_drag_mode)?{});
-- get the object-associated operations in the new mode
new_domain := domain(new_ops := ops_in_drag_mode(new_mode)?{});
-- current and target modes
current_drag_mode := new_mode; -- switch to the new mode
for obj in new_domain loop
-- change to the 'new mode' operations for all objects that have one
[dg_st,dg,dg_end] := new_ops(obj); -- get the start, drag, and end codes
obj{"ButtonPress-1:XY"} := dg_st;
obj{"B1-Motion:XY"} := dg;
obj{"ButtonRelease-1:XY"} := dg_end;
end loop;
-- now turn off any remaining operations that were on in the previous mode
for obj in prior_domain - new_domain loop
-- change to the 'new mode' operations for all objects that have one
obj{"ButtonPress-1:XY"} := null_1;
-- this is done by setting the response to a 1-parameter null vector
obj{"B1-Motion:XY"} := null_1;
obj{"ButtonRelease-1:XY"} := null_1;
end loop;
end switch_drag_mode;
procedure null_1(x); end null_1; -- null procedure of one operand
procedure make_draggable(the_obj,dg_start,dg,dg_end);
-- make a widget or widgets draggable
return gen_draggable(the_obj,dg_start,dg,dg_end,0);
end make_draggable;
procedure make_horiz_draggable(the_obj,dg_start,dg,dg_end);
-- make a widget or widgets horizontally draggable
return gen_draggable(the_obj,dg_start,dg,dg_end,1);
end make_horiz_draggable;
procedure make_vert_draggable(the_obj,dg_start,dg,dg_end);
-- make a widget or widgets vertically draggable
return gen_draggable(the_obj,dg_start,dg,dg_end,2);
end make_vert_draggable;
procedure gen_draggable(the_obj,dg_start,dg,dg_end,horiz_vert);
-- make a widget or widgets draggable
if not is_tuple(the_obj) then the_obj := [the_obj]; end if;
-- force to tuple; note that a list of widgets sharing common drag
-- routines might have been passed
if (nam := (the_obj(1)).Tk_id()) = "" then
return; -- this should not happen
end if;
if nam(1) = "w" then -- dealing with a widget
w_make_draggable(the_obj,dg_start,dg,dg_end,horiz_vert);
else -- dealing with a canvas item
c_make_draggable(the_obj,dg_start,dg,dg_end,horiz_vert);
end if;
end gen_draggable;
procedure w_make_draggable(the_objs,dg_start,dg,dg_end,horiz_vert);
-- make a list of widgets sharing common drag routines draggable
for the_obj in the_objs loop
if is_procedure(dg_start) then -- attach the start routine with extra action
the_obj{"ButtonPress-1:XY"} := press_op := attach_start(the_objs,dg_start);
else -- attach the start routine with no extra action
the_obj{"ButtonPress-1:XY"} := press_op := attach_start_noproc(the_objs);
end if;
if is_procedure(dg) then -- attach the drag routine with extra action
the_obj{"B1-Motion:XY"} := drag_op := attach_drag(the_objs,dg,horiz_vert);
-- start the drag
else -- attach the start routine with no extra action
the_obj{"B1-Motion:XY"} := drag_op := attach_drag_noproc(the_objs,horiz_vert);
end if;
if is_procedure(dg_end) then -- attach termination routine
the_obj{"ButtonRelease-1:XY"} := release_op := attach_end(the_objs,dg_end);
else -- attach the termination routine with no extra action
the_obj{"ButtonRelease-1:XY"} := release_op := attach_end_noproc(the_objs);
end if;
ops_in_drag_mode(current_drag_mode) ?:= {};
ops_in_drag_mode(current_drag_mode)(the_obj) := [press_op,drag_op,release_op];
-- save the operations associated with the object in the current mode
end loop;
end w_make_draggable;
procedure attach_end(the_objs,dg_end);
-- bind the object into the termination routine
return lambda(xy);
was_dragging := the_objs; -- note the objects that were being dragged
[now_abs_x,now_abs_y] := xy; -- get the drag-end x and y coordinates
now_abs_x := unstr(now_abs_x); now_abs_y := unstr(now_abs_y);
-- put coordinates into numerical form
dg_end(the_objs,dropped_at := [now_abs_x,now_abs_y]);
-- note the point at which the drag ended,
-- and pass it to the drag-end routine
end lambda;
end attach_end;
procedure attach_end_noproc(the_objs);
-- bind the object into the termination routine
return lambda(xy);
was_dragging := the_objs; -- note the objects that were being dragged
[now_abs_x,now_abs_y] := xy; -- get the drag-end x and y coordinates
now_abs_x := unstr(now_abs_x); now_abs_y := unstr(now_abs_y);
-- put coordinates into numerical form
dropped_at := [now_abs_x,now_abs_y];
-- note the point at which the drag ended
end lambda;
end attach_end_noproc;
procedure attach_start(the_objs,dg_start); -- drag start routine generator
return lambda(xy);
was_dragging := the_objs; -- note the objects being dragged
[start_abs_x,start_abs_y] := xy; -- get the drag-start x and y coordinates
start_abs_x := unstr(start_abs_x); start_abs_y := unstr(start_abs_y);
-- put coordinates into numerical form
drag_offs_x := drag_offs_y := [];
-- prepare to build vectors of x and y displacements, kept globally
for obj in the_objs loop
-- loop over all the objects being dragged
[place_x,place_y] := obj.place();
-- get object's current place in its parent
drag_offs_x with:= (place_x - start_abs_x);
-- convert locations into displacements from start position
drag_offs_y with:= (place_y - start_abs_y);
obj.raise(OM);
-- raise dragged objects to top level in rendering order
end loop;
dg_start(the_objs,[start_abs_x,start_abs_y]);
-- call the supplementary routine
end lambda;
end attach_start;
procedure attach_start_noproc(the_objs);
-- drag start routine generator; no action version
return lambda(xy);
was_dragging := the_objs; -- note the objects being dragged
[start_abs_x,start_abs_y] := xy;
-- get the drag-start x and y coordinates
start_abs_x := unstr(start_abs_x); start_abs_y := unstr(start_abs_y);
-- put coordinates into numerical form
drag_offs_x := drag_offs_y := [];
-- prepare to build vectors of x and y displacements
for obj in the_objs loop
-- loop over all the objects being dragged
[place_x,place_y] := obj.place();
-- get object's current place in its parent
drag_offs_x with:= (place_x - start_abs_x);
-- convert locations into displacements from start position
drag_offs_y with:= (place_y - start_abs_y);
obj.raise(OM); -- raise dragged object to top level in rendering order
end loop;
end lambda;
end attach_start_noproc;
procedure attach_drag(the_objs,dg,horiz_vert); -- drag routine generator
var parx,pary; -- parent object width and height,
-- globalized for binding into procedures below
parent := the_objs(1)("parent"); -- get the parent of the first object
parx := parent("width"); pary := parent("height");
-- get the parent's width and height
parx -:= 2; pary -:= 2; -- decrement by 2 pixels, for safety
return lambda(xy); -- object dragging package: drag routine to be returned
[now_abs_x,now_abs_y] := xy; -- get the drag-start x and y coordinates
now_abs_x := unstr(now_abs_x); now_abs_y := unstr(now_abs_y);
-- put coordinates into numerical form
for obj = the_objs(j) loop
-- loop over all the objects being dragged
-- increment the coordinates by the stored offsets from the mouse position
nax := ((now_abs_x + drag_offs_x(j)) max 0) min parx;
-- confine to parent rectangle
nay := ((now_abs_y + drag_offs_y(j)) max 0) min pary;
if horiz_vert = 0 then
-- if dragging is both horizontal and vertical
obj("place,x,y") := str(nax) + "," + str(nay);
-- assign new x and y coordinates
elseif horiz_vert = 1 then -- if dragging is only horizontal
obj("place,x") := str(nax);
-- assign new x coordinate
else -- if dragging is only vertical
obj("place,y") := str(nay);
-- assign new y coordinate
end if;
end loop;
dg(the_objs,[nax,nay]);
-- call the supplementary routine, passing the list of all
-- objects in the drag-set as a parameter
end lambda;
end attach_drag;
procedure attach_drag_noproc(the_objs,horiz_vert);
-- drag routine generator; no action
var parx,pary;
parent := the_objs(1)("parent"); -- get the parent of the first object
parx := parent("width"); pary := parent("height");
-- get the parent's width and height
parx -:= 2; pary -:= 2; -- decrement by 2 pixels, for safety
return lambda(xy); -- object dragging package: drag routine to be returned
[now_abs_x,now_abs_y] := xy;
now_abs_x := unstr(now_abs_x); now_abs_y := unstr(now_abs_y);
for obj = the_objs(j) loop -- loop over all the objects being dragged
-- increment the coordinates by the stored offsets from the mouse position
nax := ((now_abs_x + drag_offs_x(j)) max 0) min parx;
-- confine to parent rectangle
nay := ((now_abs_y + drag_offs_y(j)) max 0) min pary;
if horiz_vert = 0 then
-- if dragging is both horizontal and vertical
obj("place,x,y") := str(nax) + "," + str(nay);
-- assign new x and y coordinates
elseif horiz_vert = 1 then -- if dragging is only horizontal
obj("place,x") := str(nax); -- assign new x coordinate
else -- if dragging is only vertical
obj("place,y") := str(nay); -- assign new y coordinate
end if;
end loop;
end lambda;
end attach_drag_noproc;
procedure make_drop_sensitive(the_obj,drop_response);
-- build response for mouse entry event (by drop)
the_obj{"Enter:xy"} := lambda(xy);
-- this is the mouse entry code; mouse position is transmitted when called
wd := was_dragging; was_dragging := OM;
-- was_dragging is the list of objects being dragged
if wd /= OM and the_obj /= wd(1) then
-- dropped on object other than itself
-- if a drag was in progress and drop is not on object being dragged
was_dragging := OM; -- drop the 'drag was in progress' flag
drop_response(the_obj,wd(1)); -- note the drop-on event
end if;
end lambda;
end make_drop_sensitive;
procedure c_make_draggable(the_objs,dg_start,dg,dg_end,horiz_vert);
-- make a canvas item draggable
for the_obj in the_objs loop
if is_procedure(dg_start) then
-- attach the start routine with extra action
the_obj{"ButtonPress-1:xy"} := press_op := c_attach_start(the_objs,dg_start);
else -- attach the start routine with no extra action
the_obj{"ButtonPress-1:xy"} := press_op := c_attach_start_noproc(the_objs);
end if;
if is_procedure(dg) then
-- attach the drag routine with extra action
the_obj{"B1-Motion:xy"} := drag_op := c_attach_drag(the_objs,dg,horiz_vert);
-- start the drag
else -- attach the start routine with no extra action
the_obj{"B1-Motion:xy"} := drag_op := c_attach_drag_noproc(the_objs,horiz_vert);
end if;
if is_procedure(dg_end) then -- attach termination routine
the_obj{"ButtonRelease-1:xy"} := release_op := c_attach_end(the_objs,dg_end);
else -- attach the termination routine with no extra action
the_obj{"ButtonRelease-1:xy"} := release_op := c_attach_end_noproc(the_objs);
end if;
end loop;
ops_in_drag_mode(current_drag_mode) ?:= {};
ops_in_drag_mode(current_drag_mode)(the_obj) := [press_op,drag_op,release_op];
-- save the operations associated with the object in the current mode
end c_make_draggable;
procedure c_attach_start_noproc(the_objs);
-- drag start routine generator; no action version
return lambda(xy);
[start_canv_x,start_canv_y] := xy;
-- get the drag-start x and y coordinates
start_canv_x := float(unstr(start_canv_x));
-- put coordinates into numerical form
start_canv_y := float(unstr(start_canv_y));
start_coords_obj :=
[[unstr(x): x in the_obj("coords")]: the_obj in the_objs];
-- save the starting coordinates of all the
-- objects being dragged in a global
for the_obj in the_objs loop the_obj.raise(OM); end loop;
-- raise dragged objects to top level in rendering order
end lambda;
end c_attach_start_noproc;
procedure c_attach_start(the_objs,dg_start); -- drag start routine generator
return lambda(xy);
[start_canv_x,start_canv_y] := xy;
-- get the drag-start x and y coordinates
start_canv_x := float(unstr(start_canv_x));
-- put coordinates into numerical form
start_canv_y := float(unstr(start_canv_y));
start_coords_obj := [[unstr(x): x in the_obj("coords")]: the_obj in the_objs];
-- save the starting coordinates of all the
-- objects being dragged in a global
for the_obj in the_objs loop the_obj.raise(OM); end loop;
-- raise dragged objects to top level in rendering order
dg_start(the_objs,[start_canv_x,start_canv_y]);
-- call the supplementary start routine
end lambda;
end c_attach_start;
procedure c_attach_drag_noproc(the_objs,horiz_vert);
-- drag routine generator; no action
return lambda(xy); -- object dragging package: drag routine
[now_canv_x,now_canv_y] := xy; -- get the current mouse position
now_canv_x := float(unstr(now_canv_x));
-- put coordinates into numerical form
now_canv_y := float(unstr(now_canv_y));
delta_x := now_canv_x - start_canv_x; delta_y := now_canv_y - start_canv_y;
-- convert to offsets from starting position
for the_obj = the_objs(k) loop
-- loop over all the objects being dragged
if horiz_vert = 0 then
-- if drag mode is both horizontal and vertical
now_coords_stg :=
"" +/ [str(x + if odd(j) then delta_x else delta_y end if) + " ":
x = start_coords_obj(k)(j)];
-- apply x and y offsets to initial coordinates
elseif horiz_vert = 1 then
-- else if drag mode is only horizontal
now_coords_stg :=
"" +/ [str(x + if odd(j) then delta_x else 0.0 end if) + " ":
x = start_coords_obj(k)(j)];
-- apply only x offsets to initial coordinates
else
-- else drag mode is only vertical
now_coords_stg :=
"" +/ [str(x + if even(j) then delta_y else 0.0 end if) + " ":
x = start_coords_obj(k)(j)];
-- apply only y offsets to initial coordinates
end if;
the_obj("coords") := now_coords_stg;
-- move object to new coordinate position
end loop;
end lambda;
end c_attach_drag_noproc;
procedure c_attach_drag(the_objs,dg,horiz_vert); -- drag routine generator
return lambda(xy); -- object dragging package: drag routine
[now_canv_x,now_canv_y] := xy;
now_canv_x := float(unstr(now_canv_x)); now_canv_y := float(unstr(now_canv_y));
delta_x := now_canv_x - start_canv_x; delta_y := now_canv_y - start_canv_y;
-- convert to offsets from starting position
for the_obj = the_objs(k) loop
if horiz_vert = 0 then
-- if drag mode is both horizontal and vertical
now_coords_stg :=
"" +/ [str(x + if odd(j) then delta_x else delta_y end if) + " ":
x = start_coords_obj(k)(j)];
-- apply x and y offsets to initial coordinates
elseif horiz_vert = 1 then
-- else if drag mode is only horizontal
now_coords_stg :=
"" +/ [str(x + if odd(j) then delta_x else 0.0 end if) + " ":
x = start_coords_obj(k)(j)];
-- apply only x offsets to initial coordinates
else
-- else drag mode is only vertical
now_coords_stg :=
"" +/ [str(x + if even(j) then delta_y else 0.0 end if) + " ":
x = start_coords_obj(k)(j)];
-- apply only y offsets to initial coordinates
end if;
the_obj("coords") := now_coords_stg;
-- move object to new coordinate position
dg(the_obj,[now_canv_x,now_canv_y]);
-- call the supplementary drag routine
end loop;
end lambda;
end c_attach_drag;
procedure c_attach_end_noproc(the_objs);
-- end drag routine generator; no action version
return lambda(xy);
was_dragging := the_objs; -- note the object that was being dragged
[now_canv_x,now_canv_y] := xy; -- get the current mouse position
now_canv_x := unstr(now_canv_x); -- put coordinates into numerical form
now_canv_y := unstr(now_canv_y);
dropped_at := [now_canv_x,now_canv_y];
-- note the point at which the drag ended
end lambda;
end c_attach_end_noproc;
procedure c_attach_end(the_objs,dg_end);
-- end drag routine generator
return lambda(xy);
was_dragging := the_objs; -- note the object that was being dragged
[now_canv_x,now_canv_y] := xy; -- get the current mouse position
now_canv_x := unstr(now_canv_x);
now_canv_y := unstr(now_canv_y); -- put coordinates into numerical form
dg_end(the_objs,dropped_at := [now_canv_x,now_canv_y]);
-- note the point at which the drag ended, and call the drag-end routine
end lambda;
end c_attach_end;
end drag_pak;
Our next example is a more complete drag and drop mini-application, which shows the use of the 'make_drop_sensitive' routine supplied by 'drag_pak'. It creates a canvas surrounded by an array of small colored boxes, with a colored circle in the middle of the canvas. If any of these colored boxes is dragged onto the circle, the color of the circle is changed to the color of the box dragged onto it.
program test; -- SETL interactive interface example 1
use tkw,drag_pak; -- use the main widget class and the drag_pak routines
var Tk; -- globalize for use in procedure below
var start_coords,rect_coords; -- globalize for use in procedure below
-- table of colors for use in procedure below
const colors := ["red","green","blue","yellow","cyan",
"magenta","grey","black","purple","pink"];
Tk := tkw(); Tk(OM) := "Drag a box onto the Circle";
-- create the Tk interpreter
ca := Tk("canvas","300,300"); ca("side") := "left"; -- create a canvas
for col = colors(j) loop
-- put an array of colored squares into it
box := [30 * j - 20,10,30 * j,30];
rect := ca("rectangle",
"" +/ [str(x) + if k < 4 then "," else "" end if : x = box(k)]);
rect("fill") := col;
make_draggable(rect,drag_start_procedure,drag_procedure,drag_end_procedure);
-- use drag_pak to make the rectangles draggable, and set its drag_start,
-- drag, and drag_end procedures
end loop;
-- put a rectangle, oval, and spline into it
oval := ca("oval","50,50,250,250"); oval("fill") := "green";
-- put a circle into the canvas
make_drop_sensitive(oval,drop_response);
Tk.mainloop(); -- enter the Tk main loop
procedure drop_response(on_obj,dropped_obj); -- oval's drop_response procedure
on_obj("fill") := dropped_obj("fill");
end drop_response;
procedure drag_start_procedure(objs_being_dragged,place);
-- rectangle drag start procedure
start_coords := objs_being_dragged(1)("coords");
-- note ts starting coordinates
end drag_start_procedure;
procedure drag_end_procedure(objs_being_dragged,end_pt);
-- rectangle drag end procedure
obj_being_dragged := objs_being_dragged(1);
obj_being_dragged("coords") := start_coords;
-- return the object to its original position
end drag_end_procedure;
end test;
9.15. The 'Clipboard'. The 'clipboard' is an in-RAM file of string data used to communicate between applications. When a selection is 'copied' (or 'cut') in most text-oriented applications, a copy of it is put into the keyboard. When the 'paste' operation available in most such applications is used, the text which appears is that contained in the clipboard. The SETL interface provides operations which allow the clipboard contents to be manipulated directly. These are
Tk("clipboard") -- returns the current string value in the clipboard
Tk("clipboard") := stg; -- sets the current string value in the clipboard
The following small program illustrates the use of the clipboard operations. It sets up two buttons, one bound to a routine which simply prints the contents of the clipboard, and the second of which is bound to a routine which puts the time into the clipboard whenever the button is clicked. You can test this by selecting text from a window belonging to any application other than SETL (the SETL environment remains frozen while this, or any other, Tk application is open), or by clicking on the second button and then on the first.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk; -- globalize for use below
Tk := tkw(); Tk(OM) := "Example 1"; -- create the Tk interpreter
but := Tk("button","Print Clipboard"); but("side") := "top";
but{OM} := lambda(); print(Tk("clipboard")); end lambda;
but := Tk("button","Set Clipboard"); but("side") := "top";
but{OM} := lambda(); Tk("clipboard") := time(); end lambda;
Tk.mainloop(); -- enter the Tk main loop
procedure my_procedure(); -- procedures go here
end my_procedure;
end test;
When communicating via clipboard with another SETL application, it may be convenient to pass a binary string encoding a SETL value (e.g. a map), and to decode it on receipt; the code for this is simply
Tk("clipboard") := binstr(x); and y := unbinstr(Tk("clipboard"));
and it allows arbitrary SETL values to be passed via the clipboard.
Custom translators between SETL formats and the data formats expected by clipboard-enabled applications which expect data in other forms can be written to communicate with such applications via the clipboard.
The following short program illustrates these rules. We set up three textlines. Actions triggered when the focus arrives at each of these textlines are then set up. For the first textline we also set up an action that is executed when this line loses the focus. You can experiment by clicking on these textlines and by shifting the focus using the 'tab' key to see how they react to the arrival and loss of focus.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,win; -- globalize for use in procedure below
Tk := tkw(); -- create the Tk interpreter
-- create three textlines
tline1 := Tk("entry","20"); tline1("side") := "top";
tline1(OM) := "Type text here";
tline1("font") := "{Times 18 bold}"; -- one black on white
-- print the widget's tk name when the focus arrives
tline1("takefocus") := lambda(tkn); print("Focus is at: ",tkn); end lambda;
-- set up a command to be executed when the focus arrives
tline1{OM} := lambda(); print("Thank you!"); end lambda;
-- set up a command to be executed when the focus leaves
tline2 := Tk("entry","20"); tline2("side") := "top";
tline2(OM) := "Type text there";
tline2("font,justify,background,foreground")
:= "{Times 18 bold},right,black,white";
-- one white on black
-- print the widget's tk name when the focus arrives
tline2("takefocus") := lambda(tkn); print("Focus is at: ",tkn); end lambda;
-- set up a command to be executed when the focus arrives
tline3 := Tk("entry","20"); tline3("side") := "top";
tline3(OM) := "Type text where";
tline3("font,justify,foreground") := "{Times 18 bold},center,red";
-- one red on white
-- print the widget's tk name when the focus arrives
tline3("takefocus") := lambda(tkn); print("Focus is at: ",tkn); end lambda;
-- set up a command to be executed when the focus arrives
Tk.mainloop(); -- enter the Tk main loop
end test;
The expression
Tk.focus()
returns the widget which currently has the focus. The variant expression
Tk.focus_in_top()
returns the widget in the master window which currently has the focus. The command
widget.get_focus();
transfers the focus to the specified widget. These facts are illustrated by the following short program, which is worth close inspection. We create two widows, a master window which contains two textlines, and and a child window which contains one. We print all the textline widgets, in an order which allows correlation of the names printed for them with the variable names identifying them in the code. The keyboard focus, whose momentary location is signaled (subtly) by the presence of a blinking insertion cursor, can rest with any of the three textlines. The location of the focus can also be tested by typing a few characters and noting the textline in which they appear. The master window contains two buttons, one of which uses 'focus()' to print out the name of the textline which has the focus, but also 'focus_in_top()' to print out the textline in the master window which will recapture the focus when the master window is activate. A ' button having this same functionality is put into the child window. The second button in the master window, labeled 'Refocus', moves the focus to the textline in the child window. It is worth experimenting with this program to see which user actions cause the focus to move. Note,in particular,that the programmed action of the 'Refocus' button can move the focus to the textline in the child window even when the master window remains active, but that if we activate the child window by clicking on it and then reactivate the master window by clicking on it, focus will return to the textline in the master window which originally had it (the textline identified by 'focus_in_top()'), which the graphical interface clearly remembers.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,txt2; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Master"; -- create the Tk interpreter
win := Tk("toplevel","100,100"); win(OM) := "Other";
-- create a second window
txt1 := Tk("entry","15"); txt1("side") := "left"; txt1(OM) := "what";
-- put a textline in the main window
txt1a := Tk("entry","15"); txt1a("side") := "left"; txt1a(OM) := "flat";
-- put a second textline in the main window
txt2 := win("entry","30"); txt2("side") := "left"; txt2(OM) := "what";
-- put a textline in the second window
print(win); print(txt1); print(txt1a); print(txt2);
-- print all the widgets
but := Tk("button","Who has focus"); but("side") := "left";
-- create a first button in the main window
but{OM} := lambda(); print("\n",Tk.focus()); print(Tk.focus_in_top()); end lambda;
-- bind it to two show-focus operations
but := Tk("button","Refocus"); but("side") := "left";
-- create a second button in the main window
but{OM} := lambda(); txt2.get_focus(); print("\n",Tk.focus()); end lambda;
-- bind it to a set-focus and a show-focus operation
but := win("button","Who has focus"); but("side") := "left";
-- create a third button, in the auxiliary window
but{OM} := lambda(); print("\n",Tk.focus()); print(Tk.focus_in_top()); end lambda;
-- bind it to two show-focus operations
Tk.mainloop(); -- enter the Tk main loop
end test;
When a widget has the 'focus', the principal command (if any) associated with it will be executed hen the focus leaves the widget, e.g. if the tab key is hit. This is shown by the following small program, which creates a window with two textlines, which are bound to 'principal' commands which simply print 'Focus leaving txt1' and 'Focus leaving txt1a' respectively when the textlines lose focus. Experimentation will show that these messagees appear when focus is lost either in consequence of a mouse click or a tab-key press.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Master"; -- create the Tk interpreter
txt1 := Tk("entry","15"); txt1("side") := "left"; txt1(OM) := "what";
-- put a textline in the main window
txt1a := Tk("entry","15"); txt1a("side") := "left"; txt1a(OM) := "flat";
-- put a secondtextline in the main window
txt1{OM} := lambda; print("Focus leaving txt1"); end lambda;
txt1a{OM} := lambda; print("Focus leaving txt1a"); end lambda;
Tk.mainloop(); -- enter the Tk main loop
end test;
The operation window("grab") := "global" (or OM, or anything else) can be used to set a toplevel window of the SETL interface into a 'modal' state in which user interaction with other windows is restricted or suppressed. Setting window("grab") := "global" suppresses all interactions with other windows. window("grab") := OM clears the grab. Any other grab value suppresses interactions with other interface windows, but not with other applications.
The following program illustrates this operation. We open an auxiliary window for use in the experiments to be done. Three buttons are then placed in the main window one of which sets the 'grab' attribute of the main window to 'global', 'local' and 'OM' respectively. By clicking on these buttons and then trying to bring the auxiliary window, or the window of some other application to the front you can then see the effect of these 'grab' settings. On the Macintosh the 'global' setting makes a window mobile whereas the 'local' setting has no effect.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
var Tk,win; -- globalize for use in procedure below
Tk := tkw(); Tk(OM) := "Possibly Modal Window";
-- create the Tk interpreter
win := Tk("toplevel","200,200"); win(OM) := "A Second Window";
-- create a second window
but := Tk("button","Make Modal"); but("side") := "top";
-- create a button
but{OM} := lambda(); Tk("grab") := "global"; end lambda;
-- bind a global grab to the click
but := Tk("button","Make Modal Within SETL"); but("side") := "top";
-- create a second button
but{OM} := lambda(); Tk("grab") := "local"; end lambda;
-- bind a local grab to the click
but := Tk("button","Drop Grab"); but("side") := "top";
-- create a button
but{OM} := lambda(); Tk("grab") := OM; end lambda;
-- bind a grab release to the click
Tk.mainloop(); -- enter the Tk main loop
end test;
The operations on file widgets are shown in the following table.
file_widg(att_list) get file attributes file_widg(att_list) := att_val_list; set file attributes, delete file, or rename file/TD> file_widg.disks() get list of currently mounted disk names
In these operations, att_list is a comma- or semicolon-separated list of file attribute names, and att_val_list a similar list of allowed attribute values.
The allowed file attribute names are as follows (some of these are platform dependent, and are given in their Macintosh version).
name type link_name ctime mtime atime dev gid ino mode nlink size dev_type uid Mac_creator Mac_type Mac_readonly Mac_hidden
The following table explains the meaning of each of these attributes.
name file name type file type: can be file, directory, socket, and (under Unix) fifo, link, characterSpecial, or blockSpecial link_name if the file is an 'alias', a this is the name of the file which it references. Otherwise it is the nullstring. ctime time of last file change mtime time of last file modification atime time of last file access dev number of device storing file gid group id of file owner ino file inode number mode file protection mode nlink number of hard links to file size total file size in bytes dev_type type of device on which file is stored uid user id of file owner Mac_creator 4-character Macintosh file creator code Mac_type 4-character Macintosh file type code Mac_readonly read only flag Mac_hidden hidden file flag
Only the subset of these attributes appearing in the following table, which explains the meaning of each possible attribute assignment, can be written using the attribute-assignment statement file_widg(att_list) := att_val_list;.
Assignable attribute name Meaning of assignment name if the file or directory exists, changes its name, possibly moving it to another parent directory./nIf no file or directory with the specified name exists, a new, empty directory with that name is created. /nIf the new name is empty, the file or directory is deleted. type only valid if new type value is 'directory'. Erases file if it exists, and replaces it with an empty directory of the same name Mac_creator change 4-character Macintosh file creator code Mac_type change 4-character Macintosh file type code Mac_readonly change file's read only flag Mac_hidden change file's hidden file flag
The following small Macintosh program illustrates the use of the Tk file operations described above. We open two files to ensure that they exist and then close them immediately. We also create two directories. The Macintosh type of the first file is then changed to make it a 'BBedit' file and to move it to the first of the newly created directories, and the second file is deleted. We then try to delete both directories, but this succeeds only with the second directory, since directories can only be deleted if they are empty.
Note that to delete a directory we assign '[""]' to its name; this relatively complex construction is used to make inadvertent file deletions less likely.
Note also that to move a file to a new directory by changing its name, the new name must be given either as a full path, or at least with the prefixed character ":" to indicate that the path to it begins in the current working directory.
program test; -- SETL interactive interface example 1
use tkw; -- use the main widget class
Tk := tkw(); Tk(OM) := "Interactive interface file example";
-- create the Tk interpreter
close(open(fname := "test_files/junk_file_for_test","RANDOM"));
-- open a file to create it and then close it immediately
close(open(fname2 := "test_files/bunk_file_for_test","RANDOM"));
-- open a second file to create it and then close it immediately
file_obj := Tk("file",fname);
-- build Tk file-object versions of both these files
file_obj2 := Tk("file",fname2);
file_obj("mac_creator,mac_type") := "R*ch,TEXT";
-- change first file to a 'BBedit"-type text file
print(file_obj("mac_creator,mac_type,size,type,pointer"));
-- print info concerning first file
file_obj2("name") := [""]; -- delete the second file
tfobj := Tk("file",fn := "test_files/test_dir"); tfobj("name") := fn;
-- create a first new directory
tfobj2 := Tk("file",fn := "test_files/test_dir2"); tfobj2("name") := fn;
-- create a second new directory
file_obj("name") := "test_files/test_dir/junk_file_for_test";
-- move the first file into the new directory
tfobj("name") := [""]; -- try to delete the first directory
tfobj2("name") := [""]; -- delete the second directory
end test;
A construct basic to all internet programming is the so-called client socket, or more simply 'socket', which is just one end of a communication channel opened between two computers. Byte streams can be sent back and forth using such sockets once one is open at each of the two ends of the desired communication path, and the two are linked. Once such a link has been established, either computer can write to its end of the socket pair, and can use its end of the socket pair to read what the other computer has written.
Initiation of socket communication becomes possible when one of two potentially communicating computers begins to monitor for linkage request signals transmitted to it by other computers connected to a common network. The software object used for such 'request listening' is called a server socket. To send a request to such a 'server socket', the requesting computer first creates and then uses a more rudimentary client socket at its end. This is simply a communication channel, as yet not specifically connected at its other end, over which an initial request to open communication can be sent to any remote host computer. The request message carries the Internet address of the requesting ('client'), which consists of two parts, a 'host address', which identifies the requesting computer and locates it on the Internet, and a 'port number' provided so that each computer can open as many socket-communication channels as it likes. The server socket at the other end receives this request, and creates a second client socket on the listening computer. The listening computer then informs the requestor of this new socket's identity (i.e. port number), the two client sockets are linked, and byte-stream communication can proceed.
Once socket communication has been opened between two computers, communication proceeds by the exchange of byte streams, which can be thought of as strings. These strings are often ordinary text strings that are not hard for a person to read. So by 'spying' on both ends of a socket communication, one can often understand the conventions ('protocols') which guide the conversation.
The Tk socket routines allow sockets of both kinds, 'client' and 'server', to be opened for communication via the net. Socket widgets are created by calls of the form
sock_widget := Tk("socket",[host_and_or_port,blocksize_or_handler]);
where 'Tk' designates the Tk master window which must already have been opened. In this call, 'host_and_or_port' must either be an integer designating a port number or a string-valued host name like "www.att.com", "www.att.com:80", "123.456.78:990", or "123.456.78:990:80" (as seen here, the internet host address required can be given either in symbolic or numerical form, and may or may not include a port number.) If the host_and_or_port parameter given is an integer, a server_socket listening on the port which this integer designates will be created. In this case, the blocksize_or_handler procedure must be a 1-parameter procedure which will be called each time the server socket receives a connection request. Otherwise the host_and_or_port parameter must be a string, and must either be a valid Internet address or have the form Internet_address:socket_number. In this case a client socket object will be created, and blocksize_or_handler should be a string or integer specifying the way in which this client socket will buffer the data transmitted over it. Specifically, blocksize_or_handler can either be an integer specifying a buffering size in bytes, or the word 'text', indicating that buffering is to be by text lines.
To initiate communication with a remote computer, one simply creates a client socket widget addressing it, using the command shown above. A port number should be used, to ensure that the correct service program on the remote computer is being addressed. Many of these port numbers are 'well known', i.e. established by broadly adopted Internet convention. For example, telnet servers use the port number 23 by convention; the file transfer protocol uses port number 20; a remote job entry application generally has the port number of 5; the Hypertext Transfer Protocol (HTTP) application has the port number of 80; and the Post Office Protocol Version 3 (POP3) application, commonly used for e-mail delivery, has the port number of 110. Port 7 generally has an attached echo service, which merely sends back any message received. Port number 13 runs a time service. A comprehensive list of port numbers is found at this public_service Website. Port numbers below 1024 are reserved for 'official' uses; those over 1024 are available for user assignment and assignment to automatically generated client sockets.
Once communication is established, one can write to a socket using commands of the form
sock_widget(OM) := string_to_write;
and read from them using commands
response_string := sock_widget(OM);
The following short program illustrates these basic conventions, by opening socket communication, first with a time-of-day service, then with an echo service (to which a message ending with backspace-linefeed must be sent if it is to respond), and then with a Web server.
program test; -- socket example 1
use tkw; -- use the widget class, which also provides sockets
Tk := tkw(); -- create the Tk interpreter
sock := Tk("socket",["galt.nyu.edu:13","text"]);
-- open socket communication with a time-of-day service
print("response: ",sock(OM));
-- it responds by sending the time of day
sock.socket_close(); -- close the socket
sock := Tk("socket",["galt.nyu.edu:7","text"]);
-- open socket communication with an echo service
print("request: ",sock(OM) := "I say potato, you say potahto\r\n");
-- send a message
print("response: ",sock(OM)); -- it responds by echoing the message
sock.socket_close(); -- close the socket
sock := Tk("socket",["www.nyu.edu:80","text"]);
-- open socket communication with an HTML server
print("request: ",sock(OM) := "I say potato, you say potahto\r\n");
-- send a crazy message
print("response: ",sock(OM)); -- it responds with an error message
sock.socket_close(); -- close the socket
end test;
The output produced is
response: Thu Mar 8 14:27:40 2001 request: I say potato, you say potahto response: I say potato, you say potahto request: I say potato, you say potahto response: HTTP/1.1 400 Bad Request
Instead of handling the data coming in over a client socket synchronously, as in the above example, once can bind a handler to the client socket, to be called whenever data arrives. This is done by writing
server_socket{io_direction} := io_response_proc;
where io_response_proc is the 1-parameter procedure to be passed incoming data strings when they become available. The 'io_direction' parameter must either be '>' (to indicate that the I/O event to which the handler responds is the availability of input on the client socket), or '<' (to indicate that the I/O event to which the handler responds is the availability of free space in the client socket's output buffer.)
The following variant program shows this alternative, often superior, way of handling socket I/O. We open three sockets for reading, all of them connected to response routines generated by a common read response procedure. Each response routine reads output from the corresponding socket as long as there is any but then closes the socket as soon as an end of output condition is detected. The output produced by these communication links are of course determined by the services to which the sockets connect. The first two sockets are connected to simple Web time and echo services; the third socket connects to an HTML server. However, since the message sent to the HTML server is not in the expected format, only a 'bad request' response is elicited.
program test; -- socket example 2
use tkw; -- use the widget class, which also provides sockets
Tk:= tkw(); -- create the main Tk window
sock := Tk("socket",["galt.nyu.edu:13","text"]);
-- open socket communication with a time open socket communication with a time-of-day service
sock{">"} := read_response("first socket",sock);
-- bind in a socket readability handler
sock := Tk("socket",["galt.nyu.edu:7","text"]);
-- open socket communication with an echo service
sock{">"} := read_response("second socket",sock);
-- bind in a socket readability handler
print("request: ",sock(OM) := "I say potato, you say potahto\r\n");
-- send a message
sock := Tk("socket",["www.nyu.edu:80","text"]);
-- open socket communication with an HTML server
sock{">"} := read_response("third socket",sock);
-- bind in a socket readability handler
print("request: ",sock(OM) := "I say potato, you say potahto\r\n");
-- send a crazy message
Tk.mainloop();
procedure read_response(msg,sock);
-- bind an asynchronously read socket to its response routine
-- this routine will read input till there is no more.
return lambda(tk_sock_name_list);
-- end response routine; closes socket if end-of-file or error
if sock.socket_error = "" then sock.socket_close();
elseif (resp := sock(OM)) /= "" then print(msg + " response: ",resp); end if;
end lambda;
end read_response;
end test;
The output produced is as follows. Note that in this version, but not in the previous one,we see all of the lines of output with which the HTML server responds to our unexpected message.
request: I say potato, you say potahto request: I say potato, you say potahto second socket response: I say potato, you say potahto first socket response: Thu Mar 8 16:21:41 2001 third socket response: HTTP/1.1 400 Bad Request third socket response: Date: Thu, 08 Mar 2001 21:20:24 GMT third socket response: Server: Apache/1.3.12 (Unix) mod_ssl/2.6.5 OpenSSL/0.9.5 third socket response: Connection: close third socket response: Content-Type: text/html; charset=iso-8859-1 third socket response: <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN"> third socket response: <HTML><HEAD> third socket response: <TITLE>400 Bad Request</TITLE> third socket response: </HEAD> third socket response: <;H1>Bad Request</H1> third socket response: Your browser sent a request that this server could not understand. third socket response: Invalid URL in request I say potato, you say potahto third socket response: <P> third socket response: <HR> third socket response: <ADDRESS>Apache/1.3.12 Server at www.nyu.edu Port 80</ADDRESS> third socket response: </BODY></HTML>
Server Sockets. Server sockets are created in the manner described above. Then, when the callback handler of a server socket is called in consequence of an incoming connection request, the parameter transmitted to it will be a triple of the form
[tk_socket_id,calling_host,calling_port],
where calling_host and calling_port specify the computer and Internet port from which the request originates, and tk_socket_id is an internal Tk name for the new client socket that the server socket creates in response to connection requests. The way in which this name is used is shown in the examples below.
The first of our examples represents a simplified Web service which responds to incoming requests in HTML format (so that requests can be transmitted from a standard browser). The service provided can be thought of as a highly simplified dynamic HTML page generation service written in SETL. Each incoming request triggers a call to the 'request_acceptor' routine seen below. This decodes the three parameters transmitted by each incoming request, namely the host and port identifiers of the calling client, and the Tk name of the client socket spun off by the server socket in response to the incoming request. This Tk name is used immediately to build a Tk client socket connected to the socket on the client computer that issued the request. This completes the basic socket connection step required to establish communication. The server then sends out a sequence of text lines some of which are simply copied from a table of lines set up in advance, but a few of which are dynamically generated by choosing an integer at random, calculating its prime factorization, and formatting this bit of information as HTML lines which can be integrated into the pre-formatted HTML portion of the generated response.
Although this particular 'service' is of little real interest, it illustrates the technique that can be used to provide more substantial HTML-based services, for example, database accesses, commercial and information services, etc.
program test; -- test the of the server-socket function
use tkw,string_utility_pak,random_pak;
-- i.e. use the client and server socket class
var sock,newsock,clno := 0;
-- server socket, generated client socket, and incrementing client number
var page_w_headers,rand_handle;
-- HTML page to be served, and handle for generation of random integers
var Tk; -- globalize for use in procedure
const setl_server_address := "64.152.26.188:80";
page_w_headers := "HTTP/1.0 200 OK\n" + -- data for HTML page to be served
"Server: SETL Socketserver\n" +
"MIME-Version: 1.0\n" +
"Content-type: text/html\n" +
"\n" +
"<BASE HREF='http://www.multimedialibrary.com/'>\n" +
"<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 3.2//EN'>\n" +
"<HTML>\n" +
"<HEAD>\n" +
"<TITLE>SETL Socketserver</TITLE>\n" +
"</HEAD>\n" +
"<BODY>\n" +
"<BR>\n" +
"<H1>Welcome to the SETL Socketserver</H1> \n" +
"<BR>\n" +
"``````\n" + -- this line indicates the point at which a dynamic substitution
-- is to be made
"<BR>\n" +
"</BODY>\n" +
"</HTML> \n" +
"</BODY>\n" +
"</HTML>\n";
rand_handle := Start_Random(10000000,OM); -- create a stream of random numbers
Tk := tkw(); -- create the Tk interpreter
but := Tk("button","socket");
-- create a button, which can be used to trigger a client call to the server
but("side") := "top"; but{om}:= call_socket;
print("server_sock: ",server_sock := Tk("socket",[80,request_acceptor]));
-- create a server socket, attached to port 80
Tk.mainloop(); -- enter the Tk main loop
procedure call_socket;
-- manually generated calls to server socket; triggered by button click
print("client_sock: ",sock := Tk("socket",[setl_server_address,"text"]));
-- call the computer on which the SETL server is running
-- this creates a client of the SETL server
sock{">"} := readsock(sock);
-- bind this client socket to a data-reader callback
sock(OM) := "get /\r\n\r\n";
-- send a word, and then an empty line, to the server
end call_socket;
procedure request_acceptor(x);
-- request acceptor callback routine for server socket
print("accepted: ",x);
-- note incoming request
[newsock_name,calling_host,calling_port] := x;
-- decode incoming request
print("newsock: ",newsock := Tk("socket",[newsock_name + ":","text"]));
-- turn the socket name generated by Tk's response to
-- an incoming request into a socket object, appropriately configured
-- (in this case, for line buffering)
lines := breakup(page_w_headers,"\n");
-- cut pre-prepared HTML response text into lines
for line in lines loop
-- loop over lines, transmitting them as is or making planned replacements
newsock(OM) := -- write to the generated client socket
if line = "``````" then
-- replace the mark indicating that the following material is wanted
"<P>Hello there. The time is now "+ time()
+ ". You are client number " + str(clno +:= 1) + "</H1><P>"
+ "Your Internet address is " + calling_host
+ ", and you are currently using port " + calling_port +
" to communicate with me.<P>Your lucky integer is "
+ str(rn := random(rand_handle))
+ ", and its prime factorization is<P><blockquote>" + str(rn) +
" = " + str(join([str(x): x in primefacts(rn)]," * ")) + "</blockquote>"
else -- just send a pre-prepared line back
line
end if;
end loop;
newsock{">"} := readnewsock;
-- after sending all the above material, connect an input acceptor routine
-- to the newly created socket
end request_acceptor;
procedure readsock(sock); -- socket contents-reader for client
return lambda(x); -- bind the socket into the reader
cameback := sock(OM); -- read a string from the socket
print("received: ",
if sock.socket_error = "" then "final, possibly blank line: "
else "" end if,cameback);
if sock.socket_error = "" then
print("client socket closed - eof:",sock); sock.socket_close();
end if;
-- close the socket if end-of-data received
end lambda;
end readsock;
procedure readnewsock(x);
-- socket contents reader for generated client sockets on server end
print("received new: ",newsock(OM));
-- print the data received
if newsock.socket_error = "" then
print("client socket generated from server closed - eof:",sock);
sock.socket_close();
end if;
end readnewsock;
procedure primefacts(n); -- prime factorization routine for demo
if n = 0 then return []; end if; -- 0 has no factors
facts := []; -- prepare to collect factors
while even(n) loop facts with:= 2; n/:= 2; end loop; -- collect even factors
while n mod 3 = 0 loop facts with:= 3; n/:= 3; end loop; -- collect factors 3
while n > 1 and (exists m in [3..fix(sqrt(float(n))) + 1] | n mod m = 0) loop
facts with:= m; n/:= m; -- collect remaining factors
end loop;
return if n > 1 then facts with n else facts end if;
-- collect final factor and return
end primefacts;
end test;
If the server created by the preceding code is invoked from the Netscape browser, the 'readnewsock' routine will print all the lines that the browser sends. Suppose, to be specific, that the URL entered into the browser is
26.152.64.188:80/give/me/a/break?wont=you&please=sir
Then the browser sends the following lines before closing it to signal the end of communication.