--------------------------------------------------------------------------------
--                                                                            --
-- 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 System;                  use System;
with Interfaces.C;            use Interfaces.C;
with Kernel;                  use Kernel;


package body RASCAL.WimpMenu is

   Wimp_CreateMenu : constant := 16#400D4#;

   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 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 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_Item (Menu          : in out Menu_Type;
                       Item          : in 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!
      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 Menu.Max_Items = (Item+1) and then Item = 0 then
          Flags := MenuFlags_both;
        elsif Menu.Max_Items = (Item+1) then
          Flags := MenuFlags_last;
        elsif Item = 0 then
          Flags := MenuFlags_first;
        else
          Flags := MenuFlags;
        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_Item;

   --

   function Get_Item (Menu : in Menu_Type;
                      Item : in Natural) return String is
   
      Adr_Offset : Integer;
   begin
      Adr_Offset := 28 + Item * 24;
      return MemoryToString(Integer_To_Adr(GetWord(Menu.Pointer,Adr_Offset+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 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;