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;