package slider_help; -- package for slider control panels -- procedure init_slider_help(the_Tk); -- initialize the slider helper -- procedure post_all(); -- copy the control panel settings to the widget being controlled procedure attach_slider_help(subject_widget); -- attach to the widget being controlled end slider_help; package body slider_help; -- package for slider control panels use tkw,string_utility_pak; -- use the main widget package var Tk := OM,sample_widget; const numerical_attribs := ["from","to","length","tickinterval","digits","resolution","width", "sliderlength","repeatdelay","repeatinterval","bigincrement","borderwidth"]; const string_attribs := ["variable","takefocus","label","font","command"]; const bool_attribs := ["showvalue","orient = vertical"]; -- boolean attributes const color_attribs := ["troughcolor","background","activebackground","foreground"]; const pick_attribs := ["state","cursor","relief","sliderrelief"]; 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"]}; var troughcolor_val := "#aaaaaa",background_val := "#999999", -- color parameter values activebackground_val := "#aaaaaa",foreground_val := "#bbbbbb"; var color_responses := {["troughcolor",get_color_trough],["background",get_color_background], ["activebackground",get_color_active],["foreground",get_color_foreground]}; var state_val := "normal",relief_val := "flat",cursor_val := "arrow",sliderrelief_val := "flat"; -- pick parameter values var variable_val := "Name of Tk surrogate var. for slider value (Disabled)",takefocus_val := "Command to execute when get focus via keyboard (Disabled)",label_val := "Label",font_val := "{Times 12 bold}", command_val := "Command to execute as slider moves (Disabled)"; -- string parameter values var orient_val := "horizontal",showvalue_val := "false"; -- quasi-boolean parameter values var textline_contents := [variable_val,takefocus_val,label_val,font_val,command_val]; var textlines; -- global variable: map from string attribute names to textlines var slider_displays := { },sliders := { }; -- maps slider names into small display areas var from_val := 0,to_val := 100,length_val := 200,tickinterval_val := 50, digits_val := 2,resolution_val := 5,width_val := 15, sliderlength_val := 15,repeatdelay_val := 200, repeatinterval_val := 200,bigincrement_val := 10,borderwidth_val := 3; procedure init_slider_help(the_Tk); -- initialize the slider helper initials := [from_val,to_val,length_val,tickinterval_val,digits_val,resolution_val,width_val, sliderlength_val,repeatdelay_val,repeatinterval_val,bigincrement_val,borderwidth_val]; textline_contents := [variable_val,takefocus_val,label_val,font_val,command_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) := "Slider Attributes"; choices("cursor") := ["b:" + curse: curse in breakup(cursors_stg,",")]; lengths := [300,300,300,300,100,100,100,100,100,100,100,100]; to := [300,300,300,300,4,10,30,30,1000,1000,20,20]; sliders := { }; -- maps slider names into slider objects frame_top := Tk("frame","1,1"); frame_bot := Tk("frame","1,1"); frame_botbot := Tk("frame","1,1"); frame_top("side") := "top"; frame_bot("side") := "top"; frame_botbot("side") := "top"; frame_left := frame_bot("frame","1,1"); frame_right := frame_bot("frame","1,1"); frame_left("side") := "left"; frame_right("side") := "right"; for attrib_name = numerical_attribs(j) loop -- place the numerical attributes as sliders if j <= 4 then frame := frame_top("frame","1,1"); frame("side,anchor") := "top,w"; else 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",numerical_attribs(j)); msg("width") := 100; 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 if attrib_name = "tickinterval" then -- add an extra explanatory message frame := frame_top("frame","1,1"); frame("side,anchor") := "top,w"; msg := frame("message","To eliminate the ticks portion of the slider, set its tickinterval attribute to 0."); msg("width") := 500; msg("side") := "top"; msg("foreground") := "#ff5555"; end if; end loop; 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; 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; textlines := { }; -- map from string attribute names to textlines for attrib_name = string_attribs(j) loop -- place the string attributes as textlines frame := frame_botbot("frame","1,1"); frame("side,fill") := "top,both"; caption := frame("message",attrib_name); caption("width") := 100; caption("side,anchor") := "left,w"; textline := frame("entry","40"); textline("side,anchor") := "right,w"; textlines(attrib_name) := textline; textline(OM) := textline_contents(j); textline{OM} := store_textline(attrib_name); if attrib_name in {"variable","takefocus","command"} then textline("background") := "grey"; end if; end loop; for attrib_name = pick_attribs(j) loop -- place the pick attributes as menu buttons menub := frame_right("menubutton",attrib_name); 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_slider_help; procedure attach_slider_help(subject_widget); sample_widget := subject_widget; read_all(sample_widget); -- read all attributes of the sample widget init_slider_help(sample_widget("toplevel")); -- initialize the widget helper return Tk; -- return the button control window end attach_slider_help; procedure get_color_trough(); -- get trough color Tk("ask_color","initialcolor,title") := troughcolor_val + ",Pick the Slider Trough Color"; troughcolor_val := if dialog_response /= "" then dialog_response else troughcolor_val end if; -- update if not canceled post_all(); -- post all settings to the sample slider end get_color_trough; procedure get_color_background(); -- get background color Tk("ask_color","initialcolor,title") := background_val + ",Pick the Slider 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 slider end get_color_background; procedure get_color_foreground(); -- get foreground color Tk("ask_color","initialcolor,title") := foreground_val + ",Pick the Slider Foreground 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 slider end get_color_foreground; procedure get_color_active(); -- get active slider color Tk("ask_color","initialcolor,title") := activebackground_val + ",Pick the Active Slider Color"; activebackground_val := if dialog_response /= "" then dialog_response else activebackground_val end if; -- update if not canceled post_all(); -- post all settings to the sample slider end get_color_active; 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 "state" => return lambda(); match(picked,"b:"); state_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 "sliderrelief" => return lambda(); match(picked,"b:"); sliderrelief_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 "variable" => return lambda(); variable_val := textlines(text_att_name)(OM); post_all(); end lambda; when "takefocus" => return lambda(); takefocus_val := textlines(text_att_name)(OM); post_all(); end lambda; when "label" => return lambda(); label_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 "command" => return lambda(); command_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 "from" => return lambda(x); slider_displays(attrib_name)(OM) := from_val := x(1); post_all(); end lambda; when "to" => return lambda(x); slider_displays(attrib_name)(OM) := to_val := x(1); post_all(); end lambda; when "width" => return lambda(x); slider_displays(attrib_name)(OM) := width_val := x(1); post_all(); end lambda; when "tickinterval" => return lambda(x); slider_displays(attrib_name)(OM) := tickinterval_val := x(1); post_all(); end lambda; when "digits" => return lambda(x); slider_displays(attrib_name)(OM) := digits_val := x(1); post_all(); end lambda; when "resolution" => return lambda(x); slider_displays(attrib_name)(OM) := resolution_val := x(1); post_all(); end lambda; when "length" => return lambda(x); slider_displays(attrib_name)(OM) := length_val := x(1); post_all(); end lambda; when "sliderlength" => return lambda(x); slider_displays(attrib_name)(OM) := sliderlength_val := x(1); post_all(); end lambda; when "repeatdelay" => return lambda(x); slider_displays(attrib_name)(OM) := repeatdelay_val := x(1); post_all(); end lambda; when "repeatinterval" => return lambda(x); slider_displays(attrib_name)(OM) := repeatinterval_val := x(1); post_all(); end lambda; when "bigincrement" => return lambda(x); slider_displays(attrib_name)(OM) := bigincrement_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; 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)) = "1" then "vertical" else "horizontal" end if; post_all(); end lambda; when 1 => return lambda(); showvalue_val := if Tk.getvar("checkvar_" + str(box_num)) = "1" then "1" else "0" end if; post_all(); end lambda; end case; end store_check; procedure post_all(); -- post all settings to the sample slider set_att("troughcolor",troughcolor_val); -- color values set_att("background",background_val); set_att("foreground",foreground_val); set_att("activebackground",activebackground_val); set_att("state",state_val); -- pick values set_att("relief",relief_val); set_att("cursor",cursor_val); set_att("sliderrelief",sliderrelief_val); set_att("variable",variable_val); -- string values set_att("takefocus",takefocus_val); set_att("label",label_val); set_att("font",font_val); set_att("command",command_val); set_att("orient",orient_val); -- quasi-boolean parameter values set_att("showvalue",showvalue_val); set_att("from",from_val); -- numerical parameter values set_att("to",to_val); set_att("width",width_val); set_att("tickinterval",tickinterval_val); set_att("digits",digits_val); set_att("resolution",resolution_val); set_att("length",length_val); set_att("sliderlength",sliderlength_val); set_att("repeatdelay",repeatdelay_val); set_att("repeatinterval",repeatinterval_val); set_att("bigincrement",bigincrement_val); set_att("borderwidth",borderwidth_val); end post_all; procedure read_all(att_name); -- read all attributes of the sample widget troughcolor_val := sample_widget("troughcolor"); -- color values background_val := sample_widget("background"); foreground_val := sample_widget("foreground"); activebackground_val := sample_widget("activebackground"); state_val := sample_widget("state"); -- pick values relief_val := sample_widget("relief"); cursor_val := sample_widget("cursor"); sliderrelief_val := sample_widget("sliderrelief"); variable_val := sample_widget("variable"); -- string values -- takefocus_val := sample_widget("takefocus"); label_val := sample_widget("label"); font_val := sample_widget("font"); -- command_val := sample_widget("command"); orient_val := sample_widget("orient"); -- quasi-boolean parameter values showvalue_val := sample_widget("showvalue"); from_val := sample_widget("from"); -- numerical parameter values to_val := sample_widget("to"); width_val := sample_widget("width"); tickinterval_val := sample_widget("tickinterval"); digits_val := sample_widget("digits"); resolution_val := sample_widget("resolution"); length_val := sample_widget("length"); sliderlength_val := sample_widget("sliderlength"); repeatdelay_val := sample_widget("repeatdelay"); repeatinterval_val := sample_widget("repeatinterval"); bigincrement_val := sample_widget("bigincrement"); borderwidth_val := sample_widget("borderwidth"); end read_all; procedure set_att(att_name,att_val); -- set an attribute of the sample widget --print("sample_widget(",att_name,") := ",att_val); if att_name in {"variable","takefocus","command"} then return; end if; -- these are disabled sample_widget(att_name) := str(att_val); end set_att; end slider_help; program test; -- helper for the slider widget use tkw,string_utility_pak,slider_help; -- use the main widget class var Tk; Tk := tkw(); -- create the Tk interpreter -- create an auxiliary toplevel contining the sample widget sample_widget := Tk("scale","0,100"); sample_widget("side") := "top"; Tk(OM) := "Sample Slider"; attach_slider_help(sample_widget); -- attach this widget to the control panel Tk.mainloop(); -- enter the Tk main loop end test;