-------------------------------------------------------------------
--           RAPID - RAPID ADA PORTABLE INTERFACE DESIGNER         
--           TCL PEER FOR THE MCC GUI PACKAGE LIBRARY 
--           Copyright (C) 1999 Martin C. Carlisle.                
--                                                                 
-- RAPID is free software;  you can  redistribute it  and/or modify
-- it under terms of the  GNU General Public License as published  
-- by the Free Software  Foundation;  either version 2,  or (at your
-- option) any later version.  RAPID 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 the GNU General Public License for more details.  
-- You should have  received  a copy of the GNU General Public License
-- distributed with RAPID; see file COPYING.  If not, write to the 
-- Free Software Foundation,  59 Temple Place - Suite 330,  Boston, 
-- MA 02111-1307, USA.                                                 
--                                                                     
-- As a special exception, if other files instantiate generics from
-- this unit, or you link this unit with other files to produce an 
-- executable, this unit does not by itself cause the resulting 
-- executable to be covered by the GNU General Public License.  
-- This exception does not however invalidate any other reasons 
-- why the executable file might be covered by the GNU Public 
-- License.  This exception does not apply to executables which
-- are GUI design tools, or that could act as a replacement
-- for RAPID.
------------------------------------------------------------------------------
with Peer;
with Mcc.Gui.Widget.Listbox;
with Mcc.Gui.Widget.Dropdown;
with Mcc.Gui.Widget.Progress;
package body Mcc.Gui.Widget is
   Tooltip_Initialized : Boolean := False;

   --------------------------
   -- Set_Foreground_Color --
   --------------------------

   procedure Set_Foreground_Color
     (Obj       : in out Widget;
      New_Color : in     Color)
   is
      Color_String : String := Peer.To_Hex_String(
         Integer(New_Color.Red)*(256**2) +
         Integer(New_Color.Green)*256 +
         Integer(New_Color.Blue));
   begin
      if Widget'Class(Obj) in Mcc.Gui.Widget.Progress.Progress'Class then
         Peer.Eval(Obj.My_Peer.Name.all & ".part configure -background #" &
            Color_String);
      elsif Widget'Class(Obj) in Mcc.Gui.Widget.Listbox.Listbox'Class then
         Peer.Eval(Obj.My_Peer.Name.all & ".list configure -foreground #" &
            Color_String);
      elsif Widget'Class(Obj) in Mcc.Gui.Widget.Dropdown.Dropdown'Class then
         Peer.Eval(Obj.My_Peer.Name.all & 
            ".top.frame.list configure -foreground #" &
            Color_String);
      else
         Peer.Eval(Obj.My_Peer.Name.all & " configure -foreground #" &
            Color_String);
      end if;
   end Set_Foreground_Color;

   -- The following procedure is modified from one appearing in
   -- Graphical Application with Tcl&TK, 2nd Edition
   -- by Eric Foster-Johnson pp. 558-559.
   procedure Initialize_Tooltip is
   begin
      Tooltip_Initialized := True;
      Peer.Eval("proc tooltip { widget message } {" & ASCII.LF &
         "after 1300 ""tooltip_show $widget $message""}");
      Peer.Eval("proc tooltip_show { widget args } {" & ASCII.LF &
         "global thewidget" & ASCII.LF &
         "set thewidget $widget" & ASCII.LF &
         "set mx [winfo pointerx $widget]" & ASCII.LF &
         "set my [winfo pointery $widget]" & ASCII.LF &
         "set has_mouse [winfo containing $mx $my]" & ASCII.LF &
         "if { $has_mouse == $widget } {" & ASCII.LF &
         "   if {[winfo exists .tooltip]} {destroy .tooltip}" & ASCII.LF &
         "   toplevel .tooltip -cursor right_ptr" & ASCII.LF &
         "   wm override .tooltip 1" & ASCII.LF &
         "   wm withdraw .tooltip" & ASCII.LF &
         "   set x [expr [winfo rootx $widget] + " &
         "      ([winfo width $widget] / 2) ]" & ASCII.LF &
         "   set y [expr [winfo rooty $widget] + " &
         "      ([winfo height $widget] / 2) ]" & ASCII.LF &
         "   if { $mx < $x } { set x [expr $mx - 3] }" & ASCII.LF &
         "   if { $my < $y } { set y [expr $my - 3] }" & ASCII.LF &
         "   wm geometry .tooltip ""+$x+$y""" & ASCII.LF &
         "   frame .tooltip.frm -bd 1 -relief solid" & ASCII.LF &
         "   label .tooltip.frm.help -text ""$args"" -bg #FFFFAF" & ASCII.LF &
         "   pack .tooltip.frm.help -ipadx 3" & ASCII.LF &
         "   pack .tooltip.frm" & ASCII.LF &
         "   bind .tooltip <Leave> { destroy .tooltip }" & ASCII.LF &
         "   bind .tooltip <ButtonPress-1> { destroy .tooltip; " & ASCII.LF &
         "      catch ""eval [$thewidget cget -command]"" }" & ASCII.LF &
         "   wm deiconify .tooltip" & ASCII.LF &
         "   }" & ASCII.LF &
         "}");
   end Initialize_Tooltip;
   
   ------------------------------------------------
   -- procedure Set_Tooltip_Text
   --
   -- Set tooltip text for a widget
   -- Widget has no tooltip unless this procedure
   -- has been called.
   ------------------------------------------------
   procedure Set_Tooltip_Text(
      Obj  : in out Widget;
      Text : in     String) is
   begin
      if not Tooltip_Initialized then
         Initialize_Tooltip;
      end if;
      
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <Enter> {" &
         "tooltip " & Obj.My_Peer.Name.all & " """ &
         Peer.Fix_Quotes(Text) & """}");
   end Set_Tooltip_Text;

   ----------------
   -- Get_Parent --
   ----------------

   function Get_Parent
     (Obj : in Widget'Class)
      return Mcc.Gui.Container.Container_Pointer
   is
   begin
      return Obj.Parent;
   end Get_Parent;

   -----------
   -- focus --
   -----------
   
   procedure focus (obj : in widget) is
   begin
    --Peer.Eval("focus " & Obj.My_Peer.Name.all);
      Peer.Eval("focus " & Obj.My_Peer.Name.all & ascii.lf & "update");
   end focus; -- 20030404ph20030425

end Mcc.Gui.Widget;