home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
GEMini Atari
/
GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso
/
files
/
bbs
/
pibterm
/
pibt3sp3
/
pibscren.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-08-22
|
40KB
|
806 lines
(*----------------------------------------------------------------------*)
(* PIBSCREN.PAS --- Screen Handling Routines for Turbo Pascal *)
(*----------------------------------------------------------------------*)
(* *)
(* Author: Philip R. Burns *)
(* *)
(* Date: Version 1.0: January, 1985 (Part of PibMenus) *)
(* Version 1.1: March, 1985 (Part of PibMenus) *)
(* Version 1.2: May, 1985 (Part of PibMenus) *)
(* Version 2.0: June, 1985 (Split from PibMenus) *)
(* *)
(* Systems: For MS-DOS on IBM PCs and close compatibles only. *)
(* Note: I have checked these on Zenith 151s under *)
(* MSDOS 2.1 and IBM PCs under PCDOS 2.0. *)
(* *)
(* History: These routines provide a simple windowing facility for *)
(* Turbo Pascal as well as routines for direct access to the *)
(* screen memory area. *)
(* *)
(* The windowing facility provides windows similar to those *)
(* implemented in QMODEM by John Friel III. *)
(* *)
(* Version 1.0 of these routines formed part of the *)
(* PIBMENUS.PAS include file. These routines were split off *)
(* into a separate PIBSCREN.PAS file at version 2.0. *)
(* *)
(* Thanks to Mike Harrington for an elegant way of finding *)
(* the current upper left corner of a window without using *)
(* the kludge implemented in version 1.1. *)
(* *)
(* Suggestions for improvements or corrections are welcome. *)
(* Please leave messages on Gene Plantz's BBS (312) 882 4145 *)
(* or Ron Fox's BBS (312) 940 6496. *)
(* *)
(* If you use this code in your own programs, please be nice *)
(* and give all of us credit. *)
(* *)
(*----------------------------------------------------------------------*)
(* *)
(* Needs: These routines need the include files MINMAX.PAS, *)
(* GLOBTYPE.PAS, ASCII.PAS, and INT24.PAS. These files are not *)
(* included here, since Turbo regrettably does not allow *)
(* nested includes. *)
(* *)
(*----------------------------------------------------------------------*)
(* *)
(* Note that code for stacked windows is available here. You may *)
(* want to modify this to use compile-time window spaces, or remove *)
(* the current push-down stack structure. *)
(* *)
(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)
(* Constants, Types, and Variables for Screen Access *)
(*----------------------------------------------------------------------*)
CONST
Color_Screen_Address = $B800; (* Address of color screen *)
Mono_Screen_Address = $B000; (* Address of mono screen *)
Screen_Length = 4000; (* 80 x 25 x 2 = screen area length *)
Max_Saved_Screen = 5; (* Maximum no. of saved screens *)
TYPE
(* A screen image *)
Screen_Type = ARRAY[ 1 .. Screen_Length ] OF BYTE;
Screen_Ptr = ^Screen_Image_Type;
Screen_Image_Type = RECORD
Screen_Image: Screen_Type;
END;
(* Screen stack entries *)
Saved_Screen_Ptr = ^Saved_Screen_Type;
Saved_Screen_Type = RECORD
Screen_Image : Screen_Type;
Screen_Row : INTEGER;
Screen_Column : INTEGER;
Screen_X1 : INTEGER;
Screen_Y1 : INTEGER;
Screen_X2 : INTEGER;
Screen_Y2 : INTEGER;
END;
VAR
(* Memory-mapped screen area *)
Actual_Screen : Screen_Ptr;
(* Saves screen behind menus *)
Saved_Screen : Saved_Screen_Ptr;
(* Stack of saved screens *)
Saved_Screen_List : ARRAY[ 1 .. Max_Saved_Screen ] OF Saved_Screen_Ptr;
(* STRUCTURED *) CONST
(* Depth of saved screen stack *)
Current_Saved_Screen : 0 .. Max_Saved_Screen = 0;
(*----------------------------------------------------------------------*)
(* Color_Screen_Active --- Determine if color or mono screen *)
(*----------------------------------------------------------------------*)
FUNCTION Color_Screen_Active : BOOLEAN;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Color_Screen_Active *)
(* *)
(* Purpose: Determines if color or mono screen active *)
(* *)
(* Calling Sequence: *)
(* *)
(* Color_Active := Color_Screen_Active : BOOLEAN; *)
(* *)
(* Color_Active --- set to TRUE if the color screen is *)
(* active, FALSE if the mono screen is *)
(* active. *)
(* *)
(* Calls: INTR *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Regs : RegPack;
BEGIN (* Color_Screen_Active *)
Regs.Ax := 15 SHL 8;
INTR( $10 , Regs );
Color_Screen_Active := ( Regs.Al <> 7 );
End (* Color_Screen_Active *);
(*----------------------------------------------------------------------*)
(* Current_Video_Mode --- Determine current video mode setting *)
(*----------------------------------------------------------------------*)
FUNCTION Current_Video_Mode: INTEGER;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Current_Video_Mode *)
(* *)
(* Purpose: Gets current video mode setting from system *)
(* *)
(* Calling Sequence: *)
(* *)
(* Current_Mode := Current_Video_Mode : INTEGER; *)
(* *)
(* Current_Mode --- set to integer representing current *)
(* video mode inherited from system. *)
(* *)
(* Calls: INTR *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Regs : RegPack;
BEGIN (* Current_Video_Mode *)
Regs.Ax := 15 SHL 8;
INTR( $10 , Regs );
Current_Video_Mode := Regs.Al;
End (* Current_Video_Mode *);
(*----------------------------------------------------------------------*)
(* Get_Screen_Address --- Get address of current screen *)
(*----------------------------------------------------------------------*)
PROCEDURE Get_Screen_Address( VAR Actual_Screen : Screen_Ptr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Get_Screen_Address *)
(* *)
(* Purpose: Gets screen address for current type of display *)
(* *)
(* Calling Sequence: *)
(* *)
(* Get_Screen_Address( Var Actual_Screen : Screen_Ptr ); *)
(* *)
(* Actual_Screen --- pointer whose value receives the *)
(* current screen address. *)
(* *)
(* Calls: Color_Screen_Active *)
(* PTR *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Get_Screen_Address *)
IF Color_Screen_Active THEN
Actual_Screen := PTR( Color_Screen_Address , 0 )
ELSE
Actual_Screen := PTR( Mono_Screen_Address , 0 );
END (* Get_Screen_Address *);
(*----------------------------------------------------------------------*)
(* Video Display Control Routines *)
(*----------------------------------------------------------------------*)
(* *)
(* RvsVideoOn --- Turn On Reverse Video *)
(* RvsVideoOff --- Turn Off Reverse Video *)
(* *)
(*----------------------------------------------------------------------*)
PROCEDURE RvsVideoOn( Foreground_Color, Background_Color : INTEGER );
BEGIN (* RvsVideoOn *)
TextColor ( Background_color );
TextBackGround( Foreground_color );
END (* RvsVideoOn *);
(*----------------------------------------------------------------------*)
PROCEDURE RvsVideoOff( Foreground_Color, Background_Color : INTEGER );
BEGIN (* RvsVideoOff *)
TextColor ( Foreground_color );
TextBackGround( Background_color );
END (* RvsVideoOff *);
(*----------------------------------------------------------------------*)
(* TURBO Pascal Window Location Routines *)
(*----------------------------------------------------------------------*)
(* *)
(* These routines and constants give the four corners of the current *)
(* Turbo window: *)
(* *)
(* Lower right-hand corner: (Lower_Right_Column, Lower_Right_Row) *)
(* Upper left_hand corner: Upper_Left( Column, Row ) *)
(* *)
(*----------------------------------------------------------------------*)
(* Lower right corner of *)
(* current TURBO window *)
VAR
Lower_Right_Column : Byte ABSOLUTE Cseg:$016A;
Lower_Right_Row : Byte ABSOLUTE Cseg:$016B;
(*----------------------------------------------------------------------*)
(* Upper_Left --- Upper Positions of current window *)
(*----------------------------------------------------------------------*)
PROCEDURE Upper_Left( VAR X1, Y1 : INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Upper_Left *)
(* *)
(* Purpose: Returns upper positions of current TURBO window *)
(* *)
(* Calling Sequence: *)
(* *)
(* Upper_Left( VAR X1, Y1 : INTEGER ); *)
(* *)
(* X1 --- returned upper left column *)
(* Y1 --- returned upper left row *)
(* *)
(* Calls: INTR *)
(* WhereX *)
(* WhereY *)
(* GoToXY *)
(* *)
(*----------------------------------------------------------------------*)
VAR
TempX : INTEGER;
TempY : INTEGER;
Reg : RegPack;
BEGIN (* Upper_Left *)
TempX := WhereX; (* Save Current Cursor Pos. *)
TempY := WhereY;
GoToXY( 1 , 1 ); (* Goto Upper Left corner of window *)
Reg.Ax := $0300; (* Set up reg's for INTR *)
Reg.Bx := 0;
INTR( $10 , Reg ); (* Call BIOS Read Cursor Position *)
Y1 := Reg.Dh + 1; (* get Row *)
X1 := Reg.Dl + 1; (* get Column *)
GoToXY( TempX , TempY ); (* Return to orig. position *)
END (* Upper_Left *);
(*----------------------------------------------------------------------*)
(* Set/Reset Text Color Routines *)
(*----------------------------------------------------------------------*)
(* *)
(* These routines set and reset the global text foreground and *)
(* background colors. *)
(* *)
(*----------------------------------------------------------------------*)
(* Global Text Color Variables *)
VAR
Global_ForeGround_Color : INTEGER;
Global_BackGround_Color : INTEGER;
(*----------------------------------------------------------------------*)
(* Set_Global_Colors --- Reset global foreground, background cols. *)
(*----------------------------------------------------------------------*)
PROCEDURE Set_Global_Colors( ForeGround, BackGround : INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Set_Global_Colors *)
(* *)
(* Purpose: Sets global text foreground, background colors. *)
(* *)
(* Calling Sequence: *)
(* *)
(* Set_Global_Colors( ForeGround, BackGround : INTEGER ); *)
(* *)
(* ForeGround --- Default foreground color *)
(* BackGround --- Default background color *)
(* *)
(* Calls: TextColor *)
(* TextBackGround *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Set_Global_Colors *)
Global_ForeGround_Color := ForeGround;
GLobal_BackGround_Color := BackGround;
TextColor ( Global_ForeGround_Color );
TextBackground( Global_BackGround_Color );
END (* Set_Global_Colors *);
(*----------------------------------------------------------------------*)
(* Reset_Global_Colors --- Reset global foreground, background cols. *)
(*----------------------------------------------------------------------*)
PROCEDURE Reset_Global_Colors;
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Reset_Global_Colors *)
(* *)
(* Purpose: Resets text foreground, background colors to global *)
(* defaults. *)
(* *)
(* Calling Sequence: *)
(* *)
(* Reset_Global_Colors; *)
(* *)
(* Calls: TextColor *)
(* TextBackGround *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Reset_Global_Colors *)
TextColor ( Global_ForeGround_Color );
TextBackground( Global_BackGround_Color );
END (* Reset_Global_Colors *);
(*----------------------------------------------------------------------*)
(* Screen Manipulation Routines *)
(*----------------------------------------------------------------------*)
(* *)
(* These routines save and restore screen images in support of the *)
(* windowing facility. Also, the current screen image can be printed *)
(* and text extracted from the screen memory. *)
(* *)
(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)
(* Get_Screen_Text_Line --- Extract text from screen image *)
(*----------------------------------------------------------------------*)
PROCEDURE Get_Screen_Text_Line( VAR Text_Line : AnyStr;
Screen_Line : INTEGER;
Screen_Column : INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Get_Screen_Text_Line *)
(* *)
(* Purpose: Extracts text from current screen image *)
(* *)
(* Calling Sequence: *)
(* *)
(* Get_Screen_Text_Line( Var Text_Line : AnyStr; *)
(* Screen_Line : INTEGER; *)
(* Screen_Column : INTEGER ); *)
(* *)
(* Text_Line --- receives text extracted from screen *)
(* Screen_Line --- line on screen to extract *)
(* Screen_Column --- starting column to extract *)
(* *)
(* Calls: None *)
(* *)
(* Remarks: *)
(* *)
(* Only the text -- not attributes -- from the screen is *)
(* returned. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
First_Pos : INTEGER;
Last_Pos : INTEGER;
I : INTEGER;
BEGIN (* Get_Screen_Text_Line *)
Screen_Line := Max( Min( Screen_Line , 25 ) , 1 );
Screen_Column := Max( Min( Screen_Column , 80 ) , 1 );
Text_Line := '';
First_Pos := ( ( Screen_Line - 1 ) * 80 + Screen_Column ) * 2 - 1;
Last_Pos := First_Pos + ( 80 - Screen_Column ) * 2 + 1;
REPEAT
Text_Line := Text_Line + CHR( Actual_Screen^.Screen_Image[ First_Pos ] );
First_Pos := First_Pos + 2;
UNTIL ( First_Pos > Last_Pos );
END (* Get_Screen_Text_Line *);
(*----------------------------------------------------------------------*)
(* Print_Screen --- Print current screen image *)
(*----------------------------------------------------------------------*)
PROCEDURE Print_Screen;
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Print_Screen *)
(* *)
(* Purpose: Prints current screen image (memory mapped area) *)
(* *)
(* Calling Sequence: *)
(* *)
(* Print_Screen; *)
(* *)
(* Calls: None *)
(* *)
(* Remarks: *)
(* *)
(* Only the text from the screen is printed, not the attributes. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
I : INTEGER;
Text_Line : STRING[80];
BEGIN (* Print_Screen *)
FOR I := 1 TO 25 DO
BEGIN
Get_Screen_Text_Line( Text_Line, I, 1 );
WRITELN( Lst , Text_Line );
END;
END (* Print_Screen *);
(*----------------------------------------------------------------------*)
(* Write_Screen --- Write current screen image to file *)
(*----------------------------------------------------------------------*)
PROCEDURE Write_Screen( Fname : AnyStr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Write_Screen *)
(* *)
(* Purpose: Write current screen image (memory mapped area) to *)
(* a file. *)
(* *)
(* Calling Sequence: *)
(* *)
(* Write_Screen( Fname : AnyStr ); *)
(* *)
(* Fname --- Name of file to write screen to *)
(* *)
(* Calls: None *)
(* *)
(* Remarks: *)
(* *)
(* Only the text from the screen is written, not the attributes. *)
(* If the file already exists, then the new screen is appended *)
(* to the end of the file. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
I : INTEGER;
Text_Line : STRING[80];
F : TEXT [512];
BEGIN (* Write_Screen *)
(*$I-*)
ASSIGN( F , Fname );
RESET ( F );
IF Int24Result = 0 THEN
BEGIN
CLOSE( F );
APPEND( F );
END
ELSE
BEGIN
CLOSE ( F );
REWRITE( F );
END;
FOR I := 1 TO 25 DO
BEGIN
Get_Screen_Text_Line( Text_Line, I, 1 );
WRITELN( F , Text_Line );
END;
CLOSE( F );
(*$I+*)
END (* Write_Screen *);
(*----------------------------------------------------------------------*)
(* WriteSLin --- Write text string to screen *)
(*----------------------------------------------------------------------*)
PROCEDURE WriteSLin( S: AnyStr; Color: INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: WriteSLin *)
(* *)
(* Purpose: Writes text string to current line in screen memory *)
(* *)
(* Calling Sequence: *)
(* *)
(* WriteSLin( S: AnyStr; Color: INTEGER ); *)
(* *)
(* S --- String to be written *)
(* Color --- Color in which to write string *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Length_S : INTEGER;
S_Column : INTEGER;
S_Row : INTEGER;
I : INTEGER;
BEGIN (* WriteSLin *)
Length_S := LENGTH( S );
S_Column := 1;
S_Row := ( WhereY - 1 ) * 160;
FOR I := 1 TO Length_S DO
WITH Actual_Screen^ DO
BEGIN
Screen_Image[ S_Column + S_Row ] := ORD( COPY( S, I, 1 ) );
Screen_Image[ S_Column + S_Row + 1 ] := Color;
S_Column := S_Column + 2;
END;
S_Row := S_Row + 160;
IF S_Row > 3800 THEN
InsLine;
END (* WriteSLin *);
(*----------------------------------------------------------------------*)
(* WriteSXY --- Write text string to specified row/column *)
(*----------------------------------------------------------------------*)
PROCEDURE WriteSXY( S: AnyStr; X: INTEGER; Y: INTEGER; Color: INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: WriteSXY *)
(* *)
(* Purpose: Writes text string at specified row and column *)
(* position on screen. *)
(* *)
(* Calling Sequence: *)
(* *)
(* WriteSXY( S: AnyStr; X: INTEGER; Y: INTEGER; Color: INTEGER );*)
(* *)
(* S --- String to be written *)
(* X --- Column position to write string *)
(* Y --- Column position to write string *)
(* Color --- Color in which to write string *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Length_S : INTEGER;
S_Column : INTEGER;
S_Row : INTEGER;
I : INTEGER;
S_Pos : INTEGER;
BEGIN (* WriteSXY *)
Length_S := LENGTH( S );
S_Pos := 0;
FOR I := 1 TO Length_S DO
WITH Actual_Screen^ DO
IF S_Pos < 4001 THEN
BEGIN
S_Pos := ( ( Y - 1 ) * 80 + X ) * 2 - 1;
Screen_Image[ S_Pos ] := ORD( COPY( S, I, 1 ) );
Screen_Image[ S_Pos + 1 ] := Color;
X := X + 1;
END;
END (* WriteSXY *);
(*----------------------------------------------------------------------*)
(* WriteCXY --- Write character to screen at specified row/column *)
(*----------------------------------------------------------------------*)
PROCEDURE WriteCXY( C: CHAR; X: INTEGER; Y: INTEGER; Color: INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: WriteCXY *)
(* *)
(* Purpose: Writes a character at specified row and column *)
(* position on screen. *)
(* *)
(* Calling Sequence: *)
(* *)
(* WriteCXY( C: CHAR; X: INTEGER; Y: INTEGER; Color: INTEGER ); *)
(* *)
(* C --- Character to be written *)
(* X --- Column position to write string *)
(* Y --- Column position to write string *)
(* Color --- Color in which to write string *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
VAR
S_Pos : INTEGER;
BEGIN (* WriteCXY *)
WITH Actual_Screen^ DO
BEGIN
S_Pos := ( ( Y - 1 ) * 80 + X ) * 2 - 1;
Screen_Image[ S_Pos ] := ORD( C );
Screen_Image[ S_Pos + 1 ] := Color;
END;
END (* WriteCXY *);
(*----------------------------------------------------------------------*)
(* Save_Screen --- Save current screen image *)
(*----------------------------------------------------------------------*)
PROCEDURE Save_Screen( VAR Saved_Screen_Pointer : Saved_Screen_Ptr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Save_Screen *)
(* *)
(* Purpose: Saves current screen image (memory mapped area) *)
(* *)
(* Calling Sequence: *)
(* *)
(* Save_Screen( Var Saved_Screen_Pointer : Saved_Screen_Ptr ); *)
(* *)
(* Saved_Screen_Pointer --- pointer to record receiving *)
(* screen image, window location, *)
(* and current cursor location. *)
(* *)
(* Calls: Move *)
(* Upper_Left *)
(* *)
(* Remarks: *)
(* *)
(* This version checks for stack overflow. *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Save_Screen *)
(* Overwrite last screen if no room *)
IF Current_Saved_Screen >= Max_Saved_Screen THEN
Saved_Screen_Pointer := Saved_Screen_List[ Max_Saved_Screen ]
ELSE
BEGIN
Current_Saved_Screen := Current_Saved_Screen + 1;
NEW( Saved_Screen_Pointer );
Saved_Screen_List[ Current_Saved_Screen ] := Saved_Screen_Pointer;
END;
WITH Saved_Screen_Pointer^ DO
BEGIN
Upper_Left( Screen_X1, Screen_Y1 );
Screen_X2 := Lower_Right_Column;
Screen_Y2 := Lower_Right_Row;
Screen_Row := WhereY;
Screen_Column := WhereX;
MOVE( Actual_Screen^.Screen_Image, Screen_Image, Screen_Length );
END;
END (* Save_Screen *);
(*----------------------------------------------------------------------*)
(* Restore_Screen --- Restore saved screen image *)
(*----------------------------------------------------------------------*)
PROCEDURE Restore_Screen( VAR Saved_Screen_Pointer : Saved_Screen_Ptr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Restore_Screen *)
(* *)
(* Purpose: Restores previously saved screen image. *)
(* *)
(* Calling Sequence: *)
(* *)
(* Restore_Screen( Var Saved_Screen_Pointer: Saved_Screen_Ptr ); *)
(* *)
(* Saved_Screen_Pointer --- pointer to record with saved *)
(* screen image, window location, *)
(* and cursor location. *)
(* *)
(* Calls: Window *)
(* Move *)
(* GoToXY *)
(* *)
(* Remarks: *)
(* *)
(* All saved screen pointers from the last saved down to the *)
(* argument pointer are popped from the saved screen list. *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Restore_Screen *)
WITH Saved_Screen_Pointer^ DO
BEGIN
Window( Screen_X1, Screen_Y1, Screen_X2, Screen_Y2 );
MOVE( Screen_Image, Actual_Screen^.Screen_Image, Screen_Length );
GoToXY( Screen_Column, Screen_Row );
END;
WHILE( Saved_Screen_List[ Current_Saved_Screen ] <> Saved_Screen_Pointer ) DO
BEGIN
DISPOSE( Saved_Screen_List[ Current_Saved_Screen ] );
Current_Saved_Screen := Current_Saved_Screen - 1;
END;
IF Current_Saved_Screen > 0 THEN
Current_Saved_Screen := Current_Saved_Screen - 1;
DISPOSE( Saved_Screen_Pointer );
Saved_Screen_Pointer := NIL;
END (* Restore_Screen *);
ə
