package message_help; -- package for message control panels -- procedure init_message_help(the_Tk); -- initialize the message helper -- procedure post_all(); -- copy the control panel settings to the widget being controlled procedure attach_message_help(subject_widget); -- attach to the widget being controlled end message_help; package body message_help; -- package for button control panels use tkw,string_utility_pak; -- use the main widget package var Tk := OM,sample_widget; var choices := {["state","b:normal,b:active,b:disabled"], ["relief","b:flat,b:sunken,b:raised,b:groove,b:ridge"], ["sliderrelief","b:flat,b:sunken,b:raised,b:groove,b:ridge"], ["anchor","b:n,b:ne,b:e,b:se,b:s,b:sw,b:w,b:nw,b:center"], ["justify","b:left,b:right,b:center"]}; -- ********** The attributes ********** const color_attribs := ["background","foreground","highlightbackground","highlightcolor"]; const pick_attribs := ["anchor","justify","relief","cursor"]; const numerical_attribs := ["width","aspect","highlightthickness","borderwidth"]; const string_attribs := ["text","takefocus","font","textvariable"]; -- ************************************ var color_responses := {["background",get_color_background], ["foreground",get_color_foreground], ["highlightbackground",get_color_highlightbackground], ["highlightcolor",get_color_highlightcolor]}; var background_val := "#999999",foreground_val := "#111111",highlightbackground_val := "#333333", highlightcolor_val := "#ff0000"; -- initial color values var anchor_val := "ne",relief_val := "flat",cursor_val := "arrow",justify_val := "left"; -- pick parameter values var width_val := 100,aspect_val := 66,borderwidth_val := 3,highlightthickness_val := 3; -- numerical parameter values var text_val := "This is a sample message\nof two lines", takefocus_val := "Command to execute when get focus via keyboard (Disabled)", font_val := "{Times 12 bold}", textvariable_val := "Surrogate Tk variable for message contents (Disabled)"; -- string parameter values var textline_contents := [text_val,takefocus_val,font_val,textvariable_val]; var textlines; -- global variable: map from string attribute names to textlines var slider_displays := { }; -- maps slider names into small display areas var sliders := { }; -- maps slider names into slider objects procedure init_message_help(the_Tk); -- initialize the message helper initials := [width_val,aspect_val,borderwidth_val,highlightthickness_val]; textline_contents := [text_val,takefocus_val,font_val,textvariable_val]; if Tk /= OM and Tk.win_open() /= OM then -- build the window only once, but initialize data repeatedly for attrib_name = numerical_attribs(j) loop -- place the numerical attributes as sliders sd := slider_displays(attrib_name); sd(OM) := str(initials(j)); sc := sliders(attrib_name); sc(OM) := initials(j); -- set the slider to its initial value and position end loop; for attrib_name = string_attribs(j) loop -- place the string attributes as textlines textline := textlines(attrib_name); textline(OM) := textline_contents(j); end loop; return; end if; Tk := the_Tk("toplevel","1,1"); Tk(OM) := "Message Attributes"; lengths := [300,300,100,100]; -- help slider lengths to := [600,300,10,10]; -- help slider ranges choices("cursor") := ["b:" + curse: curse in breakup(cursors_stg,",")]; -- ************ set up the help window: divide the help frame into a top area running all the way across, -- a middle area with a left and right, and a bottom area running all the way across frame_top := Tk("frame","1,1"); frame_middle := Tk("frame","1,1"); frame_bot := Tk("frame","1,1"); frame_top("side") := "top"; frame_middle("side") := "top"; frame_bot("side") := "top"; frame_left := frame_middle("frame","1,1"); frame_right := frame_middle("frame","1,1"); frame_left("side") := "left"; frame_right("side") := "right"; -- ************ put sliders into the help window ************ for attrib_name = numerical_attribs(j) loop -- place the numerical attributes as sliders if j <= 3 then -- first 3 sliders, with their captions, are wide, so put into top frame := frame_top("frame","1,1"); frame("side,anchor") := "top,w"; else -- next slider is narrower, so put in left frame := frame_left("frame","1,1"); frame("side,anchor") := "top,w"; end if; slider_displays(attrib_name) := sd := frame("entry","4"); sd("side") := "left"; -- create a slider display sd(OM) := str(initials(j)); sliders(attrib_name) := (sc := frame("scale","0,100")); sc("side") := "left"; -- create a slider msg := frame("message",attrib_name + if attrib_name = "aspect" then "\n(only if width = 0)" else "" end if); msg("width") := 150; msg("side") := "right"; sc("orient,variable") := "horizontal," + attrib_name; -- the attribute name is used as the slider's associated variable sc("length,width,from,to,sliderlength,showvalue") := str(lengths(j)) + ",8,0," + str(to(j)) + ",12,false"; sc{OM} := store_slider(attrib_name); sc(OM) := initials(j); -- set the slider to its initial value and position end loop; -- ************ put color picker buttons into the help window ************ for attrib_name = color_attribs(j) loop -- place the color attributes as buttons, opening dialogs button := frame_right("button",attrib_name); button("side,fill") := "top,both"; button{OM} := color_responses(attrib_name); -- set up specialized color picker end loop; -- ************ put checkboxes into the help window ************ bool_attribs := [ ]; -- no boolean attributes in this case for attrib_name = bool_attribs(j) loop -- place the boolean attributes as checkboxes check := frame_right("checkbutton",attrib_name); check("side") := "bottom"; check("variable") := "checkvar_" + str(j); check{OM} := store_check(j); end loop; -- ************ put supplementary text areas and lines into the help window ************ textlines := { }; -- map from string attribute names to textlines for attrib_name = string_attribs(j) loop -- place the string attributes as textlines frame := frame_bot("frame","1,1"); frame("side,fill") := "top,both"; caption := frame("message",attrib_name); caption("width") := 100; caption("side,anchor") := "left,w"; textline := frame(if j = 1 then "text" else "entry" end if,if j = 1 then "40,10" else "40" end if); textline("side,anchor") := "right,w"; if j = 1 then textline("background") := "#FFEEEE"; end if; -- pinkish background for text box textlines(attrib_name) := textline; textline(OM) := textline_contents(j); textline{OM} := store_textline(attrib_name); if attrib_name in {"textvariable","takefocus"} then textline("background") := "grey"; end if; end loop; -- ************ put menu buttons for the pick attributes into the help window ************ for attrib_name = pick_attribs(j) loop -- place the pick attributes as menu buttons menub := frame_left("menubutton",attrib_name); -- use the left side, where there is space menub("side") := "bottom"; -- create a menubutton the_menu := menub("menu","normal"); the_menu(1..0) := choyces := choices(attrib_name); -- add items to the menu choyces := breakup(choyces,","); for choice = choyces(k) loop the_menu{k,OM} := store_pick(attrib_name,choice); -- set command for Menu item end loop; menub("menu") := the_menu; end loop; end init_message_help; procedure attach_message_help(subject_widget); -- attach to the widget being controlled sample_widget := subject_widget; read_all(sample_widget); -- read all attributes of the sample widget init_message_help(sample_widget("toplevel")); -- initialize the widget helper return Tk; -- return the button control window end attach_message_help; procedure get_color_background(); -- get background color Tk("ask_color","initialcolor,title") := background_val + ",Pick the Text Background Color"; background_val := if dialog_response /= "" then dialog_response else background_val end if; -- update if not canceled post_all(); -- post all settings to the sample widget end get_color_background; procedure get_color_foreground(); -- get foreground color Tk("ask_color","initialcolor,title") := foreground_val + ",Pick the Text Color"; foreground_val := if dialog_response /= "" then dialog_response else foreground_val end if; -- update if not canceled post_all(); -- post all settings to the sample widget end get_color_foreground; procedure get_color_highlightbackground(); -- get highlightbackground color Tk("ask_color","initialcolor,title") := highlightbackground_val + ",Pick the non-Highlight Indicator Color"; highlightbackground_val := if dialog_response /= "" then dialog_response else highlightbackground_val end if; -- update if not canceled post_all(); -- post all settings to the sample widget end get_color_highlightbackground; procedure get_color_highlightcolor(); -- get highlightcolor Tk("ask_color","initialcolor,title") := highlightcolor_val + ",Pick the Highlight Indicator Color"; highlightcolor_val := if dialog_response /= "" then dialog_response else highlightcolor_val end if; -- update if not canceled post_all(); -- post all settings to the sample widget end get_color_highlightcolor; procedure store_pick(pick_att_name,picked); -- closure generator for menu picks case pick_att_name -- return parameterless response routine with enclosed att_name and choice when "anchor" => return lambda(); match(picked,"b:"); anchor_val := picked; post_all(); end lambda; when "relief" => return lambda(); match(picked,"b:"); relief_val := picked; post_all(); end lambda; when "cursor" => return lambda(); picked := picked(1); match(picked,"b:"); cursor_val := picked; post_all(); end lambda; when "justify" => return lambda(); match(picked,"b:"); justify_val := picked; post_all(); end lambda; end case; end store_pick; procedure store_textline(text_att_name); -- closure generator for text attributes case text_att_name -- return parameterless response routine with enclosed att_name and choice when "text" => return lambda(); text_val := textlines(text_att_name)(OM); text_val := text_val(1..#text_val - 1); -- drop terminating eol post_all(); end lambda; when "takefocus" => return lambda(); takefocus_val := textlines(text_att_name)(OM); post_all(); end lambda; when "font" => return lambda(); font_val := textlines(text_att_name)(OM); post_all(); end lambda; when "textvariable" => return lambda(); textvariable_val := textlines(text_att_name)(OM); post_all(); end lambda; end case; end store_textline; -- this procedure handles numerical attributes procedure store_slider(attrib_name); -- the attribute name is used as the associatd Tk variable name case attrib_name -- return parameterless response routine with enclosed att_name and choice when "width" => return lambda(x); slider_displays(attrib_name)(OM) := width_val := x(1); post_all(); end lambda; when "borderwidth" => return lambda(x); slider_displays(attrib_name)(OM) := borderwidth_val := x(1); post_all(); end lambda; when "highlightthickness" => return lambda(x); slider_displays(attrib_name)(OM) := highlightthickness_val := x(1); post_all(); end lambda; when "aspect" => return lambda(x); slider_displays(attrib_name)(OM) := aspect_val := x(1); post_all(); end lambda; end case; end store_slider; procedure store_check(box_num); -- closure generator for boolean attributes case box_num -- return parameterless response routine with enclosed att_name and choice when 2 => -- checkbox values are returned as 0 or 1 return lambda(); orient_val := if Tk.getvar("checkvar_" + str(box_num)) = "0" then "vertical" else "horizontal" end if; post_all(); end lambda; when 1 => return lambda(); showvalue_val := if Tk.getvar("checkvar_" + str(box_num)) = "0" then "1" else "0" end if; post_all(); end lambda; end case; end store_check; procedure post_all(); -- post all settings to the sample widget set_att("background",background_val); set_att("foreground",foreground_val); set_att("highlightbackground",highlightbackground_val); set_att("highlightcolor",highlightcolor_val); set_att("anchor",anchor_val); -- pick values set_att("justify",justify_val); set_att("relief",relief_val); set_att("cursor",cursor_val); set_att("text",text_val); -- string values set_att("takefocus",takefocus_val); set_att("font",font_val); set_att("textvariable",textvariable_val); -- quasi-boolean parameter values (none in this case) set_att("width",width_val); -- numerical parameter values set_att("borderwidth",borderwidth_val); set_att("highlightthickness",highlightthickness_val); set_att("aspect",aspect_val); end post_all; procedure read_all(sample_widget); -- read all attributes of the sample widget background_val := sample_widget("background"); foreground_val := sample_widget("foreground"); highlightbackground_val := sample_widget("highlightbackground"); highlightcolor_val := sample_widget("highlightcolor"); anchor_val := sample_widget("anchor"); -- pick values justify_val := sample_widget("justify"); relief_val := sample_widget("relief"); cursor_va := sample_widget("cursor"); text_val := sample_widget("text"); -- string values -- takefocus_val := sample_widget("takefocus"); font_val := sample_widget("font"); -- textvariable_val := sample_widget("textvariable"); -- quasi-boolean parameter values (none in this case) width_val := sample_widget("width"); -- numerical parameter values if width_val = 0 then width_val := 8 * #text_val; end if; borderwidth_val := sample_widget("borderwidth"); highlightthickness_val := sample_widget("highlightthickness"); aspect_val := sample_widget("aspect"); end read_all; procedure set_att(att_name,att_val); -- set an attribute of the sample widget --print("sample_widget(",att_name,") := ",att_val); return; if att_name = "text" then sample_widget(OM) := att_val; return; end if; if att_name in {"textvariable","takefocus"} then return; end if; -- these are disabled sample_widget(att_name) := str(att_val); end set_att; end message_help; program test; -- helper for the message widget use tkw,string_utility_pak,message_help; -- use the main widget class var Tk; Tk := tkw(); -- create the Tk interpreter -- ******* The sample widget: create an auxiliary toplevel contining the sample widget ******* sample_widget := Tk("message","This is a sample message\nof two lines"); sample_widget("side") := "top"; sample_widget(OM) := "Sample Message"; attach_message_help(sample_widget); -- attach this widget to the control panel Tk.mainloop(); -- enter the Tk main loop end test;