------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- widget.sa: Widget abstract and helper classes
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>

abstract class $TK_WIDGET is
   -- Widget abstraction. Most widgets correspond directly to their
   -- Tk equivalents, but some consist of a frame + the Tk widget + optional
   -- scroll bars. The standard widgets get their functionality from 
   -- TK_WIDGET_INCL, whereas scrollable widgets use SCOLLABLE_WIDGET_INCL
   
   widget_name: STR;
   -- The name of the widget itself. With one exception, the widget name
   -- and the path name are the same. The exception is the root window
   -- "." Its widget name is "." but the path used by its children is ""
   -- Beware of this difference when destroying windows, binding events
   -- to windows etc.
   
   path_name: STR;
   -- The name of the path to the widget, including the widget itself.
   -- Used for creating children of a widget
   
   
   act_on(id: INT,args: ARRAY{STR});
   -- Internal working of the widget - this routine is called by GUI_APP_END
   -- whenever the widget gets a callback
   
end; -- abstract class $TK_WIDGET
-------------------------------------------------------------------

class TK_GEN_WIDGET < $TK_WIDGET is
   -- Widget used as a handle for tk widgets that don't have a full
   -- fledged sather version
   readonly attr widget_name: STR;
   readonly attr path_name: STR;
    
   create(widget_name,path_name: STR): SAME is
      res ::= new;
      res.widget_name := widget_name;
      res.path_name := path_name;
      return res;
   end;
    
   act_on(id: INT,args: ARRAY{STR}) is
      raise("No actions may be performed on TK_GEN_WIDGETS");
   end;
   
