--------------------------------------------------------------------------------
--                                                                            --
-- Copyright (C) 2004, RISC OS Ada Library (RASCAL) developers.               --
--                                                                            --
-- This library is free software; you can redistribute it and/or              --
-- modify it under the terms of the GNU Lesser General Public                 --
-- License as published by the Free Software Foundation; either               --
-- version 2.1 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 the GNU           --
-- Lesser General Public License for more details.                            --
--                                                                            --
-- You should have received a copy of the GNU Lesser General Public           --
-- License along with this library; if not, write to the Free Software        --
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA    --
--                                                                            --
--------------------------------------------------------------------------------

-- $Author$
-- $Date$
-- $Revision$

with RASCAL.Utility;          use RASCAL.Utility;

with Interfaces.C;            use Interfaces.C;
with Kernel;                  use Kernel;


package body RASCAL.WimpMenu is

   Wimp_CreateMenu    : constant := 16#400D4#;
   Wimp_CreateSubMenu : constant := 16#400E8#;

   type nullmemtyp is array (0..1) of Integer;
   nullmem : nullmemtyp;

   --

   Current_Menu : Menu_Type;
   Current_X    : Integer;
   Current_Y    : Integer;

   --

   function Init (Items : in Natural) return Menu_Type is

      Menu : Menu_Type;
   begin
      Menu.Pointer   := Memory.Allocate(28 + Items*24);
      Menu.Max_Items := Items;
      Menu.Items     := 0;
      Set_Colours(Menu);
      Set_Parameters(Menu);
      return Menu;
   end Init;

   --

   procedure Create (MenuPtr : in Integer;
                     X       : in Integer;
                     Y       : in Integer) is
   
      Register : aliased Kernel.swi_regs;
      Error    : oserror_access;
   begin
      Register.R(1) := int(Menuptr);
      Register.R(2) := int(X);
      Register.R(3) := int(Y);
      Error := Kernel.swi (Wimp_CreateMenu, Register'Access, Register'Access );
      if Error /= null then
         pragma Debug(Report("Menu.Create: " & To_Ada(Error.ErrMess)));
         OS.Raise_Error(Error);
      end if;
   end Create;

   --

   procedure Create_SubMenu (MenuPtr : in Integer;
                             X       : in Integer;
                             Y       : in Integer) is
   
      Register : aliased Kernel.swi_regs;
      Error    : oserror_access;
   begin
      Register.R(1) := int(Menuptr);
      Register.R(2) := int(X);
      Register.R(3) := int(Y);
      Error := Kernel.swi (Wimp_CreateSubMenu, Register'Access, Register'Access );
      if Error /= null then
         pragma Debug(Report("Menu.Create_Sub: " & To_Ada(Error.ErrMess)));
         OS.Raise_Error(Error);
      end if;
   end Create_SubMenu;

   --

   procedure Open (Menu : in Menu_Type;
                   X    : in Integer;
                   Y    : in Integer) is
   begin
      Current_Menu := Menu;
      Current_X    := X;
      Current_Y    := Y;
      Create(Adr_To_Integer(Menu.Pointer),x,y);
   end Open;

   --

   procedure Reopen is
   begin
      Open (Current_Menu,Current_x,Current_y);
   end Reopen;

   --

   procedure Open_SubMenu (Menu : in Menu_Type;
                           X    : in Integer;
                           Y    : in Integer) is
   begin
      Current_Menu := Menu;
      Current_X    := X;
      Current_Y    := Y;
      Create_SubMenu(Adr_To_Integer(Menu.Pointer),x,y);
   end Open_SubMenu;

   --

   procedure Close is
   begin
      Create (-1,0,0);
   end Close;

   --

   function Current return Menu_Type is
   begin
      return Current_Menu;
   end Current;

   --

   procedure Set_Title (Menu  : in Menu_Type;
                        Title : in String) is
   
      length   : Integer := Title'length + 1;
      MemBlock : mem_adr_Type;
   begin
      MemBlock := Memory.Allocate(length);
      PutWord (Adr_To_Integer(MemBlock), Menu.Pointer);
      PutWord (length, Menu.Pointer,8);
      StringToMemory (title,MemBlock);
   end Set_Title;

   --

   function Get_Title (Menu : in Menu_Type) return String is
   begin
      return MemoryToString (Integer_To_Adr(GetWord(Menu.Pointer)));
   end Get_Title;

   --

   procedure Add_Last_Item (Menu          : in out Menu_Type;
                            Item          : out Natural;
                            Name          : in String;
                            Reserve_Space : in Natural := 0;
                            Tick          : in Boolean := false;
                            Dotted        : in Boolean := false;
                            Writable      : in Boolean := false;
                            Message       : in Boolean := false;
                            SubMenu       : in Boolean := false) is
   
      MenuFlags_first : constant := 256;
      MenuFlags       : constant := 0;
      MenuFlags_last  : constant := 128;
      MenuFlags_both  : constant := 256+128;
      
      MenuiconFlags   : constant := 2#00000111000000000000000100110001#;
      
      Flags : Integer := 0;
      
      Adr_Offset : Integer;
      Menu_Adr   : Address := Menu.Pointer;
      TextLength : Natural := Name'length + 1;
      Text_Adr   : mem_adr_Type;
   begin
      Item := Menu.Items;
      Adr_Offset := 28 + Item * 24;
      if Menu.Max_Items <= Item then
         Item := 0; -- error case!
         raise too_many_menu_items;
      else
         if reserve_space = 0 then
            Text_Adr := Memory.Allocate(TextLength);
            StringToMemory(name,Text_Adr);
         else
            Text_Adr := Memory.Allocate(reserve_space+1);
            if reserve_space > TextLength then
              StringToMemory(name,Text_Adr,0,reserve_space+1);
            else
              StringToMemory(name(name'first..name'first+reserve_space),
                             Text_Adr);
            end if;
            TextLength := reserve_space + 1;
         end if;
         -- set base MenuFlags: title indirected, last Item etc...
         if Item = 0 then
            Flags := MenuFlags_both;
         else
            Flags := MenuFlags_last;
            PutWord(GetWord(Menu_Adr,28 + (Item-1) * 24)-MenuFlags_last,Menu_Adr,28 + (Item-1) * 24);
         end if;
         -- set special MenuFlags
         if tick then
            Flags := Flags + 1;
         end if;
         if dotted then
            Flags := Flags + 2;
         end if;
         if writable then
            Flags := Flags + 4;
         end if;
         if message then
            Flags := Flags + 8;
         end if;
         if SubMenu then
            Flags := Flags + 16;
         end if;
         -- write Menu structure to memory
         PutWord(Flags,Menu_Adr,Adr_Offset);
         PutWord(-1,Menu_Adr,Adr_Offset + 4);
         PutWord(MenuiconFlags,Menu_Adr,Adr_Offset + 8);
         PutWord(Adr_To_Integer(Text_Adr),Menu_Adr,Adr_Offset + 12);
         PutWord(Adr_To_Integer(nullmem'Address),Menu_Adr,Adr_Offset + 16);
         PutWord(TextLength,Menu_Adr,Adr_Offset + 20);
         Menu.Items := Item + 1;
      end if;
   end Add_Last_Item;

   --

   procedure Add_Last_Item (Menu          : in out Menu_Type;
                            Item          : out Natural;
                            Item_Flags    : in System.Unsigned_Types.Unsigned;
                            Icon_Flags    : in System.Unsigned_Types.Unsigned;
                            Icon_Data     : in Icon_Data_String) is
   
      MenuFlags_last  : constant System.Unsigned_Types.Unsigned := 128;
      MenuFlags_both  : constant System.Unsigned_Types.Unsigned := 256+128;
      Flags : System.Unsigned_Types.Unsigned;
      
      Adr_Offset : Integer;
      Menu_Adr   : Address := Menu.Pointer;
   begin
      Item := Menu.Items;
      Adr_Offset := 28 + Item * 24;
      if Menu.Max_Items <= Item then
         Item := 0; -- error case!
         raise too_many_menu_items;
      else
         if Item = 0 then
            Flags := Item_Flags+MenuFlags_both;
         else
            Flags := Item_Flags+MenuFlags_last;
            PutWord(Unsigned_To_Int(Int_To_Unsigned(GetWord(Menu_Adr,28 + (Item-1) * 24))-MenuFlags_last),Menu_Adr,28 + (Item-1) * 24);
         end if;
         PutWord(Unsigned_To_Int(Flags),Menu_Adr,Adr_Offset);
         PutWord(-1,Menu_Adr,Adr_Offset + 4);
         PutWord(Unsigned_To_Int(Icon_Flags),Menu_Adr,Adr_Offset + 8);
         StringToMemory(Icon_Data,Menu_Adr,Adr_Offset+12);
         Menu.Items := Item + 1;
      end if;
   end Add_Last_Item;

   --

   function Get_Item (Menu : in Menu_Type;
                      Item : in Natural) return String is   
   begin
      return Get_Item(Menu.Pointer,Item);
   end Get_Item;

   --

   function Get_Item (Menu : in Address;
                      Item : in Natural) return String is
   
      Adr_Offset : Integer := 28 + Item * 24;
   begin
      --return MemoryToString(Integer_To_Adr(GetWord(Menu,Adr_Offset+12)));
      return MemoryToString(Menu,Adr_Offset+12,12);
   end Get_Item;

   --

   procedure Change_Item (Menu : in Menu_Type;
                          Item : in Natural;
                          name : in String) is
   
      DummyString : Ustring;
      ItemAddress : Address;
      Adr_Offset  : Integer;
   begin
      Adr_Offset := 28 + Item * 24;
      DummyString := U(Get_Item (Menu,Item));
      ItemAddress := Integer_To_Adr(GetWord(Menu.Pointer,Adr_Offset+12));

--   --  if S(dummystring)'Length > name'Length then
--   --    Deallocate (Integer_To_Adr(GetWord(Itemaddress,Adr_Offset+12)));
--   --    StringToMemory(name,To_Adr(Allocate(name'Length + 1)));
--   --  else
      StringToMemory (Name,ItemAddress);
   --  end if;
   end Change_Item;

   --

   procedure Change_ItemCount (Menu      : in out Menu_Type;
                               New_Count : in Natural) is
   begin
      Menu.Items := New_Count;
   end Change_ItemCount;

   --

   procedure Shade_Item (Menu : in Menu_Type;
                         Item : in Natural;
                         shade: in Boolean := true) is
   
      Adr_Offset  : Integer;
      IconFlags   : Integer;
      Itemaddress : Address := Menu.Pointer;
   begin
      Adr_Offset := 28 + Item * 24 + 8;
      IconFlags := GetWord(Itemaddress,Adr_Offset);
      if shade then
        IconFlags := IconFlags or 16#00400000#;
      else
        IconFlags := IconFlags and 16#FFBFFFFF#;
      end if;
      PutWord (iconFlags,Itemaddress,Adr_Offset);
   end Shade_Item;

   --

   procedure Tick_Item (Menu : in Menu_Type;
                        Item : in Natural;
                        tick : in Boolean := true) is
   
   
      Adr_Offset  : Integer;
      MenuFlags   : Integer;
      Itemaddress : Address := Menu.Pointer;
   begin
      Adr_Offset := 28 + Item * 24;
      MenuFlags  := GetWord(Itemaddress,Adr_Offset);
      if tick then
        MenuFlags := MenuFlags or 16#00000001#;
      else
        MenuFlags := MenuFlags and 16#FFFFFFFE#;
      end if;
      PutWord (MenuFlags,Itemaddress,Adr_Offset);
   end Tick_Item;

   --

   procedure Attach_Window (Menu : in Menu_Type;
                            Item : in Natural;
                            wh   : in Wimp_Handle_Type) is
   
      Adr_Offset : Integer;
   begin
      Adr_Offset := 28 + Item * 24;
      PutWord(Integer(wh),Menu.Pointer,Adr_Offset + 4);
   end Attach_Window;

   --

   procedure Attach_SubMenu (Menu    : in Menu_Type;
                             Item    : in Natural;
                             SubMenu : in Menu_Type) is
   
      Adr_Offset : Integer;
   begin
      Adr_Offset := 28 + Item * 24;
      PutWord(Adr_To_Integer(SubMenu.Pointer),Menu.Pointer,Adr_Offset + 4);
   end Attach_SubMenu;

   --

   procedure Set_Colours (Menu         : in Menu_Type;
                          Title_FG     : in Integer := 7;
                          Title_BG     : in Integer := 2;
                          Work_Area_FG : in Integer := 7;
                          Work_Area_BG : in Integer := 0) is
   
      Menu_Adr : Address := Menu.Pointer;
   begin
      PutByte (Title_FG,Menu_Adr,12);
      PutByte (Title_BG,Menu_Adr,13);
      PutByte (Work_Area_FG,Menu_Adr,14);
      PutByte (Work_Area_BG,Menu_Adr,15);
   end Set_Colours;

   --

   procedure Get_Colours (Menu         : in Menu_Type;
                          Title_FG     : out Integer;
                          Title_BG     : out Integer;
                          Work_Area_FG : out Integer;
                          Work_Area_BG : out Integer) is
   
      Menu_Adr : Address := Menu.Pointer;
   begin
      Title_FG := GetByte (Menu_Adr,12);
      Title_BG := GetByte (Menu_Adr,13);
      Work_Area_FG := GetByte (Menu_Adr,14);
      Work_Area_BG := GetByte (Menu_Adr,15);
   end Get_Colours;

   --

   procedure Set_Parameters (Menu   : in Menu_Type;
                             Width  : in Integer := 0;
                             Height : in Integer := 44;
                             Gap    : in Integer := 0) is
   
      Menu_Adr : Address := Menu.Pointer;
   begin
      PutWord (Width,Menu_Adr,16);
      PutWord (Height,Menu_Adr,20);
      PutWord (Gap,Menu_Adr,24);
   end Set_Parameters;

   --

   procedure Get_Parameters (Menu   : in Menu_Type;
                             Width  : out Integer;
                             Height : out Integer;
                             Gap    : out Integer) is
   
      Menu_Adr : Address := Menu.Pointer;
   begin
      Width  := GetWord (Menu_Adr,16);
      Height := GetWord (Menu_Adr,20);
      Gap    := GetWord (Menu_Adr,24);
   end Get_Parameters;

   --

   function Get_Pointer (Menu : in Menu_Type) return Mem_Adr_Type is   
   begin
      Return Menu.Pointer;
   end GeT_Pointer;

   --

end RASCAL.WimpMenu;