with Mcc.Gui.Container.Frame;
with Mcc.Gui.Container.Window;
with Expanding_Array;
with Ada.Strings.Bounded;
with Tcl;
with Interfaces.C;
with Cargv;
with Cargv_Helpers;
with Ada.Characters.Handling;
with Ada.Unchecked_Conversion;
package body Mcc.Gui.Menu is
   type Parent_Access is access constant Menu'Class; 
   function Convert is 
   new Ada.Unchecked_Conversion(
      Parent_Access,Menu_Pointer);

   Menu_Command : Tcl.Tcl_Command;  

   Have_Menu_Command : Boolean := False;  

   package Menu_Expanding_Array is new Expanding_Array(Menu_Callback,100);
   Menu_Table : Menu_Expanding_Array.Expander;  

   --------------------------
   -- Tcl callback for
   -- Push events
   --------------------------
   function Menu_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, Menu_Command_Function);

   -- protocol for arguments will be
   -- 1st argument : lookup into Expanding_Array
   function Menu_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 
      Callback : Menu_Callback;  
      Number   : Integer       := Cargv_Helpers.Argument (Argv, 1);  
   begin
      Callback := Menu_Expanding_Array.Retrieve(
        Table    => Menu_Table, 
        Location => Number);
      if Callback /= null then
         Callback.all;
      end if;
      return Tcl.Tcl_Ok;
   end Menu_Command_Function;

   -- call Init_Menu_Command to make
   -- sure the command is ready to go
   procedure Init_Menu_Command is 
   begin
      if not Have_Menu_Command then
         Menu_Command := Peer.Createcommands.Tcl_Createcommand (
            Peer.Get_Interp,
            "menucommand", Menu_Command_Function'access, 0, null);
         Have_Menu_Command := True;
      end if;
   end Init_Menu_Command;

   -- Translate accelerator to Tcl format 
   -- converts Ctrl to Control
   -- converts + to -
   -- converts Del to Delete
   -- converts Ins to Insert
   -- converts F1..F12 to Key-F1..Key-F12
   function Translate_Accelerator (
         Accelerator : in     String ) 
     return String is 
      package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length(
         80);
      use type Bounded.Bounded_String;
      Result : Bounded.Bounded_String := Bounded.Null_Bounded_String;  
      Count  : Integer                := Accelerator'First;  
   begin
      while Count <= Accelerator'Last loop
         if Count+3 <= Accelerator'Last and then
               Accelerator(Count..Count+3) = "Ctrl" then
            Result := Result & "Control";
            Count := Count + 4;
         elsif Count+2 <= Accelerator'Last and then
               Accelerator(Count..Count+2) = "Del" then
            Result := Result & "Delete";
            Count := Count + 3;
         elsif Accelerator(Count) = '+' then
            Result := Result & "-";
            Count := Count + 1;
         else
            if Accelerator(Count) /= 'F' or else
                  Count = Accelerator'Last or else
                  not Ada.Characters.Handling.Is_Digit(Accelerator(Count+
                     1)) then
               declare
                  Newresult : String := Accelerator (Count .. Accelerator'Last);
               begin
                  for I in Newresult'range loop
                     Newresult(I) := Ada.Characters.Handling.To_Lower(
                        Newresult(I));
                  end loop;
                  Result := Result & ("Key-" & Newresult);
               end;
            else
               Result := Result & ("Key-" & Accelerator(Count..
                     Accelerator'Last));
            end if;
            Count := Accelerator'Last + 1;
         end if;
      end loop;
      return Bounded.To_String(Result);
   end Translate_Accelerator;

   -- perform key binding for 
   procedure Do_Accelerator (
         Accelerator : in     String; 
         Menu_Name   : in     String; 
         Lookup      : in     Natural ) is 
      -- find name of window so we can bind keys in it
      function Get_Window_Name return String is 
         Stop : Natural := Menu_Name'First;  
      begin
         loop
            exit when Menu_Name(Stop..Stop+7) = ".menubar" or else
               Menu_Name(Stop..Stop+7) = ".frmmenu";
            Stop := Stop + 1;
         end loop;
         return Menu_Name(Menu_Name'First..Stop-1);
      end Get_Window_Name;
      Lookup_Image           : String := Integer'Image (Lookup);  
      Translated_Accelerator : String := Translate_Accelerator (Accelerator);
         
   begin
      if Menu_Name(Menu_Name'First..Menu_Name'First+7) = ".menubar" then
         Peer.Eval("bind all <" & Translated_Accelerator &
            "> {menucommand " & Lookup_Image & "}");
      else
         Peer.Eval("bind " & Get_Window_Name &
            " <" & Translated_Accelerator &
            "> {menucommand " & Lookup_Image & "}");
      end if;
   end Do_Accelerator;

   ----------------
   -- Add_Choice --
   ----------------
   procedure Add_Choice (
         Obj         : in out Choice;             
         To_Menu     : in     Menu'Class;         
         Text        : in     String;             
         Action      : in     Menu_Callback;      
         Underline   : in     Natural;            
         Accelerator : in     String        := "" ) is 
      Last : Natural := To_Menu.My_Peer.Name.
      all'Last;
   begin
      Init_Menu_Command;

      Obj.Parent := Convert(To_Menu'Unchecked_Access);

      -- if we are a choice in a frame's menu, then do (e.g.):
      -- menubutton .menubar.m1 -text "File" -underline 0
      if To_Menu.My_Peer.Name(Last-6..Last)="frmmenu" then
         Obj.My_Peer := Peer.Create_Peer(To_Menu.My_Peer);
         Menu_Expanding_Array.Insert(
           Table    => Menu_Table,        
           Element  => Action,            
           Location => Obj.My_Peer.Lookup);
         Obj.Text := new String'(Text);
         Peer.Eval("menubutton " & Obj.My_Peer.Name.all &
            " -text """ & Peer.Fix_Quotes(Text) &
            """ -underline " & Integer'Image(Underline-1) &
            " -menu " & Obj.My_Peer.Name.all & ".menu");
         Peer.Eval("pack " & Obj.My_Peer.Name.all &
            " -side left");
         Peer.Eval("menu " & Obj.My_Peer.Name.all & ".menu" &
            " -tearoff 0");
         Peer.Eval(Obj.My_Peer.Name.all & ".menu configure -postcommand " &
            " {menucommand" &
            Integer'Image(Obj.My_Peer.Lookup) & "}");
         -- otherwise, do (e.g.):
         -- .menubar add command -label "File" -underline 0
         --    -command {...} -accelerator "Ctrl+N"
      else
         Menu_Expanding_Array.Insert(
           Table    => Menu_Table,        
           Element  => Action,            
           Location => Obj.My_Peer.Lookup);
         Obj.My_Peer.Name := To_Menu.My_Peer.Name;
         Obj.Text := new String'(Text);
         Peer.Eval(To_Menu.My_Peer.Name.all &
            " add command -label """ & Peer.Fix_Quotes(Text) &
            """ -underline " & Integer'Image(Underline-1) &
            " -accelerator """ & Accelerator & """" &
            " -command {menucommand" &
            Integer'Image(Obj.My_Peer.Lookup) & "}");
      end if;
      if Accelerator /= "" then
         Do_Accelerator(Accelerator,Obj.My_Peer.Name.all,Obj.My_Peer.
            Lookup);
      end if;
   end Add_Choice;

   ----------------
   -- Add_Choice --
   ----------------

   procedure Add_Choice (
         Obj         : in out Choice;             
         To_Menu     : in     Menu'Class;         
         Text        : in     String;             
         Action      : in     Menu_Callback;      
         Underline   : in     Natural;            
         Location    : in     Natural;            
         Accelerator : in     String        := "" ) is 
      Last : Natural := To_Menu.My_Peer.Name.
      all'Last;
   begin
      Init_Menu_Command;
      Menu_Expanding_Array.Insert(
        Table    => Menu_Table,        
        Element  => Action,            
        Location => Obj.My_Peer.Lookup);

      -- if we are a choice in a frame's menu, then we
      -- can't do the insertion
      if To_Menu.My_Peer.Name(Last-6..Last)="frmmenu" then
         raise Unimplemented;
         -- otherwise, do (e.g.):
         -- .menubar add command -label "File" -underline 0
         --    -command {...} -accelerator "Ctrl+N"
      else
         Obj.My_Peer.Name := To_Menu.My_Peer.Name;
         Obj.Text := new String'(Text);
         Obj.Parent := Convert(To_Menu'Unchecked_Access);

         Peer.Eval(To_Menu.My_Peer.Name.all &
            " insert " & Integer'Image(Location) &
            " command -label """ & Peer.Fix_Quotes(Text) &
            """ -underline " & Integer'Image(Underline-1) &
            " -accelerator """ & Accelerator & """" &
            " -command {menucommand" &
            Integer'Image(Obj.My_Peer.Lookup) & "}");
      end if;
      if Accelerator /= "" then
         Do_Accelerator(Accelerator,Obj.My_Peer.Name.all,Obj.My_Peer.
            Lookup);
      end if;
   end Add_Choice;

   -----------------
   -- Add_Submenu --
   -----------------

   procedure Add_Submenu (
         Obj         : in out Submenu;              
         Text        : in     String;               
         Underline   : in     Natural;              
         Parent_Menu : in     Menu'Class;           
         On_Post     : in     Menu_Callback := null ) is 
      Last : Natural := Parent_Menu.My_Peer.Name.
      all'Last;
      Menu_Name : Peer.String_Pointer;  
   begin
      Obj.My_Peer := Peer.Create_Peer(Parent_Menu.My_Peer);
      Obj.Text := new String'(Text);
      Obj.Parent := Convert(Parent_Menu'Unchecked_Access);

      Menu_Name := new String'(Obj.My_Peer.Name.all & ".menu");

      -- if we are a choice in a frame's menu, then do (e.g.):
      -- menubutton .menubar.m1 -text "File" -underline 0
      --    -menu .menubar.m1.menu
      if Parent_Menu.My_Peer.Name(Last-6..Last)="frmmenu" then
         Peer.Eval("menubutton " & Obj.My_Peer.Name.all &
            " -text """ & Peer.Fix_Quotes(Text) &
            """ -underline " & Integer'Image(Underline-1) &
            " -menu " & Menu_Name.all);
         Peer.Eval("pack " & Obj.My_Peer.Name.all &
            " -side left");
         Peer.Free_String(Obj.My_Peer.Name);
         Obj.My_Peer.Name := Menu_Name;
         -- otherwise, do (e.g.):
         -- .menubar add cascade -label "File" -underline 0
         --    -menu .menubar.m1
      else
         Obj.My_Peer := Peer.Create_Peer(Parent_Menu.My_Peer);
         Peer.Eval(Parent_Menu.My_Peer.Name.all &
            " add cascade -label """ & Peer.Fix_Quotes(Text) &
            """ -underline " & Integer'Image(Underline-1) &
            " -menu " & Obj.My_Peer.Name.all);
      end if;

      if On_Post /= null then
         Init_Menu_Command;
         Menu_Expanding_Array.Insert(
           Table    => Menu_Table,        
           Element  => On_Post,           
           Location => Obj.My_Peer.Lookup);
         Peer.Eval("menu " & Obj.My_Peer.Name.all & " -postcommand " &
            " {menucommand" &
            Integer'Image(Obj.My_Peer.Lookup) & "}");
      else
         Peer.Eval("menu " & Obj.My_Peer.Name.all);
      end if;
   end Add_Submenu;

   -----------------
   -- Add_Submenu --
   -----------------

   procedure Add_Submenu (
         Obj         : in out Submenu;              
         Text        : in     String;               
         Underline   : in     Natural;              
         Parent_Menu : in     Menu'Class;           
         Location    : in     Natural;              
         On_Post     : in     Menu_Callback := null ) is 
      Last : Natural := Parent_Menu.My_Peer.Name.
      all'Last;
   begin

      -- if we are a choice in a frame's menu, then we
      -- can't do anything-- raise Unimplemented
      if Parent_Menu.My_Peer.Name(Last-6..Last)="frmmenu" then
         raise Unimplemented;
         -- otherwise, do (e.g.):
         -- .menubar insert 3 cascade -label "File" -underline 0
         --    -menu .menubar.m1.menu
      else
         Obj.Text := new String'(Text);
         Obj.My_Peer := Peer.Create_Peer(Parent_Menu.My_Peer);
         Obj.Parent := Convert(Parent_Menu'Unchecked_Access);
         Peer.Eval(Parent_Menu.My_Peer.Name.all &
            " insert " & Integer'Image(Location) &
            " cascade -label """ & Peer.Fix_Quotes(Text) &
            """ -underline " & Integer'Image(Underline-1) &
            " -menu " & Obj.My_Peer.Name.all);
      end if;

      if On_Post /= null then
         Init_Menu_Command;
         Menu_Expanding_Array.Insert(
           Table    => Menu_Table,        
           Element  => On_Post,           
           Location => Obj.My_Peer.Lookup);

         Peer.Eval("menu " & Obj.My_Peer.Name.all & " -postcommand " &
            " {menucommand" &
            Integer'Image(Obj.My_Peer.Lookup) & "}");
      else
         Peer.Eval("menu " & Obj.My_Peer.Name.all);
      end if;
   end Add_Submenu;

   ------------
   -- Create --
   ------------

   procedure Create (
         Obj    : in out Window_Menu;                      
         Window : in     Mcc.Gui.Container.Container'Class ) is 
   begin
      Obj.Parent := null;
      if Window in Mcc.Gui.Container.Window.Window'Class then
         -- in a window, use the following code: (e.g.)
         -- menu .menubar -type menubar
         -- . configure -menu .menubar
         if Mcc.Gui.Container.Get_Peer(Window).Name.all = "." then
            Obj.My_Peer.Name := new String'(".menubar");
         else
            Obj.My_Peer.Name := new String'(
               Mcc.Gui.Container.Get_Peer(Window).Name.all & ".menubar");
         end if;
         -- in this peculiar block of code,
         -- I get the window size, add something to the menu
         -- resize the window (so it is the right size with the menu)
         -- and then delete the dummy item
         Peer.Eval("set geometry [winfo geometry " &
            Mcc.Gui.Container.Get_Peer(Window).Name.all & "]");
         Peer.Eval("menu " & Obj.My_Peer.Name.all &
            " -type menubar");
         Peer.Eval(Mcc.Gui.Container.Get_Peer(Window).Name.all & " configure -menu " &
            Obj.My_Peer.Name.all);
         Peer.Eval(Obj.My_Peer.Name.all & " add cascade -label ""Z""" &
            ASCII.LF & "update");
         Peer.Eval("wm geometry " & Mcc.Gui.Container.Get_Peer(Window).Name.all & 
            " $geometry");
         Peer.Eval(Obj.My_Peer.Name.all & " delete 1");
      elsif Window in Mcc.Gui.Container.Frame.Frame'Class then
         -- in a frame, use the following code: (e.g.)
         -- frame .menubar -relief raised -borderwidth 1
         -- place .menubar -x 0 -y -0 -relwidth 1.0
         if Mcc.Gui.Container.Get_Peer(Window).Name.all = "." then
            Obj.My_Peer.Name := new String'(".frmmenu");
         else
            Obj.My_Peer.Name := new String'(
               Mcc.Gui.Container.Get_Peer(Window).Name.all & ".frmmenu");
         end if;
         Peer.Eval("frame " & Obj.My_Peer.Name.all &
            " -relief raised -borderwidth 1");
         Peer.Eval("place " & Obj.My_Peer.Name.all &
            " -x 0 -y 0 -relwidth 1.0");
      else
         raise Unimplemented;
      end if;
   end Create;


   --------------------------------------------------
   -- function Get_Parent_Menu
   --
   -- returns parent menu name
   -- remove up to last . and 1 more if ending in .menu
   --------------------------------------------------
   function Get_Parent_Menu (
         Menu_Name : in     String ) 
     return String is 
      Last : Natural := Menu_Name'Last;  
   begin
      if Menu_Name(Last-4..Last) = ".menu" then
         return Get_Parent_Menu(Menu_Name(Menu_Name'First..Last-5));
      end if;

      while Menu_Name(Last) /= '.' loop
         Last := Last -1;
      end loop;

      return Menu_Name(Menu_Name'First..Last-1);
   end Get_Parent_Menu;

   ------------
   -- Delete --
   ------------

   procedure Delete (
         Obj : in out Menu_Item ) is 
   begin
      if Menu_Item'Class(Obj) in Window_Menu'Class then
         Peer.Eval("destroy " & Obj.My_Peer.Name.all);
      elsif Menu_Item'Class(Obj) in Submenu'Class then
         declare
            Parent_Menu : String := Get_Parent_Menu (Obj.My_Peer.Name.
            all);
         begin
            if Parent_Menu(Parent_Menu'Last-7..Parent_Menu'Last) =
                  ".frmmenu" then
               Peer.Eval("destroy " &
                  Obj.My_Peer.Name.all(Obj.My_Peer.Name.all'First..
                     Obj.My_Peer.Name.all'Last-5));
            else
               Peer.Eval(Parent_Menu &
                  " delete """ & Peer.Fix_Quotes(Obj.Text.all) &
                  """");
            end if;
         end;
      elsif Menu_Item'Class(Obj) in Choice'Class then
         Peer.Eval(Obj.My_Peer.Name.all &
            " delete """ & Peer.Fix_Quotes(Obj.Text.all) &
            """");
      end if;
   end Delete;

   -------------
   -- Disable --
   -------------

   procedure Disable (
         Obj : in out Choice ) is 
   begin
      Peer.Eval(Obj.My_Peer.Name.all & " entryconfigure """ &
         Peer.Fix_Quotes(Obj.Text.all) & """ -state disabled");
   end Disable;

   ------------
   -- Enable --
   ------------

   procedure Enable (
         Obj : in out Choice ) is 
   begin
      Peer.Eval(Obj.My_Peer.Name.all & " entryconfigure """ &
         Peer.Fix_Quotes(Obj.Text.all) & """ -state normal");
   end Enable;

   procedure Add_Separator (
         Obj     : in out Separator; 
         To_Menu : in     Menu'Class ) is 
   begin
      Peer.Eval(To_Menu.My_Peer.Name.all &
         " add separator");
   end Add_Separator;

   procedure Add_Separator (
         Obj      : in out Separator;  
         To_Menu  : in     Menu'Class; 
         Location : in     Natural     ) is 
      Last : Natural := To_Menu.My_Peer.Name.
      all'Last;
   begin
      -- if we are a choice in a frame's menu, then we
      -- can't do anything-- raise Unimplemented
      if To_Menu.My_Peer.Name(Last-6..Last)="frmmenu" then
         raise Unimplemented;
         -- otherwise, do (e.g.):
         -- .menubar insert 3 separator
      else
         Peer.Eval(To_Menu.My_Peer.Name.all &
            " insert " & Integer'Image(Location) &
            " separator");
      end if;
   end Add_Separator;

end Mcc.Gui.Menu;