-------------------------------------------------------------------
--           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 Tcl;
with Cargv;
with Cargv_Helpers;
with My_Expanding_Array;
with Interfaces.C;
with Mcc.Gui.Container.Window;
with Mcc.Gui.Widget.Listbox;
with Mcc.Gui.Widget.Dropdown;
with Mcc.Gui.Widget.Label;

package body Mcc.Gui is

   Key_Command   : Tcl.Tcl_Command;
   Mouse_Command : Tcl.Tcl_Command;

   Have_Key_Command   : Boolean := False;
   Have_Mouse_Command : Boolean := False;

   procedure Get_Screen_Dimensions(Width, Height : out Integer) is
   begin
      Peer.Eval("set width [winfo screenwidth .]");
      Peer.Eval("set height [winfo screenheight .]");
      Peer.Get_Value("width",Width);
      Peer.Get_Value("height",Height);
   end Get_Screen_Dimensions;

   procedure Get_Size(
      Obj    : in     Sized_Object;
      Width  :    out Integer;
      Height :    out Integer) is
   begin
      Peer.Eval("set width [winfo width " & Obj.My_Peer.Name.all & "]");
      Peer.Eval("set height [winfo height " & Obj.My_Peer.Name.all & "]");
      Peer.Get_Value("width",Width);
      Peer.Get_Value("height",Height);
   end Get_Size;
   
   -------------
   -- Destroy --
   -------------

   procedure Destroy (Obj : in Object) is
   begin
      Peer.Eval("destroy " & Obj.My_Peer.Name.all);
   end Destroy;

   --------------
   -- Get_Peer --
   --------------

   function Get_Peer (Obj : in Object) return Peer.Peer is
   begin
      return Obj.My_Peer;
   end Get_Peer;

   ----------
   -- Move --
   ----------

   procedure Move
     (Obj : in out Sized_Object;
      X   : in     Integer;
      Y   : in     Integer)
   is
      x_image : string := integer'image(x);
      y_image : string := integer'image(y);
   begin
      if Sized_Object'Class(Obj) in Mcc.Gui.Container.Window.Window'Class then
         Peer.Eval("wm geometry " & Obj.My_Peer.Name.all &
            " +" & x_image(x_image'first+1..x_image'last) &
            "+" & y_image(y_image'first+1..y_image'last));
      else
         Peer.Eval("place " & Obj.My_Peer.Name.all & " -x " &
            integer'image(x) & " -y " &
            integer'image(y));
      end if;
   end Move;

   ------------
   -- Resize --
   ------------

   procedure Resize
     (Obj    : in out Sized_Object;
      Width  : in     Integer;
      Height : in     Integer)
   is
      width_image  : string := integer'image(width);
      height_image : string := integer'image(height);
   begin
      if Sized_Object'Class(Obj) in Mcc.Gui.Container.Window.Window'Class then
         Peer.Eval("wm geometry " & Obj.My_Peer.Name.all &
            " =" & width_image(width_image'first+1..width_image'last) &
            "x" & height_image(height_image'first+1..height_image'last));
      else
         Peer.Eval("place " & Obj.My_Peer.Name.all & " -width " &
            integer'image(width) & " -height " &
            integer'image(height));
      end if;

      -- added 07/27/99 by mcc to solve reconfiguring label
      if Sized_Object'Class(Obj) in Mcc.Gui.Widget.Label.Label'Class then
         Peer.Eval(Obj.My_Peer.Name.all & " configure -width " &
            integer'image(width));
      end if;
   end Resize;

   --------------------------
   -- Set_Background_Color --
   --------------------------

   procedure Set_Background_Color
     (Obj       : in out Sized_Object;
      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 Sized_Object'Class(Obj) in Mcc.Gui.Widget.Listbox.Listbox'Class then
         Peer.Eval(Obj.My_Peer.Name.all & ".list configure -background #" &
            Color_String);
      elsif Sized_Object'Class(Obj) in Mcc.Gui.Widget.Dropdown.Dropdown'Class then
         Peer.Eval(Obj.My_Peer.Name.all & 
            ".top.frame.list configure -background #" &
            Color_String);
      else
         Peer.Eval(Obj.My_Peer.Name.all & " configure -background #" &
            Color_String);
      end if;
   end Set_Background_Color;

   --------------------------
   -- Tcl callback for
   -- key events
   --------------------------
   function Key_Command_Function (
      ClientData : in Integer;
      Interp     : in Tcl.Tcl_Interp;
      Argc       : in Interfaces.C.Int;
      Argv       : in CArgv.Chars_Ptr_Ptr
   ) return Interfaces.C.Int;
   pragma Convention (C, Key_Command_Function);

   -- protocol for arguments will be
   -- 1st argument : lookup into Expanding_Array
   -- 2nd argument : 0 => pressed, 1 => released
   -- 3rd argument : key code
   function Key_Command_Function (
      ClientData : in Integer;
      Interp     : in Tcl.Tcl_Interp;
      Argc       : in Interfaces.C.Int;
      Argv       : in CArgv.Chars_Ptr_Ptr
   ) return Interfaces.C.Int is
     Obj : Sized_Object_Pointer;
     Key_Int    : Integer;
     Action_Int : Integer;
   begin
      Obj := My_Expanding_Array.Retrieve(
         Table    => My_Expanding_Array.Table,
         Location => Cargv_Helpers.Argument(Argv,1));
      Key_Int    := Cargv_Helpers.Argument(Argv,3);
      Action_Int := Cargv_Helpers.Argument(Argv,2);
      Obj.Key_Handler(Obj.all,
         Key_Event'(
            Key    => Key_Type(Key_Int),
            Action => Key_Action_Type'Val(Action_Int)));
      return Tcl.TCL_OK;
   end Key_Command_Function;

   ----------------------
   -- Set_Key_Listener --
   ----------------------

   procedure Set_Key_Listener
     (Obj      : in Sized_Object_Pointer;
      Listener : in Key_Listener)
   is
   begin
      if Obj.My_Peer.Lookup = 0 then
         My_Expanding_Array.Insert(
            Table    => My_Expanding_Array.Table,
            Element  => Obj,
            Location => Obj.My_Peer.Lookup);
      end if;

      if not Have_Key_Command then
         Key_Command := Peer.CreateCommands.Tcl_CreateCommand (
            Peer.Get_Interp,
            "keycommand", Key_Command_Function'access, 0, NULL);
         Have_Key_Command := True;
      end if;

      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <KeyPress> " &
         "{keycommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 0 %k}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <Key-Tab> " &
         "{keycommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 0 9}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <KeyRelease> " &
         "{keycommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 1 %k}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <KeyRelease-Tab> " &
         "{keycommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 1 9}");
      Obj.Key_Handler := Listener;
   end Set_Key_Listener;

   --------------------------
   -- Tcl callback for
   -- mouse events
   --------------------------
   function Mouse_Command_Function (
      ClientData : in Integer;
      Interp     : in Tcl.Tcl_Interp;
      Argc       : in Interfaces.C.Int;
      Argv       : in CArgv.Chars_Ptr_Ptr
   ) return Interfaces.C.Int;
   pragma Convention (C, Mouse_Command_Function);

   -- protocol for arguments will be
   -- 1st argument : lookup into Expanding_Array
   -- 2nd argument : # of mouse button 
   --                0 => None, 1 => left, 2 => middle, 3 => right
   -- 3rd argument : event code
   --                0 => press, 1 => move, 2 => release, 3 => dbl-click
   -- 4th argument : mouse X
   -- 5th argument : mouse Y
   function Mouse_Command_Function (
      ClientData : in Integer;
      Interp     : in Tcl.Tcl_Interp;
      Argc       : in Interfaces.C.Int;
      Argv       : in CArgv.Chars_Ptr_Ptr
   ) return Interfaces.C.Int is
     Obj : Sized_Object_Pointer;
     Button_Int : Integer;
     Event_Int  : Integer;
     Event      : Mouse_Event;
   begin
      Obj := My_Expanding_Array.Retrieve(
         Table    => My_Expanding_Array.Table,
         Location => Cargv_Helpers.Argument(Argv,1));

      Button_Int := Cargv_Helpers.Argument(Argv,2);
      Event_Int  := Cargv_Helpers.Argument(Argv,3);

      Event.Button := Mouse_Button'Val(Button_Int);
      Event.Action := Mouse_Action_Type'Val(Event_Int);
      Event.X      := Cargv_Helpers.Argument(Argv,4);
      Event.Y      := Cargv_Helpers.Argument(Argv,5);
      Obj.Mouse_Handler(Obj.all,Event);
      return Tcl.TCL_OK;
   end Mouse_Command_Function;

   ------------------------
   -- Set_Mouse_Listener --
   ------------------------

   procedure Set_Mouse_Listener
     (Obj      : in Sized_Object_Pointer;
      Listener : in Mouse_Listener)
   is
   begin
      if Obj.My_Peer.Lookup = 0 then
         My_Expanding_Array.Insert(
            Table    => My_Expanding_Array.Table,
            Element  => Obj,
            Location => Obj.My_Peer.Lookup);
      end if;

      if not Have_Mouse_Command then
         Mouse_Command := Peer.CreateCommands.Tcl_CreateCommand (
            Peer.Get_Interp,
            "mousecommand", Mouse_Command_Function'access, 0, NULL);
         Have_Mouse_Command := True;
      end if;

      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <ButtonPress> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " %b 0 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <ButtonRelease> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " %b 2 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <Button1-Motion> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 1 1 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <Button2-Motion> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 2 1 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <Button3-Motion> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 3 1 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all & " <Motion> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 0 1 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all &
         " <Double-ButtonPress-1> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 1 3 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all &
         " <Double-ButtonPress-2> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 2 3 %x %y}");
      Peer.Eval("bind " & Obj.My_Peer.Name.all &
         " <Double-ButtonPress-3> " &
         "{mousecommand " & Integer'Image(Obj.My_Peer.Lookup) &
         " 3 3 %x %y}");
      Obj.Mouse_Handler := Listener;
   end Set_Mouse_Listener;

   ------------------------------------------------
   -- procedure Set_Cursor
   --
   -- change which cursor will be displayed when
   -- mouse is over this object
   ------------------------------------------------
   procedure Set_Cursor(
      Obj    : in Sized_Object;
      Cursor : in Cursor_Type) is
      function Cursor_String(Cursor : in Cursor_Type) return String is
      begin
         case Cursor is
            when Default_Cursor =>
               return "{}";
            when Resize_NW =>
               return "top_left_corner";
            when Resize_N =>
               return "top_side";
            when Resize_NE =>
               return "top_right_corner";
            when Resize_E =>
               return "right_side";
            when Resize_SE =>
               return "bottom_right_corner";
            when Resize_S =>
               return "bottom_side";
            when Resize_SW =>
               return "bottom_left_corner";
            when Resize_W =>
               return "left_side";
            when Move_Cursor =>
               return "fleur";
         end case;
      end Cursor_String;
   begin
      Peer.Eval(Obj.My_Peer.Name.all & " configure -cursor " &
         Cursor_String(Cursor));
   end Set_Cursor;

   procedure Bell is
   begin
      Peer.Eval("bell");
   end Bell;

   ----------------------
   -- Get_Key_Listener --
   ----------------------

   function Get_Key_Listener
     (Obj : in Sized_Object'Class)
      return Key_Listener
   is
   begin
      return Obj.Key_Handler;
   end Get_Key_Listener;

   ------------------------
   -- Get_Mouse_Listener --
   ------------------------

   function Get_Mouse_Listener
     (Obj : in Sized_Object'Class)
      return Mouse_Listener
   is
   begin
      return Obj.Mouse_Handler;
   end Get_Mouse_Listener;
end Mcc.Gui;