end;
------------------------------------------------------------------
partial class TK_WIDGET_INCL{CFGINFO < $TK_WIDGET_CFG} is
   -- Note that SatherGui widgets may consist of an outer frame
   -- and some auxilliary widgets (such as scroll bars) in addition
   -- to the "actual_widget"
   -- 
   --   path_name refers to the path to the outermost frame
   --   widget_name is the sams as the path name except for the root window
   --      in which case the widget name is "." and the path name is ""
   --   actual_widget_name refers to the widget proper - the actual
   --     text widget or canvas widget (for example) to which all 
   --    configuration options must apply.
    
   private attr bindings: LIST{ROUT{TK_EVENT_INFO}}; -- Store the bindings
    
   readonly attr parent: $TK_WIDGET;
   readonly attr path_name: STR; -- refers to the path to the outermost frame
   -- which may contain scrollbars etc.
    
   readonly attr name: STR;	-- name of the full path to the widget proper
    
   -- ------------------- Descendants sould redefine -----------------
   stub tk_widget_type: STR;
   -- Specifies the tk name of the widget
    
   private default_init(c: CFGINFO) is end;
   -- Default initialization hook 
   private default_packing: TK_PACK is
      return TK_PACK::top_grow_horiz_n_vert
   end;  
   -- Default packing
   
   private default_config: CFGINFO is return CFGINFO::std end;
   -- Default configuration information
    
   -- ------------------- ------------------------------------------

   widget_name: STR is return path_name end;
   -- In the default case the path and widget names are the same
    
   private actual_widget_name: STR is return widget_name end;
   -- Sometimes the "real" tk widget is nested within an outer
   -- frame. Configuration options must then be passed to the
   -- "actual" widget.
    
   -- Different versions of the create routine
   create: SAME is
      -- Create a new widget with default options under the root window
      parent ::= TK_TOPLEVEL::root_window;
      res ::= #SAME(parent);
      return res;
   end;
    
   create(parent: $TK_WIDGET): SAME is 
      -- Create a new widget, specifying a particular parent widget/window.
      return create(parent,default_packing);
   end;
    
   create(parent: $TK_WIDGET,np: STR): SAME is 
      -- Create a new widget, specifying a particular parent and a
      -- name for the widget. The name "np" controls what tcl name is
      -- used and is only useful just for debugging purposes
      return create(parent,np,default_packing);
   end;
    
   create(parent: $TK_WIDGET,cf: CFGINFO): SAME is
      -- Create a new widget 
      --  Arg parent specifies the parent window/widget. This could
      --    be a #TK_ROOTWINDOW or a TK_TOPLEVEL
      --    toplevel_win ::= #TK_TOPLEVEL;
      --    this_win := #<some widget class>(toplevel_win,
      --  Arg cf specifies a configuration option that should be used
      --    by this widget. This routine is declared in TK_WIDGET_INCL
      --    where the type of the configuration option is a type parameter
      --    CFGINFO, which is usually set to <widget_name>TK__CFG
      return create(parent,"widget",cf,default_packing);
   end;
    
   create(parent: $TK_WIDGET,pack: TK_PACK): SAME is 
      -- Create a new widget
      --  Arg parent specifies the container parent window/widget
      --  Arg pack specifies the location of the widget within the
      --   parent (packing).
      return create(parent,"widget",default_config,pack);
   end;
    
   create(parent: $TK_WIDGET,cf: CFGINFO,pack: TK_PACK): SAME is 
      -- Create a new widget.
      --   Arg parent specifies the container parent window/widget
      --   Arg cf specifies configuration options (a parameter of
      --   TK_WIDGET_INCL)
      --   Arg pack specifies the packing options
      return create(parent,"widget",cf,pack);
   end;
    
   create(parent: $TK_WIDGET,np: STR, pack: TK_PACK): SAME is 
      -- Create a new widget.
      --   Arg parent specifies the container parent window/widget
      --   Arg np is used to specify a widget name for debugging
      --   Arg pack specifies the packing options
      return create(parent,np,default_config,pack);
   end;
    
   create(parent:$TK_WIDGET,np:STR,cf: CFGINFO,pack:TK_PACK): SAME is
      -- Actual widget creation routine. All the rest are wrappers.
      --   Arg parent specifies the container parent window/widget
      --   Arg np is used to specify a widget name for debugging
      --   Arg cf specifies configuration options (a parameter of
      --   TK_WIDGET_INCL)
      --   Arg pack specifies the packing options
      --   Returns a configured, packed widget
      res ::= new;
      res.bindings := #;
      name ::= fix_tcl_name(np)+'u'+UNIQ::next;
      deb("Creating widget named:"+name+" specfied name:"+np);
      res.init(parent,name,cf);
      res.register;      
      eval(res.actual_widget_name,"configure", cf.str);
      if pack.str.size > 3 then
	 -- If packing is explicitly set to a short empty string,
	 -- don't pack
	 eval("pack",res.widget_name,pack.str);
      end;
      return res;
   end;
    
   private init(prnt: $TK_WIDGET,nm: STR,cf: CFGINFO) is
      parent := prnt;
      name := nm;
      if ~void(parent) then path_name := parent.path_name+"."+nm;
      else path_name :=  "."+nm end;
      eval(tk_widget_type,path_name);
      default_init(cf);
   end;
    
   is_eq(o:$TK_WIDGET): BOOL is return SYS::ob_eq(self,o); end;
    
   configure(cf: CFGINFO) is
      -- Reconfigure the widget with the new configuration "cf"
      -- Unstated parameters of "cf" remain unchanged
      eval(actual_widget_name,"configure",cf.str);
   end;
    
   destroy is
      -- Destroy the widget associated with self
      eval("destroy ",widget_name);
   end;
    
   bind_event(event: $TK_EVENT,action: ROUT{TK_EVENT_INFO}) is
      -- Bind the event "event" to the action "action", a bound
      -- routine which takes an EVENT_INFO as an argument
      -- The first argument to the callback is an index in to
      -- the list of bindings that corresponds to this "action"
      action_index: INT := add_to_bindings(action);
      eval("bind "+widget_name+' '+event.str+' '+" \" sather "
	   +actual_widget_name+" " +action_index+" "+event.cb_str+"\"");
   end;
    
    
   act_on(id: INT,args: ARRAY{STR}) is
      -- Private to the
      -- Peform the action associated with the index "id".  
      if id >= bindings.size then 
	 raise "Internal error in widget! Binding "+id+" is out of range";
      else
	 deb("Acting on:"+id+" in widget:"+widget_name);
	 func ::= bindings[id];
	 event_info ::= #TK_EVENT_INFO(args);
	 deb("Event info:"+event_info.str);
	 func.call(event_info);
      end;
   end;
    
   private add_to_bindings(act:ROUT{TK_EVENT_INFO}):INT is
      action_index: INT := bindings.size;
      deb("Binding an action with index:"+action_index+"\n");
      bindings.append(act);
      return action_index;
   end;
   
   private fix_tcl_name(s: STR): STR is
      -- SEF:Eliminate problems with tcl name, returning the empty
      -- string if necessary.
      res ::= #FSTR("");
      loop c ::= s.elt!;
	 if c.is_alpha then res := res+c.lower;  end;
      end;
      return res.str;
   end;
    
   private register is
      -- Register this widget with the widget map so that subsequent
      -- callbacks that belong to this widget may be directed here.
      TK_WIDGET_MAP::register(actual_widget_name,self);
   end;
    
   private err(s: STR) is
      -- Print out an error message.
      #ERR+"**************************************************\n";
      #ERR+s+"\n";
      #ERR+"In widget:"+widget_name+"\n";
      #ERR+"**************************************************\n";
   end;
    
   private deb(s: STR) is GUI_APP_END::deb(s) end;
   -- Print out a debugging message
    
   -- Wrapper routines to make it easier to perform an eval
   private eval(a1: $STR) is   GUI_APP_END::eval(a1.str); end;
    
   private eval(a1,a2: $STR) is  GUI_APP_END::eval(a1.str.append(" ",a2.str));
   end;
    
   private eval(a1,a2,a3: $STR) is
      GUI_APP_END::eval(a1.str.append(" ",a2.str," ",a3.str));
   end;
    
   private eval(a1,a2,a3,a4: $STR) is
      GUI_APP_END::eval(a1.str.append(" ",a2.str," ",a3.str," ",a4.str));
   end;
    
   private eval(a1,a2,a3,a4,a5: $STR) is
      GUI_APP_END::eval(a1.str+" "+a2.str+" "+a3.str+" "+a4.str+" "+a5.str);
   end;
    
   private quote(s:STR): STR is return "{".append(s,"}") end;
   -- Return a (tcl) quoted version of the string "s"
    
   private join(a1,a2: $STR): STR is
      res ::= #FSTR("");
      if ~void(a1) then res := res + " " + a1.str; end;
      if ~void(a2) then res := res + " " + a2.str; end;
      return res.str;
   end;
    
