Views
Document Actions
atkw_class_w_test.stl
by
Paul McJones
—
last modified
2021-02-25 11:15
- History
-
Action Performed by Date and Time Comment Publish Paul McJones 2021-02-25 11:15 No comments.
"Syntactic and semantic conventions for the SETL widget class", with test.
package Tk_interp_holder; -- small auxiliary package for holding TK interpreter object
var interp; -- the master tk interpreter
end Tk_interp_holder;
package body Tk_interp_holder; -- small auxiliary package for holding TK interpreter object
end Tk_interp_holder;
package doubleclick_pak; -- doubleclick timing package for Tk
procedure doubleclikk(the_Tk,proc); -- wrapper procedure for doubleclick, non-canvas items
procedure canvas_doubleclikk(the_Tk,proc); -- wrapper procedure for doubleclick, canvas items
end doubleclick_pak;
package Tk_defaults; -- defaults for Tk attribute values
var Tk_children,Tk_packed,Tk_gridded,Tk_placed,Tk_config_data,Tk_binding_tags;
var Tk_bindings,Tk_binding_responses,Tk_canvas_objs,Tk_text_objs,Tk_canvas_objs_data;
var Tk_canvas_tags_bindings,Tk_canvas_binding_responses;
var Tk_text_tags,Tk_text_tags_bindings,Tk_text_binding_responses,Tk_text_tags_data;
var new_item_from_orig_name; -- global used in rebuild process
-- major global information mappings and sets for persistency system
const Tk_pack_defaults := {["padx", "0"], ["anchor", "center"], ["ipadx", "0"], ["expand", "0"],
["fill", "none"], ["pady", "0"], ["ipady", "0"]};
const Tk_grid_defaults := {["padx", "0"], ["ipadx", "0"], ["pady", "0"], ["ipady", "0"],
["rowspan", "1"], ["columnspan", "1"]};
const Tk_place_defaults := {["relx", "0"], ["rely", "0"], ["anchor", "nw"]};
const Tk_button_defaults := {["anchor", "center"], ["activebackground", "systemButtonText"], ["bitmap", ""],
["default", "disabled"], ["foreground", "systemButtonText"], ["height",0], ["underline", "-1"],
["width", "0"], ["wraplength", "0"], ["bd", "borderWidth"], ["background", "systemButtonFace"],
["activeforeground", "systemButtonFace"], ["image", ""], ["command", ""], ["textvariable", ""],
["manager", "pack"], ["state", "normal"], ["font", "system"],
["highlightbackground", "systemWindowBody"], ["cursor", ""], ["relief", "flat"], ["pady", "3"],
["borderwidth", "2"], ["children", []], ["takefocus", ""], ["height", "0"], ["ismapped", 0],
["disabledforeground", "#a3a3a3"], ["highlightthickness", "4"], ["showing", "0"], ["manager", "pack"],
["highlightcolor", "systemButtonFrame"], ["justify", "center"], ["padx", "7"], ["Tk_tags", ["Button", ".", "all"]]};
const Tk_canvas_defaults := {["highlightthickness", "3"], ["selectbackground", "systemHighlight"],
["xscrollcommand", ""], ["yscrollcommand", ""], ["yscrollincrement", "0"], ["xscrollincrement", "0"],
["ismapped", 0], ["confine", "1"], ["insertborderwidth", "0"], ["closeenough", "1.0"],
["borderwidth", "0"], ["bd", "borderWidth"], ["insertofftime", "300"], ["insertontime", "600"],
["highlightcolor", "Black"], ["manager", "pack"], ["selectborderwidth", "1"], ["manager", "pack"],
["background", "systemWindowBody"], ["highlightbackground", "systemWindowBody"], ["cursor", ""],
["relief", "flat"], ["insertwidth", "2"], ["scrollregion", ""], ["selectbackground", "systemHighlight"],
["children", []], ["takefocus", ""], ["showing", "0"], ["selectforeground", "Black"], ["insertbackground", "Black"],
["Tk_tags", ["Canvas", ".", "all"]]};
const Tk_frame_defaults := {["colormap", ""], ["ismapped", 0], ["borderwidth", "0"], ["visual", ""], ["bd", "borderWidth"],
["highlightcolor", "Black"], ["manager", "pack"], ["background", "systemWindowBody"], ["manager", "pack"],
["highlightbackground", "systemWindowBody"], ["container", "0"], ["cursor", ""], ["relief", "flat"], ["class", "Frame"],
["takefocus", "0"], ["highlightthickness", "0"], ["showing", "0"],["Tk_tags", ["Frame", ".", "all"]]};
const Tk_toplevel_defaults := {["colormap", ""], ["height", "0"], ["class", "Tk"], ["width", "0"], ["borderwidth", "0"],
["visual", ""], ["bd", "borderWidth"], ["use", ""], ["menu", ""], ["ismapped", 1], ["highlightcolor", "Black"],
["background", "systemWindowBody"], ["highlightbackground", "systemWindowBody"], ["container", "0"], ["cursor", ""],
["relief", "flat"], ["showing", "1"], ["screen", ""], ["takefocus", "0"], ["highlightthickness", "0"],
["manager", "wm"],["Tk_tags", [".", "Tk", "all"]]};
const Tk_message_defaults := {["anchor", "center"], ["aspect", "150"], ["ismapped", 0], ["width", "0"],
["bd", "borderWidth"], ["textvariable", ""], ["highlightcolor", "Black"], ["manager", "pack"],
["font", "system"], ["background", "systemWindowBody"], ["justify", "left"],
["highlightbackground", "systemWindowBody"], ["cursor", ""], ["relief", "flat"],
["pady", "3"], ["borderwidth", "2"], ["padx", "6"], ["children", []], ["takefocus", "0"],
["highlightthickness", "0"], ["showing", "0"], ["foreground", "Black"], ["Tk_tags", ["Message", ".", "all"]]};
const Tk_label_defaults := {["anchor", "center"], ["bitmap", ""], ["foreground", "systemButtonText"],
["height", "0"], ["ismapped", 0], ["underline", "-1"], ["pady", "1"], ["width", "0"], ["manager", "pack"],
["wraplength", "0"], ["bd", "borderWidth"], ["background", "systemButtonFace"], ["image", ""],
["textvariable", ""], ["padx", "1"], ["font", "system"], ["highlightbackground", "systemWindowBody"],
["cursor", ""], ["relief", "flat"], ["manager", "grid"], ["borderwidth", "2"], ["children", []],
["takefocus", "0"], ["highlightthickness", "0"], ["showing", "0"], ["highlightcolor", "systemButtonFrame"],
["justify", "center"], ["Tk_tags", ["Label", ".", "all"]]};
const Tk_menubutton_defaults := {["anchor", "center"], ["bitmap", ""], ["manager", "pack"],
["height", "0"], ["ismapped", 0], ["underline", "-1"], ["width", "0"], ["wraplength", "0"], ["padx", "4"],
["bd", "borderWidth"], ["image", ""], ["textvariable", ""], ["highlightcolor", "Black"],
["state", "normal"], ["font", "system"], ["direction", "below"], ["background", "systemWindowBody"],
["justify", "left"], ["highlightbackground", "systemWindowBody"], ["cursor", ""], ["relief", "flat"],
["manager", "grid"], ["pady", "3"], ["borderwidth", "2"],
["indicatoron", "0"], ["children", []], ["takefocus", "0"], ["highlightthickness", "0"],
["disabledforeground", "#a3a3a3"], ["activebackground", "#ececec"], ["showing", "0"],
["activeforeground", "Black"], ["foreground", "Black"],["Tk_tags", ["Menubutton", ".", "all"]]};
const Tk_menuitem_defaults := {["activebackground","{} {} {} {}"], ["activeforeground","{} {} {} {}"],
["accelerator","{} {} {} {}"], ["background","{} {} {} {}"], ["bitmap","{} {} {} {}"], ["columnbreak","{} {} 0 0"],
["command","{} {} {} {}"], ["font","{} {} {} {}"], ["foreground","{} {} {} {}"], ["hidemargin","{} {} 0 0"],
["image","{} {} {} {}"],["underline", "{} {} -1 -1"], ["state", "{} {} normal normal"]};
const Tk_menu_defaults := {["activeforeground", "SystemMenuActiveText"], ["foreground", "SystemMenuText"],
["disabledforeground", "SystemMenuDisabled"], ["tearoffcommand", ""],
["postcommand", ""], ["activeborderwidth", "0"], ["borderwidth", "0"], ["bd", "borderWidth"],
["activebackground", "SystemMenuActive"], ["background", "SystemMenu"], ["title", ""],
["cursor", "arrow"], ["type", "normal"], ["font", "system"],
["relief", "flat"], ["tearoff", "0"], ["children", []], ["takefocus", "0"], ["wincoords", [0, 0]],
["selectcolor", "SystemMenuActive"], ["showing", "0"],["rect", [0, 0, 1, 1]],
["ismapped", 0], ["manager", "wm"], ["Tk_tags", ["Menu", "all"]]};
const Tk_text_defaults := {["highlightthickness", "3"], ["selectforeground", "systemHighlightText"],
["selectbackground", "systemHighlight"], ["xscrollcommand", ""], ["yscrollcommand", ""], ["setgrid", "0"],
["ismapped", 0], ["pady", "1"], ["insertborderwidth", "0"], ["borderwidth", "0"],
["bd", "borderWidth"], ["spacing1", "0"], ["insertofftime", "300"], ["insertontime", "600"], ["padx", "1"],
["highlightcolor", "Black"], ["selectborderwidth", "1"], ["state", "normal"], ["insertwidth", "1"],
["background", "systemWindowBody"], ["highlightbackground", "systemWindowBody"], ["wrap", "char"],
["spacing2", "0"], ["relief", "flat"], ["font", "Courier 12"],
["children", []], ["tabs", ""], ["takefocus", ""], ["spacing3", "0"], ["showing", "0"],
["exportselection", "1"], ["cursor", "xterm"], ["foreground", "Black"], ["insertbackground", "Black"],
["manager", "pack"],["Tk_tags", ["Text", ".", "all"]]};
const Tk_text_tag_data_defaults := {["wrap", ""], ["background", ""], ["offset", ""], ["borderwidth", ""],
["lmargin1", ""], ["spacing1", ""], ["overstrike", ""], ["fgstipple", ""], ["bgstipple", ""],
["underline", ""], ["justify", ""], ["lmargin2", ""], ["spacing2", ""], ["relief", ""],
["rmargin", ""], ["tabs", ""], ["spacing3", ""], ["foreground", ""], ["font", ""]};
const Tk_entry_defaults := {["selectforeground", "systemHighlightText"], ["selectbackground", "systemHighlight"],
["xscrollcommand", ""], ["ismapped", 0], ["insertborderwidth", "0"], ["bd", "borderWidth"],
["insertofftime", "300"], ["insertontime", "600"], ["textvariable", ""], ["highlightcolor", "Black"], ["manager", "pack"],
["selectborderwidth", "1"], ["state", "normal"], ["insertwidth", "1"], ["borderwidth", "1"], ["background", "systemWindowBody"],
["justify", "left"], ["highlightbackground", "systemWindowBody"], ["relief", "solid"], ["font", "Helvetica 12"],
["children", []], ["takefocus", ""], ["highlightthickness", "0"], ["show", ""], ["showing", "0"],
["exportselection", "1"], ["cursor", "xterm"], ["foreground", "Black"], ["insertbackground", "Black"],
["Tk_tags", ["Entry", ".", "all"]]};
const Tk_listbox_defaults := {["width", "8"], ["yscrollcommand", ".w1.w9 set"], ["selectforeground", "systemHighlightText"],
["selectbackground", "systemHighlight"], ["selectmode", "browse"], ["xscrollcommand", ""], ["manager", "pack"],
["setgrid", "0"], ["ismapped", 0], ["selectborderwidth", "0"], ["bd", "borderWidth"], ["highlightcolor", "Black"],
["manager", "pack"], ["borderwidth", "1"], ["background", "systemWindowBody"], ["highlightbackground", "systemWindowBody"],
["cursor", ""], ["relief", "solid"], ["font", "application"], ["children", []], ["takefocus", ""],
["highlightthickness", "0"], ["showing", "0"], ["exportselection", "1"], ["foreground", "Black"],
["Tk_tags", ["Listbox", ".", "all"]]};
const Tk_scrollbar_defaults := {["jump", "0"], ["ismapped", 0], ["manager", "pack"],
["orient", "vertical"], ["borderwidth", "0"], ["repeatinterval", "100"], ["bd", "borderWidth"], ["troughcolor", "#c3c3c3"],
["highlightcolor", "Black"], ["manager", "pack"], ["repeatdelay", "300"], ["elementborderwidth", "-1"],
["background", "systemWindowBody"], ["highlightbackground", "systemWindowBody"], ["cursor", ""], ["relief", "flat"],
["activerelief", "raised"], ["children", []], ["takefocus", ""],
["highlightthickness", "0"], ["activebackground", "#ececec"], ["showing", "0"],["Tk_tags", ["Scrollbar", ".", "all"]]};
const Tk_scale_defaults := {["showvalue", "1"], ["ismapped", 0], ["command", ""], ["manager", "pack"],
["bigincrement", "0.0"], ["width", "10"], ["orient", "horizontal"], ["label", ""], ["tickinterval", "0.0"],
["repeatinterval", "100"], ["bd", "borderWidth"], ["troughcolor", "#c3c3c3"],
["variable", ""], ["highlightcolor", "Black"], ["state", "normal"], ["font", "system"],
["repeatdelay", "300"], ["background", "systemWindowBody"], ["highlightbackground", "systemWindowBody"],
["cursor", ""], ["relief", "flat"], ["sliderrelief", "raised"], ["borderwidth", "2"],
["resolution", "1.0"], ["children", []], ["takefocus", ""], ["digits", "0"], ["highlightthickness", "0"],
["activebackground", "#ececec"], ["showing", "0"], ["foreground", "Black"], ["Tk_tags", ["Scale", ".", "all"]]};
const Tk_checkbutton_defaults := {["anchor", "center"], ["activebackground", "systemButtonText"], ["bitmap", ""],
["foreground", "systemButtonText"], ["height", "0"], ["ismapped", 0], ["manager", "pack"],
["underline", "-1"], ["offvalue", "r1"], ["pady", "1"], ["width", "0"], ["wraplength", "0"], ["bd", "borderWidth"],
["background", "systemButtonFace"], ["activeforeground", "systemButtonFace"], ["image", ""],
["selectimage", ""], ["textvariable", ""], ["padx", "1"], ["manager", "pack"], ["state", "normal"], ["font", "system"],
["highlightbackground", "systemWindowBody"], ["selectcolor", "#b03060"], ["cursor", ""], ["relief", "flat"],
["borderwidth", "2"], ["children", []], ["takefocus", ""],
["disabledforeground", "#a3a3a3"], ["highlightthickness", "4"], ["showing", "0"], ["highlightcolor", "systemButtonFrame"],
["justify", "center"], ["indicatoron", "1"], ["Tk_tags", ["Checkbutton", ".", "all"]]};
const Tk_radiobutton_defaults := {["anchor", "center"], ["activebackground", "systemButtonText"], ["bitmap", ""],
["foreground", "systemButtonText"],["value", "Radio1"], ["height", "0"], ["manager", "pack"],
["ismapped", 0], ["command", ""], ["underline", "-1"], ["pady", "1"], ["width", "0"], ["wraplength", "0"],
["bd", "borderWidth"], ["background", "systemButtonFace"], ["activeforeground", "systemButtonFace"],
["image", ""], ["selectimage", ""], ["textvariable", ""], ["padx", "1"],
["manager", "pack"], ["state", "normal"], ["font", "system"], ["highlightbackground", "systemWindowBody"],
["selectcolor", "#b03060"], ["cursor", ""], ["relief", "flat"], ["borderwidth", "2"],
["children", []], ["takefocus", ""], ["disabledforeground", "#a3a3a3"], ["highlightthickness", "4"], ["showing", "0"],
["highlightcolor", "systemButtonFrame"], ["justify", "center"],
["indicatoron", "1"], ["Tk_tags", ["Radiobutton", ".", "all"]]};
const Tk_oval_defaults := {["width", "1"], ["stipple", ""], ["outline", "black"], ["tags", []]};
const Tk_rectangle_defaults := {};
const Tk_arc_defaults := {["style", "pieslice"], ["width", "1"], ["outlinestipple", ""], ["stipple", ""],
["outline", "black"]};
const Tk_line_defaults := {["smooth", "0"], ["tags", []], ["joinstyle", "round"], ["width", "1"],
["splinesteps", "12"], ["capstyle", "butt"], ["stipple", ""], ["arrow", "none"], ["arrowshape", "8 10 3"],
["fill", "black"]};
const Tk_polygon_defaults := {["smooth", "0"], ["width", "1"], ["splinesteps", "12"], ["outline", ""],
["stipple", ""], ["fill", ""], ["tags", []]};
const Tk_canvaswidget_defaults := {["width", "0"], ["height", "0"], ["anchor", "nw"], ["tags", []]};
const Tk_canvasimage_defaults := {["anchor", "nw"], ["tags", []]};
const Tk_canvastext_defaults := {["width", "0"], ["justify", "left"], ["stipple", ""], ["tags", ["all"]],
["fill", "black"], ["anchor", "nw"], ["tags", []]};
const Tk_data_defaults := {["button",Tk_button_defaults],["canvas",Tk_canvas_defaults],["message",Tk_message_defaults],
["label",Tk_label_defaults],["menubutton",Tk_menubutton_defaults],["frame",Tk_frame_defaults],
["toplevel",Tk_toplevel_defaults],["menu",Tk_menu_defaults],
["scale",Tk_scale_defaults],["checkbutton",Tk_checkbutton_defaults],["radiobutton",Tk_radiobutton_defaults],
["listbox",Tk_listbox_defaults],["scrollbar",Tk_scrollbar_defaults],["oval",Tk_oval_defaults],
["rectangle",Tk_rectangle_defaults],["arc",Tk_arc_defaults],["line",Tk_line_defaults],
["polygon",Tk_polygon_defaults],["text",Tk_text_defaults],["entry",Tk_entry_defaults],
["text_tag_data",Tk_text_tag_data_defaults],["menuitem_data",Tk_menuitem_defaults],
["widget",Tk_canvaswidget_defaults],["image",Tk_canvasimage_defaults],["canvas_text",Tk_canvastext_defaults]};
end Tk_defaults;
package body Tk_defaults; -- defaults for Tk attribute values (dummy body, empty)
end Tk_defaults;
class tkw; -- tk widget class; alternative draft
class var show_commands := false; -- DEBUGGING SWITCH
class var debug_trace; -- global variable for tracing
class var for_tk := OM; -- for accumulating calls to Tk
class var dialog_response; -- for transmitting responses from standard dialogs
class var prior_id := OM,numcanceled := 0; -- global variables for doubleclick tracking
class var namegen_ctr := 0; -- counter for generating auxiliary Tk variables for storing server_socket associated callback procedures
var socket_error; -- instance variable,storing error resulting from read and write if object is a socket
const cursors_stg := "arrow,double_arrow,based_arrow_down,based_arrow_up,draft_large,draft_small," +
"top_left_arrow,right_ptr,center_ptr,right_side,left_side,bottom_side,top_side," +
"center_ptr,sh_h_double_arrow,sh_v_double_arrow,sh_left_arrow,sh_right_arrow," +
"sh_up_arrow,sh_down_arrow,xterm," +
"x_cursor,plus,tcross,crosshair,spider,fleur,iron_cross,diamond_cross," +
"cross_reverse,cross,dot," +
"right_tee,left_tee,bottom_tee,top_tee," +
"ll_angle,lr_angle,ul_angle,ur_angle," +
"dotbox,draped_box,sizing,middlebutton,rightbutton,leftbutton,target," +
"box_spiral,icon,rtl_logo," +
"bottom_left_corner,bottom_right_corner,top_left_corner,top_right_corner," +
"exchange,mouse,spraycan,pencil,star,boat,bogosity,pirate,man,question_arrow," +
"gobbler,gumby,hand1,hand2,heart,trek,clock,circle,coffee_mug,sailboat,umbrella," +
"watch,shuttle";
class var doubleclick,canvas_doubleclick; -- wrapper procedure for doubleclick; transmitted from preceding package
-- 'proc' should be a 1-parameter procedure, which expects to be passed the number of prior cancelled events
procedure create(); -- creation of fundamental interpreter and empty objects
procedure do_all_calls(); -- transmit any accumulated calls to Tk, as single string; then stop accumulating
procedure hold_calls(); -- start accumulating calls to Tk
procedure Tk_id(); -- returns an object's (short) Tk name
procedure Tk_kind(); -- returns an object's Tk type
procedure Tk_break(); -- terminate event handling in the Tk sequence
procedure Tk_continue(); -- jump in event handling in the Tk sequence
procedure dooneevent(); -- wait for some (any) Tk event
procedure do_later(proc); -- execute a procedure after a short delay
procedure obj_from_tkname(tkname); -- reconstruct a widget from its Tk name
procedure tk_parent(); -- the parent object of an object
procedure win_of_pt(x,y); -- find the widget containing x,y
procedure full_name(); -- finds full tk name string of widget PUBLIC FOR DEBUGGING ONLY
procedure selfstr(); -- string conversion
procedure beeper(); -- beep procedure; utility for SETL
procedure stopper(); -- destruction of top level window to force return from Tk main loop
procedure place(); -- returns object x and y coordinates if placed in parent
procedure gridbox(i,j); -- returns coordinates of specified gridbox
procedure raise(after_obj); -- raises object to position just after after_obj, or to top
procedure lower(before_obj); -- lowers object to position just before before_obj, or to bottom
procedure createtimer(interval,SETL_fun); -- create a timer callback (rings once)
procedure cancel_event(id); -- cancel a timer or idle callback
procedure break_event(); -- suppress further processing of an event
-- ****** Operations available for all widgets ******
procedure bindtags(tag); -- gets event bindings for specified tag, or for whole widget if tag = OM
-- procedure virt_event_info(virt_event); -- gets physical definition of specified virtual events, or virtual event list if param is OM [ Tk{"event",virt_event} ]
procedure virt_event_delete(virt_event); -- deletes specified virtual event
-- ****** Canvas Operations ******
procedure addtag_after(tag); -- **OK** --the following group of routines
-- add a specified tag to the item just before (or after) that a
-- given object in the display list, or to all items, or to all enclosed in a given
-- rectangle, or to the nearest item to a given point,
-- or to items which already have a given tag or numerical identifier
procedure addtag_before(tag); -- **OK**
procedure addtag_in(tag,rect); -- **OK**
-- add tag to all items in a rectangle, or to all items if rect is OM
procedure addtag_nearest(tag,xy,halo,start); -- nearest to x,y, or last within radius halo of x,y, or
-- first such after item start in the canvas display list **OK**
procedure addtag_if(newtag,hastag); -- add new tag if already has a tag. **OK**
procedure addtag(newtag); -- add new tag to a canvas item **OK**
procedure bbox_tags(tags); -- get bounding box of items with given tags **OK**
procedure canvasx(x,roundto); -- map from screen to canvas coordinates, possibly rounded to grid units **OK**
procedure canvasy(y,roundto); -- map from screen to canvas coordinates, possibly rounded to grid units **OK**
procedure delete_items(tags_or_ids); -- remove the item(s) identified by a tag **OK**
procedure delete(); -- delete a canvas item
procedure delete_till(end_ci); -- delete a range of canvas items
procedure draw_ovals(descriptor_tup); -- draw a group of ovals; called as ca.draw_ovals(descriptor_tup), ca must be canvas
-- returns pair consisting of first and last ovals drawn
procedure deltag(tags_or_ids); -- remove the specified tags from a canvas item **OK**
procedure deltag_if(iftag,tags_or_ids); -- remove the specified tags from the item identified by an id or tag **OK**
procedure get_tagindex(tag,index); -- gets the value of an index in a tagged canvas text item
procedure get_select(tag); -- gets the value of sel.first and sel.last in a tagged canvas text item
procedure set_select(tag,i,j); -- sets the value of sel.first and sel.last in a tagged canvas text item
procedure refocus(tag); -- sets the focus to a tagged canvas text item, or gets it if tag = OM
procedure find_after(); -- find all the items just above (or below) that with a given tag, **OK**
-- or to all items, or to all enclosed in a given rectangle, or to the
-- nearest item to a given point, or to items which already have a given tag or id
procedure find_before(); -- each of these routines returns a canvas object, identified by the serial number of **OK**
procedure find_in(rect); -- the canvas item which it finds **OK**
procedure find_touching(rect); -- find all the items touching in a given rectangle **OK**
procedure find_nearest(xy,halo,start); -- **OK**
procedure find(tag); -- find all the items with a given tag **OK**
procedure focus(); -- return widget in win which has the focus
procedure focus_in_top(); -- return widget in same toplevel as win which has the focus
procedure get_focus(); -- set focus to this window
procedure read_grab(); -- determine the modal grab state of this window: none, local, or global
procedure grabber(); -- return window which has exerted a grab
procedure destroy(); -- destroy a widget **OK**
procedure wait(); -- wait for this window to open
procedure wait_close(); -- wait for this window to be destroyed
-- ****** Canvas Widget Operations ******
-- procedure dchars(m,n); -- delete characters m thru n of specified canvas text item **OK** [textitem(m..n) := ""]
-- procedure insert_ct_item(m,stg); -- insert specified string into canvas text item at position m **OK** [textitem(m..n) := stg]
procedure index_item(ix_key); -- get numerical value of index_key, which can be active, end, last, etc. **OK**
procedure lower_tid(tag_or_id,be); -- lower the item identified by an id or tag either to specified level,
-- or to the start of the display list
procedure raise_tid(tag_or_id,ab); -- raise the item identified by an id or tag either to speicified level,
-- or to the end of the display list
procedure move(tag_or_id,dx,dy); -- move the item(s) identified by an id or tag, a specified amount **OK**
procedure postscript(options); -- generate postscript for the contents of a canvas. See below for options available
procedure scale_item(cent_x,cent_y,amt_x,amt_y); -- **OK**
-- scale a canvas item by a specified amount about a specified center
procedure scan_mark(x,y); -- place mark indicating scroll position
procedure scan_to(x,y); -- scroll to indicated position
procedure scan_mark_1(x); -- place mark indicating scroll position
procedure scan_to_1(x); -- scroll to indicated position
procedure canvas_select(); -- ???
procedure xview_percent(p); -- move to place fraction p of string offscreen to the left; p is real **OK**
procedure xview_scroll(n,what); -- scroll horizontally, n 'units' or 'pages'
procedure yview_scroll(n,what); -- scroll vertically, n 'units' or 'pages'
procedure image_of(rect); -- capture the contents of a rectangle within a canvas, as a Tk absolute image
-- ****** Text Widget Operations ******
-- procedure bbox(n); -- return bounding box of specified character
procedure compare(op,ix1,ix2); -- compare character indices in line.char and other allowed formats
procedure debug(on_off); -- enable consistency checking for B-tree code???
-- procedure delete(m,n); -- delete one character, or a range of characters [text(m..n) := ""] **OK**
-- procedure get(m,n); -- return range of characters [text(m..n)] **OK**
procedure insert_tt(n,chars_and_tags);
-- insert a substring; this can carry specified tags in designated subsections **OK**
procedure linebox(n); -- return bounding box and baseline of line n
procedure insert_image(n,img); -- insert an image at a specified text position **OK**
-- procedure images(); -- return the ordered list of all images in the text widget [txt("images")] **OK**
procedure index(ix_stg); -- return line.character position of specified text index **OK**
-- text indices can be "current" (char under mouse), "end", "insert" (insert position),
-- line.char, image (name), widget (name), mark (stg), tag_name.first, tag_name.last,
procedure mark_set(name,n); -- place a named mark at the specified index **OK**
procedure mark_unset(name); -- remove a named mark (can also be comma-separated list)
procedure mark_gravity(name,n);
-- set the 'gravity' (left,right) of a mark, which determines the placement of strings inserted at the mark
procedure mark_next(n); -- return the first mark after text position n **OK**
procedure mark_prev(n); -- return the last mark before text position n **OK**
-- procedure scan_mark(x,y); -- place mark indicating scroll position???
-- procedure scan_to(x,y); -- scroll to indicated position
procedure search(options,pattern,n,m); -- string search; returns empty string if unsuccessful **OK**
-- search section of text from m to n for a pattern. 'options' parameter can be
-- "forward", "backward", "nocase", (count - return count of matched characters in specified var)
-- "exact", "regexp" (use regular expression matching)
-- unless regular expression ,matching is specified, the 'pattern' is
-- only allowed to have "*" (wildcard), ? (one char), or [abc] specified chars
procedure see(n); -- scroll to make a given line.character position n visible
-- text widget tag information is fetched/set by operations of the syntactic form
-- tw("tag","attribute,attribute,...") and tw("tag","attribute,attribute,...") := "val,val,..";
-- to bind callback procedures to textfield tag events we use the syntax
-- textfield{"tag_name","event_descriptor,event_fields_signature"} := SETL_procedure;
-- this is like all other binding syntax, but carries a tag name as an extra parameter
procedure tag_add(tag,index_range_stg); -- add tag to a list of character ranges **OK** (possib. off by 1)
procedure tag_remove(tag,index_range_stg); -- remove tag from list of text ranges **OK** (possib. off by 1)
-- procedure tag_delete(tag_list); -- delete information for list of tags [txt("tags") := list;] **OK**
procedure tag_names(n); -- return ordered list of tags at specified char position. OM gives all **OK**
-- procedure tag_lower(tag,below); -- lower tag to specified position in priority list of tags, or to start [txt("tags") := list;] **OK**
-- procedure tag_raise(tag,above); -- raise tag to specified position in priority list of tags, or to end [txt("tags") := list;] **OK**
procedure tag_nextrange(tag,n,m); -- search for first subrange of specified range that carries specified tag **OK**
procedure tag_prevrange(tag,n,m); -- search for last subrange of specified range that carries specified tag **OK**
procedure tag_ranges(tag); -- get list of all ranges for specified tag
procedure insert_widget(n,wind); -- insert an widget window at a specified text position **OK**
-- procedure widgets_in(); -- return the ordered list of all widgets in the text widget [txt("widgets")] **OK**
-- procedure xview_percent(p); -- move to place fraction p of string offscreen to the left; p is real **OK**
-- procedure xview_scroll(n,what); -- scroll horizontally, n 'units' or 'pages'
procedure yview_percent(p); -- move to place fraction p of string offscreen to the top; p is real
-- procedure yview_scroll(n,what); -- scroll vertically, n 'units' or 'pages'
-- ****** Button Operations ******
procedure flash(); -- cause the button to flash **OK**
procedure invoke_button(); -- trigger the button's action **OK**
-- procedure deselect(); -- deselect radio button or checkbutton [button("selected") := 0;] **OK**
-- procedure select_button(); -- select radio button or checkbutton [button("selected") := 1;] **OK**
-- ****** Menu Operations ******
-- procedure activate(n); -- highlight specified entry (zero based) [menu("active") := n;]
-- procedure add(the_type,options_values); -- add entry of specified type with specified options [menu(i..i - 1) := labels] **OK**
procedure clone(); -- make linked copy of the menu (for tearoffs, etc.)
-- procedure delete(m,n); -- delete entries from m to n [menu(n..m) := ""] **OK**
-- procedure index(index_key); -- get numerical value of index_key, which can be active, end, last, etc.
-- procedure insert(type,n,options);
-- insert entry of specified type with specified options at position n [menu(n..m) := labels] **OK**
procedure invoke(n); -- trigger the entry's action **OK**
procedure post(i,j); -- display menu at specified coordinates
procedure popup(i,j); -- display menu at specified coordinates
procedure postcascade(n); -- display menu in hierarchical position for entry n
procedure entry_type(n); -- get the type of menu entry n [menu(n,"type")]
procedure unpost(); -- hide the menu
procedure yposition(n); -- return vertical position of top of entry n
-- ****** Scale Operations ******
procedure coords(n); -- transform scale value into geometric position **OK**
procedure get(ij); -- get scale value, or value corresponding to given position
procedure identify(ij); -- return 'trough1' (left of slider), 'slider', or 'trough2 (right of slider)' **OK**
-- procedure set_scale(n); -- move the scale to indicated value **OK** [sc(OM) := n;]
-- ****** Scrollbar Operations ******
procedure activate(x); -- query/set active element, which can be arrow1, arrow2, or slider
procedure delta(dxy); -- convert desired horizontal or vertical value change to slider units
procedure fraction(x); -- convert point position into fraction relative to scrollbar extent
-- procedure identify(i); -- identify the scrollbar element (arrow1, arrow2, or slider) under point x,y
-- ****** Entry Operations ******
procedure bbox(n); -- return bounding box of specified character **OK**
-- procedure delete(m,n); -- delete characters from m to n [entry(m..n)] **OK**
-- procedure get(m,n); -- return characters from m to n of string in the entry [entry(m..n), #entry]
-- procedure index(index_key); -- get numerical value of index_key, which can be anchor, end, insert, etc. **OK**
-- procedure insert(n,string); -- insert string at indicated position [entry(m..n) := stg] **OK**
-- procedure scan_mark(x); -- place mark indicating scroll position???
-- procedure scan_to(x); -- scroll to indicated position
procedure select(m,n); -- select characters m to n, or clear the selection **OK**
procedure select_anchor(m); -- set the anchor point for the selection
-- procedure xview_percent(p); -- move to place fraction p of string offscreen to the left; p is real **OK**
-- procedure xview_scroll(n,what); -- scroll horizontally, n 'units' or 'pages'
-- ****** Listbox Operations ******
---> Working On these
-- procedure activate(n); -- activate specified line [listbox("active") := line;]
-- procedure bbox(n); -- return bounding box of specified line ????
-- procedure curselection(); -- return list of selected lines [listbox(OM)] **OK**
-- procedure delete(i,j); -- delete indicated range of lines [listbox(i..j) := ""] **OK**
-- procedure get(m,n); -- return lines m thru n [listbox(m..n)] **OK**
-- procedure index(index_key); -- get numerical value of index_key, which can be anchor, end, insert, etc. **OK**
-- procedure insert(n,strings); -- insert list of strings before indicated item [listbox(m..m - 1) := lines] **OK**
procedure nearest(y); -- return index of line vertically nearest to y
-- procedure scan_mark(x); -- place mark indicating scroll position???
-- procedure scan_to(x); -- scroll to indicated position
-- procedure see(n); -- adjust display to make line n visible
-- procedure select_anchor(m); -- set the anchor line for the selection
-- procedure select(m,n); -- select lines m to n, or clear the selection
procedure is_select_line(m); -- determine if line m is selected
-- procedure size(); -- number of elements in list [#listbox] **OK**
-- procedure xview(n); -- move to make character line visible, or read vertical scroll position
-- procedure xview_percent(p); -- move to place fraction p of string offscreen to the left; p is real **OK**
-- procedure xview_scroll(n,what); -- scroll horizontally, n 'units' or 'pages'
procedure yview(n); -- move to make indicated line visible, or read vertical scroll position
-- procedure yview_percent(p); -- move to place fraction p of string offscreen to the top; p is real
-- procedure yview_scroll(n,what); -- scroll vertically, n 'units' or 'pages'
-- ****** Clipboard Operations ******
procedure clear_selection(win,the_sel); -- clear specified selection in specified window
procedure get_selection(win,the_sel,the_type); -- return the specified selection
procedure handle_selection(win,the_type,format,the_sel,proc);
-- define proc to be handler for set/the_type selection requests when 'win' is selection owner
procedure own_selection(win,the_sel,proc);
-- assert that win is sel owner; and that proc should be called when it loses ownership
procedure selection_owner(win,the_sel); -- find string name of current owner of selection 'sel'
procedure clear_clipboard(win); -- clear clipboard for specified window
procedure addto_clipboard(win,the_type,format,data);
-- add 'data', of specified format and type, to clipboard for specified window
-- ****** Dialogs and Message boxes ******
-- Note: all these have been put in the syntax win("ask_...","options") := "option_vals";
-- ****** Absolute Image Operations; see final comments for other image operations in SETL syntax ******
procedure dither(); -- dither the image **OK**
procedure write_im(file,options); -- write image to file **OK**
procedure copy_im(source,options); -- copy one image to another **OK**
procedure stuff_im(data,rect); -- insert data into image rectangle ???
-- ****** Window Manager Operations ******
procedure win_close(); -- close or iconify a toplevel
procedure win_open(); -- open or deiconify a toplevel
procedure containing(x,y); -- window containing given point
procedure pixels(n); -- number of pixels corresponding to given size in screen units
procedure fpixels(n); -- floating number of pixels corresponding to given size in screen units
procedure rgb(color_name); -- numerical code for named color
procedure get_winfo_attr(att); -- get an attribute available through the Tk 'winfo' primitives
-- ****** Rastport Operations ******
procedure put_img(gr_img,x,y); -- stuff gr_img into tkrport at position x, y
procedure put_add(gr_img,x,y); -- stuff gr_img into tkrport using 'sum'
procedure put_dif(gr_img,x,y); -- stuff gr_img into tkrport using 'dif'
procedure put_mul(gr_img,x,y); -- stuff gr_img into tkrport using 'mul'
procedure put_div(gr_img,x,y); -- stuff gr_img into tkrport using 'div'
procedure put_min(gr_img,x,y); -- stuff gr_img into tkrport using 'min'
procedure put_max(gr_img,x,y); -- stuff gr_img into tkrport using 'max'
procedure put_blend(gr_img,x,y,c1,c2);
-- blend the image gr_img with the tk widget at position x, y using coefficients c1 and c2
-- ****** rotated cases of the put operations ******
procedure put_imgr(gr_img,x,y); -- stuff gr_img into tkrport at position x, y
procedure put_addr(gr_img,x,y); -- stuff gr_img into tkrport using 'sum'
procedure put_difr(gr_img,x,y); -- stuff gr_img into tkrport using 'dif'
procedure put_mulr(gr_img,x,y); -- stuff gr_img into tkrport using 'mul'
procedure put_divr(gr_img,x,y); -- stuff gr_img into tkrport using 'div'
procedure put_minr(gr_img,x,y); -- stuff gr_img into tkrport using 'min'
procedure put_maxr(gr_img,x,y); -- stuff gr_img into tkrport using 'max'
procedure put_blendr(gr_img,x,y,c1,c2);
procedure get_img(gr_img,x,y); -- stuff gr_img into tkrport at position x, y
procedure get_add(gr_img,x,y); -- stuff gr_img into tkrport using 'sum'
procedure get_dif(gr_img,x,y); -- stuff gr_img into tkrport using 'dif'
procedure get_mul(gr_img,x,y); -- stuff gr_img into tkrport using 'mul'
procedure get_div(gr_img,x,y); -- stuff gr_img into tkrport using 'div'
procedure get_min(gr_img,x,y); -- stuff gr_img into tkrport using 'min'
procedure get_max(gr_img,x,y); -- stuff gr_img into tkrport using 'max'
procedure get_blend(gr_img,x,y,c1,c2);
-- blend the image gr_img with the tk widget at position x, y using coefficients c1 and c2
-- ****** Font Routines ******
procedure font_metrics(font); -- get the metrics of the designated font
procedure measure_fonted(stg,font); -- get the size of the string in the designated font
procedure font_families(); -- get the list of fonts available in Tk
-- ****** File Routines ******
procedure disks(); -- get the currently mounted disks
-- ****** Socket Routines ******
procedure socket_close(); -- close a socket
-- ****** Main Control Operations ******
procedure mainloop(); -- call the tk main loop and wait for callback
procedure handle_event(); -- GIUSEPPE
procedure get_event_source_function(); -- GIUSEPPE
procedure quit(); -- close the tk interpreter
procedure call(txt); -- transmit a command to the tk main loop
procedure setvar(name,val); -- set a tk variable to the indicated value
procedure getvar(name); -- read a tk variable
procedure waitvar(name); -- wait for the specified tk variable to change
procedure update(); -- request screen display update
-- ****** Miscellaneous Utilities ******
procedure clock(); -- clock and date utility
-- returns time in format [very_fine,seconds,dau,month,am_pm,weekno_in_year,mm/dd/yy,abbrev_time,monthno,dayno_in_year,dayno_in_week]
-- ****** Temporarily exposed for development/debugging ******
procedure stgs_from_Tk(stg); -- get list of strings from Tk blank-delimited form;
procedure stg_to_Tk(stg); -- sanitize the quote marks, blanks, backslashes, and square brackets in a string
procedure as_map(stg); -- converts a Tk configuration descriptor string to a mapping from attrbute names to values
-- ********** Routines for persistency **************
procedure get_Tk_packed(); -- gets the Tk packing information as a map
procedure get_Tk_gridded(); -- gets the Tk gridding information as a map
procedure get_Tk_children(); -- gets the full hierarchy of Tk children as a map
procedure setup_from_dump(target_texwidg_name,dump_stg); -- reconstruct a text area grom its dump string
procedure sep_tags_and_marks(stg_tup); -- separate a string's dump tuple into its text, plus tags_and_marks
procedure reconstruct_image_from_name(img_name); -- rebuild an existing absolute image using its name
procedure reconstruct_bitmap_from_name(bm_name); -- rebuild an existing absolute bitmap using its name
end tkw;
package body doubleclick_pak; -- supplementarty package for doubleclick-detector utility routine
use tkw; -- use the main widget class
var Tk,prior_id := OM,numcanceled := 0,canvasevent_pending := false; -- global variables for doubleclick tracking
procedure doubleclikk(the_Tk,proc); -- wrapper procedure for doubleclick
Tk := the_Tk;
return lambda; -- return this closure, with 'proc' bound in, to be called when a clock occurs
if canvasevent_pending then return; end if; --a non-canvas event cannot cancel a pending canvas event
if prior_id /= OM then Tk.cancel_event(prior_id); numcanceled +:= 1; end if;
prior_id := Tk.createtimer(200,catch_procedure(proc)); -- set the catch_procedure (a closure) to be called after a delay
procedure catch_procedure(proc); -- catch procedure for doubleclick; binds in the procedure parameter of doubleclick
return lambda; prior_id := OM; numc := numcanceled; numcanceled := 0; proc(numc); end lambda;
end catch_procedure;
end lambda;
end doubleclikk;
procedure canvas_doubleclikk(the_Tk,proc); -- wrapper procedure for doubleclick
Tk := the_Tk;
return lambda; -- return this closure, with 'proc' bound in, to be called when a clock occurs
if prior_id /= OM then Tk.cancel_event(prior_id); numcanceled +:= 1; end if;
prior_id := Tk.createtimer(200,catch_procedure(proc)); -- set the catch_procedure (a closure) to be called after a delay
canvasevent_pending := true; -- note that a canvas item event is now pending
procedure catch_procedure(proc); -- catch procedure for doubleclick; binds in the procedure parameter of doubleclick
return lambda; prior_id := OM; numc := numcanceled; numcanceled := 0; proc(numc); canvasevent_pending := false; end lambda;
end catch_procedure;
end lambda;
end canvas_doubleclikk;
end doubleclick_pak;
-- this class uses the tk native package, which provides the routines
-- procedure tk_create(); -- create a tk interpreter
-- procedure tk_kall(tkobj,cmd); -- transmit a command to the tk interpreter
-- procedure tk_createcommand(tkobj,cmd,fun);
-- create a new callback command for the tk interpreter
-- procedure tk_dooneevent(tkobj);
-- procedure tk_mainloop(tkobj); -- call the tk interpreter and wait for a callback
-- procedure tk_quit(tkobj); -- close the tk interpreter?????
-- procedure tk_createtimer(interval,fun);
-- procedure tk_idlecallback(fun);
-- The following is an alternative version of the tk widget class and various related objects
-- (e.g. canvas items). Each class instance has a tk_type, which can be either button, menu,
-- menubutton, frame, toplevel, label, message, scale, scrollbar, entry, listbox, text, canvas
-- (the builtin tk widgets), or arc, bitmap, image, line, oval, polygon, canvas_text, widget
-- (the canvas items). The tk interpreter identifies widgets by their place in its name hierarchy,
-- and canvas items by their serial number in the canvas to which they belong. This class gives
-- every item a unique generated name of the form Wnnn (for widgets) or Cnnn (for canvas items),
-- allowing SETL widgets and canvas item objects to be identified rapidly from their tk names.
-- Basic syntactic conventions: the most basic syntactic conventions established by this package
-- are those concerning attribute set/get operations (corresponding to 'cget' and 'configure' operations
-- in Tk, and those having to do with callback operation binding (corresponding to the Tk 'bind'
-- and the Tk 'command' parameter). attribute set/get operations for a widget w are represented in the form
-- w("attr,attr,..") and w("attr,attr,..") := "val,val,..". Callback operations are bound to events
-- and the widgets or tags to which these events are delivered by statements of forms like
-- w{"event_descriptor:event_fields_signature"} := SETL_procedure;
-- the special case of button, checkbutton, radiobutton, and menu button commands are handled
-- without any event_fields_signature, using the syntax
-- obj{OM} := SETL_procedure;
-- to implement this syntax, we use the tk_createcommand(interp,tk_command_name,SETL_procedure)
-- call of the underlying native library. This posts the (parameterless) SETL_procedure to the
-- tk interpreter, as a new externally implemented command whose name is tk_command_name. This
-- routine is called inside the stg_for_tk routine, which converts all non-tk right-hand sides
-- of such calls to string forms acceptable to the tk interpreter.
-- More generally, we use this syntax to send its 'principal command' to any widget; this is the
-- command triggered by whatever we choose to regard as the widget's 'principal event' For
-- listboxes and tags in text widgets, this is a button-up ; for menubuttons it is
-- a button-down ; for text entries and text widgets (outside of text tags) it is loss of
-- focus ; for scales it is dragging motion ; for canvas_items it is button-down
-- ; for menus it is a button-up ; for frames, toplevels, and canvases
-- it is dragging motion .
class body tkw; -- tk widget class; alternative draft
use tk; -- use the tk native package
use string_utility_pak; -- use various SETL utility packages
use image; -- object wrappings for grlib images
use Tk_interp_holder; -- small auxiliary package for holding TK interpreter object
use doubleclick_pak; -- doubleclick timing package for Tk
use Tk_defaults; -- defaults for Tk attribute values
const button := "button", menu := "menu", menubutton := "menubutton", frame := "frame", rastport := "rastport",
toplevel := "toplevel", label := "label", message := "message", scale := "scale",
scrollbar := "scrollbar", entry := "entry", listbox := "listbox", text := "text",
canvas := "canvas", checkbutton := "checkbutton", radiobutton := "radiobutton";
-- the tk event types
const event_types := {"activate", "buttonpress", "buttonrelease", "circulate", "colormap", " configure",
"deactivate", "destroy", "enter", "expose", "focusin", "focusout", "gravity",
"keypress", "keyrelease", "motion", "leave", "map", "property", "reparent",
"unmap", "visibility", "double", "triple"};
const event_opts_from_chars := -- mapping of event characters to option keywords
{["#","serial"],["a","above"],["b","button"],["c","count"],["d","detail"],
["f","focus"],["h","height"],["k","keycode"],["m","mode"],["o","override"],
["p","place"],["s","state"],["t","time"],["w","width"],["x","x"],["y","y"],
["B","borderwidth"],["E","sendevent"],["K","keysym"],["R","root"],
["S","subwindow"],["X","rootx"],["Y","rooty"]};
const widgets := {button, checkbutton, radiobutton, menu, menubutton, frame, rastport, toplevel, label, message,
scale, scrollbar, entry, listbox, text, canvas};
-- note that we do not count 'image' as a widget, but handle it a bit specially,
-- even though tkw objects of type 'image'will be formed
const main_command := { ["menubutton",""], --["button",""], ["checkbutton",""], ["radiobutton",""],
--["scale",""], __ these items hve built-in '-command' options
["menu",""], ["frame",""], ["rastport",""],
["toplevel",""], ["entry",""],
["listbox",""], ["text",""], ["optionbutton",""],
["canvas",""], ["label",""], ["message",""],
["arc",""],["bitmap",""], ["image",""],
["line",""], ["oval",""], ["canvas_text",""],
["polygon",""], ["rectangle",""], ["widget",""]};
const main_options := {["button","text"],["menu","type"],["menubutton","text"],["frame","hw"],["rastport","hw"],
["toplevel","hw"],["label","text"],["message","text"],["scale","ft"],
["scrollbar","orient_w"],["entry","width"],["listbox","height"],
["text","hw"],["canvas","hw"],["checkbutton","text"],["radiobutton","text"]};
const horiz_scrollable := {"entry","listbox","text","canvas"}; -- horizontally scrollable widgets
const fully_scrollable := {"listbox","text","canvas"}; -- fully scrollable widgets
const arc := "arc", bitmap := "bitmap", imaje := "image", line := "line", oval := "oval",
polygon := "polygon", rectangle := "rectangle", widget := "widget",
canvas_text := "canvas_text";
const window := "window", all := "all";
const canvas_items := {arc, bitmap, imaje, line, oval, polygon, rectangle, canvas_text, widget};
-- image and widget are also text items
-- principal keywords for geometry managers
const geom_manager_main_atts := {"side","pack","grid","place","coords"};
const geometry_keywords := {"pack","side","grid","row","column","place"};
-- keywords indicating geometry manager calls
const gen_attributes := -- general 'winfo' attributes of widgets
{"children","showing","manager","parent","rect","wincoords","toplevel","ismapped","height","width",
-- wincoords is absolute window location of the toplevel window ancestor of an object
"mouse","screendepth","screensize","screenmm"} + -- environent attributes
{"cells", "children", "class", "colormapfull", "depth", "height", "id", -- , "geometry" (moved to wm_attributes)
"ismapped", "manager", "name", "parent", "pointerx", "pointery","reqheight",
"reqwidth", "rootx", "rooty", "screen", "screencells", "screendepth", "screenheight",
"screenwidth", "screenmmheight", "screenmmwidth", "screenvisual", "server",
"toplevel", "viewable", "visual", "visualid", "vrootheight", "vrootwidth",
"vrootx", "vrooty", "width", "x", "y", "atom", "atomname", "containing",
"interps", "pathname", "exists", "fpixels", "pixels", "rgb",
"visualsavailable"};
const wm_attributes := -- general 'wm' attributes of toplevels
{"wingrid","iconified","iconposition","maxsize","minsize","resizable","sizefrom","winstate","geometry","aspect","title"};
const wm_attributes_list := ["wingrid","iconposition","maxsize","minsize","resizable","sizefrom","winstate","geometry","aspect","title",
"height","width","borderwidth","bd", "borderWidth","menu","highlightcolor",
"background","highlightbackground","cursor","relief","takefocus","highlightthickness"];
const for_toplevel_config := {"height","width","borderwidth","highlightcolor","background",
"highlightbackground","cursor","menu","relief","takefocus","highlightthickness"};
const attributes_of := { -- maps widget and canvas_item kinds to their valid attributes
-- all widgets have the following attributes, available through the Tk 'winfo' command
[all,{"cells", "children", "class", "colormapfull", "depth", "geometry", "height", "id",
"ismapped", "manager", "name", "parent", "pointerx", "pointery", "reqheight",
"reqwidth", "rootx", "rooty", "screen", "screencells", "screendepth", "screenheight",
"screenwidth", "screenmmheight", "screenmmwidth", "screenvisual", "server",
"toplevel", "viewable", "visual", "visualid", "vrootheight", "vrootwidth",
"vrootx", "vrooty", "width", "x", "y", "atom", "atomname", "containing",
"interps", "pathname", "exists", "fpixels", "pixels", "rgb",
"visualsavailable"}],
-- specific widgets have the following additional attributes
[button,{"activebackground", "activeforeground", "anchor", "background", "bitmap",
"borderwidth", "cursor", "default", "disabledforeground",
"font", "foreground", "height", "highlightbackground", "highlightcolor",
"highlightthickness", "image", "justify", "padx", "pady", "relief",
"state", "takefocus", "text", "textvariable", "underline", "width",
"wraplength"}],
[menu,{"activebackground", "activeborderwidth", "activeforeground", "background",
"borderwidth", "cursor", "disabledforeground", "font", "foreground",
"postcommand", "relief", "selectcolor", "takefocus", "tearoff",
"tearoffcommand", "title", "type"}],
[menubutton,{"activebackground", "activeforeground", "anchor", "background", "bitmap",
"borderwidth", "cursor", "direction", "disabledforeground", "font",
"foreground", "height", "highlightbackground", "highlightcolor",
"highlightthickness", "image", "indicatoron", "justify", "menu",
"padx", "pady", "relief", "state", "takefocus", "text",
"textvariable", "underline", "width", "wraplength"}],
[frame,{"background", "borderwidth", "class", "colormap", "container", "cursor",
"height", "highlightbackground", "highlightcolor", "highlightthickness",
"relief", "takefocus", "visual", "width"}],
[toplevel,{"background", "borderwidth", "class", "colormap", "container", "cursor",
"height", "highlightbackground", "highlightcolor", "highlightthickness",
"menu", "relief", "screen", "takefocus", "use", "visual", "width"}],
[label,{"anchor", "background", "bitmap", "borderwidth", "cursor", "font", "foreground",
"height", "highlightbackground", "highlightcolor", "highlightthickness",
"image", "justify", "padx", "pady", "relief", "takefocus", "text",
"textvariable", "underline", "width", "wraplength"}],
[message,{"anchor", "aspect", "background", "borderwidth", "cursor", "font", "foreground",
"highlightbackground", "highlightcolor", "highlightthickness", "justify",
"padx", "pady", "relief", "takefocus", "text", "textvariable",
"width"}],
[scale,{"activebackground", "background", "bigincrement", "borderwidth", "cursor",
"digits", "font", "foreground", "from", "highlightbackground", "highlightcolor",
"highlightthickness", "label", "length", "orient", "relief", "repeatdelay",
"repeatinterval", "resolution", "showvalue", "sliderlength",
"sliderrelief", "state", "takefocus", "tickinterval", "to",
"troughcolor", "variable", "width"}],
[scrollbar,{"activebackground", "activerelief", "background", "borderwidth",
"cursor", "elementborderwidth", "highlightbackground", "highlightcolor",
"highlightthickness", "jump", "orient", "relief", "repeatdelay",
"repeatinterval", "takefocus", "troughcolor", "width"}],
[entry,{"background", "borderwidth", "cursor", "exportselection", "font", "foreground",
"highlightbackground", "highlightcolor", "highlightthickness",
"insertbackground", "insertborderwidth", "insertofftime", "insertontime",
"insertwidth", "justify", "relief", "selectbackground",
"selectborderwidth", "selectforeground", "show", "state",
"takefocus", "textvariable", "width", "xscrollcommand"}],
[listbox,{"background", "borderwidth", "cursor", "exportselection", "font", "foreground",
"height", "highlightbackground", "highlightcolor", "highlightthickness",
"relief", "selectbackground", "selectborderwidth", "selectforeground",
"selectmode", "setgrid", "takefocus", "width", "xscrollcommand",
"yscrollcommand"}],
[text,{"background", "borderwidth", "cursor", "exportselection", "font", "foreground",
"height", "highlightbackground", "highlightcolor", "highlightthickness",
"insertbackground", "insertborderwidth", "insertofftime", "insertontime",
"insertwidth", "padx", "pady", "relief", "selectbackground",
"selectborderwidth", "selectforeground", "setgrid", "spacing1",
"spacing2", "spacing3", "state", "tabs", "takefocus", "width",
"wrap", "xscrollcommand", "yscrollcommand"}],
[canvas,{"coords", "background", "borderwidth", "class", "colormap", "container", "cursor",
"height", "highlightbackground", "highlightcolor", "highlightthickness",
"menu", "relief", "screen", "takefocus", "use", "visual", "width"}],
[arc,{"extent", "fill", "outline", "outlinestipple", "start", "stipple", "style",
"tags", "width"}],
-- [bitmap,{,,,,,,,,}],
-- [imaje,{,,,,,,,,}],
[line,{"arrow", "arrowshape", "capstyle", "fill", "joinstyle", "smooth",
"splinesteps", "stipple", "tags", "width"}],
[oval,{"fill", "outline", "stipple", "tags", "width"}],
[polygon,{"fill", "smooth", "splinesteps", "stipple", "tags", "width"}],
[rectangle, {"fill", "outline", "stipple", "tags", "width"}],
["canvas_text",{"anchor", "fill", "font", "justify", "stipple", "tags", "text",
"width"}],
["text_tag",{"background", "bgstipple", "borderwidth", "fgstipple", "font", "foreground",
"justify", "lmargin1", "lmargin2", "offset", "overstrike", "relief",
"rmargin", "spacing1", "spacing2", "spacing3", "tabs", "underline", "wrap"}],
["canvas_tag",{"arrow", "arrowshape", "capstyle", "fill", "joinstyle", "smooth",
"splinesteps", "stipple", "tags", "width"}],
["image",{"anchor","image","tags"}], -- attributes of canvas images, not real images
["widget",{"anchor", "tags", "height", "width", "window"}]
-- attributes of canvas widgets, not real widgets
};
-- indices which can be used to identify menu items
const menu_index_indices := {"active", "end", "last", "none"}; -- can also be n, @j, or label match pattern
-- indices which can be used to identify listbox items
const listbox_index_indices := {"anchor", "end", "active"}; -- can also be n, @i, or @x,y
const entry_indices := {"anchor", "end", "insert", "sel.first", "sel.last"};
-- can also be n or @j
const text_indices := {"current", "end", "insert", "sel.first", "sel.last"};
-- can also be line.char, @x,y, image_name, mark_name, widget_name, tag.first, tag.last
const pack_options := -- options for the 'pack' geometry manager
{"after","anchor","before","expand","fill","in","ipadx","ipady","ipadx","ipady","side"};
const grid_options := -- options for the 'grid' geometry manager
{"column","columnspan","row","rowspan","in","ipadx","ipady","padx","pady","ipadx","ipady","sticky"};
const place_options := -- options for the 'place' geometry manager
{"anchor","x","y","relx","rely","in","width","height","relheight","bordermode"};
const key_attributes := ["extent","window","image","bitmap","smooth","font"];
-- for determination of canvas item type from item number
const special_atts := {"sel.anchor","end","insert","sel.first","sel.last","coords"};
-- special attributes of entry widgets, text widgets, and canvas text items (the two latter have no 'anchor')
-- for text widgets tag.first and tag.last are available for all defined tags
const special_atts_less_anchor := {"end","insert","sel.first","sel.last","coords"};
const pseudo_atts := {"clipboard","fonts","definedFonts","placed","packed", -- various pseudo_atts
"gridded","image","type","limits","position", "active", "propagate"};
const special_lefts := {"xscroller", "yscroller", "clipboard", "grab", "sel.anchor", "sel", "active",
"xview", "yview" ,"xpercent", "ypercent","limits","position"}; -- various pseudo_atts usable on left
const rel_atts_of_images := {"anchor","tags","image","align","name","padx","pady"};
-- relative attributes of images, as distinct from their internal attributes
const posns_map := {["mac_creator",2],["mac_hiddden",4],["mac_readonly",6],["mac_type",8],["mtime",9],["atime",10],["gid",11],["nlink",12],
["mode",13],["type",14],["ctime",15],["uid",16],["ino",17],["size",18],["dev",19],["pointer",20]};
--positions map for file attributes
class var window_open_flag := OM, -- flag for base window already open
name_ctr := 0, -- counter for generation of widget names
proc_ctr := 0, -- counter for generation of procedure ids
proc_tk_name := { }, -- maps SETL procedures into their tk string names
-- obj_of := { }, -- maps widget name to widget object
source_of := { }; -- maps canvas image and widget items to their source objects
var name := ".", -- section of name, between '.'s
tk_type := "", -- tk type of object
parent := OM; -- parent object of widget
procedure create(); -- creation of fundamental interpreter and empty objects
-- if not adjusted, all the empty objects created here are seen as the tk root object
-- initialize the tk interpreter if necessary
if interp = OM then
interp := tk_create(); tk_kall("update"); doubleclick := doubleclikk; canvas_doubleclick := canvas_doubleclikk;
end if;
if window_open_flag = OM then
window_open_flag := 0; -- open master window just once
tk_kall("frame . -height 300 -width 300 ");
tk_type := "toplevel";
-- abend_trap := the_end;
end if;
end create;
procedure the_end;
print("debug_trace: ",debug_trace); tk_kall("beep"); stop;
end the_end;
procedure tk_kall(cmd); -- conditionally traces the tk_calls
if show_commands then print(cmd); end if; -- trace the tk_call
if for_tk = OM then
res := tk_call(interp,cmd); if show_commands then print(res); end if; return res;
end if;
-- then execute it and return the result
for_tk with:= cmd; return OM; -- otherwise accumulate command
end tk_kall;
procedure do_all_calls(); -- transmit all calls to Tk, as single string
if for_tk = OM then return; end if; -- nothing to do if not accumulating
tk_call(interp,join(for_tk,"\n")); for_tk := OM;
end do_all_calls;
procedure hold_calls(); -- start accumulating calls to Tk
do_all_calls(); for_tk := [];
end hold_calls;
procedure Tk_id(); return name; end Tk_id; -- returns an object's (short) Tk name
procedure Tk_kind(); return tk_type; end Tk_kind; -- returns an object's Tk type
procedure Tk_break(); tk_call(interp,"break"); end Tk_break; -- terminate event handling in the Tk sequence
procedure Tk_continue(); tk_call(interp,"continue"); end Tk_continue; -- jump in event handling in the Tk sequence
procedure dooneevent(); tk_dooneevent(interp); end dooneevent; -- wait for some (any) Tk event
procedure do_later(proc); tk_idlecallback(proc); end do_later;
-- execute a procedure after a short delay
procedure obj_from_tkname(tkname); -- reconstruct a widget from its Tk name
-- print("obj_from_tkname: ",tkname);
tkn := rbreak(tkname,":"); tkname := tkn; -- drop the prefix if full 'str' form is given
obj := tkw(); -- create an empty object
if #tkname < 2 then -- return a copy of the root object
obj.name := "."; obj.tk_type := "toplevel"; obj.parent := OM;
return obj;
end if;
klass := tk_kall("winfo class " + tkname);
klass := case_change1(klass);
obj.tk_type := klass; -- set the object type
nayme := rbreak(tkname,"."); rmatch(tkname,"."); -- break off the last name fragment
obj.name := nayme; -- use the first name fragment
obj.parent := obj_from_tkname(tkname); -- proceed recursively
return obj;
end obj_from_tkname;
procedure tk_parent(); return parent; end tk_parent; -- the parent object of an object
procedure win_of_pt(x,y); -- find the widget containing x,y
return if (wc := tk_kall("winfo containing " + str(x) + " " + str(y))) = "" then OM else
obj_from_tkname(wc) end if;
end win_of_pt;
procedure case_change1(stg); -- workaround for case_change bug
caps := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; lc := "abcdefghijklmnopqrstuvwxyz";
s1 := stg(1);
if exists c = caps(j) | c = s1 then stg(1) := lc(j); end if;
return stg;
end case_change1;
procedure as_pair(stg); -- reduce menu item configuration data to a map
match(stg,"-"); att_name := break(stg," "); match(stg," "); return [att_name,stg];
end as_pair;
procedure self(x); -- configuration query, item configuration query, or creation call.
-- configuration queries all have the form obj("attr;attr;...").
-- creation calls have the form parent_obj("kind", "main_param");
-- 'kind' can be one of the allowed widget kinds, or can be an allowed
-- canvas item arc, bitmap, image, line, oval, polygon, text, image,
-- or widget. We give every item a unique generated name
-- of the form Wnnn (for widgets) or Cnnn (for canvas items).
fn := full_name(); -- get full name of item
if x = OM then -- miscellaneous fetches, depending on widget type
case tk_type
when "listbox" => -- for listboxes, get the currently selected items
num_elts := unstr(tk_kall(fn + " index end"));
selected := [];
for m in [0..num_elts] loop
txt := fn + " selection includes " + str(m);
if tk_kall(txt) = "1" then selected with:= (m + 1); end if;
end loop;
return selected;
when "menu" => -- for menus, get the configuration data for al the menu items
num_elts := unstr(tk_kall(fn + " index end"));
item_info := []; -- will collect info for each meu item
for m in [0..num_elts] loop
txt := fn + " entryconfigure " + str(m);
item_info with:= {as_pair(x): x in stgs_from_Tk(tk_kall(txt))};
end loop;
return item_info; -- returntupleof info items, one for each menu entry
when "entry" => return tk_kall(fn + " get");
-- for entries, labels, and messages, get the text
when "label","message" => return tk_kall(fn + " cget -text");
when "text" => stg := tk_kall(fn + " get 0.0 end"); return stg(1..#stg - 1);
when "menubutton" => -- mb(OM) gets the menu of a menubutton
menu_name := tk_kall(fn + " cget -menu");
obj := tkw(); -- create an empty object
nayme := rbreak(menu_name,"."); rmatch(menu_name,".");
obj.tk_type := "menu";
obj.name := nayme; -- use the first name fragment
obj.parent := obj_from_tkname(menu_name); -- find the menubutton name
return obj;
when "canvas" => -- for canvases, get the vector of canvas items
items_no_list := breakup(tk_kall(fn + " find all")," ");
items_list := []; -- will build
for item_no in items_no_list loop
sino := str(item_no);
new_name := "c" + sino; -- canvas items are named cnn, nn = serial number
new_item := tkw(); -- form a blank new canvas item
new_item.parent := self; -- this canvas is the parent
kind := tk_kall(fn + " type " + sino);
if kind = "text" then kind := "canvas_text"; end if;
if kind notin canvas_items then kind := "widget"; end if;
new_item.tk_type := kind; -- note its type
new_item.name := new_name; -- note its name
items_list with:= new_item;
end loop;
return items_list;
when "scale" => -- for sliders, get the slider value
return unstr(tk_kall(fn + " get"));
when "toplevel" => -- for toplevels, get the title
return tk_kall("wm title " + fn);
when "socket" => -- for sockets, read the socket
may_error := tk_kall("set er [catch {gets " + name + " result}]"); -- pass gets command to tk
if may_error /= "0" then -- there was an error
socket_error := "error: " + may_error;
tk_kall("close " + name); -- pass 'close peer' command to tk
return OM; -- return OM as the item read
elseif (eofres := tk_kall("set er [eof " + name + "]")) /= "0" then -- there was an end of file
socket_error := ""; -- note the end-of_file
else
socket_error := 0; -- note not end-of_file
end if;
res := tk_kall("set er $result");
--print("now return result: ",socket_error,"**",res); -- return the result string just read
return res;
end case;
if tk_type in canvas_items then -- get all the information for a canvas item, as a map
--print("tk_type in canvas_items: ",tk_type," ",attributes_of(tk_type));
att_list := [x: x in attributes_of(tk_type)] with "coords";
the_attrs := read_attrs_canvas_item(att_list);
return {[att,the_attrs(j)]: att = att_list(j)};
end if;
end if; -- end of the 'fetch main data' cases
if is_string(x) then -- configuration query
-- here we require the string parameter x to be a semicolon-separated list of attribute
-- names, appropriate to the object type being queried. The corresponding tuple of
-- attribute values is returned. Canvas items must be treated specially,
-- as must a few strings such as , which we treat as attributes but tk treats differently.
attr_list := chop(x); -- break into list of attributes
if tk_type = "entry" or tk_type = "canvas_text" or tk_type = "text" then
-- the simple attributes "rect","width","height" are handled specially
attr_val_tup := if x in {"rect","width","height"} then read_attrs_widget(attr_list)
elseif x in gen_attributes then get_winfo_attr(x)
elseif x in {"place","pack","grid"} then get_winfo_attr(x)
else read_attrs_entry_or_canv_text(attr_list) end if;
elseif tk_type = "toplevel" and attr_list(1) in wm_attributes then
attr_val_tup := get_wm_attr(attr_list);
elseif tk_type in widgets then -- this item is some other kind of widget
attr_val_tup := read_attrs_widget(attr_list);
elseif tk_type in {"image","bitmap"} and parent = OM then -- this is an absolute image
attr_val_tup := [ ]; -- will collect and return the attribute values in a tuple
for att in attr_list loop -- 'name' is the name of the image itself
attr_val_tup with:= tk_kall(name + " cget " + " -" + att);
end loop;
elseif tk_type in {"image","bitmap"} and parent /= OM then -- this is a canvas or text image
attr_val_tup := read_attrs_can_or_text_im(attr_list);
elseif tk_type in canvas_items then -- we have a canvas item
attr_val_tup := read_attrs_canvas_item(attr_list);
elseif tk_type = "file" then -- get file attributes
attr_val_tup := read_file_atts(name,attr_list);
elseif tk_type = "socket" or tk_type = "server_socket" then -- get socket attributes; but this is never called
attr_val_tup := read_socket_atts(name,attr_list);
else -- if this object is a text item, we must use its parent and the itemcget
-- procedure to query its configuration
attr_val_tup := read_attrs_text_item(attr_list);
end if;
return if is_tuple(attr_val_tup) and #attr_val_tup <= 1 then attr_val_tup(1) else attr_val_tup end if;
elseif tk_type = "text" then -- here x is a tuple and we have a tag attributes or ranges query
[tag,att_names] := x;
if tag = "tag" then -- we deal with a tag ranges query
txt := full_name() + " tag ranges \"" + str(att_names) + "\""; -- in this case 'att_names' is really the tag
limits := breakup(tk_kall(txt)," "); -- convert to a list of pairs
--print("limits: ",limits,txt);
return [[one_indexing(limits(j)),limits(j + 1)]: j in [1,3..#limits]];
end if;
att_names := chop(att_names);
if att_names = [] then -- return all the attributes of the tag
att_names := attributes_of("text_tag");
return {[att,tk_kall(full_name() + " tag cget " + tag + " -" + att)]: att in att_names};
end if;
att_vals := [tk_kall(full_name() + " tag cget " + tag + " -" + att): att in att_names];
--print("att_vals: ",att_vals);
return if #att_names = 1 then att_vals(1) else att_vals end if;
else -- here x is a tuple, so we have an item configuration query, creation call, or pixel fetch
[kind,the_text] := x; -- here either the kind must be an integer designating an item, or x is a pair,
-- consisting of a valid widget or canvas-item type and its principal parameter.
-- we check the validity of the parent, create a new blank
-- widget or canvas item, and fill in its fields name, tk_type,
-- and parent
if is_integer(kind) then -- check that this is a menu or a pixel fetch
if tk_type = "image" and parent = OM then -- image pixel fetch
txt := name + " get " + str(kind) + " " + str(the_text);
return tk_kall(txt); -- return the pixel value
elseif tk_type /= "menu" then
abort("Numbered item references are only allowed for menus.");
end if;
options := chop(the_text);
return tk_kall(full_name() + " entrycget " + str(kind)
+/ [" -" + item: item in options]);
end if;
-- otherwise we deal with a ****** creation call ******
the_text := str(orig := the_text); -- force the parameter to string form
if kind = "image" and tk_type /= "text" and tk_type /= "canvas" then
return make_absolute_image(orig);
-- build an absolute image either from a file name or from an image class absolute image
elseif kind = "bitmap" and tk_type /= "text" and tk_type /= "canvas" then
return make_absolute_bitmap(orig);
-- build an absolute image either from a data string or a pair
elseif kind in canvas_items or (kind = "text" and tk_type = "canvas") then
-- creation of a canvas or text item; parent must be canvas or text
return make_canvas_or_text(kind,the_text,orig); -- build a canvas or text item
elseif kind in widgets or kind = "optionbutton" then -- any parent is OK; form the name
return make_new_widget(kind,the_text); -- build a widget
elseif kind = "file" then -- any parent is OK; make a file widget
return make_file_widget(the_text); -- build a file widget
elseif kind = "socket" or kind = "server_socket" then -- any parent is OK; make a socket widget
return make_socket_widget(orig); -- build a socket widget; here we want the original form of
-- the parameter pair [host_and_or_port,text_blocksize_or_accept_proc]
elseif kind = "named" then -- make a widget from its Tk name
Tk_name := rbreak(the_text,":"); -- break Tk name out of print form
return obj_from_tkname(Tk_name); -- reconstruct the tkw-class widget from its full Tk string name
else
abort("The widget type " + kind + " is illegal.");
end if;
end if;
end;
procedure full_name(); -- finds full tk name string of widget
return if parent = OM then name elseif (pfn := parent.full_name()) = "." then "." + name
else pfn + "." + name end if;
end full_name;
procedure selfstr(); -- string conversion
return tk_type + ":" + full_name(); -- type and name
end selfstr;
procedure one_indexing(ix_stg); -- convert to 1-indexing
back := rbreak(ix_stg,"."); return ix_stg + str(unstr(back) + 1);
end one_indexing;
procedure read_attrs_entry_or_canv_text(attr_list);
-- read attributes of an entry widget or canvas text item, with a few
-- special attributes: anchor, end, insert, sel.first, sel.last
if attr_list = [] then -- return all the attributes
--print("read_attrs_entry_or_canv_text, null attr_list: ",tk_type);
return ((as_map(tk_kall(full_name() + " configure")) +
{[att,get_winfo_attr(att)]: att in ["children","showing","manager","rect","ismapped","wincoords","toplevel"]})
- (Tk_data_defaults(tk_type)?{})) with
["text",tk_kall(full_name() + if tk_type = "text" then " dump -all 1.0 end" else " get" end if)];
-- get the text as an attribute; full form if we have a tex widget
end if;
attr_val_tup := [ ]; -- will collect and return the attribute values in a tuple
--print("read_attrs_entry_or_canv_text: ",attr_list,tk_type,special_atts);
if tk_type = "canvas_text" then -- attributes of canvas text item
fn := parent.full_name();
for att in attr_list loop -- loop, using the tk cget command to get the value
if att = "type" then -- get the type
attr_val_tup with:= tk_type; continue;
elseif att notin special_atts_less_anchor then -- need not treat specially
-- not in {"end", "insert", "sel.last", "sel.first", "coords"}:
att_val := tk_kall(fn + " itemcget " + name(2..) + " -" + att);
attr_val_tup with:= if att = "font" then "{" + att_val + "}"
elseif att = "text" then "\"" + att_val + "\"" else att_val end if;
elseif att /= "coords" then -- treat specially, using 'index'
res := tk_kall(fn + " index " + name(2..) + " " + att);
if res = "selection isn't in item" then res := 0; end if;
attr_val_tup with:= res;
else -- special treatment for "coords"
fn := parent.full_name(); -- get the full tk name of the parent canvas
attr_val_tup with:= breakup(tk_kall(fn + " coords " + name(2..))," ");
end if;
end loop;
return [if x = 0 then OM else x end if: x in attr_val_tup]; -- done with this case
end if;
fn := full_name(); -- otherwise we deal with an entry or text widget
-- get the full tk name of this widget or of canvas item parent
if tk_type = "text" and attr_list = [] then
return tk_kall(fn + " dump -all 1.0 end"); -- get all the information for a text widget
end if;
for att in attr_list loop -- loop, using the tk cget command to get the value
if att = "type" then -- get the type
attr_val_tup with:= tk_type;
elseif att = "tags" and tk_type = "text" then -- we have the "tags" attribute of a text widget
tag_list := breakup(tk_kall(fn + " tag names")," ");
attr_val_tup with:= tag_list;
elseif att = "marks" and tk_type = "text" then -- we have the "marks" attribute of a text widget
mark_list := breakup(tk_kall(fn + " mark names")," ");
attr_val_tup with:= mark_list;
elseif att = "widgets" and tk_type = "text" then -- we have the widgets in a text widget
lis := breakup(tk_kall(full_name() + " window names ")," ");
return [obj_from_tkname(item): item in lis];
elseif att = "images" and tk_type = "text" then -- we have the images in a text widget
return images();
elseif att notin special_atts then -- use ordinary cget call
attr_val_tup with:= tk_kall(fn + " cget -" + att);
else -- use 'index' call, in form appropriate to entry and text widgets
attr_val_tup with:= tk_kall(fn + " index " + att);
end if;
end loop;
return attr_val_tup;
end read_attrs_entry_or_canv_text;
procedure position_in_window(fn); -- gets the anchor position of the object from its Tk name
--print("position_in_window: ",fn); -- relative to the top level window of the object; works for placed objects only
windn := tk_kall("winfo toplevel " + fn);
offx := offy := 0;
while fn /= windn and fn /= "" loop
if (geometry_val := tk_call(interp,"place info " + fn)) = "" then exit; end if; -- quit if there is an ancestor level which is not 'placed'
--print("geometry_val: ",geometry_val," ",fn); -- relative to the top level window of the object; works for placed objects only
geometry_tup := breakup(geometry_val," "); geo_map := {geometry_tup(j..j+1): j in [1,3..#geometry_tup]}; -- break into pairs
offx +:= unstr(geo_map("-x")); offy +:= unstr(geo_map("-y"));
rbreak(fn,"."); rmatch(fn,".");
end loop;
return [offx,offy];
end position_in_window;
procedure get_winfo_attr(att); -- get an attribute available through the Tk 'winfo' primitives
fn := full_name();
--print("fn: ",att," ",fn);
case att
when "children" => chlist := breakup(tk_kall("winfo children " + fn)," ");
return [obj_from_tkname(x): x in chlist];
when "showing" => return tk_kall("winfo viewable " + fn);
when "manager" => return tk_kall("winfo manager " + fn); -- pc, grid, or place
when "parent" => return obj_from_tkname(tk_kall("winfo paren " + fn));
when "rect" => -- this returns the element's enclosing rectangle
-- the following code works for widgets, but needs to be checked for canvas items
-- [x,y] := position_in_window(fn);
height := unstr(tk_kall("winfo height " + fn));
width := unstr(tk_kall("winfo width " + fn));
return [x := unstr(tk_kall("winfo rootx " + fn)),
y := unstr(tk_kall("winfo rooty " + fn)),x + width,y + height];
when "ismapped" => return unstr(tk_kall("winfo ismapped " + fn));
when "wincoords" => return [unstr(tk_kall("winfo rootx " + fn)),
unstr(tk_kall("winfo rooty " + fn))];
when "toplevel" => return obj_from_tkname(tk_kall("winfo toplevel " + fn));
when "mouse" => -- the following are environent attributes
return [unstr(tk_kall("winfo pointerx " + fn)),
unstr(tk_kall("winfo pointery " + fn))];
when "screendepth" => return unstr(tk_kall("winfo depth " + fn));
when "screensize" => return [unstr(tk_kall("winfo screenwidth " + fn)),
unstr(tk_kall("winfo screenheight " + fn))];
when "screenmm" => return [unstr(tk_kall("winfo screenmmwidth " + fn)),
unstr(tk_kall("winfo screenmmheight " + fn))];
when "place","pack","grid" =>
geometry_val := tk_kall(att + " info " + self.full_name());
val_list := breakup(geometry_val," ");
geo_map := {[val_list(j)(2..),vljp1]: j in [1,3..#val_list - 1] | (vljp1 := val_list(j + 1)) /= "{}"};
return geo_map;
otherwise => return unstr(tk_kall("winfo " + att + " " + fn));
end case;
end get_winfo_attr;
--->working
procedure get_wm_attr(attr_list); -- get window-manager attributes of toplevel
attvals := []; -- will collect
fn := full_name(); -- widget name
orig_attr_list := attr_list; -- save for testing below
if attr_list = [] then -- want all attributes
attr_list := ["wingrid","iconposition","maxsize","minsize","resizable","sizefrom","winstate","geometry","aspect","title"];
end if;
for att in attr_list loop
att := if att = "wingrid" then "grid" elseif att = "winstate" then "state" elseif att = "rect" then "geometry" else att end if;
res := tk_kall("wm " + att + " " + if att = "interps" then "" else fn end if);
-- "wingrid","iconposition","maxsize","minsize","resizable","sizefrom","winstate","geometry" = "rect","aspect","title"
case att -- return normal tuples where blank-delimited tuples would have been returned
when "grid","maxsize","minsize","resizable" => res := [unstr(x): x in breakup(res," ")];
when "geometry" => [w,h,ul_x,ul_y] := [unstr(x): x in breakup(res,"x+")];
res := [ul_x,ul_y,ul_x + w,ul_y + h]; -- return as standard rectangle
end case;
attvals with:= res;
end loop;
if orig_attr_list = [] then return {[alj,attvals(j)]: alj = attr_list(j)}; end if;
return if #attvals = 1 then attvals(1) else attvals end if;
end get_wm_attr;
procedure containing(x,y); -- window containing given point
return tk_kall("winfo containing " + x + " " + y);
end containing;
procedure pixels(n); -- number of pixels corresponding to given size in screen units
return tk_kall("winfo pixels " + full_name() + " " + n);
end pixels;
procedure fpixels(n); -- floating number of pixels corresponding to given size in screen units
return tk_kall("winfo fpixels " + full_name() + " " + n);
end fpixels;
procedure rgb(color_name); -- numerical code for named color
return tk_kall("winfo rgb " + full_name() + " " + color_name);
end rgb;
procedure set_wm_atts(attr_list,y); -- set window-manager attributes of toplevel
fn := full_name(); -- widget name
--print("set_wm_atts: ",fn,attr_list,y);
if #attr_list = 1 and ((al1 := attr_list(1)) = "geometry" or al1 = "resizable" or al1 = "maxsize" or al1 = "minsize" or al1 = "aspect")
and is_tuple(y) and #y > 1 then y := [y]; end if; -- force to singleton if singleton wanted
hold_over := OM; -- might have holdovers for processing by reconfigure_from_map
if attr_list = [] then -- want to set all attributes from a map
--print("from a map: ",y);
y("wincoords") := OM; y("rect") := OM; -- treat these as 'write-only'
y("toplevel") := OM; y("children") := OM; -- treat these as 'write-only'
y("bd") := OM; y("ismapped") := OM; y("manager") := OM; y("showing") := OM; -- treat these as 'write-only'
y("Tk_tags") := OM; -- the tags attributes are handled elsewhere
-- eliminate read-only attributes of toplevels (can be set only when toplevel being created)
y("colormap") := OM; -- can't modify -colormap option after widget is created
y("visual") := OM; -- can't modify -visual option after widget is created
y("use") := OM; -- can't modify -use option after widget is created
y("container") := OM; -- can't modify -container option after widget is created
y("screen") := OM; -- can't modify -screen option after widget is created
y("class") := OM; -- can't modify -class option after widget is created
hold_over := {[att,y(att)]: att in for_toplevel_config}; -- holdovers for reconfigure_from_map
attr_list := [att in wm_attributes_list | y(att) /= OM and att notin for_toplevel_config
and att /= "iconposition" and att /= "aspect" and att /= "wingrid"]; -- disable two atributes which may be UNIX only
y := [ya: att in wm_attributes_list | (ya := y(att)) /= OM and att notin for_toplevel_config
and att /= "iconposition" and att /= "aspect" and att /= "wingrid"];
end if;
for att = attr_list(j) loop
att := if att = "wingrid" then "grid" elseif att = "winstate" then "state" elseif att = "rect" then "geometry" else att end if;
-- "wingrid","iconposition","maxsize","minsize","resizable","sizefrom","winstate","geometry" = "rect","aspect","title"
if att = "state" then -- may iconify, withdraw, or set to normal
yj := y(j);
if yj = "iconic" or yj = "normal" or yj = "withdrawn" then
yj := if yj = "iconic" then "iconify" elseif yj = "normal" then "deiconify" else "withdraw" end if;
kall_res := tk_kall(txt := "wm " + yj + " " + fn);
--print("kall_res: ",kall_res," ",txt);
end if;
continue; -- done with this case
end if;
if att = "geometry" then -- parameter must be put in special w_x_h+x+y form
bu_y := if is_string(y(j)) then breakup(y(j),";,") else y(j) end if; -- decompose the argument if it was transmitted as a delimited string
[ul_x,ul_y,lr_x,lr_y] := if is_string(bu_y(1)) then [unstr(eltx): eltx in bu_y] else bu_y end if; -- force to numeric
param_val := str(lr_x - ul_x) + "x" + str(lr_y - ul_y) + "+" + ul_x + "+" + ul_y; -- put in special form
else -- put parameter in normal blank-delimited form
--print("att,y(j): ",att," ",y(j)," ",j," y: ",y);
yy := if is_string(y(j)) then if (yj := y(j)) = "" then ["{}"] else breakup(y(j),";,") end if else y(j) end if;
-- put nullstring values into Tk form
param_val := join(if is_string(yy(1)) then yy else [str(z): z in yy] end if," ");
-- space out parameter components with blanks after forcing to string
end if;
res := tk_kall("wm " + att + " " + fn + " " + param_val);
--print("set_wm_atts: ","wm " + att + " " + fn + " " + param_val," ",res);
end loop;
if hold_over /= OM then reconfigure_from_map(hold_over); end if;
-- handle remaining ttributes in reconfigure_from_map
end set_wm_atts;
procedure toplev_bracket_posns(stg); -- get top-level bracket positions in original string
tup := single_out(stg,"{}\\ "); -- single out significant characters
charloc := 0;
toplev := []; parenlev := 0; was_escape := false; -- will group into top-level bracketed items
for x = tup(j) loop
charloc +:= 1; -- location of current character
if x = "{" then
if was_escape then -- open paren is escaped; don't collect
was_escape := false; continue;
end if;
if parenlev = 0 then toplev with:= charloc; end if; -- collect parenthesis position at top level
parenlev +:= 1; -- advance since now within
elseif x = "}" then
if was_escape then -- open paren is escaped; don't collect
was_escape := false; continue;
end if;
parenlev -:= 1; -- decrement since now out
if parenlev = 0 then toplev with:= charloc; end if; -- collect parenthesis position at top level
elseif x = "\\" then -- reverse escape state
was_escape := not was_escape; continue;
else
charloc +:= (#x - 1); -- one character was handled above
end if;
was_escape := false; -- applied if value not explicitly set aove
end loop;
return toplev; -- return the list of toplevel unescaped bracket positions
end toplev_bracket_posns;
-- procedure my_single_out(stg,pat); -- single out characters in pat
-- if (pat_pl := [j: c = stg(j) | c in pat]) = [] then return stg; end if;
-- pieces := if (pp1 := pat_pl(1)) = 1 then [] else [stg(1..pp1 - 1)] end if; -- will collect
-- for pp = pat_pl(j) loop -- iterate over all the significant charater locations
-- pieces with:= stg(pp); -- take the significant character
-- if (next := (pat_pl(j + 1)?(#stg + 1)) - 1) > pp then -- take the next or final piece if not empty
-- pieces with:= stg(pp + 1..next);
-- end if;
-- end loop;
-- return pieces;
-- end my_single_out;
procedure stgs_from_Tk(stg); -- get list of strings from Tk blank-delimited form;
-- break string at top-level blank positions and de-escape
toplev := toplev_bracket_posns(stg); -- get top_level bracket positions
if toplev = [] then return break_at_blanks(stg); end if; -- no toplevel bracket positions
pieces := break_at_blanks(stg(1..toplev(1) - 1)); -- break first section
for k in [1..(ntl := #toplev) - 1] loop
stg_section := stg(toplev(k) + 1..toplev(k + 1) - 1);
-- dont break bracketed sections
pieces +:= if stg(toplev(k)) = "{" then [stg_section] else break_at_blanks(stg_section) end if;
end loop;
pieces +:= break_at_blanks(stg(toplev(ntl) + 1..)); -- break final section
return pieces;
end stgs_from_Tk;
procedure break_at_blanks(stg); -- break string at unescaped blanks, and de-escape
if stg = "" then return []; end if; -- empty string become null
just_escaped := false; -- initialize
cleaned_stg := ""; -- will build
tup := []; -- will collect
for c = stg(j) loop -- characters of the string
if just_escaped then
just_escaped := false;
cleaned_stg +:=
if c = "n" then "\n" elseif c = "r" then "\r" elseif c = "t" then "\t" elseif c = "t" then "\\x" else c end if;
-- take the character, which may be a backslash; normally escaped characters are speical cased
elseif c = "\\" then -- this is an 'escape'
just_escaped := true;
elseif c = " " then -- a section ends
if cleaned_stg /= "" then tup with:= cleaned_stg; end if; cleaned_stg := ""; -- collect and restart
else -- take this normal chaacter
cleaned_stg +:= c;
end if;
end loop;
if cleaned_stg /= "" then tup with:= cleaned_stg; end if; -- collect final section
return tup; -- return the list of pieces
end break_at_blanks;
procedure remove_escapes(stg); -- remove Tk escapes from string
if stg = "" then return ""; end if;
just_escaped := false; -- initialize
cleaned_stg := ""; -- will build
tup := []; -- will collect
for c = stg(j) loop -- characters of the string
if just_escaped then
just_escaped := false;
cleaned_stg +:=
if c = "n" then "\n" elseif c = "r" then "\r" elseif c = "t" then "\t" elseif c = "t" then "\\x" else c end if;
-- take the character, which may be a backslash; tabs, eols, and hex signs get special treatment
elseif c = "\\" then -- this is an 'escape'
just_escaped := true;
else -- take this normal chaacter
cleaned_stg +:= c;
end if;
end loop;
return cleaned_stg; -- return the cleaned_stg
end remove_escapes;
procedure as_map(stg); -- converts a Tk configuration descriptor string to a mapping from attrbute names to values
--print("as_map: ",stg);
toplev := toplev_bracket_posns(stg); -- get top_level bracket positions
the_map := {}; parenlev := 0; -- initialize
for k in [1,3..#toplev - 1] loop
slash_parity := 0; -- restart
substg := stg(toplev(k) + 1..toplev(k + 1) - 1); -- get one configuation descriptor segment
-- we are looking for the pieces delimited by the first and last top level blanks
attrib := break(substg," "); match(substg," ");
if (attrib := attrib(2..)) = "bg" or attrib = "fg" then continue; end if; -- these ae just synonyms
last_sig_blank := 0; -- intiatialize
for x = substg(kk) loop -- look for last significant blank
if x = "{" then
if kk > 1 and substg(kk - 1) = "\\" and slash_parity = 1 then -- open bracket is escaped
continue;
end if;
parenlev +:= 1;
elseif x = "}" then
if kk > 1 and substg(kk - 1) = "\\" and slash_parity = 1 then -- close bracket is escaped
continue;
end if;
parenlev -:= 1;
elseif x = " " and parenlev = 0 then -- we have a significant blank
last_sig_blank := kk;
elseif x = "\\" then
slash_parity := 1 - slash_parity;
end if;
end loop;
mv := substg(last_sig_blank + 1..);
if (nmv := #mv) > 0 and mv(1) = "{" and mv(nmv) = "}" then mv := mv(2..nmv - 1); end if;
the_map(attrib) := mv;
end loop;
return the_map;
end as_map;
procedure read_attrs_widget(attr_list); -- read widget attributes
attr_val_tup := [ ]; -- will collect and return the attribute values in a tuple
fn := full_name(); -- get the full tk name of this widget
if attr_list = [] then
res := as_map(tk_kall(fn + " configure")) +
{[att,get_winfo_attr(att)]: att in ["children","showing","manager","rect","ismapped","wincoords","toplevel"]};
--print("read_attrs_widget, testing listbox: ",);
return if tk_type = "listbox" then res with ["text",self(1..#self)]
elseif tk_type = "toplevel" then res + get_wm_attr([]) else res end if;
end if; -- empty list returns collection of all attributes
for att in attr_list loop -- loop, using the tk cget command to get the value
if att in gen_attributes then
--print("gen_attributes read_attrs_widget: ",attr_list);
if att in {"height","width"} and tk_type /= "toplevel" then
attr_val_tup with:= unstr(tk_kall(fn + " cget -" + att)); continue;
elseif att = "toplevel" then
tlevel := tk_kall(" winfo toplevel " + fn);
--print("tlevel:",tlevel);
attr_val_tup with:= obj_from_tkname(tlevel); continue;
end if;
attr_val_tup with:= get_winfo_attr(att); continue; -- but width and heightof topleves is read using 'winfo'
end if;
if att = "selected" and (tk_type = "radiobutton" or tk_type = "checkbutton") then
-- pseudo-attribute: read the associated variable
varname := tk_kall(fn + " cget -variable "); -- get name of associated variable
varval := tk_kall("set " + varname); -- get value of associated variable
if tk_type = "radiobutton" then
-- get the value that the variable would have if this button was on
corresp_val := tk_kall(fn + " cget -value ");
attr_val_tup with:= if varval = corresp_val then "1" else "0" end if;
elseif tk_type = "checkbutton" then
attr_val_tup with:= varval;
end if;
continue; -- done with this case
elseif att in {"place","pack","grid"} then -- get the geometry manager info
-- note that this returns the info relative to the object's parent
geometry_val := tk_kall(att + " info " + self.full_name());
val_list := breakup(geometry_val," ");
--print("geometry_val: ",val_list);
geo_map := {[val_list(j)(2..),vljp1]: j in [1,3..#val_list - 1] | (vljp1 := val_list(j + 1)) /= "{}"};
attr_val_tup with:= geo_map; -- return the geometry information as a map
continue; -- done with this case
elseif att = "font" then -- attach "{" and "}"
attr_val_tup with:= "{" + tk_kall(fn + " cget -" + att) + "}";
continue; -- done with this case
elseif att in pseudo_atts then -- various pseudo-attribute retrieval operations
case att
when "active" => -- get a scrollbar's active element
attr_val_tup with:= tk_kall(full_name() + " activate"); continue;
when "position" => -- get a scrollbars currentpositon
int_lis := breakup(tk_kall(full_name() + " get")," ");
attr_val_tup with:= [unstr(x): x in int_lis]; continue;
when "type" => -- get the object's type
attr_val_tup with:= tk_type; continue;
when "image" => -- get the contents of a canvas as an image_analysis library image
--print("widget configuration query: "); return "testing";
if tk_type = "canvas" then
image_no := unstr(tk_kall("save " + full_name()));
-- this is the opaque integer pointer to the native grlib image object
-- we create an image-analysis class object from it
attr_val_tup with:= image(image_no); -- add to attribute tuple, as ifthis were an attribute
else -- use ordinary configuration query
attr_val_tup with:= tk_kall(fn + " cget -" + att);
end if;
continue;
when "clipboard" => -- get the contents of the clipboard
attr_val_tup with:= tk_kall("selection get -selection CLIPBOARD");
continue;
when "definedFonts" => -- get the list of available fonts
items := tk_kall("font names");
return breakup(items," ");
continue;
when "fonts" => -- get the list of available fonts
items := tk_kall("font families");
items_list := []; -- will collect
while items /= "" loop
items_piece := break(items,"{"); rspan(items_piece," ");
items_list +:= breakup(items_piece," ");
item_to_close := break(items,"}"); item_to_close +:= match(items,"}");
items_list with:= item_to_close;
span(items," ");
end loop;
items_list := [item: item = items_list(j) | item /= ""];
attr_val_tup with:= join(items_list,","); -- return the comma-separated font list
continue;
when "placed" => -- get the items placed into this widget
items := tk_kall(" place slaves " + full_name());
when "packed" => -- get the items packed into this widget
items := tk_kall(" pack slaves " + full_name());
when "gridded" => -- get the the items gridded into this widget
items := tk_kall(" grid slaves " + full_name());
when "propagate" => -- get a window or frame's propagation status
attr_val_tup with:= tk_kall("pack propagate " + full_name()); continue;
end case;
the_list := [obj_from_tkname(x): x in breakup(items," ")];
attr_val_tup with:= the_list; -- return the geometry information as a comma-separated list
continue;
end if;
attr_val_tup with:= tk_kall(fn + " cget -" + att);
end loop;
return attr_val_tup;
end read_attrs_widget;
procedure read_attrs_can_or_text_im(attr_list); -- read the attributes of a canvas or text image
attr_val_tup := [ ]; -- will collect and return the attribute values in a tuple
fn := parent.full_name(); -- get the full tk name of the parent canvas or text item
for att in attr_list loop
if att in {"image","bitmap"} then -- convert name to an image or bitmap
im_name := tk_kall(fn + " itemcget " + name(2..) + " -" + att);
the_im := tkw(); -- create a new blank object
the_im.name := im_name; the_im.tk_type := att;
attr_val_tup with:= the_im;
elseif att = "coords" then -- use the "coords" operation
attr_val_tup with:= breakup(tk_kall(fn + " coords " + name(2..))," ");
else -- use att-val itself
attr_val_tup with:= tk_kall(fn + " itemcget " + name(2..) + " -" + att);
end if;
end loop;
return attr_val_tup;
end read_attrs_can_or_text_im;
procedure read_attrs_canvas_item(attr_list); -- read the attributes of a canvas item
-- The attributes of canvas items are: tags, width, and coords in all cases, plus
-- for canvas geometric objects: fill, outline, and stipple
-- for images: anchor and image
-- for canvas text objects: anchor, fill, font, justify, stipple, and text
-- for canvas widgets: anchor, height, and window
-- Tk uses itemcget/itemconfigure calls to get/set all but the coords attributes,
-- but a coords calls to get/set the coords attribute.
--print("read_attrs_canvas_item: ",tk_type);
attr_val_tup := [ ]; -- will collect and return the attribute values in a tuple
fn := parent.full_name(); -- get the full tk name of the parent canvas
for att in attr_list loop -- loop, using the tk cget command to get the value
-- unless the attribute is 'coords' or "tags", in which case we use
-- the parent 'coords' or 'gettags' command to get it
case att
when "coords" =>
attr_val_tup with:= breakup(tk_kall(fn + " coords " + name(2..))," ");
when "tags" =>
attr_val_tup with:= breakup(tk_kall(fn + " gettags " + name(2..))," ");
when "type" =>
attr_val_tup with:= tk_type;
when "window" =>
res := tk_kall(fn + " itemcget " + name(2..) + " -window");
attr_val_tup with:= obj_from_tkname(res);
otherwise =>
attr_val_tup with:= tk_kall(fn + " itemcget " + name(2..) + " -" + att);
end case;
end loop;
return attr_val_tup;
end read_attrs_canvas_item;
procedure read_attrs_text_item(attr_list); -- read the attributes of a text item
attr_val_tup := [ ]; -- will collect and return the attribute values in a tuple
fn := parent.full_name(); -- get the full tk name of the parent widget
for att in attr_list loop -- loop, using the tk cget command to get the value
-- unless the attribute is 'bbox', in which case we use
-- the parent bbox command to get it, or 'coords',
if att = "bbox" then -- pseudo-attribute: use the "bbox" command
attr_val_tup with:= breakup(tk_kall(fn + " bbox " + name(2..))," ");
else
attr_val_tup with:= tk_kall(fn + " itemcget " + name(2..) + " -" + att);
end if;
end loop;
return attr_val_tup;
end read_attrs_text_item;
procedure read_file_atts(fname,att_list); -- get specified attributes of file
atts := breakup(raw_atts := tk_kall("file attributes " + fname) + " " +
tk_kall("file stat " + fname + " fs\nset x \"$fs(mtime) $fs(atime) $fs(gid) $fs(nlink) " +
"$fs(mode) $fs(type) $fs(ctime) $fs(uid) $fs(ino) $fs(size) $fs(dev)\"" ) +
tk_kall("file writable " + fname)," ");
--print("raw_atts: ",raw_atts);
link := tk_kall("file readlink " + fname);
m := match(link,"couldn't readlink \"");
if m/= "" then link := ""; end if;
atts with:= link; -- atts are now in the order * creator,2 * hiddden,4 * readonly,6 * mac_type,8
-- mtime,9 atime,10 gid,11 nlink,12 mode,13 type,14 ctime,15 uid,16 ino,17 size,18 dev,19 pointer,20
return [atts(posns_map(att)?("UNDEFINED:" + att)): att in att_list]; -- return list of attributes
end read_file_atts;
procedure read_socket_atts(fname,att_list); -- get specified attributes of socket
end read_socket_atts;
procedure make_absolute_image(the_text); -- build an absolute image
-- build an absolute image either from a file name or from an image class absolute image
-- the parameter is taken to be either the file from which the image should be read,
-- or a string of the special form designating the 'Grlib' core of
-- an image-class image, which must be a 3-plane, discrete image
if not is_string(the_text) then -- assume that it is a image-class image -- #the_text > 8 and the_text(1..8) = " string
txt := "set im [image create mimage -opaque \"" + str(the_text) + "\"]"; -- we will call Tk to make a Tk absolute image
--print("make_absolute_image: ",txt);
else -- assume that we have an image file
txt := "image create photo " + the_text + "`" + str(name_ctr +:= 1) + " -file " + the_text;
end if;
img_name := tk_kall(txt); -- call Tk to create the Tk asolute image image from the given grilb image or file
new_image := tkw(); -- form a blank new object
new_image.parent := OM; -- images have no parent
new_image.tk_type := "image"; -- note its type
new_image.name := img_name;
-- note its name, which we make unique
--print("new_image.name: ",new_image.name," ",new_image.full_name());
return new_image;
end make_absolute_image;
procedure reconstruct_image_from_name(img_name); -- rebuild an existing absolute image using its name
new_image := tkw(); -- form a blank new object
new_image.parent := OM; -- images have no parent
new_image.tk_type := "image"; -- note its type
new_image.name := img_name; -- note its name
return new_image;
end reconstruct_image_from_name;
procedure reconstruct_bitmap_from_name(bm_name); -- rebuild an existing absolute bitmap using its name
new_image := tkw(); -- form a blank new object
new_image.parent := OM; -- images have no parent
new_image.tk_type := "bitmap"; -- note its type
new_image.name := bm_name; -- note its name
return new_image;
end reconstruct_bitmap_from_name;
procedure make_absolute_bitmap(data); -- build an absolute image either from a data string or a pair
img_name := "XBM`" + str(name_ctr +:= 1); -- generate new name
if is_tuple(data) then -- icon and mask data are given
[icon_data,mask_data] := data; -- unpack
txt := "image create bitmap " + img_name + " -data \"" + icon_data + "\" -maskdata \"" + mask_data + "\"";
--print("make_absolute_image: ",txt);
else -- no mask data is given
txt := "image create bitmap " + img_name +" -data \"" + data + "\"";
end if;
img_name := tk_kall(txt); -- call Tk to create the image
new_image := tkw(); -- form a blank new object
new_image.parent := OM; -- images have no parent
new_image.tk_type := "bitmap"; -- note its type
new_image.name := img_name;
-- note its name, which we make unique
--print("new_image.name: ",new_image.name," ",new_image.full_name());
return new_image;
end make_absolute_bitmap;
procedure make_canvas_or_text(kind,the_text,orig); -- build a canvas or text item
if tk_type = "text" then -- we are creating a text item
if kind /= "image" and kind /= "bitmap" and kind /= "widget" then
abort("An item of type " + kind + " cannot have a text widget as parent.");
end if;
-- otherwise we must create a text image or text widget, both from an object
-- of appropriate kind
null; -- ********* FILL IN *********
end if;
if tk_type /= "canvas" and tk_type /= "widget" then
abort("An item of type " + kind + " must have a canvas or subcanvas, not a " +
tk_type + " as parent.");
end if;
-- create the canvas item; if the kind is 'text', the object becomes
-- canvas_text internally. If it is 'image' or 'widget', the second
-- parameter is an actual object of type tkw, whose name must be extracted
-- for the Tk creation call
pref := ""; -- no prefix is used except for 'text'
if kind = "text" then -- this becomes "canvas_text" internally, and text is not split
pref := "canvas_";
elseif kind in {"image","bitmap"} then -- second parameter must be an image or bitmap object; get its name
txt := full_name() + " create image 0 0 -image " + orig.name;
-- Note that the image name has no prefixed letter
ci_num := tk_kall(txt); -- this returns the serial number of the image item
--print("bitmap: ",txt);
new_item := tkw(); -- form the blank new canvas item
new_item.parent := self; -- this canvas is the parent
new_item.tk_type := kind; -- note its type
new_item.name := "c" + ci_num; -- note its serial number (prefixing a 'c')
new_name := new_item.full_name(); -- get the full name of the new item
source_of(new_name) := orig; -- map this into the source item
--print("source_of: ",source_of);
return new_item;
elseif kind = "widget" then -- second parameter must be a widget object; get its name
txt := full_name() + " create window 0 0 -window " + orig.full_name();
ci_num := tk_kall(txt);
new_item := tkw(); -- form the blank new canvas item
new_item.parent := self; -- this canvas is the parent
new_item.tk_type := "widget"; -- note its type
new_item.name := "c" + ci_num; -- note its serial number (prefixing a 'c')
new_name := new_item.full_name(); -- get the full name of the new item
source_of(new_name) := orig; -- map this into the source item
return new_item;
end if;
-- here we are creating a canvas item
if kind /= "text" then -- break up the parameter list
orig_breakup := the_breakup := chop(the_text);
-- we allow non-numeric 'coordinates' as an identifying tags of the newly created canvas item
tag_locs := {j: x = the_breakup(j) | (exists c in x | (c notin "-0123456789."))}; -- can be floating
tags := [x: x = the_breakup(j) | j in tag_locs];
the_breakup := [x: x = the_breakup(j) | j notin tag_locs];
txt := (fn := full_name()) + " create " + kind + " " +/ [num + " ": num in the_breakup] + " -tag ....";
-- this special tag identifies the currently created object
ci_num := tk_kall(txt); -- create the item, and get the item number which Tk assigns
if kind = "oval" then tk_kall(fn + " addtag OVAL withtag ...."); end if; -- add the OVAL tag if needed
-- ovals are assigned the tag "OVAL", so they can be recognized later
tags := [tags(j): j in [ntgs := #tags,ntgs - 1..1]]; -- reverse order so that tags come out in order of creation parameter
for tag in tags | tag /= "OVAL" loop -- attach other tags if any
res := tk_kall(txt := fn + " addtag " + tag +" withtag ....");
--print("attach other tags: ",kind," ",res," ",txt);
end loop;
tk_kall(fn + " dtag ...."); -- remove the special 'current' mark
--print("verify tags after remove: ",tk_kall(fn + " gettags " + ci_num));
else -- dont break up the parameter list
txt := (fn := full_name()) + " create text 0 0 -text " + "\"" + stg_to_Tk(the_text) + "\"" + " -tag ....";
ci_num := tk_kall(txt); -- create the item, and get the item number which Tk assigns
tags := []; -- FIX FIX **********
tags := [tags(j): j in [ntgs := #tags,ntgs - 1..1]] with "all";
-- here we add the 'all' tag since by default canvas text itmes have no tags
-- reverse order so that tags come out in order of creation parameter
for tag in tags loop -- attach other tags if any
res := tk_kall(txt := fn + " addtag " + tag + " withtag ....");
end loop;
tk_kall(fn + " dtag ...."); -- remove the special 'current' mark
end if;
--print("\ntxttxt: ",txt," ",tags," ",the_breakup," ",tag_locs," ",orig_breakup);
new_name := "c" + ci_num; -- canvas items are named cnnn, where nnn is their serial number
new_item := tkw(); -- form the blank new canvas item
new_item.parent := self; -- this canvas is the parent
new_item.tk_type := pref + kind; -- note its type
new_item.name := new_name; -- note its name
return new_item;
end make_canvas_or_text;
procedure make_new_widget(kind,the_text); -- build a widget
new_name := "w" + str(name_ctr +:= 1);
new_widget := tkw(); -- form the blank new widget
new_widget.parent := self; -- this widget is the parent
new_widget.tk_type := kind; -- note its type
new_widget.name := new_name; -- note its name
-- now create it, as a tk object
tk_name := new_widget.full_name();
if kind = "menu" then return make_menu(new_widget,tk_name,the_text); end if;
if kind = "optionbutton" then return make_optionbutton(new_widget,tk_name,the_text); end if;
if (main_option := main_options(kind)) = "hw" then -- parameter must be width,height
[width,height] := chop(the_text);
suffix := " -width " + width + " -height " + height;
elseif main_option = "ft" then -- parameter must be from,to
[fromm,too] := chop(the_text);
suffix := " -from " + fromm + " -to " + too;
elseif main_option = "orient_w" then -- parameter must be 'h' or 'v','width'
[hv,width] := chop(the_text);
suffix := " -orient " + if hv = "v" then "vertical" else "horizontal" end if + " -width " + width;
else
if main_option = "text" and (the_text?"") /= "" then the_text := stg_to_Tk(the_text); end if;
-- put the string used in creation into Tk form
tt := if the_text = "OM" then "" else " \"" + the_text end if + "\"";
suffix := if the_text = "OM" then "" else " -" + main_option + tt end if;
end if;
--print("creation call: ",kind + " " + tk_name + suffix);
tk_kall(kind + " " + tk_name + suffix);
--print("created new_widget: ",tk_name);
return new_widget; -- return it
end make_new_widget;
procedure make_file_widget(the_text); -- build a file widget
new_widget := tkw(); -- form the blank new widget
new_widget.parent := self; -- this widget is the parent
new_widget.tk_type := "file"; -- note its type
new_widget.name := the_text; -- note the file name
return new_widget; -- return it
end make_file_widget;
procedure make_socket_widget(param_pair); -- build a socket widget
new_widget := tkw(); -- form the blank new widget
new_widget.parent := self; -- this widget is the parent
[host_and_or_port,text_blocksize_or_accept_proc] := param_pair; -- unpack the parameter pair
if is_integer(host_and_or_port) then -- host_and_or_port is integer port number, so socket being created is server
kind := "server_socket";
if not is_procedure(text_blocksize_or_accept_proc) then
print("****** bad server socket accept handler: ",text_blocksize_or_accept_proc); stop;
end if;
tk_name_for_proc := "s" + str(namegen_ctr := (namegen_ctr?0) + 1); -- generate a new tk variable name
tk_createcommand(interp,tk_name_for_proc,text_blocksize_or_accept_proc); -- register the setl accept-handler procedure under this name
-- see comment below on semantics and typical form of accept handlers
txt := "set " + "socket_var " + " [socket -server " + tk_name_for_proc + " " + str(host_and_or_port) + "]";
-- when called upon receipt of an external connection request by an external process, an accept handler will get a tuple
-- [tk_socket_id,external_net_address,external_initiating_port] as its 1 parameter. it should immediately convert the tk_socket_id
-- to a client socket object, and set i/o event routines for this new socket; these i/o event routines can then read the socket
-- when input arrives, or write it.
-- compose the tk socket-creation command
tk_socket_name := tk_kall(txt); -- pass this command to tk, which responds with a generated socket name
--print("created server: ",tk_socket_name);
else -- host_and_or_port is a string 'host_addr:port', so a client socket is to becreated
kind := "socket";
host := break(host_and_or_port,":"); m := match(host_and_or_port,":"); --break port from 'host_addr:port'
if host_and_or_port = "" and m = ":" then -- null port, but ":" is present, so this is a client socket generated by an accepted request
tk_socket_name := host; -- set tk peer name variable to known name of already generated socket
elseif host_and_or_port = "" then -- missing host name,so error case
print("****** bad client socket port: ",host,m,host_and_or_port); stop;
else -- we have an acceptable host name, so we create a client socket
txt := "set " + "socket_var" + " [socket " + host + " " + host_and_or_port + "]";
-- compose the tk socket-creation command
tk_socket_name := tk_kall(txt); -- pass this command to tk, which respondswith a generated socket name
end if;
if text_blocksize_or_accept_proc = "text" then -- configure as a line-oriented client socket, to the indicated host_and_port
txt := "fconfigure $" + "socket_var" + " -buffering line"; -- tk buffer_by_lines command
tk_kall(txt); -- pass this command to tk
elseif not is_integer(text_blocksize_or_accept_proc) or text_blocksize_or_accept_proc <= 0 then
-- should have integer buffer size; should be configured as 'block'
print("****** bad client socket block size: ",text_blocksize_or_accept_proc); stop;
else -- configure as 'block'
buffer_size := text_blocksize_or_accept_proc; -- this flags block-buffering client sockets
txt := "fconfigure $" + "socket_var" + " - buffering full -buffersize " + buffer_size; -- tk buffer_by_blocks command
tk_kall(txt); -- pass this command to tk
end if;
end if;
new_widget.tk_type := kind; -- note the socket type
new_widget.name := tk_socket_name; -- note the socket name
return new_widget; -- return it
end make_socket_widget;
procedure make_menu(menu_obj,menu_name,descriptor); -- create the items of a new menu from its descriptor
tk_kall("menu " + menu_name + " -tearoff 0"); -- create the menu
define_menu_items(menu_name,descriptor); -- define the items of the menu
return menu_obj;
end make_menu;
procedure make_optionbutton(button_obj,menu_name,descriptor);
varname := break(descriptor,";"); span(descriptor,";");
alternatives := "" +/ [" " + x: x in breakup(descriptor,",")];
button_obj.tk_type := "menubutton";
--print("make_optionbutton: ",menu_name);
tk_kall("tk_optionMenu " + menu_name + " " + varname + alternatives);
-- create the optionbutton and its menu
return button_obj;
end make_optionbutton;
procedure define_menu_items(menu_name,descriptor); -- define the items of a menu from a descriptor
items := breakup(chop(descriptor),":");
for [kind,lab] in items loop
if lab = OM then -- should be separator or tearoff
if kind = "t" then -- tearoff
tk_kall(menu_name + " add tearoff");
else -- take as separator
tk_kall(menu_name + " add separator");
end if;
else
case kind
when "c" => -- checkbutton item
tk_kall(menu_name + " add checkbutton -label " + lab + " -indicatoron 1");
when "r" => -- radiobutton item
tk_kall(menu_name + " add radiobutton -label " + lab + " -variable " + lab);
when "s" => -- submenu item
tk_kall(menu_name + " add cascade -label " + lab);
otherwise => -- take as button item
tk_kall(menu_name + " add command -label " + lab);
end case;
end if;
end loop;
end define_menu_items;
procedure self(x) := y; -- assignment of attributes (configuration)
-- 'self' can reference either a widget, canvas item, image, or bitmap.
-- We require x (resp. y) to be comma or semicolon-separated lists of attribute names (resp.
-- values), appropriate to the object type being queried. The values are assigned
-- to the corresponding attributes
-- y is allowed to be a ;-separated string, a tuple, a procedure, or a widget object. If y is a
-- string, we cut it into a tuple and proceed as in the tuple case. empty option names
-- can be used with option value strings which identify their options uniquely,
-- e.g. for options like
-- The 'geometry manager' commands pack, grid, and place can also appear in x,
-- as initial 'pseudo-attributes'. If they appear, all the other attributes
-- which follow them must be legal geometry manager options, and the componts of y
-- must be legal values for these options.
-- the canvas-item types are arc, bitmap, image, bitmap, line, oval, polygon, rectangle, text,
-- canvas_widget
if is_integer(y) or is_real(y) then y := str(y); end if;
-- convert right-hand sides which are not procedures, objects, or tuples into strings
if x = OM then -- miscellaneous sets of 'whole content', depending on widget type
return set_whole_contents(y);
-- set content of an entry, text, message, label, scale, or toplevel widget;
-- set the menu of a menubutton; write to a client socket
end if;
if x = "" then -- completely reconfigure widget; y must be a mapping
if tk_type = "toplevel" then return set_wm_atts([],y); end if; -- handle in set_wm_atts
return reconfigure_from_map(y); -- handle in reconfigure_from_map
end if;
if y = OM then -- miscellaneous nulling ops of attribute
return null_whole_attribute(x); -- null the value of this attribute
end if;
if is_tuple(x) then -- configuration of a menu item, dialog in toplevel, canvas or text widget tag,
-- tag in text, or geometry manager configuration to widget other than parent
[itm,the_text] := x; -- this must have the form object; int, item_attributes,
-- or "tag",tag_name
-- if 'the_text' is not a string, it should be a widget object, passed as part of an
-- extended geometry manager call
if itm = "font" then -- this is a font definition
nna := #(name_and_atts := chop(the_text));
font_name := name_and_atts(1);
if font_name in breakup(tk_kall("font names")," ") then
tk_kall("font delete " + font_name); -- delete the font in case it exists
end if;
y := chop(y);
att_and_vals := "" +/ [" -" + name_and_atts(j + 1) + " " + yj: yj = y(j) | j < nna];
txt := "font create " + font_name + att_and_vals;
return tk_kall(txt);
end if;
if not is_string(the_text) then -- we have an extended geometry manager call; 'the_text'
-- is the widget in which another widget is being packed,
-- placed, or gridded.
-- The underlying call is like self("side",frame) := "left"
xx := chop(itm);
if xx(1) notin geometry_keywords then
abort("illegal second parameter b in widget(a,b) := c: " + str(the_text));
end if;
return configure_geometry_in(xx,chop(y),the_text);
-- handle extended geometry-manager calls
end if;
options := if (the_text?"") = "" then [] else chop(the_text) end if;
case tk_type -- proceed in a manner dependent on the type of this widget
when "toplevel","" => -- pseudo-configuration of dialog in toplevel or absolute master window; or wm call
return configure_toplevel(itm,options,y); -- handle all the standard built-in dialogs
when "text","canvas" =>
-- configuration of canvas or text tag, binding of procedure to click on tagged range,
-- or tag configuration in text
if itm = "tag" and tk_type = "text" then --tag configuration in text
-- y must be a tuple of pairs
tk_kall(full_name() + " tag remove " + the_text + " 1.0 end"); -- remove present ranges
the_text := the_text + " " +/ [fi + " " + la + " ": [fi,la] in y];
return tk_kall(full_name() + " tag add " + the_text); -- restore new ranges
end if;
-- here we are configuring a canvas tag or text tag
-- break y into its parts if it is a string
y := chop(y); if not is_tuple(y) then y := [y]; end if;
txt := full_name() + " tag configure " + str(itm) -- in this case 'itm' is the tag name
+/ [" -" + item + " " + may_quote(tk_string_of(y(j)?"nothing")): item = options(j)];
--print("configuring a tag: ",txt);
return tk_kall(txt);
when "menu" => -- configuration of menu item
if not is_integer(itm) then
-- if itm = "system" and the_text = "menu" then -- definition of "Apple" menu in menu bar
-- return tk_kall(full_name() + ".apple configure " + " -menu " + y.full_name());
-- elseif itm = "help" and the_text = "menu" then -- definition of "Help" menu in menu bar
-- return tk_kall(full_name() + ".help configure " + " -menu " + y.full_name());
-- end if;
abort("Only numbered item references are allowed for menus.");
end if;
if the_text = "menu" then -- should be assignment of submenu to cascade item
return tk_kall(full_name() + " entryconfigure " + str(itm) + " -menu " + y.full_name());
end if;
-- break y into its parts if it is a string
y := chop(y); if not is_tuple(y) then y := [y]; end if;
txt := full_name() + " entryconfigure " + str(itm)
+/ [" -" + item + " \"" + tk_string_of(y(j)?"nothing") + "\"": item = options(j)];
return tk_kall(txt);
end case;
end if; -- *********** end if is_tuple(x) ***********
y := chop(y);
if x = "tags" and tk_type = "text" then -- configuration of the tag order of a text widget
-- is now the specified tag list. We first drop all elements in it which are not actually tags
tag_set := {z: z in breakup(tk_kall(full_name() + " tag names")," ")} less "sel";
y := [z: z in y | z in tag_set];
tag_set -:= {z: z in y}; -- tag_set is now the collection of tags to be dropped
-- All other elements are dropped from the tag set
if #tag_set > 0 then
tk_kall(txt := full_name() + " tag delete" +/ [" " + tag: tag in tag_set]);
end if;
if #y = 0 then return; end if; -- now we raise all these elements to the end, giving them top priority.
tk_kall(txt := full_name() + " tag raise " + y(1)); -- first raise the initial element
for j in [2..#y] loop -- then raise each to the position after the prior
tk_kall(full_name() + " tag raise " + y(j) + " " + y(j - 1));
end loop;
return;
elseif x in special_lefts then
-- xscroller, yscroller, clipboard, grab, sel, sel.anchor, xview, yview, xpercent, ypercent, active
--print("special_lefts ",x);
case x
when "xview" => -- set the xview in a scrollable widget
txt := full_name() + " xview "+ str(unstr(y(1)?"0") - 1);
--print("xview: ",txt);
return tk_kall(txt);
when "yview" => -- set the yview in a scrollable widget
txt := full_name() + " yview "+ str(unstr(y(1)?"0") - 1);
return tk_kall(txt);
when "xpercent" => -- set the xview percentage in a scrollable widget
txt := full_name() + " xview moveto " + (y(1)?"0");
return tk_kall(txt);
when "ypercent" => -- set the yview percentage in a scrollable widget
txt := full_name() + " yview moveto " + (y(1)?"0");
return tk_kall(txt);
when "position" => -- set the limits of a scrollbar
txt := full_name() + " set " + str(y(1)?"0") + " " + str(y(2)?"0");
--print("limits ",txt);
return tk_kall(txt);
when "sel" => -- set the selection in a textline or listbox
--print("set the selection: ",y);
[m,n] := y;
if m = OM and n = OM then
txt := full_name() +
if tk_type = "entry" then " select clear" else " selection clear" end if;
return tk_kall(txt);
end if;
n := if n = OM then str(unstr(m) - 1) else n end if;
txt := full_name() +
if tk_type = "entry" then " selection range " else " selection set " end if +
str(unstr(m) - 1) + " " + str(unstr(n));
--print("set the selection cmd: ",txt);
res := tk_kall(txt);
return res;
when "sel.anchor" => -- set the selection anchor in a textline or listbox
txt := full_name() +
if tk_type = "textline" then " selection from " else " selection anchor " end if +
str(unstr(y(1)) - 1);
return tk_kall(txt);
when "active" => -- set activated element in a listbox, menu, or scrollbar
txt := full_name() + " activate " +
if tk_type = "scrollbar" then y(1) else str(unstr(y(1)) - 1) end if;
--print("active ",txt);
return tk_kall(txt);
when "xscroller" => -- attach a scroller to a horizontally scrollable widget
if not tk_type in horiz_scrollable then -- error: widget is not scrollable
abort(tk_type + "widgets are not scrollable");
end if;
if not type(y) = "TKW" or not y.tk_type = "scrollbar" then -- error: not a scrollbar
abort("A widget's 'xscroller' attribute must be a scrollbar");
end if;
-- now link the widget's attribute to the scrollbar, and the scrollbar's command attribute to the widget
yname := y.full_name(); widname := full_name();
tk_kall(yname + " configure -command {" + widname + " xview}");
return tk_kall(widname + " configure -xscrollcommand {" + yname + " set}");
when "yscroller" => -- attach a scroller to a fully scrollable widget
if not tk_type in fully_scrollable then -- error: widget is not scrollable
abort(tk_type + "widgets are not vertically scrollable");
end if;
if not type(y) = "TKW" or not y.tk_type = "scrollbar" then -- error: not a scrollbar
abort("A widget's 'yscroller' attribute must be a scrollbar");
end if;
-- now link the widget's attribute to the scrollbar, and the scrollbar's command attribute to the widget
yname := y.full_name(); widname := full_name();
tk_kall(yname + " configure -command {" + widname + " yview}");
return tk_kall(widname + " configure -yscrollcommand {" + yname + " set}");
when "clipboard" => -- assignment of y to clipboard
tk_kall("clipboard clear");
return tk_kall("clipboard append \"" + str(y(1)) + "\""); -- here y is transmitted as tuple
when "grab" => -- set of a toplevel window grab status
if tk_type /= "toplevel" then abort("'Grab' can only be set for toplevel windows"); end if;
grab_stg := if y = ["global"] then "grab -global "
else "grab " end if + full_name();
return tk_kall(grab_stg);
end case;
end if;
-- otherwise we have a configuration call, either for a canvas or text item or an ordinary widget
-- break x, the string of options to be configured, into a tuple
orig_x := x; x := if x = OM then [] else chop(x) end if;
-- allow comma if there is no semi. If x = OM we convert it into a 'list of OM's'
--print("configuration call: ",x," ",y," orig_x: ",orig_x," #orig_x: ",#orig_x);
if tk_type = "image" and parent = OM then -- must be an absolute image
return configure_image(x,y); -- configure the image
elseif tk_type = "menu" then -- configure a menu
return configure_menu(x,y); -- configure a menu
elseif tk_type = "bitmap" and parent = OM then -- must be an absolute bitmap
return configure_bitmap(x,y); -- configure the bitmap
elseif tk_type in canvas_items then -- we must configure a canvas item
return configure_canvas_item(x,y); -- configure a canvas item
elseif tk_type = "toplevel" and ((x(1) in wm_attributes) or orig_x = "") then
-- we allow a null string, which sets all attributes from a map
if orig_x = "" then x := []; end if;
return set_wm_atts(x,y); -- set window-manager attributes of a toplevel
elseif tk_type = "file" then -- we must configure a file item
return configure_file_item(name,x,y); -- configure a file item
elseif tk_type = "socket" or tk_type = "server_socket" then -- we must configure a socket item
return configure_socket_item(x,y); -- configure a socket item; but this is never called
end if;
--print("ordinary widget configuration call: ",x," ",y);
case type(y) -- this is a configuration call for an ordinary widget, or a geometry-manager operation
when "TUPLE" => -- we use y in a geometry or configuration call
case x(1) -- here we handle the geometry-manager related pseudo-configuration operations,
-- and some others
when "pack","side","grid","row","column","place" =>
return configure_geometry(x,y); -- handle geometry-manager calls
otherwise => -- we have a configuration call for a widget, or canvas or text item
--print("widget/canvas/text configuration call: ",x,"",y);
if tk_type = "toplevel" and #x = 1 and x(1) = "rect" then -- configuring the rectangle of a toplevel window
geomstg := str(abs(y(3) - (y1 := y(1)))) + "x"+ str(abs(y(4) - (y2 := y(2)))) + "+" + str(y1) + "+" + str(y2);
-- geometry string in
tk_kall(txt := "wm geometry " + full_name() + " " + geomstg); -- set the specified geometry
--print("winconfig: ",txt);
return; -- done with this case
elseif (#name > 0 and name(1) = "w") or tk_type = "toplevel" then -- we are configuring a Tk widget or toplevel
the_text := full_name() + " configure ";
else -- we are configuring a canvas or text item
if x = "coords" then -- if the original string x is simply 'coords', y will be
-- the string of coordinates being assigned; otherwise
-- this will be y(j) in the loop below
coord_text := parent.full_name() + " coords " + name(2..) + " "
+/ [str(xx) + " ": xx in y];
--print("coord_text: ",coord_text);
return tk_kall(coord_text); -- execute the 'coords' command; then finished
end if; -- otherwise this is not a coords call; handle normally
the_text := parent.full_name() + " itemconfigure " + name(2..) + " ";
end if;
attribs_to_handle := 0; -- count of attributes not handled in subroutine
for xj = x(j) loop -- assemble the options and option values
if handle_pseudo_attrib(name,xj,y(j)) then continue; end if;
-- we are done with this case if 'true' is returned; otherwise not
attribs_to_handle +:= 1; -- count of attributes not handled in subroutine
if is_procedure(yj := y(j)?"") then
-- call the tk library 'createcommand' function, to associate a
-- new command id of the form Pnnn with the SETL callback procedure supplied;
-- then include the command id in the command string being built
tk_createcommand(interp, item := "P" + str(proc_ctr +:= 1) ,y(j));
-- we will include the callback id in the command being built
elseif type(yj) = "TKW" and yj.parent = OM and yj.tk_type in {"image","bitmap"} then
item := yj.name; -- we are assigning an absolute image or bitmap; use its name
-- Note that absolute images and bitmaps are referenced by their name
elseif xj = "scrollregion" then
the_text +:= (" -" + xj + " {" + join(y," ") + "} ");
-- print("scrollregion: ",the_text);
continue;
else -- item should be a tk string value
if yj = "" then
item := " {}"; -- transmit nullstrings in Tk form
elseif yj(1) = "{" then -- special case for fonts; omit quotes
item := " " + str(yj);
else
item := " \"" + str(yj) + "\""; -- include the string value in the command being built
end if;
end if;
--print("fonts, bitmaps: ",xj," ",item);
the_text +:= if xj = "font" or xj = "bitmap" or xj = "image" then (" -" + xj + " " + item)
-- fonts, bitmaps, and images not quoted. Note: for images, only forms like label("image") := "{}" are used
else (" -" + xj + item) end if;
-- add to command if not pseudo-att
end loop;
end case;
--print("the_text: ",the_text);
if attribs_to_handle = 0 then return ""; end if; -- if all attributes are handled in subroutine, there is nothing to do
return tk_kall(the_text); -- we finish the operation here
-- a SETL callback procedure (for commands), or a tk string value
when "PROCEDURE","TKW" => -- the right-hand side is a procedure or tk widget. convert it to tk string form
-- ignore all but the first component of the left-hand parameter tuple
--if type(y) = "TKW" then print("TKW case: ",x," ",y); end if;
the_text := full_name() + " configure -" + x(1) + " " + tk_string_of(y);
return tk_kall(the_text);
otherwise => -- the right-hand side is neither a string, tuple, or procedure; might be absolute image
if x(1) = "propagate" then -- set propagation attribute of frame or window
tk_kall("grid propagate " + full_name() + " " + y); -- set both the grid and the pack attributes
return tk_kall("pack propagate " + full_name() + " " + y);
end if;
the_text := full_name() + " configure -" + x(1) + " " + str(y);
--print("config call, final case: ",the_text);
return tk_kall(the_text);
end case;
end; -- of procedure for self(x) := y; operations
procedure analyze_text(raw_text); -- raw text analysis routine
-- given a raw_text, this returns the same text with all tag and mark designators removed, along with
-- two lists: a tag list of the form [i,j,tag] giving the opening and closing 'line.char' index of
-- each tagged section, and a marks list of the form [i,mark] giving the 'line.char' index of the
-- mark position.
num_lines := 1; -- number of the current line
raw_text_sections := single_out(raw_text,"`\r\n>"); -- break into sections
--print("raw_text: ",raw_text,"\nraw_text_sections: ",raw_text_sections);
len_raw := #raw_text; -- get the length of the raw text
current_aux := ""; current_aux_len := 0; -- current auxiliary string
tags_list := []; -- list of completed tags
posns_of_open := {}; -- maps open tags and marks into their list of positions
inside_of_opener := false; inside_of_closer := false;
start_of_tag := 0;
end_of_last_opener := OM; last_tag_opened := OM; -- ending position of last tag opener
-- the starting position of a possible tag string, if we are inside_of_opener or inside_of_closer
raw_text_loc := 1; -- next character in raw text to be examined
digested_text := ""; digested_length := 0; -- the tag-free text, and its length within this line
rtsix := 0;
while (section := raw_text_sections(rtsix +:= 1)) /= OM loop -- iterate over the sections
--print("section: ",section,20 * " ",digested_text," ",inside_of_opener," ",inside_of_closer);
if (ns := #section) = 0 then continue; end if;
if (ns > 1 or section notin "`\r\n") and not (inside_of_opener or inside_of_closer) then
-- we have an inactive section
digested_text +:= section; digested_length +:= (ns := #section);
raw_text_loc +:= ns; -- and advance in the raw text
continue; -- done with this piece
end if; -- otherwise we have an active character
raw_text_loc +:= #section; -- advance this to the next character past that being examined
if section = "`" then
if inside_of_opener or inside_of_closer then -- check to see if we are at the end
if raw_text_loc <= len_raw and raw_text(raw_text_loc) = ">"
and raw_text_loc - 1 > current_aux_len
and raw_text(raw_text_loc - current_aux_len - 1..raw_text_loc - 2) = current_aux then
-- we are at the end of an opener or closer
tag_completed := raw_text(start_of_tag..raw_text_loc - current_aux_len - 2);
if inside_of_opener then -- we have completed an opener
inside_of_opener := false;
last_tag_opened := tag_completed;
end_of_last_opener := raw_text_loc;
posns_of_open(tag_completed) :=
(posns_of_open(tag_completed)?[]) with (str(num_lines) + "." + str(digested_length));
--print("completed an opener: ",tag_completed," ",posns_of_open);
raw_text_loc +:= 1;
raw_text_sections(rtsix + 1) := raw_text_sections(rtsix + 1)(2..); -- drop the '>'
else -- we have completed a closer; see if it is null, and if it closes anything
--print("completed a closer: ",tag_completed," ",end_of_last_opener," ",start_of_tag - 4 - current_aux_len);
inside_of_closer := false;
-- when a tag ends, we must see if it is a null tag. If so, we take it as a
-- current_aux change. if not, we generate an entry in the tags_list
if end_of_last_opener = start_of_tag - 4 - current_aux_len then
-- we have ...`><`..., so a null tag
current_aux_len := #(current_aux := tag_completed);
posns_of_open(tag_completed) := OM; -- this null tag is no longer open
--print("current_aux changed to: ",current_aux);
elseif #(opened := posns_of_open(tag_completed)) > 0 then
-- tag does not apply to null section and should not be ignored
tags_list with:= [opened(1),
(str(num_lines) + "." + str(digested_length)),tag_completed];
-- add run to list of completed tags
posns_of_open(tag_completed) := OM; -- this tag is no longer open
end if;
raw_text_loc +:= 1;
raw_text_sections(rtsix + 1) := raw_text_sections(rtsix + 1)(2..); -- drop the '>'
end if;
end if; -- else not at the end; just bypass the ` character, which becomes part of the tag
else -- we are not in an opener or closer; check to see if a new opener or closer is starting
--print("see if strting: ",raw_text_loc," ",raw_text);
if raw_text_loc > 2 and raw_text(raw_text_loc - 2) = "<" then
-- may have either an opener or a closer
if raw_text_loc <= len_raw and raw_text(raw_text_loc) = "`"
-- possibly start of closer
and raw_text_loc + current_aux_len <= len_raw and
raw_text(raw_text_loc + 1..raw_text_loc + current_aux_len) = current_aux then
-- definitely is start of closer
start_of_tag := raw_text_loc + current_aux_len + 1; -- note start of tag
inside_of_closer := true;
rtsix +:= 1; raw_text_loc +:= 1; -- the following "`" character has been handled
digested_text := digested_text(1..#digested_text - 1); -- drop the opening '<'
digested_length -:= 1;
continue; -- this "`" character has been handled
elseif raw_text_loc + current_aux_len <= len_raw
and raw_text(raw_text_loc..raw_text_loc + current_aux_len - 1) = current_aux then
-- start of opener
start_of_tag := raw_text_loc + current_aux_len; -- note start of tag
inside_of_opener := true;
digested_text := digested_text(1..#digested_text - 1); -- drop the opening '<'
digested_length -:= 1;
continue; -- this "`" character has been handled
end if; -- otherwise just collect the character
end if; -- end case in which we are not inside_of_opener or inside_of_closer
digested_text +:= section; digested_length +:= 1;
end if; -- end treatment of "`" character
elseif section in "\r\n" then -- current character is a carriage return or linefeed
num_lines +:= 1; digested_length := 0; -- start a new section
if inside_of_opener then -- the opener ends; all characters back to the initial <`ccc
-- must be digested
digested_text +:= (addst := raw_text(start_of_tag - 2 - current_aux_len..raw_text_loc - 1));
inside_of_opener := false; -- no longer inside_of_opener
elseif inside_of_closer then -- the closer ends
digested_text +:=
(addst := raw_text(start_of_tag - 3 - current_aux_len..raw_text_loc - 1) + section);
inside_of_opener := false; -- no longer inside_of_opener
else -- just collect the character
digested_text +:= section;
end if;
-- else -- something else inside an opener or closer; just bypass
end if;
end loop;
--print("digested_text: ",digested_text); print("tags_list: ",tags_list); print("posns_of_open: ",posns_of_open);
return [digested_text,tags_list,posns_of_open]; -- the remaining open tags becomes the marks_list returned
end analyze_text;
procedure setup_text(tags_list,marks_list); -- set up pre-analyzed text in Tk text area (self)
for [range_start,range_end,tag] in tags_list loop
tag_add_no_offs(tag,range_start,range_end);
end loop;
for [mark,mark_locs] in marks_list, n in mark_locs loop
-- [n1,n2] := breakup(n,".");
mark_set(mark,n);
end loop;
end setup_text;
procedure set_whole_contents(y); -- set content of an entry, text, message, or label widget to y
-- set the slider position of a scale, or the title of a toplevel widget;
-- set the menu of a menubutton; write to a client socket
if tk_type /= "menubutton" and tk_type /= "toplevel" then y := stg_to_Tk(str(y)); end if; -- force y to sanitized string form
--print("converted y: ",y);
case tk_type
when "entry" => -- entry(OM) := y sets the whole entry widget text
tk_kall(full_name() + " delete 0 end");
txt := full_name() + " insert 0 \"" + y + "\""; -- y has been converted to Tk form above
--print("setting entry: ",txt);
return tk_kall(txt);
when "text" => -- text(OM) := y sets the whole text widget contents, after text analysis
[vis_text,tag_list,mark_list] := analyze_text(str(y));
--print("vis_text: ",vis_text,"*");
tk_kall(full_name() + " delete 1.0 end");
to_ret := tk_kall(full_name() + " insert 1.0 \"" + vis_text + "\"");
setup_text(tag_list,mark_list);
return to_ret;
when "message","label" => -- message(OM) := y, etc. sets the whole message or label widget text
return tk_kall(full_name() + " configure -text \"" + y + "\""); -- y has been converted to Tk form above
when "scale" => -- slider(OM) := y sets the slider position
variable := tk_kall(full_name() + " set " + y);
when "toplevel" => -- toplevel(OM) := y sets the title
return tk_kall("wm title " + full_name() + " {" + y + "}"); -- y has NOT been converted to Tk form above
when "menubutton" => -- toplevel(OM) := y sets the menu of a menubutton
return tk_kall(full_name() + " configure -menu " + y.full_name());
when "socket" => -- socket(OM) := y writes to a socket
tk_kall("puts " + name + " \"" + y + "\""); -- pass 'write string' command to tk
-- y has been converted to Tk form above
otherwise => abort("Illegal object type " + tk_type + " in set_whole_contents operation");
end case;
end set_whole_contents;
procedure reconfigure_from_map(att_map); -- reconfigure all attributes using attribute map
defaults := Tk_data_defaults(tk_type); -- get the default attribute values
att_map +:= {[x,y]: [x,y] in defaults | att_map(x) = OM};
att_map("wincoords") := OM; att_map("rect") := OM; -- treat these as 'write-only'
att_map("toplevel") := OM; att_map("children") := OM; -- treat these as 'write-only'
att_map("bd") := OM; att_map("ismapped") := OM; att_map("manager") := OM; att_map("showing") := OM; -- treat these as 'write-only'
att_map("Tk_tags") := OM; -- the tags attributes are handled elsewhere
if tk_type = "frame" or tk_type = "toplevel" then
-- eliminate read-only attributes of toplevels (can be set only when toplevel being created)
att_map("colormap") := OM; -- can't modify -colormap option after widget is created
att_map("visual") := OM; -- can't modify -visual option after widget is created
att_map("use") := OM; -- can't modify -use option after widget is created
att_map("container") := OM; -- can't modify -container option after widget is created
att_map("screen") := OM; -- can't modify -screen option after widget is created
att_map("class") := OM; -- can't modify -class option after widget is created
end if;
if tk_type = "listbox" then
items := att_map("text"); att_map("text") := OM; -- get the listbox items; this is not a standard attribute
end if;
if tk_type = "entry" then
contents := att_map("text"); att_map("text") := OM; -- get the listbox items; this is not a standard attribute
end if;
att_string := "" +/ ["-" + x + " " + if (sty := str(y)) = "" then "{}" else " {" + sty + "} " end if
+ " ": [x,y] in att_map]; -- stg_to_Tk(str(y))
txt := (fn := full_name()) + " configure " + att_string; -- set up the reconfiguration command
--if tk_type = "frame" then print("reconfiguration command: ",txt); end if;
res := tk_kall(txt);
--if tk_type = "toplevel" then print("reconfiguration result: ",res); end if;
if tk_type = "listbox" then -- must set the listbox list elements
tk_kall(fn + " delete 0 end"); -- drop all the present items
res := tk_kall(fn + " insert end " + join(["{" + item + "}": item in items]," "));
-- insert the new items, quoting them (need to sanitize beter)
end if;
if tk_type = "entry" then
contents := set_whole_contents(contents); -- set the text contents
end if;
return res;
end reconfigure_from_map;
procedure null_whole_attribute(att); -- null the value of this attribute
if att in geom_manager_main_atts then
-- if the side, pack, grid, or place attribute is nulled, then erase the item
if name(1) = "c" then -- we have a canvas item
tk_kall(parent.full_name() + " delete " + name(2..)); -- delete the canvas item
-- if it is an image, then delete the source image (THIS IS A TEMPORARY FIX, SHOULD BE:)
-- if it is an image or a widget, then remove the reference from the source_of map,
-- and destroy the object when no references to it remain
if (so := source_of(fna := full_name())) /= OM then -- the source must be an image; delete it
res := tk_kall("image delete " + so.name);
source_of(fna) := OM; -- remove from the source_of map
--print("so: ",so," res= ",res);
end if;
else -- we have a widget
tk_kall(if att = "side" then "pack" else att end if + " forget " + full_name());
end if;
else
case att
when "grab" =>
tk_kall("grab release " + full_name());
when "placed" => -- drop all the placed items
items := tk_kall(" place slaves " + full_name());
tk_kall(" place forget " + items);
when "packed" => -- drop all the packed items
items := tk_kall(" pack slaves " + full_name());
tk_kall(" pack forget " + items);
when att = "gridded" => -- drop all the gridded items
items := tk_kall(" grid slaves " + full_name());
tk_kall(" grid forget " + items);
end case;
end if;
end null_whole_attribute;
procedure configure_toplevel(itm,options,y); -- handle all the standard built-in dialogs
y := chop(y);
case itm
when "ask" => -- open a general choice dialog
-- parameters of tk_dialog call are: win,title,message,(bitmap = {} if none),labels,default_num
opt_vals := {[opt,str(y(j))]: opt = options(j)}; -- maps options to their values if given
-- prepare the label list in proper form
labels := "" +/ ["\"" + stg_to_Tk(label) + "\" ": label in chop(opt_vals("labels")?"")];
txt := "tk_dialog " + full_name() + " \"" + opt_vals("title")?"{}" +
"\" \"" + opt_vals("message")?"{}" + "\" " +
if (ovbm := opt_vals("bitmap")) /= OM then "\"" + ovbm + "\"" else "{}" end if +
" " + str(unstr(opt_vals("default")) - 1)?"{}" + " " + labels;
when "ask_ok" => -- open an ask_ok dialog of some type
txt := "tk_messageBox" +/ [" -" + opt + " \"" + y(j) + "\" ": opt = options(j)];
when "ask_color" => -- open a color-picker dialog
txt := "tk_chooseColor" +/ [" -" + opt + " \"" + y(j) + "\" ": opt = options(j)];
when "ask_file" => -- open an open-file dialog
if (opt := options(1)) = "filetypes" then -- use only the first option
txt := "tk_getOpenFile -" + opt + " {" +/ [yval + " ": yval = y(j)] + "}";
else
txt := "tk_getOpenFile" +/ [" -" + opt + " " + y(j): opt = options(j)];
end if;
when "ask_save_file" => -- open a save-file dialog
txt := "tk_getSaveFile" +/ [" -" + opt + " " + y(j): opt = options(j)];
otherwise => abort("Illegal configuration call " + itm + " for toplevel widget.");
end case;
return (dialog_response := tk_kall(txt));
end configure_toplevel;
procedure configure_image(x,y); -- configure an absolute image
y := if y = OM then [ ] else chop(y) end if;
for att = x(j) loop -- set designated intenral attributes of the image
if att = "file" then -- we read or clear the image
txt := "image delete " + name; -- clear the image in any case; Note that absolute images are referenced by their name
if y(j) /= OM then
txt +:= ("\n image create photo \"" + name + "\" -file " + y(j));
end if;
else -- simply configure the attribute
txt := name + " configure -" + att + " \"" + (y(j)?"") + "\"";
end if;
tk_kall(txt); -- perform the Tk operation
end loop;
end configure_image;
procedure configure_bitmap(x,y); -- configure an absolute bitmap
y := if y = OM then [ ] else chop(y) end if;
for att = x(j) loop -- set designated intenral attributes of the image
if att = "data" then -- we read or clear the image
txt := "image delete " + name; -- clear the image in any case; Note that absolute images are referenced by their name
if y(j) /= OM then
txt +:= ("\n image create bitmap \"" + name + "\" -file " + y(j));
end if;
else -- simply configure the attribute
txt := name + " configure -" + att + " \"" + (y(j)?"") + "\"";
end if;
tk_kall(txt); -- perform the Tk operation
end loop;
end configure_bitmap;
procedure configure_menu(x,y); -- configure a menu
x_to_y := {[xc,tk_string_of(y(j)?"")]: xc = x(j)};
-- convert procs and nullstrings in y to their Tk forms and represent as map
type_and_attvals := read_whole_menu();
men_fn := full_name(); -- full name of the menu being reconfigured
tk_kall("destroy " + men_fn); -- destroy the present menu, in preparation for re-creation
-- assign the new menu attributes
menu_attvals := type_and_attvals(1);
for x in domain(menu_attvals) | (new := x_to_y(x)) /= OM loop menu_attvals(x) := new; end loop;
--rbreak(men_fn,"."); men_fn +:= "w1000";
new_menu_string := "menu " + men_fn +/ [" -" + option_name + " " + tk_string_of(option_val): [option_name,option_val] in menu_attvals];
--print(new_menu_string);
tk_kall(new_menu_string); -- recreate the menu with its new attributes
-- now add back all the former items
for j in [2..#type_and_attvals] loop
item_attvals := type_and_attvals(j); -- attribute map for the items
new_item_string := men_fn + " add " + item_attvals("type") + " "
+/ [" -" + option_name + " " + tk_string_of(option_val): [option_name,option_val] in item_attvals | option_name /= "type"];
tk_kall(new_item_string);
--print(new_item_string);
end loop;
end configure_menu;
procedure read_whole_menu(); -- get the type and entry values of a menu
-- this returns the menu data as a tuple of maps, the first component representing the menu attributes and the remaining
-- representing the sucessibe menu items. Each map sends attribute namesinto attribute values
men_len := unstr(tk_kall((men_name := full_name()) + " index end"));
menu_optnames := breakup("activebackground,activeforeground,background,foreground,borderwidth,activeborderwidth,cursor,"
+ "disabledforeground,font,relief,takefocus,postcommand,selectcolor,tearoff,tearoffcommand,title,type",",");
data_tup := [{[optname,tk_kall(men_name + " cget -" + optname)]: optname in menu_optnames}]; -- will collect more
menu_item_optnames := breakup("activebackground,activeforeground,accelerator,background,foreground,bitmap,columnbreak,command,font,"
+ "hidemargin,image,label,state,underline,indicatoron,offvalue,onvalue,variable,selectcolor,selectimage,value,menu",",");
for j in [0..men_len] loop
item_type := tk_kall(men_name + " type " + j);
item_data := {["type",item_type]}
+ {[optname,x]: optname in menu_item_optnames |
(x := reduce_unknowns(tk_kall(men_name + " entrycget " + j + " -" + optname))) /= OM};
data_tup with:= item_data;
end loop;
return data_tup;
end read_whole_menu;
procedure reduce_unknowns(att_stg); -- replace 'unknown option' error messages by 'U'
return if att_stg = "" or att_stg(#att_stg) /= "\"" then att_stg else OM end if;
end reduce_unknowns;
procedure configure_canvas_item(x,y); -- configure a canvas item
-- Tk uses itemcget/itemconfigure calls to get/set all but the coords attributes,
-- but a coords calls to get/set the coords attribute. Note that x has already been broken into a tuple,
-- but y has not
-- The attributes of canvas items are: tags, width, and coords in all cases, plus
-- for canvas geometric objects: fill, outline, and stipple
-- for images: anchor and image
-- for canvas text objects: anchor, fill, font, justify, stipple, and text
-- for canvas widgets: anchor, height, and window
-- x is a tuple of attributes; y can be a string, possibly semicolon-delimited
-- with a comma-delimited list of coordinates, or can be a tuple, possibly
-- including a comma or semicolon-delimited delimited string of coordinates, or
-- a tuple of coordinates.
fn := parent.full_name(); -- get the full tk name of the parent canvas
attr_list := x;
-- print("configure_canvas_item: ",full_name()," ",x," ",y," ",fn);
-- y := if #x = 1 then [y] else chop(y) end if;
-- -- turn argument of any type into unit tuple, break string into list
for att = attr_list(j) loop -- loop, using the tk itemconfigure command to set the value
-- unless the attribute is 'coords', in which case we use
-- the parent coords command to set it
if att = "coords" and #x = 1 and ((not is_string(y1 := y(1))) or not "," in y1) then
val := y; -- use whole y as matching attrib value
elseif is_procedure(y(j)) then
-- call the tk library 'createcommand' function, to associate a
-- new command id of the form Pnnn with the SETL callback procedure supplied;
-- then include the command id in the command string being built
tk_createcommand(interp, val := "P" + str(proc_ctr +:= 1) ,y(j));
-- we will include the callback id in the command being built
else -- item should be a tk string value
val := y(j); -- include the string value in the command being built
end if;
if att = OM then -- we bind a procedure to the canvas item
op_name := main_command(tk_type);
txt := parent.full_name() + " bind " + name(2..) + " " + op_name + " " + val;
--print("configure_canvas_item: ",txt," ",x," ",y," ",val," ",name," ",op_name);
elseif att /= "coords" then
txt := fn + " itemconfigure " + name(2..) + " -" + att + " " + str(val);
--print("configure canvas_item: ",txt); stop;
else -- a tuple of numbers or comma-delimited string is expected
if is_string(val) and (nv := #val) > 0 and "{" = val(1) then val := val(2..nv - 1); end if;
if is_string(val) and "," in val then val := chop(val); end if;
txt := fn + " coords " + name(2..) + " " + "" +/ [str(d) + " ": d in val];
--print("configure coords: ",txt," y: ",y," res: ",tk_kall(txt)); print("self(OM) is: ",self(OM));
end if;
res := tk_kall(txt);
end loop;
end configure_canvas_item;
procedure configure_file_item(fname,att_list,val_list); -- configure a file item
--print("configure_file_item: ",att_list,val_list);
if not is_tuple(att_list) then att_list := [att_list]; end if; -- force to tuple
if not is_tuple(val_list) then val_list := [val_list]; end if; -- force to tuple
for att = att_list(j) loop
val := val_list(j);
case att
when "mac_creator" =>
if is_string(val) and # val = 4 then tk_kall("file attributes " + fname + " -creator " + val); end if;
when "mac_type" =>
if is_string(val) and # val = 4 then tk_kall("file attributes " + fname + " -type " + val); end if;
when "mac_hidden" => tk_kall("file attributes " + fname + " -readonly " + if val = 0 or val = "0" then "0" else "1" end if);
when "mac_readonly" => tk_kall("file attributes " + fname + " -readonly " + if val = 0 or val = "0" then "0" else "1" end if);
when "name" =>
if val = "" then -- delete the file
tk_kall("file delete " + fname);
elseif is_string(val) then -- rename the file, or create a directory of the specifed name
the_type := tk_kall("file type " + fname); -- first determine if the file exists
not_exists_msg := rmatch(the_type,"no such file or directory");
not_exists := not_exists_msg /= "";
if not_exists then -- create a directory of the given name
tk_kall("file mkdir " + val);
else -- rename the file
tk_kall("file rename " + fname + " " + val);
end if;
end if;
end case;
end loop;
end configure_file_item;
procedure configure_socket_item(x,y); -- configure a socket item
end configure_socket_item;
procedure configure_geometry(x,y); -- handle geometry-manager calls
--print("configure_geometry: ",x,y);
case x(1)
when "pack" => -- ignore, but must be followed by pack options (pack geometry manager)
if exists j in [2..#x] | x(j) notin pack_options then
abort(str(x(j)) + " is not a legal option for a pack operation");
end if;
if #y /= #x - 1 then
abort("Different number of pack operation options and option values");
end if;
the_text := "pack " + full_name();
for j in [2..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + str(y(j - 1)) + "\"");
end loop;
when "side" => -- must be followed by pack options (pack geometry manager)
if exists j in [1..#x] | x(j) notin pack_options then
abort(str(x(j)) + " is not a legal option for a pack operation");
end if;
if #y /= #x then
abort("Different number of pack operation options and option values " + str(x) + "\n" + str(y));
end if;
the_text := "pack " + full_name();
for j in [1..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + str(y(j)) + "\"");
end loop;
when "grid" => -- ignore, but must be followed by grid options (grid geometry manager)
if exists j in [2..#x] | x(j) notin grid_options then
abort(str(x(j)) + " is not a legal option for a grid operation");
end if;
if #y /= #x - 1 then
abort("Different number of grid operation options and option values");
end if;
the_text := "grid " + full_name();
for j in [2..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + str(y(j - 1)) + "\"");
end loop;
when "row","column" => -- must be followed by grid options (grid geometry manager)
if exists j in [1..#x] | x(j) notin grid_options then
abort(str(x(j)) + " is not a legal option for a grid operation");
end if;
if #y /= #x then
abort("Different number of grid operation options and option values" + str(x) + "\n" + str(y));
end if;
the_text := "grid " + full_name();
for j in [1..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + str(y(j)) + "\"");
end loop;
when "place" => -- but must be followed by place options (place geometry manager)
-- example is obj("place,x,y,anchor") := "xv,yv,nw";
if exists j in [2..#x] | x(j) notin place_options then
abort(str(x(j)) + " is not a legal option for a place operation");
end if;
if #y /= #x - 1 then
abort("Different number of place operation options and option values" + str(x) + "\n" + str(y));
end if;
the_text := "place " + full_name();
for j in [2..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + str(y(j - 1)) + "\"");
end loop;
end case;
res := tk_kall(the_text);
--print("configure_geometry: ",res," ",the_text);
return res; -- we finish the operation here
end configure_geometry;
procedure configure_geometry_in(x,y,in_widget); -- handle extended geometry-manager calls
in_widget_name := in_widget.full_name(); -- get the full name of the widget which will become the container
case x(1)
when "pack" => -- ignore, but must be followed by pack options (pack geometry manager)
if exists j in [2..#x] | x(j) notin pack_options then
abort(str(x(j)) + " is not a legal option for a pack operation");
end if;
if #y /= #x - 1 then
abort("Different number of pack operation options and option values");
end if;
the_text := "pack " + full_name();
for j in [2..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + y(j - 1) + "\"");
end loop;
when "side" => -- must be followed by pack options (pack geometry manager)
if exists j in [1..#x] | x(j) notin pack_options then
abort(str(x(j)) + " is not a legal option for a pack operation");
end if;
if #y /= #x then
abort("Different number of pack operation options and option values " + str(x) + "\n" + str(y));
end if;
the_text := "pack " + full_name();
for j in [1..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + y(j) + "\"");
end loop;
when "grid" => -- ignore, but must be followed by grid options (grid geometry manager)
if exists j in [2..#x] | x(j) notin grid_options then
abort(str(x(j)) + " is not a legal option for a grid operation");
end if;
if #y /= #x - 1 then
abort("Different number of grid operation options and option values");
end if;
the_text := "grid " + full_name();
for j in [2..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + y(j - 1) + "\"");
end loop;
when "row","column" => -- must be followed by grid options (grid geometry manager)
if exists j in [1..#x] | x(j) notin grid_options then
abort(str(x(j)) + " is not a legal option for a grid operation");
end if;
if #y /= #x then
abort("Different number of grid operation options and option values" + str(x) + "\n" + str(y));
end if;
the_text := "grid " + full_name();
for j in [1..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + y(j) + "\"");
end loop;
when "place" => -- but must be followed by place options (place geometry manager)
-- example is obj("place,x,y,anchor") := "xv,yv,nw";
if exists j in [2..#x] | x(j) notin place_options then
abort(str(x(j)) + " is not a legal option for a place operation");
end if;
if #y /= #x - 1 then
abort("Different number of place operation options and option values" + str(x) + "\n" + str(y));
end if;
the_text := "place " + full_name();
for j in [2..#x] loop -- now assemble the options and option values
the_text +:= (" -" + x(j) + " \"" + y(j - 1) + "\"");
end loop;
end case;
res := tk_kall(txt := the_text + " -in " + in_widget_name); -- we finish the operation here
--print("configure_geometry_in: ",res," ",txt);
return res;
end configure_geometry_in;
procedure handle_pseudo_attrib(name,xj,yj); -- handle special widget configuration ops
case tk_type
when "entry" => -- special action for the 'insert' pseudo-attribute
if xj /= "insert" then return false; end if;
tk_kall(full_name() + " icursor " + str(yj));
-- special action for the 'insert' pseudo-attribute; note that this is not
-- possible for text widgets
return true; -- done with this case
when "canvas_text" => -- special action for the 'insert' pseudo-attribute
if xj /= "insert" then return false; end if;
tk_kall(parent.full_name() + " icursor " + name(2..) + " " + str(yj));
return true; -- done with this case
when "radiobutton","checkbutton" => -- special action for the 'selected' pseudo-attribute
if xj /= "selected" then return false; end if;
-- else is pseudo-attribute: set the associated variable
if str(yj) = "1" then tk_kall(full_name() + " select "); else tk_kall(full_name() + " deselect "); end if;
return true; -- done with this case
-- when "checkbutton" => -- special action for the 'selected' pseudo-attribute
--
-- if xj /= "selected" then return false; end if;
-- -- else is pseudo-attribute: set the associated variable
-- varname := tk_kall(full_name() + " cget -variable "); -- get name of associated variable
-- tk_kall("set " + varname + " " + str(yj));
-- return true; -- done with this case
when "listbox" => -- special action for the 'hilight' pseudo-attribute
-- set the associated variable
if xj /= "hilight" then return false; end if;
txt := full_name() + " activate " + str(yj);
tk_kall(txt);
return true; -- done with this case
otherwise =>
if xj /= "coords" then return false; end if;
-- the "coords" case must be handled specially
yy := breakup(yj,",");
coord_text := parent.full_name() + " coords " + name(2..) + " " +/ [str(xx) + " ": xx in yy];
tk_kall(coord_text); -- execute the 'coords' command
return true; -- done with this case
end case;
end handle_pseudo_attrib;
procedure may_quote(stg); -- quote a string if not enclosed in curly brackets
return if #stg > 0 and stg(1) /= "{" then "\"" + stg + "\"" else stg end if;
end may_quote;
procedure tk_string_of(obj_or_proc); -- find appropriate name for tk widget, image, or procedure
-- convert a SETL procedure to a tk command name if none yet issued; use full names for objects other
-- than absolute images; and use the simple name for images
if obj_or_proc = "" then return "{}"; end if; -- Tk form of nullstring
if type(obj_or_proc) = "TKW" then
-- check for the absolute image case
if obj_or_proc.tk_type in {"image","bitmap"} and obj_or_proc.parent = OM then return obj_or_proc.name; end if;
return obj_or_proc.full_name(); -- use full name if this is a Tk widget
end if;
if type(obj_or_proc) /= "PROCEDURE" then return str(obj_or_proc); end if; -- simply convert to string if not procdure
if (pid := proc_tk_name(obj_or_proc)) /= OM then return pid; end if;
-- procedure has already been given a tk_name; return this
proc_tk_name(obj_or_proc) := (pid := "P" + str(proc_ctr +:= 1)); -- otherwise give it a new name
tk_createcommand(interp,pid,obj_or_proc); -- make this name into a tk command
return pid; -- return the new name
end tk_string_of;
procedure beeper(); -- beep procedure
tk_call(interp,"beep");
end beeper;
procedure stopper(); -- destruction of top level window to force return from Tk main loop
tk_call(interp,"destroy .");
end stopper;
procedure place(); -- returns object x and y coordinates if 'placed' in parent
return [unstr((self("place")("x"))?"-9999"),unstr((self("place")("y"))?"-9999")];
end place;
procedure gridbox(i,j); -- returns coordinates of specified gridbox
txt := "grid bbox " + full_name() + " " + i + " " + j; return tk_call(interp,txt);
end gridbox;
procedure raise(after_obj); -- raises object to position just after after_obj, or to top if after_obj = OM
if name = "" then return; end if; -- this should not happen
if name(1) = "w" then -- raising a widget
txt := "raise " + self.full_name();
if after_obj /= OM then txt +:= (" " + after_obj.full_name()); end if;
else
txt := if parent = OM then "raise ." else parent.full_name() + " " + "raise " + name(2..) end if;
if after_obj /= OM then txt +:= (" " + (after_obj.name)(2..)); end if;
end if;
tk_call(interp,txt);
end raise;
procedure lower(before_obj); -- lowers object to position just before before_obj, or to bottom if before_obj = OM
if name = "" then return; end if; -- this should not happen
if name(1) = "w" then -- raising a widget
txt := "lower " + self.full_name();
if before_obj /= OM then txt +:= (" " + before_obj.full_name()); end if;
else
txt := if parent = OM then "lower ." else parent.full_name() + " " + "raise " + name(2..) end if;
if after_obj /= OM then txt +:= (" " + (after_obj.name)(2..)); end if;
end if;
tk_kall(txt);
end lower;
procedure createtimer(interval,SETL_fun); -- create a timer callback (rings once)
pid := tk_string_of(SETL_fun);
txt := "after " + if interval = OM then "idle" else str(interval) end if + " " + pid;
return tk_kall(txt);
-- return if interval = OM then tk_idlecallback(SETL_fun) else tk_createtimer(interval,SETL_fun) end if;
end createtimer;
procedure cancel_event(id); -- cancel a timer or idle callback
return tk_kall("after cancel " + id);
-- return tk_destroy(id);
end cancel_event;
procedure break_event(); -- suppress further processingof an event
return tk_kall("break");
end break_event;
-- ****** Operations available for all widgets ******
procedure bindtags(tag); -- gets event bindings for specified tag, or for whole widget if tag = OM
if tag /= OM then return tk_kall("bind " + tag); end if;
return tk_kall("bindtags " + full_name());
end bindtags;
-- procedure virt_event_info(virt_event); -- gets physical definition of specified virtual events, or virtual event list if param is OM
-- return tk_kall("event info " + virt_event?"");
-- end virt_event_info;
procedure virt_event_delete(virt_event); -- deletes specified virtual event
return tk_call(interp,"event delete " + virt_event);
end virt_event_delete;
-- ****** Basic Operationss ******
procedure quit(); -- close the tk interpreter
tk_call(interp,"destroy ."); -- by destroying the top window
tk_quit(interp); -- and then calling the native package
end quit;
procedure call(txt); -- transmit a command to the tk main loop
return tk_kall(txt);
end call;
procedure mainloop(); -- call the tk main loop and wait for callback
return tk_mainloop(interp);
end mainloop;
-- GIUSEPPE START
procedure handle_event(); -- call the tk event and handle the callbacks
return tk_handle_event(interp);
end handle_event;
procedure get_event_source_function(); -- call the tk main loop and wait for callback
return tk_get_event_source_function(); -- interp); -- ?????
end get_event_source_function;
-- GIUSEPPE END
procedure setvar(name,val); -- set a tk variable to the indicated value
txt := "set " + name + " \"" + stg_to_Tk(str(val)) + "\"";
return tk_kall(txt);
end setvar;
procedure getvar(name); -- read a tk variable
txt := "set " + name; return tk_kall(txt);
end getvar;
procedure update(); -- request screen display update
txt := "update"; tk_kall(txt);
end update;
-- ****** Miscellaneous Utilities ******
procedure clock(); -- clock and date utility
-- returns time in format [very_fine,seconds,dau,month,am_pm,weekno_in_year,mm/dd/yy,abbrev_time,monthno,dayno_in_year,dayno_in_week]
ticks := tk_kall("clock clicks"); secs := tk_kall("set x [clock seconds]");
timetup := [unstr(ticks),unstr(secs)] + breakup(tk_kall("clock format $x -format %A%%%B%%%p%%%U%%%x%%%c%%%j%%%w"),"%");
return timetup;
end clock;
-- ****** Canvas Operations ******
procedure addtag_after(tag);
-- add a specified tag to the item just above (or below) that with a
-- given tag in the display list, or to all items, or to all enclosed
-- in a given rectangle, or to the nearest item to a given point,
-- or to items which already have a given tag.
txt := parent.full_name() + " addtag \"" + tag + "\" above " + name(2..);
--print("addtag_before: ",txt);
return tk_kall(txt);
end addtag_after;
procedure addtag_before(tag); -- 'add tag below' case; see preceding comment
txt := parent.full_name() + " addtag \"" + tag + "\" below " + name(2..);
return tk_kall(txt);
end addtag_before;
procedure addtag_in(tag,rect); -- add tag to all items in a rectangle, or to all items if rect is OM
if rect = OM then
txt := full_name() + " addtag \"" + tag + "\" all"; return tk_kall(txt);
end if;
rect := "" +/ [str(x) + " ": x in chop(rect)];
txt := full_name() + " addtag \"" + tag + "\" enclosed " + rect;
return tk_kall(txt);
end addtag_in;
procedure addtag_nearest(tag,xy,halo,start); -- nearest to x,y, or last within radius halo of x,y, or
-- first such after item start in the canvas display list
[x,y] := breakup(xy,",");
txt := full_name() + " addtag \"" + tag + "\" closest " + x + " " + y;
if halo /= OM then txt +:= (" " + str(halo)); end if;
if start /= OM then txt +:= (" " + str(start)); end if;
return tk_kall(txt);
end addtag_nearest;
procedure addtag_if(newtag,hastag);
txt := full_name() + " addtag \"" + newtag + "\" withtag \"" + hastag + "\"";
return tk_kall(txt);
end addtag_if;
procedure addtag(newtag); -- add new tag to a canvas item
txt := parent.full_name() + " addtag \"" + newtag + "\" withtag " + name(2..);
return tk_kall(txt);
end addtag;
procedure bbox_tags(tags); -- get bounding box of items with given tags or ids
txt := full_name() + " bbox " +/ ["\"" + tag + "\" ": tag in chop(tags)];
return tk_kall(txt);
end bbox_tags;
procedure canvasx(x,roundto); -- map from screen to canvas coordinates, possibly rounded to grid units
txt := full_name() + " canvasx " + str(x) + " " + if roundto /= OM then str(roundto)
else "" end if;
return unstr(tk_kall(txt));
end canvasx;
procedure canvasy(y,roundto); -- map from screen to canvas coordinates, possibly rounded to grid units
txt := full_name() + " canvasy " + str(y) + " " + if roundto /= OM then str(roundto)
else "" end if;
return unstr(tk_kall(txt));
end canvasy;
procedure delete(); -- delete a canvas item
if tk_type notin canvas_items then return; end if;
txt := parent.full_name() + " delete " + name(2..);
return tk_kall(txt);
end delete;
procedure delete_till(end_ci); -- delete a range of canvas items
if tk_type notin canvas_items then return; end if;
first_no := unstr(name(2..)); last_no := unstr(end_ci.name(2..));
pfn_d := parent.full_name() + " delete ";
for itm_no in [first_no,first_no + 10..last_no - 10] loop
txt := "" +/ [pfn_d + str(itm_no + j) + "\n": j in [0..9]];
tk_kall(txt); -- delete a block of 10 items
last_del := itm_no + 10; -- keep track
end loop;
txt := "" +/ [pfn_d + str(j) + "\n": j in [last_del..last_no]]; -- delete the final group
return tk_kall(txt);
end delete_till;
procedure draw_ovals(descriptor_tup); -- draw a group of ovals; callsed as ca.draw_ovals(descriptor_tup), ca must be canvas
-- each descriptor_tup section is a pair of the form ['ulx,uly,lrx,lry',fill].
-- This should return the first and the last oval drawn
fnco := (fn := full_name()) + " create oval "; -- prefix for first part of call
fnic := fn + " itemconfigure "; -- prefix for second part of call
txt := fnco + join(breakup(descriptor_tup(1)(1),",")," "); -- set up to create the first oval, whose Tk serial number will be needed
res := tk_kall(txt);
item_num := first_num := unstr(res) - 1; -- get the number of the first item created
txt := "" +/ [if j = 1 then "" else fnco + join(breakup(koords + "\n",",")," ") end if
+ fnic + str(item_num +:= 1) + " -fill " + color + "\n":
[koords,color] = descriptor_tup(j)];
--print("draw_ovals: ",txt);
res := tk_kall(txt);
return [item_from_itemno(self,first_num),item_from_itemno(self,item_num)]; -- the first and the last oval drawn
end draw_ovals;
procedure delete_items(tags_or_ids); -- remove the item(s) identified by an id or tag
txt := full_name() + " delete " +/ ["\"" + tid + "\" ": tid in chop(tags_or_ids)];
return tk_kall(txt);
end delete_items;
procedure deltag_if(iftag,tags_or_ids); -- remove the specified tag from the item(s) identified by an id or tag
txt := full_name() + " dtag " + "\"" + iftag + "\" " +/ ["\"" + tid + "\" ": tid in chop(tags_or_ids)];
return tk_kall(txt);
end deltag_if;
procedure get_tagindex(tag,index); -- gets the value of an index in a tagged canvas text item
if tk_type /= "canvas" then return "Not a canvas!"; end if; -- must be a canvas text item
txt := full_name() + " index " + tag + " " + index;
return unstr(tk_kall(txt)) + 1;
end get_tagindex;
procedure get_select(tag); -- gets the value of sel.first and sel.last in a tagged canvas text item
if tk_type /= "canvas" then return "Not a canvas!"; end if; -- must be a canvas text item
txt := full_name() + " index " + tag + " sel.first";
if (sf := tk_kall(txt))(1) = "s" then -- use the insert position if the selection is empty
txt := full_name() + " index " + tag + " insert";
return [(res := unstr(tk_kall(txt))) + 1,res]; -- done with this case
end if;
txt := full_name() + " index " + tag + " sel.last"; sl := tk_kall(txt);
return [unstr(sf) + 1,unstr(sl) + 1];
end get_select;
procedure set_select(tag,i,j); -- sets the value of sel.first and sel.last in a tagged canvas text item
if tk_type /= "canvas" then return "Not a canvas!"; end if; -- must be a canvas text item
if j = i - 1 then -- clear the selection and set the insertion point
txt := full_name() + " select clear"; tk_kall(txt);
txt := full_name() + " icursor " + tag + " " + str(j);
return tk_kall(txt); -- done with this case
end if;
txt := (fn := full_name()) + " select from " + tag + " " + str(i - 1); tk_kall(txt);
txt := fn + " select to " + tag + " " + str(j - 1); tk_kall(txt);
return tk_kall(txt);
end set_select;
procedure refocus(tag); -- sets the focus to a tagged canvas text item, or gets it if tag = OM
if tk_type /= "canvas" then return "Not a canvas!"; end if; -- must be a canvas text item
fn := full_name();
if tag = OM then return tk_kall(fn + " focus"); end if; -- in this case, read the focus
-- res := tk_kall(txt1 := "focus " + fn); -- the canvas must get the focus,to assign it to a tag
txt := fn + " focus " + tag; res := tk_kall(txt);
return res;
end refocus;
procedure deltag(tags_or_ids); -- remove the specified tags from a canvas item
for tid in chop(tags_or_ids) loop
txt := parent.full_name() + " dtag " + name(2..) + " \"" + tid + "\"";
tk_kall(txt);
end loop;
end deltag;
procedure find_after(); -- find the item just above that with a given tag in the display list,
-- or all items, or all enclosed in a given rectangle, or the
-- nearest item to a given point, or to items which already have a given tag.
txt := parent.full_name() + " find above " + name(2..);
if (item_no := tk_kall(txt)) = "" then return OM; end if;
return item_from_itemno(parent,item_no);
end find_after;
procedure find_before(); -- find the item just below that with a given tag in the display list,
txt := parent.full_name() + " find below " + name(2..);
if (item_no := tk_kall(txt)) = "" then return OM; end if;
--print(txt," ",item_no); return OM;
return item_from_itemno(parent,item_no);
end find_before;
procedure find_in(rect); -- find all the items enclosed in a given rectangle
if rect = OM then
txt := full_name() + " find all";
item_list := breakup(tk_kall(txt)," "); -- get the list of items
return [item_from_itemno(self,item_no): item_no in item_list];
end if;
rect := "" +/ [str(x) + " ": x in chop(rect)];
txt := full_name() + " find enclosed " + rect;
item_list := breakup(tk_kall(txt)," "); -- get the list of items
return [item_from_itemno(self,item_no): item_no in item_list];
end find_in;
procedure find_touching(rect); -- find all the items touching in a given rectangle
if rect = OM then
txt := full_name() + " find all";
item_list := breakup(tk_kall(txt)," "); -- get the list of items
return [item_from_itemno(self,item_no): item_no in item_list];
end if;
rect := "" +/ [str(x) + " ": x in chop(rect)];
txt := full_name() + " find overlapping " + rect;
item_list := breakup(tk_kall(txt)," "); -- get the list of items
return [item_from_itemno(self,item_no): item_no in item_list];
end find_touching;
procedure find_nearest(xy,halo,start); -- find the nearest item to a given point
txt := full_name() + " find " + " closest " + str(i) + " " + str(j);
if halo /= OM then txt +:= (" " + str(halo)); end if;
if start /= OM then txt +:= (" " + str(start)); end if;
item_no := tk_kall(txt); -- get the number of the item
return item_from_itemno(self,item_no); -- convert the item number to an item
end find_nearest;
procedure find(tag); -- find all the items having a given tag
txt := full_name() + " find withtag \"" + tag + "\"";
item_list := breakup(tk_kall(txt)," "); -- get the list of items
return [item_from_itemno(self,item_no): item_no in item_list];
end find;
procedure item_from_itemno(parnt,item_no); -- convert an item number to an item
new_item := tkw(); -- form a blank new (canvas or text) item
new_item.parent := parnt; -- set the parent
new_item.tk_type := kind_from_config(parnt,item_no := str(item_no)); -- find its type
new_item.name := "c" + item_no; -- note its serial number (prefixing a 'c')
return new_item;
end item_from_itemno;
procedure kind_from_config(parnt,item_no); -- find the type of a canvas object from its configuration
-- this routine examines the attributes of an object to determine its tk_type, using the following heuristic:
-- an arc has 'extent'; a window has 'window'; an image has 'image'; a bitmap has 'bitmap'; a line has
-- 'arrow' and 'smooth'; a polygon has 'smooth' but not 'arrow'; text has 'font'. the other two cases are
-- oval and rectangle, which we distinguish using tags assigned when created.
txt := parnt.full_name() + " itemconfigure " + item_no;
info := tk_kall(txt); -- get the configuration info
key_att := find_wds(info,key_attributes)(2);
--print("kind_from_config: ",info," ",item_no);
case key_att
when "extent" => return "arc";
when "window" => return "widget";
when "image" => return "image";
when "bitmap" => return "bitmap";
when "font" => return "canvas_text";
when "smooth" => return if #find_wds(info,["arrow"]) = 0 then "polygon" else "line" end if;
otherwise =>
info := tk_kall(txt + " -tags");
return if #find_wds(info,["OVAL"]) > 0 then "oval" else "rectangle" end if;
end case;
end kind_from_config;
procedure find_wds(in_stg,wd_list); -- find the first word in wd_list which occurs in wd_list, if any
-- return the pair [location,wd]; or [] if none
fronts := "" +/domain(wff := {[wd(1),wd(2..)]: wd in wd_list | #wd > 0});
loc := 1; -- we keep track of our location in the following scan
while in_stg /= "" loop
skipped := break(in_stg,fronts); -- advance to the next significant character
fc := any(in_stg,fronts); -- find what it is
loc +:= # skipped; -- note number of characters bypassed
if fc = "" then exit; end if; -- exit if at end
for wd_tail in wff{fc} loop -- check to see if we have one of the words sought
if match(in_stg,wd_tail) /= "" then -- found what we want
return [loc,fc + wd_tail];
end if;
loc +:= 1; -- note one more character bypassed
end loop;
end loop;
return []; -- otherwise not found
end find_wds;
procedure focus(); -- return widget in win which has the focus
txt := "focus -displayof " + full_name(); return obj_from_tkname(tk_kall(txt));
end focus;
procedure focus_in_top(); -- return widget in master window which has the focus
txt := "focus -lastfor " + full_name(); return obj_from_tkname(tk_kall(txt));
end focus_in_top;
procedure get_focus(); -- set focus to this window
txt := "focus -force " + full_name(); return tk_kall(txt);
end get_focus;
procedure grab_focus(x); -- grab the (modal) focus; x can be OM or "global"
txt := "grab " + if x = OM then "" else "-global " end if + full_name();
return tk_kall(txt);
end grab_focus;
procedure release_focus(); -- release the (modal) focus
txt := "grab release " + full_name(); return tk_kall(txt);
end release_focus;
procedure read_grab(); -- determine the modal grab state of this window: none, local, or global
txt := "grab status " + full_name(); return tk_kall(txt);
end read_grab;
procedure grabber(); -- return window which has exerted a grab
txt := "grab current " + full_name(); return tk_kall(txt);
end grabber;
procedure destroy(); -- destroy a widget
txt := "destroy " + full_name();
--print("destroy: ",txt);
return tk_kall(txt);
end destroy;
procedure wait(); -- wait for this window to open
txt := "tkwait visibility"; return tk_kall(txt);
end wait;
procedure wait_close(); -- wait for this window to be destroyed
txt := "tkwait window"; return tk_kall(txt);
end wait_close;
procedure waitvar(name); -- wait for the specified tk variable to change
txt := ""; return tk_kall(txt);
end waitvar;
procedure index_item(ix_key); -- get numerical value of index_key, which can be active, end, last, etc.
txt := parent.full_name() + " index \"" + name(2..) + "\" " + ix_key;
return tk_kall(txt);
end index_item;
procedure lower_tid(tag_or_id,be); -- lower the item identified by an id or tag either to specified level,
-- or to the start of the display list
txt := full_name() + " lower \"" + tag_or_id + "\" " + if be = OM then "" else
"\"" + be + "\"" end if;
return tk_kall(txt);
end lower_tid;
procedure move(tag_or_id,dx,dy); -- move the item(s) identified by an id or tag, a specified amount
txt := full_name() + " move \"" + tag_or_id + "\" " + str(dx) + " " + str(dy);
return tk_kall(txt);
end move;
procedure postscript(options); -- generate postscript for the contents of a canvas. See below for options available
cfn := full_name();
txt := cfn + " postscript " + handle_ps_options(options,cfn);
return tk_kall(txt);
end postscript;
procedure handle_ps_options(options,cfn); -- convert comma-delimited postscript options into tk form
-- the postscript options available are" colormap (map from color indices into colors),
-- colormode (color, gray, or mono), file (file_name), height (of area to print), width (of area to print),
-- x (left of area to print), y (top of area to print), rotate (true if paper should be turned 90 degrees),
-- fontmap (map from X font names into Postscript fonts and sizes), pageheight (of output area),
-- pagewidth (of output area), pagex (left of output area), pagey (top of output area),
-- pageanchor (c, n,e,s, w, ne, se, nw, or sw); point from which output area offset is measured
options := breakup(options?"",",;"); -- break into list
option_names := {option: option = options(j) | odd(j)};
options_string := "";
if "width" notin option_names then
options_string +:= " -width " + tk_kall(cfn + " cget -width");
end if;
if "height" notin option_names then
options_string +:= " -height " + tk_kall(cfn + " cget -height");
end if;
return options_string +/[if odd(j) then " -" else " " end if + option: option = options(j)];
end handle_ps_options;
procedure raise_tid(tag_or_id,ab); -- raise the item identified by an id or tag either to speicified level,
-- or to the end of the display list
txt := full_name() + " raise \"" + tag_or_id + "\" " + if be = OM then "" else "\"" + ab + "\"" end if;
return tk_kall(txt);
end raise_tid;
procedure scale_item(cent_x,cent_y,amt_x,amt_y);
-- scale the item(s) identified by an id or tag, by a specified amount
-- about a specified center
txt := parent.full_name() + " scale \"" + name(2..) + "\" " +
str(cent_x) + " " + str(cent_y) + " " + str(amt_x) + " " + str(amt_y);
return tk_kall(txt);
end scale_item;
procedure scan_mark(x,y); -- place mark indicating scroll position???
txt := full_name() + " scan mark " + str(x) + " " + str(y);
return tk_kall(txt);
end scan_mark;
procedure scan_to(x,y); -- scroll to indicated position
txt := full_name() + " scan dragto " + str(x) + " " + str(y);
return tk_kall(txt);
end scan_to;
procedure scan_mark_1(x); -- place mark indicating scroll position
txt := full_name() + " scan mark " + str(x);
return tk_kall(txt);
end scan_mark_1;
procedure scan_to_1(x); -- scroll to indicated position
txt := full_name() + " scan dragto " + str(x);
return tk_kall(txt);
end scan_to_1;
procedure canvas_select(); -- ???
txt := ""; return tk_kall(txt);
end canvas_select;
procedure xview_percent(p); -- move to place fraction p of string offscreen to the left; p is real
txt := full_name() + " xview moveto " + str(p); return tk_kall(txt);
end xview_percent;
procedure yview_percent(p); -- move to place fraction p of string offscreen to the top; p is real
txt := full_name() + " yview moveto " + str(p); return tk_kall(txt);
end yview_percent;
procedure xview_scroll(n,what); -- scroll horizontally, n 'units' or 'pages'
txt := full_name() + " xview scroll " + str(n) + " " + (what?"units"); -- 'what' can be 'units' or 'pages'
return tk_kall(txt);
end xview_scroll;
procedure yview_scroll(n,what); -- scroll vertically, n 'units' or 'pages'
txt := full_name() + " yview scroll " + str(n) + " " + (what?"units"); -- 'what' can be 'units' or 'pages'
return tk_kall(txt);
end yview_scroll;
procedure image_of(rect); -- capture the contents of a rectangle within a canvas, as a Tk absolute image
if rect = OM then -- no rectangle
img_name := tk_kall("image create mimage -canvas " + full_name()); -- call Tk to create the image
else
[l,t,r,b] := rect; -- unpack
txt := "image create mimage -canvas " + full_name() + " ";
txt +:= "-canvas_x " + str(l) + " -canvas_y " + str(t) + " -canvas_width " +
str(r - l) + " -canvas_height " + str(b - t);
img_name := tk_kall(txt);
end if;
--print("orig image_name and info: ",img_name," ",tk_kall(img_name + " cget -format"));
photo_img_name := tk_kall("image create photo -height 100 -width 100 "); print("photo_img_name: ",photo_img_name);
res := tk_kall(photo_img_name + " copy " + img_name); print("photo_img_name res: ",res);
new_image := tkw(); -- form a blank new object
new_image.parent := OM; -- images have no parent
new_image.tk_type := "image"; -- note its type
new_image.name := photo_img_name; -- note its name, which we make unique
return new_image;
end image_of;
-- ****** Text Widget Operations ******
procedure compare(op,ix1,ix2); -- compare character indices in line.char and other allowed formats
-- op may be "==", ">", "!=", etc.
op := if op = "=" then "==" elseif op = "/=" then "!=" else op end if;
txt := full_name() + " compare {" + ix1 + "} " + op + " {" + ix2 + "}";
return tk_kall(txt) = "1";
end compare;
procedure debug(on_off); -- enable consistency checking for B-tree code???
txt := full_name() + " debug " + if on_off = OM then "false" else on_off end if;
return tk_kall(txt);
end debug;
procedure insert_tt(n,chars_and_tags);
-- insert a substring; this can carry specified tags in designated subsections
chars_and_tags := breakup(chars_and_tags,"`");
txt := full_name() + " insert " + str(n);
for ct = chars_and_tags(j) loop -- build the sanitized string of chars and tags
txt +:= if odd(j) then " \"" + stg_to_Tk(ct) + "\""
else " {" + join(breakup(ct,",")," ") + "}" end if;
end loop;
--print("insert_tt: ",txt);
return tk_kall(txt);
end insert_tt;
procedure linebox(n); -- return bounding box and baseline of line n
txt := full_name() + " dlineinfo " + str(n) + ".0";
data := [unstr(x): x in breakup(tk_kall(txt)," ")];
[l,t,w,h] := data;
return [[l,t,l + w,t + h],data(5)];
end linebox;
procedure insert_image(n,img); -- insert an image at a specified text position
txt := full_name() + " image create " + n + " -image " + img.name;
--print("insert_image: ",txt,img);
return tk_kall(txt);
end insert_image;
procedure handle_image_options(options_values); -- convert comma-delimited image options into tk form
-- options are align (), image (), name (), padx (), pady ()
return "" +/ [if odd(j) then "-" else "\"" end if +
if is_string(ov) then ov else ov.name end if -- if the value is an image, use its name
+ if odd(j) then " " else "\" " end if: ov = options_values(j)];
end handle_image_options;
procedure images(); -- return the ordered list of all images in a text widget
txt := full_name() + " image names"; img_list := breakup(tk_kall(txt)," ");
img_set := { };
for img_name in img_list loop
if "#" in img_name then rbreak(img_name,"#"); rmatch(img_name,"#"); end if;
img_set with:= img_name;
end loop;
img_list := [ ];
for img_name in img_set loop
new_image := tkw(); -- form a blank new object
new_image.parent := OM; -- images have no parent
new_image.tk_type := if #img_name > 3 and img_name(1..4) = "XBM`" then "bitmap" else "image" end if; -- note its type
new_image.name := img_name;
img_list with:= new_image;
end loop;
return img_list;
end images;
procedure index(ix_stg); -- return character position of specified text index
-- this operation also applies to menus, entries, and listboxes
-- text indices can be "current" (char under mouse), "end", "insert" (insert position),
-- line.char, image (name), widget (name), mark (stg), tag_name.first, tag_name.last,
case tk_type
when "listbox","menu" =>
if ix_stg = "sel.anchor" then -- add 1 except for "sel.last" and "end"
txt := full_name() + " index anchor"; return unstr(tk_kall(txt)) + 1;
else
txt := full_name() + " index " + ix_stg;
return unstr(tk_kall(txt)) + 1;
end if;
when "entry" =>
if is_integer(ix_stg) then -- here we get a bit position
txt := full_name() + " index @" + str(abs(ix_stg));
ix := tk_kall(txt);
return unstr(ix) + 1;
elseif ix_stg = "sel.last" then -- add 1 except for "sel.last" and "end"
if tk_kall(full_name() + " select present") = "0" then return OM; end if;
txt := full_name() + " index " + ix_stg; return unstr(tk_kall(txt));
elseif ix_stg = "sel.first" then -- add 1 except for "sel.last" and "end"
if tk_kall(full_name() + " select present") = "0" then return OM; end if;
txt := full_name() + " index " + ix_stg; return unstr(tk_kall(txt)) + 1;
elseif ix_stg = "sel.anchor" then -- add 1 except for "sel.last" and "end"
if tk_kall(full_name() + " select present") = "0" then return OM; end if;
txt := full_name() + " index anchor"; return unstr(tk_kall(txt)) + 1;
elseif ix_stg = "end" then -- add 1 except for "sel.last" and "end"
txt := full_name() + " index " + ix_stg; return unstr(tk_kall(txt));
else
txt := full_name() + " index " + ix_stg;
return unstr(tk_kall(txt)) + 1;
end if;
when "text" => -- index position in a text widget
if is_integer(ix_stg) then -- here we get a bit position
txt := full_name() + " index @" + str(abs(ix_stg));
ix := tk_kall(txt);
return adjust_text_ix(ix);
elseif ix_stg = "sel.last" then -- add 1 except for "sel.last" and "end"
if tk_kall(full_name() + " select present") = "0" then return OM; end if;
txt := full_name() + " index " + ix_stg; return tk_kall(txt);
elseif ix_stg = "sel.first" then -- add 1 except for "sel.last" and "end"
if tk_kall(full_name() + " select present") = "0" then return OM; end if;
txt := full_name() + " index " + ix_stg; return tk_kall(txt) + 1;
elseif ix_stg = "end" then -- add 1 except for "sel.last" and "end"
txt := full_name() + " index " + ix_stg;
return tk_kall(txt);
else
txt := full_name() + " index " + ix_stg;
return adjust_text_ix(tk_kall(txt));
end if;
otherwise =>
txt := full_name() + " index \"" + ix_stg + "\""; return tk_kall(txt);
end case;
end index;
procedure mark_set(name,n); -- place a named mark at the specified index
txt := full_name() + " mark set \"" + name + "\" \"" + str(n) + "\""; return tk_kall(txt);
end mark_set;
procedure mark_unset(name); -- remove a named mark (can also be comma-separated list)
txt := full_name() + " mark unset \"" + name + "\""; return tk_kall(txt);
end mark_unset;
procedure mark_gravity(name,n);
-- set the 'gravity' (left,right) of a mark, which determines the placement of strings inserted at the mark
txt := full_name() + " mark gravity \"" + name + "\" " + str(n); return tk_kall(txt);
end mark_gravity;
procedure mark_next(n); -- return the first mark after text position n
txt := full_name() + " mark next \"" + str(n) + "\""; return tk_kall(txt);
end mark_next;
procedure mark_prev(n); -- return the last mark before text position n
txt := full_name() + " mark previous \"" + str(n) + "\""; return tk_kall(txt);
end mark_prev;
procedure search(options,pattern,n,m); -- string search; returns empty string if unsuccessful
-- search section of text frm m to n for a pattern. 'options' parameter can be
-- "forward", "backward", "nocase", "count" (return count of matched characters)
-- "exact", "regexp" (use regular expression matching)
-- unless regular expression ,matching is specified, the 'pattern' is
-- only allowed to have "*" (wildcard), ? (one char), or [abc] specified chars
txt := full_name() + " search " + handle_search_options(options) + " -- \"" +
stg_to_Tk(pattern) + "\" " +
if n = OM then "1.0" else str(n) end if + " " +
if m = OM then "" else " " + str(m) end if;
return (the_start := adjust_text_ix(tk_kall(txt))) +
if "count" notin chop(options) then ""
else "," + the_start + "+" + str(unstr(getvar("```")) - 1) + "char" end if;
end search;
procedure handle_search_options(options); -- handle possible options for search
if options = OM then return ""; end if;
return "" +/ [if "count" = option then "-count ``` "
else "-" + option + " " end if: option in chop(options)];
end handle_search_options;
procedure see(n); -- scroll to make a given line.character position n visible
txt := full_name() + " see \"" + str(n) + "\""; return tk_kall(txt);
end see;
procedure tag_add(tag,index_range_stg); -- add tag to a list of character ranges
txt := full_name() + " tag add " + tag + " " + handle_index_range(index_range_stg);
return tk_kall(txt);
end tag_add;
procedure tag_add_no_offs(tag,range_start,range_end);
txt := full_name() + " tag add " + tag + " " + range_start + " " + range_end;
return tk_kall(txt);
end tag_add_no_offs;
procedure tag_remove(tag,index_range_stg); -- remove tag from list of text ranges
txt := full_name() + " tag remove " + tag + " " + handle_index_range(index_range_stg);
return tk_kall(txt);
end tag_remove;
procedure handle_index_range(index_range_stg); -- handle list of index ranges for tag addition
ch_ixrs := chop(index_range_stg);
return "" +/ [if odd(j) then normalize_text_index(rg) else "{" + rg?"end" + "}" end if + " ": rg = ch_ixrs(j)];
end handle_index_range;
procedure chop(stg); -- chop at semis or commas if is string
return if not is_string(stg) then stg else breakup(stg,if ";" in stg then ";" else "," end if) end if;
end chop;
-- procedure tag_delete(tag_list); -- delete information for list of tags [txt("tags") := list;]
-- txt := full_name() + " tag delete " + handle_tag_list(tag_list);
-- return tk_kall(txt);
-- end tag_delete;
procedure handle_tag_list(tag_list); -- handle list of index tags for tag addition
tags := chop(tag_list);
return "" +/ ["{" + tag + "} ": tag in tags];
end handle_tag_list;
procedure tag_names(n); -- return ordered list of tags at specified char position. OM gives all
txt := full_name() + " tag names " + normalize_text_index(n);
return breakup(tk_kall(txt)," ");
end tag_names;
procedure normalize_text_index(n); -- adjust a text index to 1-basing
if n = OM then return ""; end if;
if is_integer(n) then return "1." + str(n - 1); end if;
first_digit := span(n,"0123456789"); dot := match(n,"."); second_digit := span(n,"0123456789");
if not (#first_digit > 0 and #dot > 0 and #second_digit > 0) then return "{" + n + "}"; end if;
return "{" + first_digit + dot + str(unstr(second_digit) - 1) + n + "}";
end normalize_text_index;
procedure adjust_text_ix(ix); -- adjust the character number to 1-basing
if ix = OM or ix ="" then return ix; end if;
[first_digits,second_digits] := breakup(ix,".");
return first_digits + "." + str(unstr(second_digits) + 1);
end adjust_text_ix;
-- procedure tag_lower(tag,below); -- lower tag to specified position in priority list of tags, or to start
-- txt := full_name() + " tag lower \"" + str(tag) + "\"" +
-- if below = OM then "" else " \"" + below + "\"" end if;
-- return tk_kall(txt);
-- end tag_lower;
-- procedure tag_raise(tag,above); -- raise tag to specified position in priority list of tags, or to end
-- txt := full_name() + " tag raise \"" + str(tag) + "\"" +
-- if below = OM then "" else " \"" + above + "\"" end if;
-- return tk_kall(txt);
-- end tag_raise;
procedure tag_nextrange(tag,n,m); -- search for first subrange of specified range that carries specified tag
txt := full_name() + " tag nextrange \"" + str(tag) + "\" "+ str(n) + " " +
if m = OM then "" else " " + str(m) end if;
[ix1,ix2] := breakup(tk_kall(txt)," ");
return [adjust_text_ix(ix1),adjust_text_ix(ix2)];
end tag_nextrange;
procedure tag_prevrange(tag,n,m); -- search for last subrange of specified range that carries specified tag
txt := full_name() + " tag prevrange \"" + str(tag) + "\" "+ str(m) + " " +
if n = OM then "" else " " + str(n) end if;
[ix1,ix2] := breakup(tk_kall(txt)," ");
return [adjust_text_ix(ix1),adjust_text_ix(ix2)];
end tag_prevrange;
procedure tag_ranges(tag); -- get list of all ranges for specified tag
if tag_prevrange(tag,"1.0","end") = [] then return []; end if; -- tag does not occur
ranges := []; first_now := "1.0"; -- will collect
while (nrange := tag_nextrange(tag,first_now,"end")) /= [] loop
[nr1,nr2] := nrange; ranges with:= nr1;
cpos := rbreak(nr2,"."); ranges with:= (nr2 + str(unstr(cpos) - 1));
first_now := nrange(2);
end loop;
return ranges;
end tag_ranges;
procedure insert_widget(n,wind); -- insert an widget window at a specified text position
txt := full_name() + " window create " + n + " -window " + wind.full_name();
--print("insert_widget: ",txt);
return tk_kall(txt);
end insert_widget;
procedure handle_options_and_values(options_values); -- convert comma-delimited widget options into tk form
-- options are align (), window (), stretch (), padx (), pady (), command ()
return "" +/ [if odd(j) then "-" else "{" end if +
if is_string(ov) then ov else ov.full_name() end if -- if the value is a widget, use its name
+ if odd(j) then " " else "} " end if: ov = options_values(j)];
end handle_options_and_values;
-- ****** Button Operations ******
procedure flash(); -- cause the button to flash
txt := full_name() + " flash"; return tk_kall(txt);
end flash;
procedure invoke_button(); -- trigger the button's action
txt := full_name() + " invoke";
return tk_kall(txt);
end invoke_button;
procedure select_button(); -- select radio button or checkbutton
txt := full_name() + " select"; return tk_kall(txt);
end select_button;
-- ****** Menu Operations ******
procedure clone(); -- make linked copy of the menu (for tearoffs, etc.)
txt := full_name() + " clone"; return tk_kall(txt);
end clone;
procedure invoke(n); -- trigger the entry's action; note that invoke(0) does a tearoff
txt := full_name() + " invoke " + str(n);
return tk_kall(txt);
end invoke;
procedure post(i,j); -- display menu at specified coordinates
txt := full_name() + " post " + str(i) + " " + str(j);
return tk_kall(txt);
end post;
procedure postcascade(n); -- display menu in hierarchical position for entry n
txt := full_name() + " postcascade \"" + str(n) + "\""; return tk_kall(txt);
end postcascade;
procedure popup(i,j); -- display menu at specified coordinates
txt := "tk_popup " + full_name() + " " + str(i) + " " + str(j); return tk_kall(txt);
end popup;
procedure entry_type(n); -- get the type of menu entry n
txt := full_name() + " type \"" + str(n) + "\""; return tk_kall(txt);
end entry_type;
procedure unpost(); -- hide the menu
txt := full_name() + " unpost"; return tk_kall(txt);
end unpost;
procedure yposition(n); -- return vertical position of top of entry n
txt := full_name() + " yposition \"" + str(n) + "\""; return tk_kall(txt);
end yposition;
-- ****** Scale Operations ******
procedure coords(n); -- transform scale value into geometric position
txt := full_name() + " coords \"" + str(n) + "\"";
return [unstr(x): x in breakup(tk_kall(txt)," ")]; -- return a tuple
end coords;
procedure get(ij); -- get scale value, or value corresponding to given position
is_horizontal := tk_kall(full_name() + " cget -orient") = "horizontal";
txt := full_name() + " get " + join(breakup(ij,",;")," ");
return unstr(tk_kall(txt));
end get;
procedure identify(ij); -- return 'trough', 'slider', or 'trough2': feature under indicated point
txt := full_name() + " identify " +join(breakup(ij,",;")," ");
return tk_kall(txt);
end identify;
-- ****** Scrollbar Operations ******
procedure activate(x); -- query/set active element, which can be arrow1, arrow2, or slider
txt := full_name() + " activate " + x; return tk_kall(txt);
end activate;
procedure delta(dxy); -- convert desired horizontal or vertical value change to slider units
is_vertical := tk_kall(full_name() + " cget -orient") = "vertical";
piece := if is_vertical then "0 " + str(dxy) else str(dxy) + " 0" end if;
txt := full_name() + " delta " + piece;
return tk_kall(txt);
end delta;
procedure fraction(x); -- convert point position into fraction relative to scrollbar extent
is_vertical := tk_kall(full_name() + " cget -orient") = "vertical";
--print("is_vertical",is_vertical);
piece := if is_vertical then "0 " + str(x) else str(x) + " 0" end if;
txt := full_name() + " fraction " + piece;
return tk_kall(txt);
end fraction;
-- ****** Entry Operations ******
procedure bbox(n); -- return bounding box of specified character in text or entry, or line in listbox
txt := full_name() + " bbox " + if tk_type = "entry" then str(n + 1) else str(n) end if;
--print("bbox(n): ",txt," ",tk_kall(txt)); -- some problem for listboxes
[l,t,w,h] := [unstr(x): x in breakup(tk_kall(txt)," ")];
return [l,t,w + l,h + t];
end bbox;
procedure select(m,n); -- select characters m to n, or clear the selection (this also works for listboxes)
if m = OM and n = OM then
txt := full_name() + " select clear"; return tk_kall(txt);
end if;
if tk_type = "listbox" then --listbox range selection
n := if is_integer(n) then (n - 1) else "\"" + n + "\"" end if;
txt := full_name() + " select set \"" + (m - 1) + "\" " + n;
else -- character range selection
n := if n = OM then "" else "\"" + n + "\"" end if;
txt := full_name() + " select range \"" + m + "\" " + n;
end if;
return tk_kall(txt);
end select;
procedure select_anchor(m); -- set the anchor point for the selection
txt := full_name() + " select from \""+ str(m) + "\""; return tk_kall(txt);
end select_anchor;
-- ****** Rastport Operations ******
procedure put_img(gr_img,x,y); -- stuff gr_img into tkrport at position x, y
tk_gr_put(interp,full_name(),gr_img.native_im(),x,y);
end put_img;
procedure put_add(gr_img,x,y); -- stuff gr_img into tkrport using 'sum'
tk_gr_put_add(interp,full_name(),gr_img.native_im(),x,y);
end put_add;
procedure put_dif(gr_img,x,y); -- stuff gr_img into tkrport using 'dif'
tk_gr_put_dif(interp,full_name(),gr_img.native_im(),x,y);
end put_dif;
procedure put_mul(gr_img,x,y); -- stuff gr_img into tkrport using 'mul'
tk_gr_put_mul(interp,full_name(),gr_img.native_im(),x,y);
end put_mul;
procedure put_div(gr_img,x,y); -- stuff gr_img into tkrport using 'div'
tk_gr_put_div(interp,full_name(),gr_img.native_im(),x,y);
end put_div;
procedure put_min(gr_img,x,y); -- stuff gr_img into tkrport using 'min'
tk_gr_put_min(interp,full_name(),gr_img.native_im(),x,y);
end put_min;
procedure put_max(gr_img,x,y); -- stuff gr_img into tkrport using 'max'
tk_gr_put_max(interp,full_name(),gr_img.native_im(),x,y);
end put_max;
procedure put_pow(gr_img,x,y); -- stuff gr_img into tkrport using 'pow'
tk_gr_put_pow(interp,full_name(),gr_img.native_im(),x,y);
end put_pow;
procedure put_blend(gr_img,x,y,c1,c2);
-- blend the image gr_img with the tk widget at position x, y using coefficients c1 and c2
tk_gr_put_blend(interp,full_name(),gr_img.native_im(),x,y,c1,c2);
end put_blend;
procedure put_imgr(gr_img,x,y); -- stuff gr_img into tkrport at position x, y
tk_gr_put_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_imgr;
procedure put_addr(gr_img,x,y); -- stuff gr_img into tkrport using 'sum'
tk_gr_put_add_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_addr;
procedure put_difr(gr_img,x,y); -- stuff gr_img into tkrport using 'dif'
tk_gr_put_dif_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_difr;
procedure put_mulr(gr_img,x,y); -- stuff gr_img into tkrport using 'mul'
tk_gr_put_mul_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_mulr;
procedure put_divr(gr_img,x,y); -- stuff gr_img into tkrport using 'div'
tk_gr_put_div_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_divr;
procedure put_minr(gr_img,x,y); -- stuff gr_img into tkrport using 'min'
tk_gr_put_min_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_minr;
procedure put_maxr(gr_img,x,y); -- stuff gr_img into tkrport using 'max'
tk_gr_put_max_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_maxr;
procedure put_powr(gr_img,x,y); -- stuff gr_img into tkrport using 'pow'
tk_gr_put_pow_and_rotate(interp,full_name(),gr_img.native_im(),x,y);
end put_powr;
procedure put_blendr(gr_img,x,y,c1,c2);
-- blend the image gr_img with the tk widget at position x, y using coefficients c1 and c2
tk_gr_put_blend_and_rotate(interp,full_name(),gr_img.native_im(),x,y,c1,c2);
end put_blendr;
procedure get_img(gr_img,x,y); -- stuff gr_img into tkrport at position x, y
x := tk_gr_get(interp,full_name(),gr_img.native_im(),x,y);
end get_img;
procedure get_add(gr_img,x,y); -- stuff gr_img into tkrport using 'sum'
tk_gr_get_add(interp,full_name(),gr_img.native_im(),x,y);
end get_add;
procedure get_dif(gr_img,x,y); -- stuff gr_img into tkrport using 'dif'
tk_gr_get_dif(interp,full_name(),gr_img.native_im(),x,y);
end get_dif;
procedure get_mul(gr_img,x,y); -- stuff gr_img into tkrport using 'mul'
tk_gr_get_mul(interp,full_name(),gr_img.native_im(),x,y);
end get_mul;
procedure get_div(gr_img,x,y); -- stuff gr_img into tkrport using 'div'
tk_gr_get_div(interp,full_name(),gr_img.native_im(),x,y);
end get_div;
procedure get_min(gr_img,x,y); -- stuff gr_img into tkrport using 'min'
tk_gr_get_min(interp,full_name(),gr_img.native_im(),x,y);
end get_min;
procedure get_max(gr_img,x,y); -- stuff gr_img into tkrport using 'max'
tk_gr_get_max(interp,full_name(),gr_img.native_im(),x,y);
end get_max;
procedure get_blend(gr_img,x,y,c1,c2);
-- blend the image gr_img with the tk widget at position x, y using coefficients c1 and c2
tk_gr_get_blend(interp,full_name(),gr_img.native_im(),x,y,c1,c2);
end get_blend;
-- ****** Other Operations using standard SETL syntax******
procedure #self; -- various size-related operations
case tk_type -- this operation is implemented differently for different types of widgets
when "listbox","entry","menu" => txt := full_name() + " index end";
return unstr(tk_kall(txt)) + 1;
when "text" => las := tk_kall(full_name() + " index end");
rbreak(las,"."); rmatch(las,".");
return if las = "2" and
#tk_kall(full_name() + " get 1.0 {1.0 lineend}") = 0 then 0
else unstr(las) - 1 end if;
when "canvas_text" => las := tk_kall(txt := parent.full_name() + " index " + name(2..) + " end");
--print("canvas_text: ",txt);
return unstr(las) + 1;
end case;
end;
procedure self(i..j); -- various extraction operations
-- this operation is used to extract contiguous ranges in various situations.
-- text widgets: retrieves a range of characters; absolute images: retrieves a rectangle
-- listboxes: retrieves a range of lines
case tk_type -- this operation is implemented differently for different types of widgets
when "listbox" => -- return the range of list entries, as a blank-delimited string
-- offset indices to be 1-based, as in SETL
txt := full_name() + " get " + str(i - 1) + " " + str(j - 1);
return stgs_from_Tk(tk_kall(txt)); -- break into list and return
when "text" => -- return span of characters from text
txt := full_name() + " get " + normalize_text_index(i) + " " + str(j);
when "canvas_text" => -- return span of characters from canvas_text item
txt := parent.full_name() + " itemcget " + name(2..) + " -text";
stg := tk_kall(txt);
return stg(i..j);
when "entry" => -- return span of characters from entry
if is_string(i) then i := unstr(i); end if;
if is_string(j) then j := unstr(j); end if;
cont := tk_kall(full_name() + " get");
return if j = OM then cont(i..) else cont(i..j) end if;
when "menu" => -- return the range of menu labels, as a tuple
return [tk_kall(full_name() + " entrycget " + str(k) + " -label"): k in [i..j]];
when "image" => -- return an image subrectangle
if parent /= OM then -- not an absolute image
abort("Subimage extraction is only available for absolute images.");
end if;
i := chop(i); j := chop(j);
if not is_tuple(i) or #i /= 2 then
abort("Illegal first argument " + str(i));
end if;
if not is_tuple(j) or #j /= 2 then
abort("Illegal second argument " + str(j));
end if;
[i1,i2] := i; [j1,j2] := j; i1 := str(i1); i2 := str(i2); j1 := str(j1); j2 := str(j2);
new_im := tkw(); -- create a new image
new_im.name := imnm := "`" + str(name_ctr +:= 1); -- assign name (with no originating file)
new_im.tk_type := "image"; -- tk_type is "image"
-- now copy the designated subrectangle into the image
txt := "image create photo " + imnm; tk_kall(txt); -- create the Tk image
txt := imnm + " copy " + name + " -from " + i1 + " " + i2 + " " + j1 + " " + j2;
-- copy the designated subrectangle
tk_kall(txt);
return new_im;
end case;
return tk_kall(txt);
end;
procedure self(i..j) := y; -- various insertion and deletion operations
-- this operation is used to insert contiguous ranges of items in various situations:
-- text widgets: inserts a range of characters
-- listboxes: insets a range of lines
if is_string(y) and tk_type /= "text" and tk_type /= "canvas_text" and tk_type /= "entry" then
-- convert to tuple
y := chop(y);
end if;
case tk_type -- this operation is implemented differently for different types of widgets
when "listbox" => -- offset indices to be 1-based, as in SETL
listbox_len := tk_kall(full_name() + " index end");
-- get the length of the listbox
j min:= unstr(listbox_len); -- constrain the end of the deletion range
if j >= i then -- first delete the items in the range
txt := full_name() + " delete " + str(i - 1) + " " + str(j - 1);
tk_kall(txt); -- execute the deletion operation
end if;
-- now insert the string of labels after position i
txt := full_name() + " insert " + str(i - 1) +
" " +/ ["\"" + str(item) + "\" ": item in y];
when "text" => -- write span of characters to text
j ?:= "end"; -- first delete the specified characters
txt := full_name() + " delete " + (ip := normalize_text_index(i)) + " " + str(j);
tk_kall(txt); -- execute the deletion operation
-- now insert the string y into their place.
txt := full_name() + " insert " + ip + " \"" + stg_to_Tk(str(y)) + "\"";
when "canvas_text" => -- write span of characters to canvas_text item
istg := str(i - 1); jstg := str(j - 1);
if j >= i then -- first delete the characters to be over_written
txt := parent.full_name() + " dchars " + name(2..) + " " + istg + " " + jstg;
tk_kall(txt); -- execute the deletion operation
end if;
-- now insert the string y into their place.
txt := parent.full_name() + " insert " + name(2..) + " " + istg + " \"" + stg_to_Tk(str(y)) + "\"";
when "entry" => -- return span of characters from entry
j ?:= "end"; -- first delete the specified characters
txt := full_name() + " delete " + (ip := str(if is_string(i) then unstr(i) else i end if - 1)) + " " + str(j);
tk_kall(txt); -- execute the deletion operation
-- now insert the string y into their place.
txt := full_name() + " insert " + ip + " \"" + stg_to_Tk(str(y)) + "\"";
when "menu" => -- insert a range of menu labels
menu_len := tk_kall(full_name() + " index end");
-- get the length of the menu
j min:= unstr(menu_len); -- constrain the end of the deletion range
menu_name := full_name();
if j >= i then -- first delete the items in the range
txt := menu_name + " delete " + str(i) + " " + str(j);
tk_kall(txt); -- execute the deletion operation
end if;
insert_menu_items(i,menu_name,y);
return OM; -- done with this case
when "image" => -- insert an image subrectangle
if parent /= OM then -- not an absolute image
abort("Subimage insertion is only available for absolute images.");
end if;
i := chop(i); j := chop(j);
if not is_tuple(i) or #i /= 2 then
abort("Illegal first argument " + str(i));
end if;
if not is_tuple(j) or #j /= 2 then
abort("Illegal second argument " + str(j));
end if;
[i1,i2] := i; [j1,j2] := j; i1 := str(i1); i2 := str(i2); j1 := str(j1); j2 := str(j2);
--print("insert an image subrectangle y: ",y);
if type(y) /= "TKW" or y.tk_type /= "image" or y.parent /= OM then
abort("Right-hand argument must be an absolute image"); -- the y argument
end if;
-- now copy the image into the designated subrectangle
txt := name + " copy " + y.name + " -to " + i1 + " " + i2 + " " + j1 + " " + j2;
end case;
tk_kall(txt);
end;
procedure insert_menu_items(pt,menu_name,desc_lis);
-- construct and insert the items of a menu from a descriptor
pt -:= 1; spt := str(pt);
items := breakup(desc_lis,":");
for j in [#items,#items - 1..1] loop
[kind,lab] := items(j);
if lab = OM then -- should be separator or tearoff
if kind = "t" then -- tearoff
tk_kall(menu_name + " insert " + spt + " tearoff");
else -- take as separator
tk_kall(menu_name + " insert " + spt + " separator");
end if;
else
case kind
when "c" => -- checkbutton item
tk_kall(menu_name + " insert " + spt + " check -label " + lab);
when "r" => -- radiobutton item
tk_kall(menu_name + " insert " + spt + " radio -label " +
lab + " -variable " + lab);
when "s" => -- submenu item
tk_kall(menu_name + " insert " + spt + " cascade -label " + lab);
otherwise => -- take as button item
tk_kall(menu_name + " insert " + spt + " command -label " + lab);
end case;
end if;
end loop;
end insert_menu_items;
procedure self{event_des}; -- query binding to an event descriptor, for a widget, tag, or item
item_name := OM;
if is_tuple(event_des) then -- we are retrieving a binding for a tag or menu item
--print("is_tuple event_des: ",event_des," ",tk_type);
[item_name,event_des] := event_des; -- extract the item and the real event_des
if item_name = "event" then
return breakup(suppress_chars(tk_kall("event info " + if event_des = OM then "" else "<<" + event_des + ">>" end if),"")," ");
-- return info on specific, or on all, virtual events
elseif item_name = "bindings" then -- if this is not a canvas or text object, then return event binding list for binding tag
-- otherwise return the event binding list for a canvas or text tag
if tk_type = "text" then -- return the event binding list for a text tag
res := breakup(tk_kall(full_name() + " tag bind " + event_des)," "); -- here event_des is actually the tag
new_bindings := [];
for x in res loop match(x,"<"); rmatch(x,">"); new_bindings with:= x; end loop; -- drop one set of angle brackets
return new_bindings;
elseif tk_type = "canvas" then
-- return the event binding list for a tag on some canvas item or for a text tag
res := breakup(tk_kall(full_name() + " bind " + event_des)," "); -- here event_des is actually the tag
new_bindings := [];
for x in res loop match(x,"<"); rmatch(x,">"); new_bindings with:= x; end loop; -- drop one set of angle brackets
return new_bindings;
else
res := breakup(tk_kall("bind " + event_des)," "); -- here event_des is actually the tag
--print("event binding list: ","bind " + event_des," ",res);
new_bindings := [];
for x in res loop match(x,"<"); rmatch(x,">"); new_bindings with:= x; end loop; -- drop one set of angle brackets
return new_bindings;
end if;
elseif tk_type = "canvas" then
return tk_kall(full_name() + " bind " + item_name + " <" + event_des + ">");
elseif tk_type = "text" then
--print("text binding tag and event: ",full_name() + " bind " + item_name + " <" + event_des + ">");
return tk_kall(full_name() + " tag bind " + item_name + " <" + event_des + ">");
else -- return the Tk binding information for a specific binding tag and event.
-- This covers cases like Tk("Text","")
return tk_kall("bind " + item_name + " <" + event_des + ">");
end if;
--->event
elseif event_des = OM then -- retrieve the handler for the 'principal' event associated with the widget or item
if (event_des := main_command(tk_type)) = OM then -- use the 'cget' option
return tk_kall(full_name() + " cget -command");
end if;
elseif event_des = "bindtags" then -- retrieve the list of binding tags for the widget
return breakup(tk_kall("bindtags " + full_name())," "); -- convert to SETL list
end if; -- else we are retrieving a binding for a widget, canvas item, or text item (using its id)
if ":" in event_des then
rbreak(event_des,":"); rmatch(event_des,":"); -- remove the parameter descriptor
end if;
event_des := chop(event_des);
event_stg := "" +/["<" + item + ">": item in event_des]; -- convert event_stg to Tk format
if item_name = OM then -- we are querying a binding for a widget,
-- or for a canvas item or text item (using its id)
if name = "" then return OM; end if; -- 'name' is the object name property
if name(1) = "w" then -- querying binding for a widget
txt := "bind " + full_name() + " " + event_stg;
-- construct a Tk 'bind' instruction, which lists event fields to be passed back
else -- querying binding for a canvas item, or text item (using its id)
txt := parent.full_name() + " " + "bind " + name(2..) + " " + event_stg;
end if;
else -- we are querying a binding for a text tag, canvas tag, tag or menu item
txt := "???";
end if;
return tk_kall(txt); -- return the binding info
end;
procedure self{event_des} := y; -- set binding to an event descriptor, for a widget, tag, or menu item
if tk_type = "socket" then return bind_socket_io_handler(event_des,y); end if; -- here event_des is ">" or "<"
y_orig := y; -- save the original y
y := chop(y); -- break into tuple if punctuated string
if y = [] then y := ""; end if; -- restore nullstring case to original form
--print("y is: ",y,"..",y_orig,"..");
if is_tuple(event_des) and event_des(1) = "event" then -- we are setting up the list of physical events that correspond to a virtual event
-- this covers cases like Tk("event","virt_event_name") := "phys_event_1,phys_event_2,..."
virt_event_name := "<<" + event_des(2) + ">>"; -- get the virtual event name
delres := tk_kall("event delete " + virt_event_name); -- clear the present meaning
if (y?"") = "" then return delres; end if; -- null assignment is simple deletion
return tk_kall("event add " + virt_event_name + " " +/["<" + phys + "> ": phys in y]); -- set up the new meaning
end if;
if not (is_tuple(y) or is_procedure(y) or y = "") then
abort("Only procedures or the null-string can be bound to events, not " + str(y));
end if;
if (isp := is_procedure(y)) or y = "" then y := tk_string_of(y); end if; -- convert the procedure to its string name; likewise nullstring
-- (this is a tuple if we are sending an event)
if event_des = "bindtags" then -- we are setting a widget's 'bindtags' list
return tk_kall("bindtags " + full_name() + " [list " + join(y," ") + "]");
elseif not isp then -- we are sending an event under program control, or setting the binding of a binding tag
-- this covers cases like Tk("event_des:xy") := "event_par_val_1,event_par_val_2,..."
-- it also covers cases like Tk("Text","") := Tk_code_string
-- if there is just one parameter value, it must be like Tk("event_des:x") := [event_par_val_1]
if is_tuple(event_des) then -- here we handle cases like Tk("Text","") := Tk_code_string
[binding_tag,event_des] := event_des; -- break out the binding tag
txt := "bind " + str(binding_tag) + " <" + event_des + "> {" + y_orig + "}"; -- convert to form like 'bind Text <> {Tk_code_string}'
return tk_kall(txt); -- done with this case
end if;
event := break(event_des,":"); match(event_des,":"); -- break out the event descriptor
ev_att_stg := "" +/ ["-" + eo + " " + str(eov) + " ": c = event_des(j) |
(eo := event_opts_from_chars(c)) /= OM and (eov := y(j)) /= OM];
txt := "event generate " + full_name() + " <" + event + "> " + ev_att_stg;
return tk_kall(txt);
end if;
-- in the remaining cases, y was originally a procedure; but it has now been converted to its Tk procedure name
if event_des = OM then -- bind the 'principal' event
-- the various kinds of buttons (other than menu buttons) have built-in principal
-- commands; for the others we use the principal commands designated above (main_command)
-- note that for scales and scrollbars, the built-in principal command is invoked
-- when the scale-value changes
-- we assign a value to the widget or item by binding its specified
-- main_command event to it. The tk binding syntax varies a bit, depending
-- on whether this object is a widget or a canvas object.
if (mc := main_command(tk_type)) = OM then -- use 'config'
the_text := full_name() + " configure -command " + "{" + y + "}";
elseif tk_type in widgets then -- we deal with a widget
if mc /= "" then
the_text := " bind " + full_name() + " " + mc + " {" + y + "}";
else
the_text := " bind " + full_name() + " " + mc + " {" + y + " %x %y}";
end if;
else -- we deal with a canvas object
the_text := parent.full_name() + " bind " + name(2..) + " " + mc + " {" + y + "}";
end if;
return tk_kall(the_text);
end if;
item_name := OM;
if is_tuple(event_des) then -- we are setting up a binding for a tag or menu item,
-- or defining and sending an event under program control
[item_name,event_des] := event_des; -- extract the item and the real event_des
if event_des = OM then -- this is of the form tag_name, OM, so we are setting the
-- main command of a canvas or text tag
if type(y_orig) /= "PROCEDURE" then
abort("A tag's principal command can only be bound to a procedure but is: " + str(y_orig));
end if;
if tk_type = "menu" then -- must use configuration option
item_name := if is_integer(item_name) then item_name - 1 else unstr(item_name) end if;
txt := full_name() + " entryconfigure " + str(item_name) + " -command " + y;
--print("bound: ",txt);
else -- not a menu
btb := if tk_type = "canvas" then " bind "
else " tag bind " end if; -- Bah!
txt := full_name() + btb + str(item_name) + " " + y;
end if;
return tk_kall(txt);
end if;
end if; -- else we are setting up a binding for a widget, canvas item, or text item (using its id),
if ":" in event_des then
param_stg := rbreak(event_des,":"); rmatch(event_des,":"); -- break out the parameter descriptor
else
param_stg := ""; -- otherwise no parameters
end if;
param_stg := "" +/["%" + c + " ": c in param_stg]; -- convert param_stg to Tk format
event_des := chop(event_des);
event_stg := "" +/["<" + item + ">": item in event_des]; -- convert event_stg to Tk format
if item_name = OM then -- we are setting up a binding for a widget, canvas item, or text item (using its id)
if name = "" then return; end if; -- this should not happen
if name(1) = "w" or name = "." then -- binding for a widget
txt := "bind " + self.full_name() + " " + event_stg + " {" + y + " " + param_stg + "}";
-- construct a Tk 'bind' instruction, which lists event fields to be passed back
else -- binding for a widget, canvas item, or text item (using its id)
txt := parent.full_name() + " " + "bind " + name(2..) + " " + event_stg
+ " {" + y + " " + param_stg + "}";
end if;
--print("bindinginst: ",event_des," ",y," ",txt);
elseif tk_type = "text" or tk_type = "canvas" then
-- we are setting up a binding for a text or canvas tag
txt := full_name() + if tk_type = "text" then " tag bind " else " bind " end if + item_name + " " + event_stg
+ " {" + y + if param_stg = "" then "" else " " end if + param_stg + "}";
--print("Binding text or canvas tag: ",item_name," ",event_des," ",txt);
else
txt := "???"; -- we are setting up a binding for a tag or menu item
end if;
res := tk_kall(txt); -- do the binding
--print("Bound: ",txt," ",res);
end;
procedure bind_socket_io_handler(x,io_event_proc); -- binds I/O-ready callback handler to socket
-- x is ">" for 'socket_readability_handler' and "<" for 'socket_writability_handler'
--print("bind_socket_io_handler: ",x," ",y);
if not is_string(x) or #x > 1 or x notin "" then print("****** bad socket direction indicator: ",x); stop; end if; -- validate x
if not is_procedure(io_event_proc) then -- bad I/O handler
print("****** bad io_event_proc for socket ",if x = ">" then "reading:" else "writing: " end if,text_blocksize_or_accept_proc); stop;
end if;
proc_name := "s" + str(namegen_ctr := (namegen_ctr?0) + 1); -- generate a new tk variable name
tk_createcommand(interp,proc_name,io_event_proc); -- register the setl procedure under this name
if x = ">" then -- set up the procedure as a 'ready to read' handler
tk_kall("fileevent " + name + " readable [list " + proc_name + " " + name + "]"); -- pass 'set handler' command to tk
else -- set up the procedure as a 'ready to write' handler
tk_kall("fileevent " + name + " writeable [list " + proc_name + " " + name + "]"); -- pass 'set handler' command to tk
end if;
end bind_socket_io_handler;
procedure stg_to_Tk(stg); -- sanitize the quote marks, blanks, backslashes, and square brackets in a string
--print("stg_to_Tk: ",stg);
newstr := break(stg,"\"[]\\ \n\r\t"); -- get the first non-special piece
while stg /= "" loop
piece := any(stg,"\"[]\\ \n\r\t");
newstr +:= if piece = "\n" then "\\n" elseif piece = "\r" then "\\r"
elseif piece = "\t" then "\\t" else "\\" + piece end if;
-- sanitize or recode the special character
piece := break(stg,"\"[]\\ \n\r\t");
newstr +:= piece; -- get the next non-special piece
end loop;
--print("stg_to_Tk return: ",newstr);
return newstr;
end stg_to_Tk;
-- ****** Listbox Operations ******
procedure nearest(y); -- return index of line vertically nearest to y
txt := full_name() + " nearest " + str(y); return tk_kall(txt);
end nearest;
procedure is_select_line(m); -- determine if line m is selected
txt := full_name() + " selection includes \"" + (m - 1) + "\""; return tk_kall(txt);
end is_select_line;
procedure yview(n); -- move to make indicated line visible, or read vertical scroll position
txt := full_name() + " yview " + if n = OM or n = "" then "" else (n - 1) end if; return tk_kall(txt);
end yview;
-- ****** Clipboard Operations ******
procedure clear_selection(win,the_sel); -- clear specified selection in specified window
txt := "selection clear ";
if win /= OM then txt +:= (" -displayof " + win.full_name()); end if;
if the_sel /= OM then txt +:= (" -selection " + the_sel); end if;
return tk_kall(txt);
end clear_selection;
procedure get_selection(win,the_sel,the_type); -- return the specified selection
txt := "selection get ";
if win /= OM then txt +:= (" -displayof " + win.full_name()); end if;
if the_sel /= OM then txt +:= (" -selection " + the_sel); end if;
if the_type /= OM then txt +:= (" -type " + the_type); end if;
return tk_kall(txt);
end get_selection;
procedure handle_selection(win,the_type,format,the_sel,proc);
-- define proc to be handler for set/the_type selection requests when 'win' is selection owner
txt := "selection handle ";
if the_sel /= OM then txt +:= (" -selection " + the_sel); end if;
if the_type /= OM then txt +:= (" -type " + the_type); end if;
if format /= OM then txt +:= (" -format \"" + format + "\""); end if;
txt +:= " win"; -- ********* FIX ********* handle procedure
return tk_kall(txt);
end handle_selection;
procedure own_selection(win,the_sel,proc);
-- assert that win is sel owner; and that proc should be called when it loses ownership
txt := "selection own "; tk_kall(txt);
if win /= OM then txt +:= (" -displayof " + win.full_name()); end if;
if the_sel /= OM then txt +:= (" -selection " + the_sel); end if;
if proc /= OM then txt +:= " -command "; end if; -- ********* FIX ********* handle procedure
end own_selection;
procedure selection_owner(win,the_sel); -- find string name of current owner of selection 'sel'
txt := "selection own "; tk_kall(txt);
if win /= OM then txt +:= (" -displayof " + win.full_name()); end if;
if the_sel /= OM then txt +:= (" -selection " + the_sel); end if;
end selection_owner;
procedure clear_clipboard(win); -- clear clipboard for specified window
txt := "clipboard clear " + if win = OM then "" else "-displayof " + win.full_name() end if;
return tk_kall(txt);
end clear_clipboard;
procedure addto_clipboard(win,the_type,format,data);
-- add 'data', of specified format and type, to clipboard for specified window
txt := "clipboard append ";
if win /= OM then txt +:= (" -displayof " + win.full_name()); end if;
if format /= OM then txt +:= (" -format \"" + format + "\""); end if;
if the_type /= OM then txt +:= (" -type " + the_type); end if;
txt +:= (" \"" + stg_to_Tk(data) + "\"");
--print("addto_clipboard: ",txt);
return tk_kall(txt);
end addto_clipboard;
-- ****** Dialogs and Message boxes ******
-- Note: all these have been put in the syntax win("ask_...","options") := "option_vals";
-- ****** Image Operations ******
procedure dither(); -- dither the image
txt := name + " redither";
--print("redither:",txt);
return tk_kall(txt);
end dither;
procedure handle_im_options(options); -- handle image read, write, and copy operations
-- image operation options are from (rectangle), to (rectangle), subsample (x_fact,y_fact),
-- shrink (source to match bottom right corner of target), zoom (x_fact,y_fact)
if options = "" or options = OM then return ""; end if;
options := chop(options); -- divide the options into a tuple, at commas or semicolons
tk_option_stg := ""; -- will build
k := 1;
for item = options(j) loop -- iterate over list of options
if odd(k) then
tk_option_stg +:= " -" + (prior := item) + " ";
k +:= if item = "shrink" then 2 else 1 end if; -- no parameters in shrink case, so bypass
continue; -- done with this case
end if; -- otherwise we have an option
if prior = "format" then tk_option_stg +:= ("\"" + item + "\" "); k +:= 1; continue; end if;
pieces := breakup(item,","); -- otherwise break up the comma-delimited rectangles, etc.
tk_option_stg +:= ("" +/ [piece + " ": piece in pieces]);
k +:= 1;
end loop;
return "" +/ [c +" ": c in breakup(tk_option_stg," ") | c /= ""]; -- return the completed tk option string, eliminating double blanks
end handle_im_options;
procedure write_im(file,options); -- write image to file
txt := name + " write " + file + " " + handle_im_options(options);
--print("write_im: ",txt);
res := tk_kall(txt); print(res); return res;
end write_im;
procedure tup_to_tx_imdat(tup); -- convert tuple of image data to tx list
return "{" + join(tup," ") + "}";
end tup_to_tx_imdat;
procedure stuff_im(data,rect); -- insert data into image rectangle
txt := name + " put ";
if is_string(data) then data := breakup(breakup(data,";"),","); end if;
-- the 'data' argument is assumed to be a tuple of tuples of color values
data := "{" + join([tup_to_tx_imdat(item): item in data]," ") + "}";
txt +:= (data + " "); -- add the data to the developing string
if rect /= OM then -- add the optional 'to' clause
txt +:= (" -to " +/ [str(item) + " ": item in chop(rect)]);
end if;
return tk_kall(txt);
end stuff_im;
procedure copy_im(source,options); -- copy one image to another
txt := name + " copy " + source.name + " " + handle_im_options(options);
return tk_kall(txt);
end copy_im;
-- ****** Window Manager Operations ******
procedure win_close(); -- close or iconify a toplevel
return tk_kall("wm iconify " + full_name());
end win_close;
procedure win_open(); -- open or deiconify a toplevel
test_exists := tk_kall("winfo toplevel " + full_name()); isb := match(test_exists,"bad");
if isb /= "" then return OM; end if;
return tk_kall("wm deiconify " + full_name());
end win_open;
-- ****** Font Routines ******
procedure font_metrics(font); -- get the metrics of the designated font
-- as a map from "fixed","linespace",,"ascent","descent" to ints
tup := breakup(suppress_chars(tk_kall("font metrics " + font),"-")," ");
return {[tup(j),unstr(tup(j + 1))]: j in [1,3..7]};
end font_metrics;
procedure measure_fonted(stg,font); -- get the size of the string in the designated font
return tk_kall("font measure " + font + " \"" + stg + "\"");
end measure_fonted;
procedure font_families(); -- get the list of fonts available in Tk
return tk_kall("font families");
end font_families;
-- ****** disk Routines ******
procedure disks(); -- get the currently mounted disks
return tk_kall("file volume");
end disks;
-- ****** Socket Routines ******
procedure socket_close(); -- close a socket
return tk_kall("close " + name); -- pass this command to tk
end socket_close;
-- ********** Routines for persistency **************
procedure get_Tk_packed(); -- gets the Tk packing information as a map
Tk_packed := {}; -- initialize
all_containers := {x: x in domain(Tk_children) | (xk := tag_from_tagged_name(x)) = "toplevel" or xk = "frame"}
+ {x: range_tup in range(Tk_children), x in range_tup
| (xk := tag_from_tagged_name(x)) = "toplevel" or xk = "frame"};
for obj_name in all_containers loop
tkog_names_list := breakup(Tk_kall("pack slaves " + fn_from_tagged_name(obj_name))," ");
packed_list := [(att_map_from_att_stg(Tk_kall("pack info " + obj))
- Tk_grid_defaults) less ["in",parent_name(obj)]
with ["Tk_fn",tag_from_untagged_name(obj) + ":" + obj]: obj in tkog_names_list];
Tk_packed(obj_name) := packed_list;
--print("\nTk_packed: "); for [x1,x2] in Tk_packed | #x2 > 0 loop print("\n",x1); for y in x2 loop print(y); end loop; end loop;
end loop;
--print("\nTk_packed: "); for [x1,x2] in Tk_packed | #x2 > 0 loop print("\n",x1); for y in x2 loop print(y); end loop; end loop;
end get_Tk_packed;
procedure get_Tk_gridded(); -- gets the Tk gridding information as a map
Tk_gridded := {}; -- initialize
all_containers := {x: x in domain(Tk_children) | (xk := tag_from_tagged_name(x)) = "toplevel" or xk = "frame"}
+ {x: range_tup in range(Tk_children), x in range_tup
| (xk := tag_from_tagged_name(x)) = "toplevel" or xk = "frame"};
for obj_name in all_containers loop
tkog_names_list := breakup(Tk_kall("grid slaves " + fn_from_tagged_name(obj_name))," ");
gridded_list := [(att_map_from_att_stg(Tk_kall("grid info " + obj))
- Tk_grid_defaults) less ["in",parent_name(obj)]
with ["Tk_fn",tag_from_untagged_name(obj) + ":" + obj]: obj in tkog_names_list];
if gridded_list /= [] then Tk_gridded(fn_from_tagged_name(obj_name)) := gridded_list; end if;
--print("gridded_list: ",obj_name," ",gridded_list," ",tkog_names_list);
end loop;
--print("\nTk_gridded: "); for [x1,x2] in Tk_gridded | #x2 > 0 loop print("\n",x1); for y in x2 loop print(y); end loop; end loop;
end get_Tk_gridded;
procedure get_Tk_children(); -- gets the full hierarchy of Tk children as a map
Tk_children := {}; -- initialize
get_Tk_children_in("toplevel:."); -- call recursive workhorse
--print("\nTk_children",Tk_children);
end get_Tk_children;
procedure get_Tk_children_in(obj); -- gets hierarchy of Tk children; workhorse
if (otkk := tag_from_tagged_name(obj)) notin {"toplevel","frame","menubutton","menu"} then return; end if;
Tk_children(obj) := children := [tag_from_untagged_name(child) + ":" + child:
child in breakup(Tk_kall("winfo children " + fn_from_tagged_name(obj))," ")];
for child in children loop get_Tk_children_in(child); end loop;
end get_Tk_children_in;
-- ******* Auxiliary reconfiguration routines for text; handle text dump string analysis *******
procedure setup_from_dump(target_texwidg_name,dump_stg); -- reconstruct a text area grom its dump string
[text_tuple,tags_tuple,marks_tuple,widgets_tuple,images_tuple]
:= sep_tags_and_marks(stgs_from_Tk(dump_stg));
--print("text_tuple: ",text_tuple);
the_text := "" +/text_tuple; -- calculate the new text; delete the old and insert the new
Tk_kall(target_texwidg_name + " delete 1.0 end"); Tk_kall(target_texwidg_name + " insert 1.0 " + stg_to_Tk(the_text));
for [win_name,cloc] in widgets_tuple loop
res := Tk_kall(txt := target_texwidg_name + " window create " + cloc + " -window " + fn_from_tagged_name(str(new_item_from_orig_name(win_name))));
--print("widgets_tuple: ",txt," ",win_name," ",new_item_from_orig_name(win_name));
end loop;
for [img_name,cloc] in images_tuple loop
Tk_kall(target_texwidg_name + " image create " + cloc + " -image " + img_name);
end loop;
tags_to_ranges := {};
for [mark,ix] in marks_tuple | mark /= "insert" and mark /= "current" loop
Tk_kall(target_texwidg_name + " mark set {" + mark + "} " + ix);
end loop;
for [tag,loc] in tags_tuple loop
tags_to_ranges(tag) := (tags_to_ranges(tag)?[]) with loc;
end loop;
for [tag,loc_list] in tags_to_ranges | tag /= "sel" loop
Tk_kall(target_texwidg_name + " tag add {" + tag + "} " + join(loc_list," "));
end loop;
end setup_from_dump;
procedure sep_tags_and_marks(stg_tup); -- separate a string's dump tuple into its text, plus tags_and_marks
text_tuple := [];
tags_tuple := [];
marks_tuple := [];
widgets_tuple := [];
images_tuple := [];
j := 0;
while j < #stg_tup loop
piece := stg_tup(j +:= 1);
case piece
when "text" => text_tuple with:= stg_tup(j +:= 1); j +:= 1;
when "tagon" => tags_tuple with:= [stg_tup(j +:= 1),stg_tup(j +:= 1)];
when "tagoff" => tags_tuple with:= [stg_tup(j +:= 1),stg_tup(j +:= 1)];
when "mark" => marks_tuple with:= [stg_tup(j +:= 1),stg_tup(j +:= 1)];
when "window" => widgets_tuple with:= [stg_tup(j +:= 1),stg_tup(j +:= 1)];
when "image" => images_tuple with:= [stg_tup(j +:= 1),stg_tup(j +:= 1)];
end case;
end loop;
return [text_tuple,tags_tuple,marks_tuple,widgets_tuple,images_tuple];
end sep_tags_and_marks;
-- ************************ Minor persisency utiliies ************************
procedure tag_from_tagged_name(tagged_name); tag := break(tagged_name,":"); return tag; end tag_from_tagged_name;
procedure tag_from_untagged_name(untagged_name); tag := case_change(Tk_kall("winfo class " + untagged_name),"ul"); return tag; end tag_from_untagged_name;
procedure fn_from_tagged_name(tagged_name); name := rbreak(tagged_name,":"); return name; end fn_from_tagged_name;
procedure att_map_from_att_stg(att_stg); -- convert raw Tk attribute information to SETL map form
val_list := breakup(att_stg," ");
return {[val_list(j)(2..),vljp1]: j in [1,3..#val_list - 1] | (vljp1 := val_list(j + 1)) /= "{}"};
end att_map_from_att_stg;
procedure parent_name(name); -- gets name of parent from name of child
rbreak(name,".");
if #name > 1 then rmatch(name,"."); end if;
return name;
end parent_name;
end tkw; -- ************************ END OF PACKAGE ************************
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-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-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 parameters,
-- which will be widgets. 'drop_response' will be called whenever the drag of an object
-- '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 prgram 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 horizontallly draggable
procedure make_vert_draggable(the_obj,dg_start,dg,dg_end); -- make a widget or widgets verticallly 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;
prior_domain := domain(prior_ops := ops_in_drag_mode(current_drag_mode)?{}); -- get the object-associated operations in the
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
--print("switch_drag_mode: ",new_mode,new_domain,new_ops);
for obj in new_domain loop -- change to the 'new mode' operations for all objects that have one
[dg_start,dg,dg_end] := new_ops(obj); -- get the start, drag, and end codes
obj{"ButtonPress-1:xy"} := if dg_start = OM then attach_start_noproc([obj]) else attach_start([obj],dg_start) end if;
-- only one object is put in the drag list
obj{"B1-Motion:xy"} := if dg = OM then attach_drag_noproc([obj],0) else attach_drag([obj],dg,0) end if;
-- we put this in 2D drag mode
obj{"ButtonRelease-1:xy"} := if dg_end = OM then attach_end_noproc([obj]) else attach_end([obj],dg_end) end if;
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"} := "";
obj{"B1-Motion"} := "";
obj{"ButtonRelease-1"} := "";
end loop;
end switch_drag_mode;
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 horizontallly 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 verticallly 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 lst 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;
now_abs_x := unstr(now_abs_x); now_abs_y := unstr(now_abs_y);
dg_end(the_objs,dropped_at := [now_abs_x,now_abs_y]);
end lambda; -- note the point at which the drag ended
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;
now_abs_x := unstr(now_abs_x); now_abs_y := unstr(now_abs_y);
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;
start_abs_x := unstr(start_abs_x); start_abs_y := unstr(start_abs_y);
drag_offs_x := drag_offs_y := []; -- keep vector of displacements
for obj in the_objs loop
[place_x,place_y] := obj.place();
drag_offs_x with:= (place_x - start_abs_x); drag_offs_y with:= (place_y - start_abs_y);
obj.raise(OM); -- raise dragged object 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;
start_abs_x := unstr(start_abs_x); start_abs_y := unstr(start_abs_y);
drag_offs_x := drag_offs_y := []; -- keep vector of displacements
for obj in the_objs loop
[place_x,place_y] := obj.place();
drag_offs_x with:= (place_x - start_abs_x); 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 := the_objs(1)("parent");
parx := parent("width"); pary := parent("height");
parx -:= 2; pary -:= 2;
return lambda(xy); -- object dragging demo: drag routine
[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
nax := ((now_abs_x + drag_offs_x(j)) max 0) min parx; nay := ((now_abs_y + drag_offs_y(j)) max 0) min pary;
if horiz_vert = 0 then
obj("place,x,y") := str(nax) + "," + str(nay);
elseif horiz_vert = 1 then
obj("place,x") := str(nax);
else
obj("place,y") := str(nay);
end if;
end loop;
dg(the_objs,[nax,nay]); -- call the supplementary routine, passing the list of all objects in the 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");
parx := parent("width"); pary := parent("height");
return lambda(xy); -- object dragging demo: drag routine
[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
nax := ((now_abs_x + drag_offs_x(j)) max 0) min parx; nay := ((now_abs_y + drag_offs_y(j)) max 0) min pary;
if horiz_vert = 0 then
obj("place,x,y") := str(nax) + "," + str(nay);
elseif horiz_vert = 1 then
obj("place,x") := str(nax);
else
obj("place,y") := str(nay);
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
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
was_dragging := OM;
drop_response(the_obj,wd(1)); -- note the drop-on event
end if;
end lambda;
end make_drop_sensitive;
procedure near(xy,ab); return abs(unstr(xy(1)) - ab(1)) + abs(unstr(xy(2)) - ab(2)) < 5; end near;
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;
start_canv_x := float(unstr(start_canv_x)); start_canv_y := float(unstr(start_canv_y));
start_coords_obj := [[unstr(x): x in the_obj("coords")]: the_obj in the_objs];
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;
start_canv_x := float(unstr(start_canv_x)); start_canv_y := float(unstr(start_canv_y));
start_coords_obj := [[unstr(x): x in the_obj("coords")]: the_obj in the_objs];
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_