package Ada_Store.Support.Screen

package Ada_Store.Support.Screen is
  pragma Elaborate_Body(Screen);

  Max_Lines		: constant Positive := 66;
  Max_Columns		: constant Positive := 132;

  type Height		is new Positive range 1 .. Max_Lines;
  type Width		is new Positive range 1 .. Max_Columns;

  type Position		is
    record
      Line		: Height;
      Column		: Width;
    end record;

  type Rectangle	is
    record
      Top_Left		: Position;
      Bottom_Right	: Position;
    end record;

  type Movement		is ( Up, Down, Left, Right );

  function  Cursor	return Position;

  procedure Set_Cursor
    (To	: in Position);

  function  Size	
    return Rectangle;

  procedure Clear;

  procedure Clear
    (Lines : in Height);

  procedure Clear
    (Area : in Rectangle);

  procedure Scroll
    (Direction : in Movement;
     Number    : in Positive);

  procedure Scroll
    (Direction : in Movement;
     Number    : in Positive;
     Lines     : in Height);

  procedure Scroll
    (Direction : in Movement;
     Number    : in Positive;
     Area      : in Rectangle);

  procedure HLine
    (Line : in Height);

  procedure HLine
    (Line  : in Height;
     Start : in Width;
     Stop  : in Width);

  procedure VLine
    (Column : in Width);

  procedure VLine
    (Column : in Width;
     Start  : in Height;
     Stop   : in Height);

  procedure Box
    (Area : in Rectangle);

  procedure Put
    (C : in Character);

  procedure Put
    (Str : in String);

  function Get
     return Character;

  Bad_Position		: exception;

  procedure Lock_Exclusive;
  procedure Unlock;

end Ada_Store.Support.Screen;

with Ada.Text_IO;
with Interfaces.C;
use  Interfaces.C;

with Win32;
with Win32.Winnt;
with Win32.Winbase;
with Win32.Wincon;
use  Win32.Wincon;

with Ada_Store.Support.IPC;
with Ada_Store.Support.Trace;

package body Ada_Store.Support.Screen is

