PRAGMA C_PASS_BY_COPY (128);
WITH Ada.Text_IO;
WITH Ada.Integer_Text_IO;
PACKAGE BODY Screen IS
------------------------------------------------------------------
--|
--| body of screen-handling package
--|
--| Author: Michael B. Feldman, The George Washington University
--| Last Modified: July 1995
--|
--| Modified for use with Win95 and NT by Jerry van Dijk
--| Modification made: October 1997
--|
------------------------------------------------------------------

  -- WIN32 Interface

  Fill_Char_Error      : EXCEPTION;
  Cursor_Pos_Error     : EXCEPTION;
  Buffer_Info_Error    : EXCEPTION;
  Message_Beep_Error   : EXCEPTION;
  Invalid_Handle_Error : EXCEPTION;

  TYPE UINT IS MOD 2 ** 32;
  FOR UINT'SIZE USE 32;

  TYPE SHORT IS MOD 2 ** 16;
  FOR SHORT'SIZE USE 16;

  SUBTYPE WORD   IS SHORT;
  SUBTYPE BOOL   IS Integer;
  SUBTYPE DWORD  IS Integer;
  SUBTYPE HANDLE IS Integer;

  TYPE LPDWORD IS ACCESS ALL DWORD;
  PRAGMA CONVENTION (C, LPDWORD);

  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     : WORD;
      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);

  FALSE                : CONSTANT BOOL   := 0;
  STD_OUTPUT_HANDLE    : CONSTANT DWORD  := -11;
  INVALID_HANDLE_VALUE : CONSTANT HANDLE := -1;

  FUNCTION GetStdHandle (Value : DWORD) RETURN HANDLE;
  PRAGMA IMPORT (StdCall, GetStdHandle, "GetStdHandle");

  FUNCTION MessageBeep (Beep : UINT) return BOOL;
  PRAGMA IMPORT (StdCall, MessageBeep, "MessageBeep");

  FUNCTION GetConsoleScreenBufferInfo (Buffer : HANDLE;
                                       Info   :
PCONSOLE_SCREEN_BUFFER_INFO)
                                       RETURN BOOL;
  PRAGMA IMPORT (StdCall, GetConsoleScreenBufferInfo,
                          "GetConsoleScreenBufferInfo");

  FUNCTION SetConsoleCursorPosition (Buffer : HANDLE;
                                     Pos    : COORD)
                                     RETURN BOOL;
  PRAGMA IMPORT (StdCall, SetConsoleCursorPosition,
                         "SetConsoleCursorPosition");

  FUNCTION FillConsoleOutputCharacter (Console : HANDLE;
                                       Char    : Character;
                                       Length  : DWORD;
                                       Start   : COORD;
                                       Written : LPDWORD)
                                       RETURN BOOL;
  PRAGMA IMPORT (StdCall, FillConsoleOutputCharacter,
                         "FillConsoleOutputCharacterA");

  Output_Buffer      : HANDLE;
  Num_Bytes          : ALIASED DWORD;
  Buffer_Info        : ALIASED CONSOLE_SCREEN_BUFFER_INFO;
  Buffer_Info_Access : PCONSOLE_SCREEN_BUFFER_INFO :=
Buffer_Info'Access;

  PROCEDURE Get_Buffer_Info IS
  BEGIN
    IF GetConsoleScreenBufferInfo
     (Output_Buffer, Buffer_Info_Access) = FALSE THEN
      RAISE Buffer_Info_Error;
    END IF;
  END Get_Buffer_Info;

  -- Implementation

  PROCEDURE Beep IS
  BEGIN
    IF MessageBeep (Beep => 16#FFFFFFFF#) = FALSE THEN
      RAISE Message_Beep_Error;
    END IF;
  END Beep;

  PROCEDURE ClearScreen IS
    Length  : DWORD;
    Start   : COORD := (0, 0);
    Written : LPDWORD := Num_Bytes'Access;
  BEGIN
    Get_Buffer_Info;
    Length := DWORD (Integer (Buffer_Info.Size.X) *
                     Integer (Buffer_Info.Size.Y));
    IF FillConsoleOutputCharacter (Output_Buffer, ' ', Length, Start,
Written) = FALSE THEN
      RAISE Fill_Char_Error;
    END IF;
    IF SetConsoleCursorPosition (Output_Buffer, Start) = FALSE THEN
       raise Cursor_Pos_Error;
    END IF;
  END ClearScreen;

  PROCEDURE MoveCursor (Column : Width; Row : Depth) IS
    New_Pos : COORD := (SHORT (Column), SHORT (Row));
  BEGIN
    Get_Buffer_Info;
    IF New_Pos.X > Buffer_Info.Size.X THEN
       New_Pos.X := Buffer_Info.Size.X;
    END IF;
    IF New_Pos.Y > Buffer_Info.Size.Y THEN
       New_Pos.Y := Buffer_Info.Size.Y;
    END IF;
    IF SetConsoleCursorPosition (Output_Buffer, New_Pos) = FALSE THEN
       raise Cursor_Pos_Error;
    END IF;
  END MoveCursor;

-- WIN32 initialization
BEGIN
   Output_Buffer := GetStdHandle (STD_OUTPUT_HANDLE);
   IF Output_Buffer = INVALID_HANDLE_VALUE THEN
      RAISE Invalid_Handle_Error;
   END IF;
END Screen;