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;
Copyright ©
1996 Simon Johnston &
Addison Wesley Longman