-- internal

   Mutex                : IPC.Mutex;

   Output_Console	: Win32.Winnt.HANDLE;
   Input_Console	: Win32.Winnt.HANDLE;

   Screen_Size		: Rectangle;

   procedure Initialise is
      RValue	   : Win32.BOOL;
      Console_Info : aliased CONSOLE_SCREEN_BUFFER_INFO;
      Console_Mode : aliased Win32.DWORD;
   begin

      Output_Console := Win32.Winbase.GetStdHandle(Win32.Winbase.STD_OUTPUT_HANDLE);
      Input_Console  := Win32.Winbase.GetStdHandle(Win32.Winbase.STD_INPUT_HANDLE);
      
      RValue := GetConsoleScreenBufferInfo(Output_Console, 
					   Console_Info'Unchecked_Access);
      
      Screen_Size.Top_Left     := (1,  1);
      
      Screen_Size.Bottom_Right := (Height(Console_Info.dwMaximumWindowSize.Y + 1),
				   Width(Console_Info.dwMaximumWindowSize.X + 1));

      RValue := GetConsoleMode(Input_Console,
			       Console_Mode'Unchecked_Access);

      Console_Mode := Console_Mode and (not ENABLE_LINE_INPUT) and (not ENABLE_ECHO_INPUT);

      RValue := SetConsoleMode(Input_Console,
			       Console_Mode);
   exception
      when Constraint_Error =>
	 Trace.Put("Ada.Support.Screen Initialise failed");
   end Initialise;

-- public

   function  Cursor	return Position is
      Temp_Cursor  : Position;
      RValue	   : Win32.BOOL;
      Console_Info : aliased CONSOLE_SCREEN_BUFFER_INFO;
   begin
      RValue := GetConsoleScreenBufferInfo(Output_Console, 
					   Console_Info'Unchecked_Access);
      
      Temp_Cursor.Line   := Height(Console_Info.dwCursorPosition.Y + 1);
      Temp_Cursor.Column := Width(Console_Info.dwCursorPosition.X + 1);
      
      return Temp_Cursor;
   end Cursor;
   
   procedure Set_Cursor
     (To : in Position) is
      WinCursor : COORD := (SHORT(To.Column - 1), SHORT(To.Line - 1));
      RValue    : Win32.BOOL;
   begin
      RValue := SetConsoleCursorPosition(Output_Console, 
					 WinCursor);
   end Set_Cursor;

   function  Size	return Rectangle is
   begin
      return Screen_Size;
   end Size;

   procedure Clear is
   begin
      Scroll(Up, 
	     Positive(Screen_Size.Bottom_Right.Line
		      - Screen_Size.Top_Left.Line),
	     Screen_Size);
   end Clear;

   procedure Clear
     (Lines : in Height) is

      Area : Rectangle := Screen_Size;
      CPos : Position  := Cursor;
   begin
      Area.Top_Left.Line     := CPos.Line;
      Area.Bottom_Right.Line := CPos.Line + Lines;
      
      Scroll(Up, 
	     Positive(Area.Bottom_Right.Line - Area.Top_Left.Line),
	     Area);
   end Clear;
   
   procedure Clear
     (Area : in Rectangle) is
   begin
      Scroll(Up, 
	     Positive(Area.Bottom_Right.Line - Area.Top_Left.Line),
	     Area);
   end Clear;
   
   procedure Scroll
     (Direction	: in Movement;
      Number	: in Positive) is
   begin
      Scroll(Direction, 
	     Number, 
	     Screen_Size);
   end Scroll;
   
   procedure Scroll
     (Direction	: in Movement;
      Number	: in Positive;
      Lines	: in Height) is

      Area : Rectangle := Screen_Size;
      CPos : Position  := Cursor;
   begin
      Area.Top_Left.Line     := CPos.Line;
      Area.Bottom_Right.Line := CPos.Line + Lines;
      
      Scroll(Direction, 
	     Number, 
	     Area);
   end Scroll;

   procedure Scroll
     (Direction	: in Movement;
      Number	: in Positive;
      Area	: in Rectangle) is
      
      Destination   : COORD;
      RValue        : Win32.BOOL;
      ScrollRect    : aliased SMALL_RECT;
      FillCharacter : aliased CHAR_INFO;
   begin
      ScrollRect.Top           := SHORT(Area.Top_Left.Line) - 1;
      ScrollRect.Bottom        := SHORT(Area.Bottom_Right.Line) - 1;
      ScrollRect.Left          := SHORT(Area.Top_Left.Column) - 1;
      ScrollRect.Right         := SHORT(Area.Bottom_Right.Column) - 1;
      
      FillCharacter.Char.AsciiChar := ' ';
      FillCharacter.Attributes := 7;
      
      case Direction is
	 when Up =>
	    Destination.X := SHORT(Area.Top_Left.Column) - 1;
	    Destination.Y := SHORT(Area.Top_Left.Line)   - SHORT(Number) - 1;
	 when Down =>
	    Destination.X := SHORT(Area.Top_Left.Column) - 1;
	    Destination.Y := SHORT(Area.Top_Left.Line)   + SHORT(Number) - 1;
	 when Left =>
	    Destination.X := SHORT(Area.Top_Left.Column) - SHORT(Number) - 1;
	    Destination.Y := SHORT(Area.Top_Left.Line)   - 1;
	 when Right =>
	    Destination.X := SHORT(Area.Top_Left.Column) + SHORT(Number) - 1;
	    Destination.Y := SHORT(Area.Top_Left.Line)   - 1;
      end case;
      
      RValue := ScrollConsoleScreenBuffer(Output_Console,
					  ScrollRect'Unchecked_Access,
					  ScrollRect'Unchecked_Access,
					  Destination,
					  FillCharacter'Unchecked_Access);
   end Scroll;

   procedure HLine
     (Line : in Height) is
   begin
      HLine(Line, 
	    Screen_Size.Top_Left.Column, 
	    Screen_Size.Bottom_Right.Column);
   end HLine;
   
   procedure HLine
     (Line  : in Height;
      Start : in Width;
      Stop  : in Width) is
      
   begin
      for Column in Start .. (Stop - 1) loop
	 
	 Set_Cursor((Line, Column));
	 Put('-');
      end loop;
   end HLine;

   procedure VLine
     (Column : in Width) is
   begin
      VLine(Column, 
	    Screen_Size.Top_Left.Line, 
	    Screen_Size.Bottom_Right.Line);
   end VLine;
   
   procedure VLine
     (Column : in Width;
      Start  : in Height;
      Stop   : in Height) is
   begin
      for Line in Start .. (Stop - 1) loop
	 
	 Set_Cursor((Line, Column));
	 Put('|');
      end loop;
   end VLine;

   procedure Box
     (Area : in Rectangle) is
   begin
      Set_Cursor((Area.Top_Left.Line, 
		  Area.Top_Left.Column));
      Put('+');
      HLine(Area.Top_Left.Line, 
	    Area.Top_Left.Column + 1, 
	    Area.Bottom_Right.Column);

      Set_Cursor((Area.Top_Left.Line, 
		  Area.Bottom_Right.Column));
      Put('+');
      HLine(Area.Bottom_Right.Line, 
	    Area.Top_Left.Column + 1, 
	    Area.Bottom_Right.Column);
      
      Set_Cursor((Area.Bottom_Right.Line, 
		  Area.Top_Left.Column));
      Put('+');
      VLine(Area.Top_Left.Column, 
	    Area.Top_Left.Line + 1, 
	    Area.Bottom_Right.Line);

      Set_Cursor((Area.Bottom_Right.Line, 
		  Area.Bottom_Right.Column));
      Put('+');
      VLine(Area.Bottom_Right.Column, 
	    Area.Top_Left.Line + 1, 
	    Area.Bottom_Right.Line);
   end Box;

   procedure Put
     (C	: in Character) is
   begin
      Ada.Text_IO.Put(C);
   end Put;

   procedure Put
     (Str : in String) is
   begin
      Ada.Text_IO.Put(Str);
   end Put;

   function Get
      return Character is

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

      An_Integer  : Integer;
      Return_This : Character;
   begin
      An_Integer := C_Getch;

      Return_This := Character'Val(An_Integer);

      return Return_This;
   end Get;

   procedure Lock_Exclusive is
   begin
      Mutex.Acquire;
   end Lock_Exclusive;
  
   procedure Unlock is
   begin
      Mutex.Release;
   end Unlock;

begin
   Initialise;
end Ada_Store.Support.Screen;

Contents Page

Copyright © 1996 Simon Johnston &
Addison Wesley Longman