end;
-------------------------------------------------------------------
partial class TK_SCROLL_WIDGET_INCL{CFGINFO < $TK_WIDGET_CFG} is
   -- Include class for widgets that have an "outer" frame in addition
   -- to the widget proper.  The outer frame can hold scrollbars, if
   -- needed.
   include TK_WIDGET_INCL{CFGINFO};
    
   readonly attr frame: TK_FRAME; -- Outer frame that holds widget + scrolls
   readonly attr actual_widget_name: STR; -- Name of the actual widget
   readonly attr hscroll_name,vscroll_name: STR; -- Scroll bar names
    
   actual_widget: TK_GEN_WIDGET is
      return #TK_GEN_WIDGET(actual_widget_name,actual_widget_name);
   end;
    
   -- All "widget" behavior refers to the frame, not the widget itself.
   -- To refer to the widget itself, use "actual_widget"
   widget_name: STR is return frame.path_name end;
    
   private init(a_parent: $TK_WIDGET,name:STR,cfg: CFGINFO) is
      -- Creation of the widget and its frame
      parent := a_parent;
      init_frame_name ::= name+"frame";
      frame  := #TK_FRAME(parent,init_frame_name,
			  TK_FRAME_CFG::std,TK_PACK::none);
      path_name := frame.path_name;
      actual_widget_name := frame.path_name+"."+name;
      eval(tk_widget_type,actual_widget_name); -- Create the widget proper
      -- eval(actual_widget_name,"mark set insert 0.0");
      eval("pack",actual_widget_name,"-side top -fill both -expand true");
      default_init(cfg);
   end;
    
   bind_event(event: $TK_EVENT,action: ROUT{TK_EVENT_INFO})
   -- Bind the event "event" to the action "action", a bound
   -- routine which takes an EVENT_INFO as an argument
   -- The first argument to the callback is an index in to
   -- the list of bindings that corresponds to this "action"
   is
      action_index: INT := bindings.size; -- = Index of the next binding
      bindings.append(action);
      eval("bind "+actual_widget_name+' '+event.str+' '+" \" sather "
	   +actual_widget_name+" " +action_index+" "+event.cb_str+"\"");
   end;
    
    
   hscroll: SAME is hscroll; return self end;
   vscroll: SAME is vscroll; return self end;
   hscroll is
      -- Create a horizontal scrollbar
      if ~void(hscroll_name) then return end;
      hscroll_name := widget_name+".hscroll";
      eval("scrollbar",hscroll_name,
	   "-orient horiz -command "+quote(actual_widget_name+" xview"));
      eval(actual_widget_name,"configure","-xscrollcommand",
	   quote(hscroll_name+" set"));
      eval("pack",hscroll_name,
	   "-before "+actual_widget_name+" -side bottom -fill x");
   end;
    
   vscroll is
      -- Add a vertical scrollbar
      if ~void(vscroll_name) then return end;
      vscroll_name ::= widget_name+".vscroll";
      eval("scrollbar",vscroll_name,"-command "+
	   quote(actual_widget_name+" yview"));
      eval(actual_widget_name,"configure","-yscrollcommand",
	   quote(vscroll_name+" set"));
      eval("pack",vscroll_name,
	   "-before "+actual_widget_name+" -side right -fill y");
   end;
    
