nt_console.adb

-----------------------------------------------------------------------
--
--  File:        nt_console.adb
--  Description: Win95/NT console support
--  Rev:         0.1
--  Date:        18-jan-1998
--  Author:      Jerry van Dijk
--  Mail:        jdijk@acm.org
--
--  Copyright (c) Jerry van Dijk, 1997, 1998
--  Billie Holidaystraat 28
--  2324 LK  LEIDEN
--  THE NETHERLANDS
--  tel int + 31 71 531 43 65
--
--  Permission granted to use for any purpose, provided this copyright
--  remains attached and unmodified.
--
--  THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
--  IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
--  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
-----------------------------------------------------------------------

pragma C_Pass_By_Copy (128);

with Interfaces; use Interfaces;

package body NT_Console is

   pragma Linker_Options ("-luser32");

   ---------------------
   -- WIN32 INTERFACE --
   ---------------------

   Beep_Error            : exception;
   Fill_Char_Error       : exception;
   Cursor_Pos_Error      : exception;
   Buffer_Info_Error     : exception;
   Set_Attribute_Error   : exception;
   Invalid_Handle_Error  : exception;
   Fill_Attribute_Error  : exception;
   Cursor_Position_Error : exception;

   subtype DWORD  is Unsigned_32;
   subtype HANDLE is Unsigned_32;
   subtype WORD   is Unsigned_16;
   subtype SHORT  is Short_Integer;

   type LPDWORD is access all DWORD;
   pragma Convention (C, LPDWORD);

   type Nibble is mod 2 ** 4;
   for Nibble'Size use 4;

   type Attribute is
      record
         Foreground : Nibble;
         Background : Nibble;
         Reserved   : Unsigned_8 := 0;
      end record;

   for Attribute use
      record
         Foreground at 0 range 0 .. 3;
         Background at 0 range 4 .. 7;
         Reserved   at 1 range 0 .. 7;
      end record;

   for Attribute'Size use 16;
   pragma Convention (C, Attribute);

   type COORD is
      record
         X : SHORT;
         Y : SHORT;
      end record;
   pragma Convention (C, COORD);

   type SMALL_RECT is
      record
         Left   : SHORT;
         Top    : SHORT;
         Right  : SHORT;
         Bottom : SHORT;
      end record;
   pragma Convention (C, SMALL_RECT);

   type CONSOLE_SCREEN_BUFFER_INFO is
      record
         Size       : COORD;
         Cursor_Pos : COORD;
         Attrib     : Attribute;
         Window     : SMALL_RECT;
         Max_Size   : COORD;
      end record;
   pragma Convention (C, CONSOLE_SCREEN_BUFFER_INFO);

   type PCONSOLE_SCREEN_BUFFER_INFO is access all CONSOLE_SCREEN_BUFFER_INFO;
   pragma Convention (C, PCONSOLE_SCREEN_BUFFER_INFO);

   function GetCh return Integer;
   pragma Import (C, GetCh, "_getch");

   function KbHit return Integer;
   pragma Import (C, KbHit, "_kbhit");

   function MessageBeep (Kind : DWORD) return DWORD;
   pragma Import (StdCall, MessageBeep, "MessageBeep");

   function GetStdHandle (Value : DWORD) return HANDLE;
   pragma Import (StdCall, GetStdHandle, "GetStdHandle");

   function SetConsoleCursorPosition (Buffer : HANDLE; Pos : COORD) return DWORD;
   pragma Import (StdCall, SetConsoleCursorPosition, "SetConsoleCursorPosition");

   function SetConsoleTextAttribute (Buffer : HANDLE; Attr : Attribute) return DWORD;
   pragma Import (StdCall, SetConsoleTextAttribute, "SetConsoleTextAttribute");

   function GetConsoleScreenBufferInfo (Buffer : HANDLE; Info : PCONSOLE_SCREEN_BUFFER_INFO) return DWORD;
   pragma Import (StdCall, GetConsoleScreenBufferInfo, "GetConsoleScreenBufferInfo");

   function FillConsoleOutputCharacter (Console : HANDLE; Char : Character; Length : DWORD; Start : COORD; Written : LPDWORD) return DWORD;
   pragma Import (Stdcall, FillConsoleOutputCharacter, "FillConsoleOutputCharacterA");

   function FillConsoleOutputAttribute (Console : Handle; Attr : Attribute; Length : DWORD; Start : COORD; Written : LPDWORD) return DWORD;
   pragma Import (Stdcall, FillConsoleOutputAttribute, "FillConsoleOutputAttribute");

   WIN32_ERROR          : constant DWORD  := 0;
   INVALID_HANDLE_VALUE : constant HANDLE := -1;
   STD_OUTPUT_HANDLE    : constant DWORD  := -11;

   Color_Value      : constant array (Color_Type) of Nibble := (0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14, 15);
   Color_Type_Value : constant array (Nibble) of Color_Type := (Black, Blue, Green, Cyan, Red, Magenta, Brown, Gray,
                                                                Black, Light_Blue, Light_Green, Light_Cyan, Light_Red,
                                                                Light_Magenta, Yellow, White);

   -----------------------
   -- PACKAGE VARIABLES --
   -----------------------

   Output_Buffer    : HANDLE;
   Num_Bytes        : aliased DWORD;
   Num_Bytes_Access : LPDWORD := Num_Bytes'Access;
   Buffer_Info_Rec  : aliased CONSOLE_SCREEN_BUFFER_INFO;
   Buffer_Info      : PCONSOLE_SCREEN_BUFFER_INFO := Buffer_Info_Rec'Access;

   -------------------------
   -- SUPPORTING SERVICES --
   -------------------------

   procedure Get_Buffer_Info is
   begin
      if GetConsoleScreenBufferInfo (Output_Buffer, Buffer_Info) = WIN32_ERROR then
         raise Buffer_Info_Error;
      end if;
   end Get_Buffer_Info;

   --------------------
   -- CURSOR CONTROL --
   --------------------

   function Where_X return X_Pos is
   begin
      Get_Buffer_Info;
      return X_Pos (Buffer_Info_Rec.Cursor_Pos.X);
   end Where_X;

   function Where_Y return Y_Pos is
   begin
      Get_Buffer_Info;
      return Y_Pos (Buffer_Info_Rec.Cursor_Pos.Y);
   end Where_Y;

   procedure Goto_XY (X : in X_Pos := X_Pos'First;
                      Y : in Y_Pos := Y_Pos'First) is
      New_Pos : COORD := (SHORT (X), SHORT (Y));
   begin
      Get_Buffer_Info;
      if New_Pos.X > Buffer_Info_Rec.Size.X then
         New_Pos.X := Buffer_Info_Rec.Size.X;
      end if;
      if New_Pos.Y > Buffer_Info_Rec.Size.Y then
         New_Pos.Y := Buffer_Info_Rec.Size.Y;
      end if;
      if SetConsoleCursorPosition (Output_Buffer, New_Pos) = WIN32_ERROR then
         raise Cursor_Pos_Error;
      end if;
   end Goto_XY;

   -------------------
   -- COLOR CONTROL --
   -------------------

   function Get_Foreground return Color_Type is
   begin
      Get_Buffer_Info;
      return Color_Type_Value (Buffer_Info_Rec.Attrib.Foreground);
   end Get_Foreground;

   function Get_Background return Color_Type is
   begin
      Get_Buffer_Info;
      return Color_Type_Value (Buffer_Info_Rec.Attrib.Background);
   end Get_Background;

   procedure Set_Foreground (Color : in Color_Type := Gray) is
      Attr : Attribute;
   begin
      Get_Buffer_Info;
      Attr.Foreground := Color_Value (Color);
      Attr.Background := Buffer_Info_Rec.Attrib.Background;
      if SetConsoleTextAttribute (Output_Buffer, Attr) = WIN32_ERROR then
         raise Set_Attribute_Error;
      end if;
   end Set_Foreground;

   procedure Set_Background (Color : in Color_Type := Black) is
      Attr : Attribute;
   begin
      Get_Buffer_Info;
      Attr.Foreground := Buffer_Info_Rec.Attrib.Foreground;
      Attr.Background := Color_Value (Color);
      if SetConsoleTextAttribute (Output_Buffer, Attr) = WIN32_ERROR then
         raise Set_Attribute_Error;
      end if;
   end Set_Background;

   --------------------
   -- SCREEN CONTROL --
   --------------------

   procedure Clear_Screen (Color : in Color_Type := Black) is
      Attr   : Attribute;
      Home   : COORD := (0, 0);
      Length : DWORD := DWORD ((X_Pos'Last + 1) * (Y_Pos'Last + 1));
   begin
      Get_Buffer_Info;
      Attr.Background := Color_Value (Color);
      Attr.Foreground := Buffer_Info_Rec.Attrib.Foreground;
      if SetConsoleTextAttribute (Output_Buffer, Attr) = WIN32_ERROR then
         raise Set_Attribute_Error;
      end if;
      if FillConsoleOutputAttribute (Output_Buffer, Attr, Length, Home, Num_Bytes_Access) = WIN32_ERROR then
         raise Fill_Attribute_Error;
      end if;
      if FillConsoleOutputCharacter (Output_Buffer, ' ', Length, Home, Num_Bytes_Access) = WIN32_ERROR then
         raise Fill_Char_Error;
      end if;
      if SetConsoleCursorPosition (Output_Buffer, Home) = WIN32_ERROR then
         raise Cursor_Position_Error;
      end if;
   end Clear_Screen;

   -------------------
   -- SOUND CONTROL --
   -------------------
   procedure Bleep is
   begin
      if MessageBeep (16#FFFFFFFF#) = WIN32_ERROR then
         raise Beep_Error;
      end if;
   end Bleep;

   -------------------
   -- INPUT CONTROL --
   -------------------

   function Get_Key return Character is
      Temp : Integer;
   begin
      Temp := GetCh;
      if Temp = 16#00E0# then
         Temp := 0;
      end if;
      return Character'Val (Temp);
   end Get_Key;

   function Key_Available return Boolean is
   begin
      if KbHit = 0 then
         return False;
      else
         return True;
      end if;
   end Key_Available;

begin

   --------------------------
   -- WIN32 INITIALIZATION --
   --------------------------

   Output_Buffer := GetStdHandle (STD_OUTPUT_HANDLE);
   if Output_Buffer = INVALID_HANDLE_VALUE then
      raise Invalid_Handle_Error;
   end if;

end NT_Console;