terminal_interface-curses-menus.adb

ncurses 库 可能有用酒用 没用就算了 我觉得还可以用

      Res : constant C_Int := Get_Itemindex (Itm);
   begin
      if Res = Curses_Err then
         raise Menu_Exception;
      end if;
      return Positive (Natural (Res) + Positive'First);
   end Get_Index;
-------------------------------------------------------------------------------
   procedure Post (Men  : in Menu;
                   Post : in Boolean := True)
   is
      function M_Post (Men : Menu) return C_Int;
      pragma Import (C, M_Post, "post_menu");
      function M_Unpost (Men : Menu) return C_Int;
      pragma Import (C, M_Unpost, "unpost_menu");

      Res : Eti_Error;
   begin
      if Post then
         Res := M_Post (Men);
      else
         Res := M_Unpost (Men);
      end if;
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Post;
-------------------------------------------------------------------------------
   procedure Set_Options (Men     : in Menu;
                          Options : in Menu_Option_Set)
   is
      function Set_Menu_Opts (Men : Menu;
                              Opt : C_Int) return C_Int;
      pragma Import (C, Set_Menu_Opts, "set_menu_opts");

      Opt : constant C_Int := MOS_2_CInt (Options);
      Res : Eti_Error;
   begin
      Res := Set_Menu_Opts (Men, Opt);
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Options;

   procedure Switch_Options (Men     : in Menu;
                             Options : in Menu_Option_Set;
                             On      : in Boolean := True)
   is
      function Menu_Opts_On (Men : Menu;
                             Opt : C_Int) return C_Int;
      pragma Import (C, Menu_Opts_On, "menu_opts_on");
      function Menu_Opts_Off (Men : Menu;
                              Opt : C_Int) return C_Int;
      pragma Import (C, Menu_Opts_Off, "menu_opts_off");

      Opt : constant C_Int := MOS_2_CInt (Options);
      Err : Eti_Error;
   begin
      if On then
         Err := Menu_Opts_On  (Men, Opt);
      else
         Err := Menu_Opts_Off (Men, Opt);
      end if;
      if Err /= E_Ok then
         Eti_Exception (Err);
      end if;
   end Switch_Options;

   procedure Get_Options (Men     : in  Menu;
                               Options : out Menu_Option_Set)
   is
      function Menu_Opts (Men : Menu) return C_Int;
      pragma Import (C, Menu_Opts, "menu_opts");

      Res : constant C_Int := Menu_Opts (Men);
   begin
      Options := CInt_2_MOS (Res);
   end Get_Options;

   function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set
   is
      Mos : Menu_Option_Set;
   begin
      Get_Options (Men, Mos);
      return Mos;
   end Get_Options;
-------------------------------------------------------------------------------
   procedure Set_Window (Men : in Menu;
                         Win : in Window)
   is
      function Set_Menu_Win (Men : Menu;
                             Win : Window) return C_Int;
      pragma Import (C, Set_Menu_Win, "set_menu_win");

      Res : constant Eti_Error := Set_Menu_Win (Men, Win);
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Window;

   function Get_Window (Men : Menu) return Window
   is
      function Menu_Win (Men : Menu) return Window;
      pragma Import (C, Menu_Win, "menu_win");

      W : constant Window := Menu_Win (Men);
   begin
      return W;
   end Get_Window;

   procedure Set_Sub_Window (Men : in Menu;
                             Win : in Window)
   is
      function Set_Menu_Sub (Men : Menu;
                             Win : Window) return C_Int;
      pragma Import (C, Set_Menu_Sub, "set_menu_sub");

      Res : constant Eti_Error := Set_Menu_Sub (Men, Win);
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Sub_Window;

   function Get_Sub_Window (Men : Menu) return Window
   is
      function Menu_Sub (Men : Menu) return Window;
      pragma Import (C, Menu_Sub, "menu_sub");

      W : constant Window := Menu_Sub (Men);
   begin
      return W;
   end Get_Sub_Window;

   procedure Scale (Men     : in Menu;
                    Lines   : out Line_Count;
                    Columns : out Column_Count)
   is
      type C_Int_Access is access all C_Int;
      function M_Scale (Men    : Menu;
                        Yp, Xp : C_Int_Access) return C_Int;
      pragma Import (C, M_Scale, "scale_menu");

      X, Y : aliased C_Int;
      Res  : constant Eti_Error := M_Scale (Men, Y'Access, X'Access);
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
      Lines := Line_Count (Y);
      Columns := Column_Count (X);
   end Scale;
-------------------------------------------------------------------------------
   procedure Position_Cursor (Men : Menu)
   is
      function Pos_Menu_Cursor (Men : Menu) return C_Int;
      pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor");

      Res : constant Eti_Error := Pos_Menu_Cursor (Men);
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Position_Cursor;

-------------------------------------------------------------------------------
   procedure Set_Mark (Men  : in Menu;
                       Mark : in String)
   is
      type Char_Ptr is access all Interfaces.C.char;
      function Set_Mark (Men  : Menu;
                         Mark : Char_Ptr) return C_Int;
      pragma Import (C, Set_Mark, "set_menu_mark");

      Txt : char_array (0 .. Mark'Length);
      Len : size_t;
      Res : Eti_Error;
   begin
      To_C (Mark, Txt, Len);
      Res := Set_Mark (Men, Txt (Txt'First)'Access);
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Mark;

   procedure Mark (Men  : in  Menu;
                   Mark : out String)
   is
      function Get_Menu_Mark (Men : Menu) return chars_ptr;
      pragma Import (C, Get_Menu_Mark, "menu_mark");
   begin
      Fill_String (Get_Menu_Mark (Men), Mark);
   end Mark;

   function Mark (Men : Menu) return String
   is
      function Get_Menu_Mark (Men : Menu) return chars_ptr;
      pragma Import (C, Get_Menu_Mark, "menu_mark");
   begin
      return Fill_String (Get_Menu_Mark (Men));
   end Mark;

-------------------------------------------------------------------------------
   procedure Set_Foreground
     (Men   : in Menu;
      Fore  : in Character_Attribute_Set := Normal_Video;
      Color : in Color_Pair := Color_Pair'First)
   is
      function Set_Menu_Fore (Men  : Menu;
                              Attr : C_Chtype) return C_Int;
      pragma Import (C, Set_Menu_Fore, "set_menu_fore");

      Ch : constant Attributed_Character := (Ch    => Character'First,
                                             Color => Color,
                                             Attr  => Fore);
      Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch));
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Foreground;

   procedure Foreground (Men  : in  Menu;
                         Fore : out Character_Attribute_Set)
   is
      function Menu_Fore (Men : Menu) return C_Chtype;
      pragma Import (C, Menu_Fore, "menu_fore");
   begin
      Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr;
   end Foreground;

   procedure Foreground (Men   : in  Menu;
                         Fore  : out Character_Attribute_Set;
                         Color : out Color_Pair)
   is
      function Menu_Fore (Men : Menu) return C_Chtype;
      pragma Import (C, Menu_Fore, "menu_fore");
   begin
      Fore  := Chtype_To_AttrChar (Menu_Fore (Men)).Attr;
      Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color;
   end Foreground;

   procedure Set_Background
     (Men   : in Menu;
      Back  : in Character_Attribute_Set := Normal_Video;
      Color : in Color_Pair := Color_Pair'First)
   is
      function Set_Menu_Back (Men  : Menu;
                              Attr : C_Chtype) return C_Int;
      pragma Import (C, Set_Menu_Back, "set_menu_back");

      Ch : constant Attributed_Character := (Ch    => Character'First,
                                             Color => Color,
                                             Attr  => Back);
      Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch));
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Background;

   procedure Background (Men  : in  Menu;
                         Back : out Character_Attribute_Set)
   is
      function Menu_Back (Men : Menu) return C_Chtype;
      pragma Import (C, Menu_Back, "menu_back");
   begin
      Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr;
   end Background;

   procedure Background (Men   : in  Menu;
                         Back  : out Character_Attribute_Set;
                         Color : out Color_Pair)
   is
      function Menu_Back (Men : Menu) return C_Chtype;
      pragma Import (C, Menu_Back, "menu_back");
   begin
      Back  := Chtype_To_AttrChar (Menu_Back (Men)).Attr;
      Color := Chtype_To_AttrChar (Menu_Back (Men)).Color;
   end Background;

   procedure Set_Grey (Men   : in Menu;
                       Grey  : in Character_Attribute_Set := Normal_Video;
                       Color : in Color_Pair := Color_Pair'First)
   is
      function Set_Menu_Grey (Men  : Menu;
                              Attr : C_Chtype) return C_Int;
      pragma Import (C, Set_Menu_Grey, "set_menu_grey");

      Ch : constant Attributed_Character := (Ch    => Character'First,
                                             Color => Color,
                                             Attr  => Grey);

      Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch));
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Grey;

   procedure Grey (Men  : in  Menu;
                   Grey : out Character_Attribute_Set)
   is
      function Menu_Grey (Men : Menu) return C_Chtype;
      pragma Import (C, Menu_Grey, "menu_grey");
   begin
      Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr;
   end Grey;

   procedure Grey (Men  : in  Menu;
                   Grey : out Character_Attribute_Set;
                   Color : out Color_Pair)
   is
      function Menu_Grey (Men : Menu) return C_Chtype;
      pragma Import (C, Menu_Grey, "menu_grey");
   begin
      Grey  := Chtype_To_AttrChar (Menu_Grey (Men)).Attr;
      Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color;
   end Grey;

   procedure Set_Pad_Character (Men : in Menu;
                                Pad : in Character := Space)
   is
      function Set_Menu_Pad (Men : Menu;
                             Ch  : C_Int) return C_Int;
      pragma Import (C, Set_Menu_Pad, "set_menu_pad");

      Res : constant Eti_Error := Set_Menu_Pad (Men,
                                                C_Int (Character'Pos (Pad)));
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Pad_Character;

   procedure Pad_Character (Men : in  Menu;
                            Pad : out Character)
   is
      function Menu_Pad (Men : Menu) return C_Int;