end;
-------------------------------------------------------------------
class TK_WIDGET_MAP is
   -- Mapping between widget names and widgets
   -- that is used by the callback mechanism to identify the appropriate
   -- target widget of a callback
    
   private shared window_map: FMAP{STR,$TK_WIDGET};
   
   register(window_name: STR, object: $TK_WIDGET) is
      if GUI_APP_END::debug then 
	 GUI_APP_END::deb("Registering window:"+window_name) 
      end;
      if void(window_map) then window_map := #; end;
      window_map := window_map.insert(window_name,object);
   end;
    
   get_widget(window_name: STR): $TK_WIDGET is
      if window_map.test(window_name) then
	 return window_map.get(window_name);
      else
	 raise "Window not registered:"+window_name;
      end;
   end;
    
end;
-------------------------------------------------------------------
class TK_WIDGET_CALLBACKS{ROUT_ARG} is
   -- Used by widgets to hold a mapping from a callback to 
   -- an integer "id".
   -- Mapping from ids to callbacks.
   -- Widgets use one of these to hold their callback information
   
   private attr action_map: FLIST{ROUT_ARG};
   private attr action_name: FLIST{STR};
    
   create: SAME is
      res ::= new;
      res.action_map := #;
      res.action_name := #;
      return res;
   end;
    
   register(action: ROUT_ARG): INT is
      -- Register the action "action" and assign it an integer
      -- id which can be used to later look up the action.
      return register(action,"noname");
   end;
    
   register(action: ROUT_ARG,name:STR): INT is
      -- Same as the register procedure, but also registers 
      -- an optional name for the callback which may be helpful
      -- during debugging.
      if void(action_map) then action_map := # end;
      if void(action_name) then action_name := #; end;
      action_map := action_map.push(action);
      action_name := action_name.push(name);
      return (action_map.size);
   end;
    
   get_action(id: INT): ROUT_ARG is
      -- Returns the bound routine associated with the action identifier "id"
      id := id-1;
      if id < 0 or id >= action_map.size then
	 raise "Error: Action id not known!"+id+"\n";  
      else 
	 action ::= action_map[id];
	 if GUI_APP_END::debug then
	    GUI_APP_END::deb("Callback found action for:"+id);
	    GUI_APP_END::deb("Action name:"+action_name[id]);
	 end;
	 return action;
      end;
   end;
    
   get_action_name(id: INT): STR is
      -- Return the debuggin name associated with the action identifier "id"
      return action_name[id];
   end;
    
end;
-------------------------------------------------------------------
class TK_ARG_UTIL is
   -- Utility for binding argument names and values.
   -- Key point: If the value is void, then no string is generated.
   --    this is a convenient way to not specify an option
    
   pair(nm:STR,val: STR): STR is
      if ~void(val) then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str; 
      else return ""; end;
   end;
    
   pair(nm:STR,val: FLT): STR is
      if ~val.is_nil then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str; 
      else return ""; end;
   end;
    
   pair(nm: STR,val: TK_ANCHOR): STR is
      if ~val.is_nil then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str; 
      else return ""; end;
   end;

    
end;
-------------------------------------------------------------------
class UNIQ is
   -- Generate unique integers to make strings unique so that
   -- we don't rely on string names in sather
   private shared gen: INT := 0;
    
   next: INT is     gen := gen+1; return gen; end;
    
end;
-------------------------------------------------------------------
immutable class TK_TAG_INCL is
   -- Partial TAG class
   readonly attr str: STR;
    
   create: SAME is return(#("Unnamed")) end;
    
   create(name: STR): SAME is
      -- Generates unique tags. The "name" is just for debugging purposes
      res: SAME; 
      return res.str("tag"+UNIQ::next+name);
   end;
    
end;
-------------------------------------------------------------------
class WIDGET_UTILS is
   -- Utitlity routines for the widget classes

   int_if_poss(s: STR,default: INT): INT is
      -- Convert the string "s" to an integer and return it, if possible.
      -- If an error occurs in the conversion, return the "default" value
      c ::= #STR_CURSOR(s);
      res ::= c.int;
      if c.has_error then return default  else return res end;
   end;
    
   flt_if_poss(s: STR,default: FLT): FLT is
      -- Convert the string "s" to a float and return it, if possible.
      -- If an error occurs in the conversion, return the "default" value
      c ::= #STR_CURSOR(s);
      res ::= c.get_flt;
      if c.has_error then  return default    else return res end;
   end;
    
   arr_str(a: ARRAY{STR}): STR is
      -- Print out an array version of the string, since ARRAY 
      -- does not have a .str routien in the standar library.
      res ::= "";  loop res := res+" "+a.elt!; end;   return res;
   end;
    
end;
-------------------------------------------------------------------
