terminal_interface-curses.adb

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

      if Mvwin (Win, C_Int (Line), C_Int (Column)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Move_Window;

   procedure Move_Derived_Window (Win    : in Window;
                                  Line   : in Line_Position;
                                  Column : in Column_Position)
   is
      function Mvderwin (Win    : Window;
                         Line   : C_Int;
                         Column : C_Int) return C_Int;
      pragma Import (C, Mvderwin, "mvderwin");
   begin
      if Mvderwin (Win, C_Int (Line), C_Int (Column)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Move_Derived_Window;

   procedure Set_Synch_Mode (Win  : in Window  := Standard_Window;
                             Mode : in Boolean := False)
   is
      function Syncok (Win  : Window;
                       Mode : Curses_Bool) return C_Int;
      pragma Import (C, Syncok, "syncok");
   begin
      if Syncok (Win, Curses_Bool (Boolean'Pos (Mode))) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Set_Synch_Mode;
------------------------------------------------------------------------------
   procedure Add (Win : in Window := Standard_Window;
                  Str : in String;
                  Len : in Integer := -1)
   is
      function Waddnstr (Win : Window;
                         Str : char_array;
                         Len : C_Int := -1) return C_Int;
      pragma Import (C, Waddnstr, "waddnstr");

      Txt    : char_array (0 .. Str'Length);
      Length : size_t;
   begin
      To_C (Str, Txt, Length);
      if Waddnstr (Win, Txt, C_Int (Len)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Add;

   procedure Add
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position;
      Str    : in String;
      Len    : in Integer := -1)
   is
   begin
      Move_Cursor (Win, Line, Column);
      Add (Win, Str, Len);
   end Add;
------------------------------------------------------------------------------
   procedure Add
     (Win : in Window := Standard_Window;
      Str : in Attributed_String;
      Len : in Integer := -1)
   is
      function Waddchnstr (Win : Window;
                           Str : chtype_array;
                           Len : C_Int := -1) return C_Int;
      pragma Import (C, Waddchnstr, "waddchnstr");

      Txt : chtype_array (0 .. Str'Length);
   begin
      for Length in 1 .. size_t (Str'Length) loop
         Txt (Length - 1) := Str (Natural (Length));
      end loop;
      Txt (Str'Length) := Default_Character;
      if Waddchnstr (Win,
                     Txt,
                     C_Int (Len)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Add;

   procedure Add
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position;
      Str    : in Attributed_String;
      Len    : in Integer := -1)
   is
   begin
      Move_Cursor (Win, Line, Column);
      Add (Win, Str, Len);
   end Add;
------------------------------------------------------------------------------
   procedure Border
     (Win                       : in Window := Standard_Window;
      Left_Side_Symbol          : in Attributed_Character := Default_Character;
      Right_Side_Symbol         : in Attributed_Character := Default_Character;
      Top_Side_Symbol           : in Attributed_Character := Default_Character;
      Bottom_Side_Symbol        : in Attributed_Character := Default_Character;
      Upper_Left_Corner_Symbol  : in Attributed_Character := Default_Character;
      Upper_Right_Corner_Symbol : in Attributed_Character := Default_Character;
      Lower_Left_Corner_Symbol  : in Attributed_Character := Default_Character;
      Lower_Right_Corner_Symbol : in Attributed_Character := Default_Character)
   is
      function Wborder (W   : Window;
                        LS  : C_Chtype;
                        RS  : C_Chtype;
                        TS  : C_Chtype;
                        BS  : C_Chtype;
                        ULC : C_Chtype;
                        URC : C_Chtype;
                        LLC : C_Chtype;
                        LRC : C_Chtype) return C_Int;
      pragma Import (C, Wborder, "wborder");
   begin
      if Wborder (Win,
                  AttrChar_To_Chtype (Left_Side_Symbol),
                  AttrChar_To_Chtype (Right_Side_Symbol),
                  AttrChar_To_Chtype (Top_Side_Symbol),
                  AttrChar_To_Chtype (Bottom_Side_Symbol),
                  AttrChar_To_Chtype (Upper_Left_Corner_Symbol),
                  AttrChar_To_Chtype (Upper_Right_Corner_Symbol),
                  AttrChar_To_Chtype (Lower_Left_Corner_Symbol),
                  AttrChar_To_Chtype (Lower_Right_Corner_Symbol)
                  ) = Curses_Err
      then
         raise Curses_Exception;
      end if;
   end Border;

   procedure Box
     (Win               : in Window := Standard_Window;
      Vertical_Symbol   : in Attributed_Character := Default_Character;
      Horizontal_Symbol : in Attributed_Character := Default_Character)
   is
   begin
      Border (Win,
              Vertical_Symbol, Vertical_Symbol,
              Horizontal_Symbol, Horizontal_Symbol);
   end Box;

   procedure Horizontal_Line
     (Win         : in Window := Standard_Window;
      Line_Size   : in Natural;
      Line_Symbol : in Attributed_Character := Default_Character)
   is
      function Whline (W   : Window;
                       Ch  : C_Chtype;
                       Len : C_Int) return C_Int;
      pragma Import (C, Whline, "whline");
   begin
      if Whline (Win,
                 AttrChar_To_Chtype (Line_Symbol),
                 C_Int (Line_Size)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Horizontal_Line;

   procedure Vertical_Line
     (Win         : in Window := Standard_Window;
      Line_Size   : in Natural;
      Line_Symbol : in Attributed_Character := Default_Character)
   is
      function Wvline (W   : Window;
                       Ch  : C_Chtype;
                       Len : C_Int) return C_Int;
      pragma Import (C, Wvline, "wvline");
   begin
      if Wvline (Win,
                 AttrChar_To_Chtype (Line_Symbol),
                 C_Int (Line_Size)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Vertical_Line;

------------------------------------------------------------------------------
   function Get_Keystroke (Win : Window := Standard_Window)
     return Real_Key_Code
   is
      function Wgetch (W : Window) return C_Int;
      pragma Import (C, Wgetch, "wgetch");

      C : constant C_Int := Wgetch (Win);
   begin
      if C = Curses_Err then
         return Key_None;
      else
         return Real_Key_Code (C);
      end if;
   end Get_Keystroke;

   procedure Undo_Keystroke (Key : in Real_Key_Code)
   is
      function Ungetch (Ch : C_Int) return C_Int;
      pragma Import (C, Ungetch, "ungetch");
   begin
      if Ungetch (C_Int (Key)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Undo_Keystroke;

   function Has_Key (Key : Special_Key_Code) return Boolean
   is
      function Haskey (Key : C_Int) return C_Int;
      pragma Import (C, Haskey, "has_key");
   begin
      if Haskey (C_Int (Key)) = Curses_False then
         return False;
      else
         return True;
      end if;
   end Has_Key;

   function Is_Function_Key (Key : Special_Key_Code) return Boolean
   is
      L : constant Special_Key_Code  := Special_Key_Code (Natural (Key_F0) +
        Natural (Function_Key_Number'Last));
   begin
      if (Key >= Key_F0) and then (Key <= L) then
         return True;
      else
         return False;
      end if;
   end Is_Function_Key;

   function Function_Key (Key : Real_Key_Code)
                          return Function_Key_Number
   is
   begin
      if Is_Function_Key (Key) then
         return Function_Key_Number (Key - Key_F0);
      else
         raise Constraint_Error;
      end if;
   end Function_Key;

   function Function_Key_Code (Key : Function_Key_Number) return Real_Key_Code
   is
   begin
      return Real_Key_Code (Natural (Key_F0) + Natural (Key));
   end Function_Key_Code;
------------------------------------------------------------------------------
   procedure Standout (Win : Window  := Standard_Window;
                       On  : Boolean := True)
   is
      function wstandout (Win : Window) return C_Int;
      pragma Import (C, wstandout, "wstandout");
      function wstandend (Win : Window) return C_Int;
      pragma Import (C, wstandend, "wstandend");

      Err : C_Int;
   begin
      if On then
         Err := wstandout (Win);
      else
         Err := wstandend (Win);
      end if;
      if Err = Curses_Err then
         raise Curses_Exception;
      end if;
   end Standout;

   procedure Switch_Character_Attribute
     (Win  : in Window := Standard_Window;
      Attr : in Character_Attribute_Set := Normal_Video;
      On   : in Boolean := True)
   is
      function Wattron (Win    : Window;
                        C_Attr : C_AttrType) return C_Int;
      pragma Import (C, Wattron, "wattr_on");
      function Wattroff (Win    : Window;
                         C_Attr : C_AttrType) return C_Int;
      pragma Import (C, Wattroff, "wattr_off");
      --  In Ada we use the On Boolean to control whether or not we want to
      --  switch on or off the attributes in the set.
      Err : C_Int;
      AC  : constant Attributed_Character := (Ch    => Character'First,
                                              Color => Color_Pair'First,
                                              Attr  => Attr);
   begin
      if On then
         Err := Wattron  (Win, AttrChar_To_AttrType (AC));
      else
         Err := Wattroff (Win, AttrChar_To_AttrType (AC));
      end if;
      if Err = Curses_Err then
         raise Curses_Exception;
      end if;
   end Switch_Character_Attribute;

   procedure Set_Character_Attributes
     (Win   : in Window := Standard_Window;
      Attr  : in Character_Attribute_Set := Normal_Video;
      Color : in Color_Pair := Color_Pair'First)
   is
      function Wattrset (Win    : Window;
                         C_Attr : C_AttrType) return C_Int;
      pragma Import (C, Wattrset, "wattrset"); -- ??? wattr_set
   begin
      if Wattrset (Win,
                   AttrChar_To_AttrType (Attributed_Character'
                                         (Ch    => Character'First,
                                          Color => Color,
                                          Attr  => Attr))) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Set_Character_Attributes;

   function Get_Character_Attribute (Win : Window := Standard_Window)
                                     return Character_Attribute_Set
   is
      function Wattrget (Win : Window;
                         Atr : access C_AttrType;
                         Col : access C_Short;
                         Opt : System.Address) return C_Int;
      pragma Import (C, Wattrget, "wattr_get");

      Attr : aliased C_AttrType;
      Col  : aliased C_Short;
      Res  : constant C_Int := Wattrget (Win, Attr'Access, Col'Access,
                                         System.Null_Address);
      Ch   : Attributed_Character;
   begin
      if Res = Curses_Ok then
         Ch := AttrType_To_AttrChar (Attr);
         return Ch.Attr;
      else
         raise Curses_Exception;
      end if;
   end Get_Character_Attribute;

   function Get_Character_Attribute (Win : Window := Standard_Window)
                                     return Color_Pair
   is
      function Wattrget (Win : Window;
                         Atr : access C_AttrType;
                         Col : access C_Short;
                         Opt : System.Address) return C_Int;
      pragma Import (C, Wattrget, "wattr_get");

      Attr : aliased C_AttrType;
      Col  : aliased C_Short;
      Res  : constant C_Int := Wattrget (Win, Attr'Access, Col'Access,
                                         System.Null_Address);
      Ch   : Attributed_Character;
   begin
      if Res = Curses_Ok then
         Ch := AttrType_To_AttrChar (Attr);
         return Ch.Color;
      else
         raise Curses_Exception;
      end if;
   end Get_Character_Attribute;

   procedure Set_Color (Win  : in Window := Standard_Window;
                        Pair : in Color_Pair)
   is
      function Wset_Color (Win   : Window;
                           Color : C_Short;
                           Opts  : C_Void_Ptr) return C_Int;
      pragma Import (C, Wset_Color, "wcolor_set");
   begin
      if Wset_Color (Win,
                     C_Short (Pair),
                     C_Void_Ptr (System.Null_Address)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Set_Color;

   procedure Change_Attributes
     (Win   : in Window := Standard_Window;
      Count : in Integer := -1;
      Attr  : in Character_Attribute_Set := Normal_Video;
      Color : in Color_Pair := Color_Pair'First)
   is
      function Wchgat (Win   : Window;
                       Cnt   : C_Int;
                       Attr  : C_AttrType;
                       Color : C_Short;
                       Opts  : System.Address := System.Null_Address)
                       return C_Int;
      pragma Import (C, Wchgat, "wchgat");

      Ch : constant Attributed_Character :=
        (Ch => Character'First, Color => Color_Pair'First, Attr => Attr);
   begin
      if Wchgat (Win, C_Int (Count), AttrChar_To_AttrType (Ch),
                 C_Short (Color)) = Curses_Err then
         raise Curses_Exception;
      end if;