home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frostbyte's 1980s DOS Shareware Collection
/
floppyshareware.zip
/
floppyshareware
/
USCX
/
TURBO-06.ZIP
/
UTIL.INC
< prev
next >
Wrap
Text File
|
1985-02-23
|
58KB
|
1,654 lines
{****************************************************************************
* This Module Comprises the various utility routines used by the other *
* modules in the program. Routines included in this module are: *
* *
* Routine Use *
* * 1 Upper_Left_X Returns the left x coordinate of active window *
* * 2 Upper_Left_Y Returns the upper y coord of active window *
* * 3 Lower_Right_X Returns the right x coord of active window *
* * 4 Lower_Right_Y Returns the lower y coord of active window *
* * 5 RvsOn Turns on Reverse Video *
* * 6 RvsOff Turns off Reverse Video *
* 7 Yes Prints a prompt, if user inputs 'Y' returns *
* Trues, otherwise returns False *
* * 8 Click Produces a single click from the PC speaker *
* * 9 Alert Prints a message to the screen and makes noise *
* * 10 Beep Makes noise for a specified period of time *
* 11 Replicate Duplicates a character a specified no. of times*
* 12 Left Left justifys a string in a field of spaces *
* 13 Center Centers a string in a field of specified width *
* 14 Get_Payment_Amount Calculates a loan payment amount *
* 15 Write_Neatly Outputs numbers with commas *
* 16 Get_Str Writes a string to the screen, allows it to be *
* edited and returns the terminating character *
* 17 Get_Num Does for numbers what Get_Str does for strings *
* * 18 Frame Frames a specified portion of the screen *
* * 19 UnFrame Removes the frame from the screen *
* * 20 Menu Displays a menu and gets a user input *
* * 21 Clear_Window Clears the screen within a window *
* * 22 Window_Frame Sets up, frames and titles a screen window *
* 23 Encrypt Encrypts a string using XOR *
* 24 Decrypt Decrypts a string encrypted by encrypt *
* 25 GetChar Gets a character from the keyboard *
* 26 Wait Waits for a KeyPressed *
* 27 Get_Pass Gets a password from the user *
* * 28 Push_Screen Saves the current screen *
* * 29 Pop_Screen Restores a saved screen *
* 30 Inc Increments an integer by 1 *
* 31 Dec Decrements an integer by 1 *
* * 32 Setup Sets the IBM Serial Interface *
* 34 Upper Convert String to Upper Case *
* 35 Lower Convert String to Lower Case *
* * 36 DosConOut Usr Device Driver. Calls DOS Video Output *
* * 37 SerialIn Aux Device Driver. Serial port input *
* * 38 SerialOut Aux Device Driver. Serial port output *
* 39 Power Raises a number to a power *
* * 40 Data Returns true if there is data at the RS232 *
* * 41 ColScr Switch to color monitor if there *
* * 42 MonoScr Switch to Monochrome monitor if there *
* * 43 Marquee Display Marquee and put message in it *
* * 44 Help Displays an appropriate help screen *
* * 45 Well Expresses impatience *
* * 47 Siren makes a sound like a siren *
* * 48 GetForm generalized input routine *
* * 49 Date gets the date from the system *
* * 50 Time gets time from system *
* * 51 Push_Window pushes a small section of the screen *
* * 52 Elapsed_time the time in seconds from the argument *
* *
* * Indicates that the routine has IBM PC specific sections and would need*
* to be modified for other computers *
****************************************************************************}
Procedure HighVideo;
Begin
TextColor(White);
TextBackground(Black);
End;
Procedure NormVideo;
Begin
TextColor(White);
TextBackground(Black);
End;
Procedure LowVideo;
Begin
TextColor(LightGray);
TextBackground(Black);
End;
Type
Parity_Types = (Odd_Parity, Even_Parity, No_Parity);
Reg = Record
AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
End;
Const
COM1 = 1016; {Com1 and Com2 Base port address}
DLL = 0; {LSB of Divisor Latch, Offset 0, R/W}
DLM = 1; {MSB of Divisor Latch, Offset 1, R/W}
LCR = 3; {Line Control Register, Offset 3, R/W}
MCR = 4; {Modem Control Register, Offset 4, R/W}
LSR = 5; {Line Status Register, Offset 5, RO}
MSR = 6; {Modem Status Register, Offset 6, RO}
MRR = 7; {Modem Rate Register, Offset 7, RO, (1200B Hayes only)}
DLAB = 128; {Data Latch Access Bit, High to access DLL and DLM}
SBRK = 64; {Set Break, High to transmit a break signal}
STPTY = 32; {Stick Parity, If high parity bit follows EPS}
EPS = 16; {Select Even Parity, High for Even parity}
PEN = 8; {Parity Enable, High to enable parity checking}
STB = 4; {Stop Bits, High for 2 stop bits (1.5 for 5 bit word)
low for 1 stop bit}
WLS = 3; {Select Number of bits per word as follows:
Bit 1 Bit 2 Word Length
0 0 5 Bits
0 1 6 Bits
1 0 7 Bits
1 1 8 Bits}
LOOP = 16; {Enable loop back for testing}
OUT2 = 8; {Enable interrupt line drivers if high}
OUT1 = 4; {Reset Smartmodem 1200B}
RTS = 2; {Request to send follows this bit}
DTR = 1; {Data Terminal Ready follows this bit inversely, required
for modem operation}
{****************************************************************************}
Function Upper_Left_X : Integer; {* These four routines allow a *}
{1*} {* routine to adjust its output *}
Begin {* according to what size window it *}
Upper_Left_X := Mem[Dseg:$156] + 1; {* is operating in. They are *}
End; {* compatible only with Turbo Pascal *}
{* version 2.0 on an IBM PC or *}
Function Upper_Left_Y : Integer; {* compatible *}
{2*}
Begin
Upper_Left_Y := Mem[Dseg:$157] + 1;
End;
Var
{3*}
Lower_Right_X : Byte Absolute Cseg:$16A;
{4*}
Lower_Right_Y : Byte Absolute Cseg:$16B;
{****************************************************************************}
Procedure RvsOn; {* These two routines turn on and *}
{5*} {* off Reverse video on the IBM PC *}
Begin {*************************************}
TextColor(0);
TextBackGround(7);
End;
Procedure RvsOff;
{6*}
Begin
LowVideo;
End;
{30**************************************************************************}
Procedure Inc( {* Increment argument by One *}
Var I : Integer); {*****************************************}
Begin
I := I + 1;
End;
{31**************************************************************************}
Procedure Dec( {* Decrement argument by One *}
Var I : Integer); {*****************************************}
Begin
I := I - 1;
End;
{26**************************************************************************}
Procedure Wait; {* Wait for a keypress from the KBD *}
{**************************************}
Var
AnyKey : Char;
Begin
Read(Kbd,AnyKey);
End;
{****************************************************************************}
Type {* Just a couple of type declarations*}
Menu_Item = String[40]; {* needed for a number of routines *}
{*************************************}
Menu_Selections = Array[1..15] of Menu_Item;
Long_String = String[255];
Register = Record
AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
End;
ScreenLoc = Record
Ch : Char;
Attrib : Byte;
End;
Video = Array[1..25] of Array[1..80] of ScreenLoc;
Video_Ptr = ^Video_Stack;
vidscr = array[1..1] of screenloc;
Video_Stack = Record
Next_Screen : Video_Ptr;
x1,y1,
x2,y2 : byte;
Screen_store : ^vidscr;
End;
Var
ScreenBuffer : Video;
Screen_Stack : Video_Ptr;
Screen : ^Video;
Com : Integer;
HelpContext : Integer;
ScreenFile : File of Video;
{7***************************************************************************}
Function Yes(Prompt : Long_String) : Boolean;{* This routine prints PROMPT *}
{* to the screen and waits for *}
Var {* the user to type either a *}
Inchar : Char; {* 'y' or 'n'. It is case *}
{* insensitive. If a 'y' is *}
Begin {* entered, the function *}
Write(Prompt); {* returns TRUE. *}
Repeat {*******************************}
Read(Kbd,Inchar);
Until Inchar in ['Y','y','N','n'];
Write(Inchar);
Yes := Inchar in ['Y','y'];
End;
{34**************************************************************************}
Function Upper (S : Long_String) {* Convert Strng S to Upper case *}
: Long_String; {* Return uppercase string *}
{*************************************}
Var
I : Integer;
lcase : Set of Char;
Begin
lcase := ['a'..'z'];
For I := 1 to Length(S) do
If S[I] In lcase then
S[I] := Char(Ord(S[I]) - 32);
Upper := S;
End;
{35**************************************************************************}
Function Lower (S : Long_String) {* Convert string S to lowercase *}
: Long_String; {* Return lowercase string *}
{****************************************}
Var
I : Integer;
ucase : Set of Char;
Begin
ucase := ['A'..'Z'];
For I := 1 to Length(S) do
If S[I] in ucase then
S[I] := Char(Ord(S[I]) + 32);
lower := S;
End;
{8***************************************************************************}
Procedure Click; {* Makes a clicking noise *
*************************************}
var f,n : integer;
Begin
Sound(2000);
Delay(5);
NoSound;
End;
{9***************************************************************************}
Procedure Alert(Message : Long_String);{* This routine prints MESSAGE to the*}
{* screen and makes an obnoxious *}
Var {* noise for about 1 second *}
I : Integer; {*************************************}
i1,i2,i3,i4 : integer;
begin
write(Message);
for i4 := 1 to 10 do
begin
i2 := 250 + i4 * 25;
for i3 := 1 to 2 do
begin
for i1 := 1 to 30 - i3 * 2 do
begin
sound(i1 + i2 + i3 * 2);
delay(2);
end;
delay(5);
i2 := i2 + 30;
end;
nosound;
end;
end;
{21**************************************************************************}
Procedure Clear_Window; {* Clear the Active window *}
{*******************************************}
Var
I : Integer;
Begin
For I := 1 to Lower_Right_Y - Upper_Left_Y + 1 do
Begin
GotoXY(1,I);
ClrEol;
End;
End;
{10**************************************************************************}
Procedure Beep(N : Integer); {* This routine sounds a tone of frequency *}
{* N for approximately 100 ms *}
Begin {********************************************}
Sound(n);
Delay(100);
NoSound;
End;
{28**************************************************************************}
Procedure Push_Screen; {* This routine stores the current *}
{* screen into a temporary storage *}
{* area *}
{**************************************}
Var
Temp : Video_Ptr;
i,j,k : integer;
Begin
If (MaxAvail < 0) or (MaxAvail > 4096) then
Begin
If Screen = Nil then
Screen := Ptr($B000,0);
new(Temp);
temp^.x1 := 1;
temp^.y1 := 1;
temp^.x2 := 80;
temp^.y2 := 25;
getmem(temp^.screen_store,4000);
Temp^.Next_Screen := Screen_Stack;
k := 1;
for i := 1 to 25 do
for j := 1 to 80 do
begin
temp^.screen_store^[k] := screen^[i][j];
inc(k);
end;
Screen_Stack := Temp;
End
Else
Begin
Alert('Insufficient Memory - You are being dumped');
Halt;
End;
End;
{29**************************************************************************}
Procedure Pop_Screen; {* This routine Pops a screen from the*}
{* Screen Stack *}
{**************************************}
Var
Temp : Video_Ptr;
i,j,k : integer;
Begin
If Screen = nil then
Screen := Ptr($B000,0);
k := 1;
for i := screen_stack^.y1 to screen_stack^.y2 do
for j := screen_stack^.x1 to screen_stack^.x2 do
begin
screen^[i][j] := screen_stack^.screen_store^[k];
inc(k);
end;
Temp := Screen_Stack;
Screen_Stack := Screen_Stack^.Next_Screen;
freemem(Temp^.screen_store,
((temp^.x2 - temp^.x1 + 1) * (temp^.y2 - temp^.y1 + 1)) * 2);
dispose(temp);
End;
{43**************************************************************************}
Procedure Marquee {* Draws a marquee in center screen *}
(Str : Long_String);{* Around the input parameter *}
{***************************************}
Const
OnChr = #1;
OffChr = #2;
Var
I,J,K : Integer;
X,Y : Integer;
Astrsk : Array[1..4] of Record
X,Y : Integer;
OldX,OldY : Integer;
XI,YI : Integer;
End;
Begin
Window(1,1,80,25);
Push_Screen;
ClrScr;
X := 40 - Length(Str) Div 2 - 2;
For I := 10 to 14 do
Begin
Screen^[I][X].Ch := OnChr;
Screen^[I][X].Attrib := 7;
Screen^[I][X + Length(Str) + 3].Ch := OnChr;
Screen^[I][X + Length(Str) + 3].Attrib := 7;
End;
For I := X to X + Length(Str) + 3 do
Begin
Screen^[10][I].Ch := OnChr;
Screen^[14][I].Ch := OnChr;
Screen^[10][I].Attrib := 7;
Screen^[14][I].Attrib := 7;
End;
GotoXY(X+2,12);
HighVideo;
Write(Str);
LowVideo;
Astrsk[1].X := 40;
Astrsk[1].Y := 10;
Astrsk[1].XI := 1;
Astrsk[1].YI := 0;
Astrsk[2].X := X;
Astrsk[2].Y := 12;
Astrsk[2].XI := 0;
Astrsk[2].YI := -1;
Astrsk[3].X := X + Length(Str) + 3;
Astrsk[3].Y := 12;
Astrsk[3].XI := 0;
Astrsk[3].YI := 1;
Astrsk[4].X := 40;
Astrsk[4].Y := 14;
Astrsk[4].XI := -1;
Astrsk[4].YI := 0;
Astrsk[4].OldX := Astrsk[1].X;
Astrsk[4].OldY := Astrsk[1].Y;
Astrsk[3].OldX := Astrsk[2].X;
Astrsk[3].OldY := Astrsk[2].Y;
Astrsk[2].OldX := Astrsk[3].X;
Astrsk[2].OldY := Astrsk[3].Y;
Astrsk[1].OldX := Astrsk[4].X;
Astrsk[1].OldY := Astrsk[4].Y;
K := 1;
Repeat
If K > 4 Then
K := 1;
J := Astrsk[K].Y;
I := Astrsk[K].X;
If Screen = Ptr($B800,0) then
Repeat Until (Port[$3DA] And 1) = 1
Else
Repeat Until (Port[$3BA] And 1) = 1;
Screen^[J][I].Ch := OffChr;
Screen^[Astrsk[K].OldY][Astrsk[K].OldX].Ch := OnChr;
Screen^[J][I].Attrib := 15;
Screen^[Astrsk[K].OldY][Astrsk[K].OldX].Attrib := 7;
Astrsk[K].OldX := Astrsk[K].X;
Astrsk[K].OldY := Astrsk[K].Y;
I := I + Astrsk[K].XI;
J := J + Astrsk[K].YI;
If I > (X + Length(Str) + 3) then
Begin
I := I - Astrsk[K].XI;
Astrsk[K].XI := 0;
Astrsk[K].YI := 1;
End;
If J > 14 then
Begin
J := J - Astrsk[K].YI;
Astrsk[K].YI := 0;
Astrsk[K].XI := -1;
End;
If I < X then
Begin
I := I - Astrsk[K].XI;
Astrsk[K].XI := 0;
Astrsk[K].YI := -1;
End;
If J < 10 then
Begin
J := J - Astrsk[K].YI;
Astrsk[K].YI := 0;
Astrsk[K].XI := 1;
End;
Astrsk[K].Y := J;
Astrsk[K].X := I;
Inc(K);
Until KeyPressed;
Wait;
Pop_Screen;
End;
{44**************************************************************************}
Procedure Help; {* This routine reads a screen from the*}
{* Screen file and displays it *}
Begin {***************************************}
Push_Screen;
{$I-}
Seek(ScreenFile,HelpContext);
{$I+}
If IOResult = 0 Then
Begin
{$I-}
Read(ScreenFile,ScreenBuffer);
{$I+}
Screen^ := ScreenBuffer;
If IOResult <> 0 Then
Marquee('Sorry, I''m helpless in this situation')
Else
Wait;
End
Else
Marquee('Sorry, wish I could help you.');
Pop_Screen;
End;
{11**************************************************************************}
Function Replicate ( {* Repeat a character *}
Count : Integer; {* Number of Repititions *}
Ascii : Char {* Character to be repeated *}
) : Long_String; {* String containing repeated *}
{* character *
* This function takes the character in 'Ascii', repeats it 'Count' times *
* and returns the resulting string as a 'Long_String' *
****************************************************************************}
Var
Temp : Long_String; {Used to hold the incomplete result}
I : Byte; {For Counter}
Begin
Temp := '';
For I := 1 to Count do
Temp := Temp + Ascii;
Replicate := Temp;
End; {Replicate}
{12*************************************************************************}
Function Left ( {* Left Justifies a string in a *}
Str : Long_String; {* field of spaces *}
Width : Integer {*************************************}
) : Long_String;
Begin
If Length(Str) > Width then
Left := Copy(Str,1,Width)
Else
Left := Str + Replicate(Width - Length(Str),' ');
End;
{13**************************************************************************}
Function Center ( {* Centers a string in field *}
Field_Width : Byte; {* Width of field for center *}
Center_String : Long_String {* String to Center *}
) : Long_String; {* Return the string *}
{************************************************ *
* This functions takes the string 'Center_String' and centers it in a *
* field 'Field_Width' Spaces long. It returns a 'Long_String' with a *
* length equal to 'Field_Width'. If the 'Center_String' is longer than *
* field width, it is truncated on the right end and is not centered. *
****************************************************************************}
Var
Temp : Long_String;
Middle : Byte;
Begin
Middle := Field_Width div 2;
If Length(Center_String) > Field_Width then
Center := Copy(Center_String,1,Field_Width) {Truncate and return}
Else
Begin
Temp := Replicate(Middle - (Length(Center_String) div 2),' ') +
Center_String +
Replicate(Middle - (Length(Center_String) div 2) + 1,' ');
Center := Copy(Temp, 1, Field_Width) {Truncate to Field_Width Characters}
End {Else}
End; {Center}
{39*************************************************************************}
Function Power(X : Real; Y : Integer): {* This function raises X to the *}
Real; {* Yth power *}
{**********************************}
Var
I : Integer;
N : Real;
Begin
N := 1.0;
For I := 1 To Y do
N := N * X;
Power := N;
End; {Power}
{14*************************************************************************}
Function Get_Payment_Amount (Loan_Amount : Real;
Interest_Rate : Real;
Amort_Over : Real
) : Real;
VAR
Monthly_Interest_Rate : Real;
Number_of_Payments : Integer;
BEGIN
Monthly_Interest_Rate := (Interest_Rate / 100.0) / 12.0;
Number_of_Payments := Trunc (Amort_Over * 12);
Get_Payment_Amount := Loan_Amount *
(1 / ((1 - 1 / Power((1 + Monthly_Interest_Rate),Number_Of_Payments))/
Monthly_Interest_Rate));
END;
{15**************************************************************************}
Procedure Write_Neatly ( {* Routine to write numbers *}
var OutFile : Text; {* output file *}
Number : Real; {* Number to be written *}
Width : Byte; {* Width of write area *}
Max_Dec : Byte {* Number of decimal places *}
); {* This routine takes NUMBER, and *}
{* formats it with commas and *}
{* truncates to MAX_DEC decimal *}
{* places. If NUMBER is to big to *}
{* fit in WIDTH, then a row of *}
{* asterisks WIDTH long is output *}
{***********************************}
Const
Valid_Digits : Set of char = ['0'..'9','.','-','+','e'];
Var
Field : Long_String;
Point : Integer;
I,J : Integer; {Spares for counters}
Begin
For I := 1 to Max_Dec do
Number := Number * 10;
Number := Number + 0.6;
For I := 1 to Max_Dec do
Number := Number / 10;
Str(Number:0:20,Field); {Convert the input to a string}
I := 1;
I := Pos('.',Field); {Where's the Decimal!}
If I = 0 then
Begin
Field := Field + '.'; {If no decimal, then add one}
Point := Length(Field);
End
Else
Point := I;
I := Point - 3; {Get the Point?}
While I > 1 do {put in commas, start at the back and work }
Begin {to the front}
Insert(',',Field,I);
I := I - 3
End;
I := Pos('.',Field) - 1; {Find that pesky decimal}
J := 0;
While J <= Max_Dec do
Begin
I := I + 1; {Pad to Max_Dec with zeros}
If I >= Length(Field) then
Field := Field + '0';
J := J + 1;
End;
Field := Copy(Field,1,I); {Clean it up a little and elimate trailers}
If Max_Dec = 0 then
Field := Copy(Field,1,I - 1); {Truncate to integer if necessary}
If (Length(Field) > Width) and (Width > 0) then
Write(Replicate(Width,'*')) {Too Big! tell with asterisks}
Else
Write(OutFile,Field:Width); {all that for this}
End;
{16**************************************************************************}
Function Get_Str ( {* Get a string with editing *}
Var In_Str : Long_String; {* String to be edited *}
Buffer_Len : Integer; {* Its length *}
Start_X : Integer; {* Column to start in *}
Y : Integer; {* Row for input *}
Force_Case : Boolean {* Force Input to Upper case *}
) : Char; {* Return terminating Character *}
{* *}
{* This is a fairly versatile *}
{* string input and editing *}
{* routine. It takes IN_STRING *}
{* displays it at START_X,ROW *}
{* allows the user to edit the *}
{* string using WordStar(tm) *}
{* commands. It returns the *}
{* character used to terminate *}
{* input. By setting FORCE_CASE*}
{* true, all input is forced to *}
{* upper case *}
{********************************}
Const
KeyClick = True;
Var
Insert_Mode : Boolean;
Done : Boolean;
Current_Char : Char;
X : Byte;
Escape : Boolean;
Current : Char;
in_string : Long_String;
Begin
Done := False; { ** }
Insert_Mode := False; { * Initialize starting variables}
GotoXY(Start_X,Y); { * }
X := Start_X; { ** }
Write(Replicate(Buffer_Len,'_'));
In_String := in_str;
GotoXY(X,Y);
Write (In_String); {Write the initial value of the string}
GotoXY(X,Y);
Repeat {Start main edit/input loop}
If (X - Start_X) = Buffer_Len then
Current_Char := ^M {Terminate input if buffer is full}
Else
Read(Kbd,Current_Char); {Get a character}
If Force_Case then
Current_Char := UpCase(Current_Char); {force case if necessary}
Repeat
Escape := False;
Case Current_Char of {Act on the current input}
^[ : If KeyPressed then
Begin
Read(Kbd,Current_Char);
Escape := True;
Case Current_Char of {Translate escape codes to}
'H' : Current_Char := ^E; {WordStar command codes }
'P' : Current_Char := ^X;
'K' : Current_Char := ^S;
'M' : Current_Char := ^D;
'S' : Current_Char := ^G;
'R' : Current_Char := ^V;
'<' : Current_Char := ^R;
's' : Current_Char := ^A;
't' : Current_Char := ^F;
';' : Begin
Help;
Current_Char := ^@;
End;
'D' : Begin {Special Terminator}
Done := True;
Escape := False;
End;
'I' : Begin
Done := True;
Escape := False;
End;
'Q' : Begin
Done := True;
Escape := False;
End;
'O' : Begin
Done := True;
Escape := False;
End;
'G' : Begin
Done := True;
Escape := False;
End;
End; {Case}
End; {^[}
^E : Done := True; {** }
{ ** All finished }
^X : Done := True; {** }
^F : x := start_x + length(in_string);
^A : x := start_x;
^R : Begin
In_string := in_str;
Gotoxy(start_x,y);
write(replicate(Buffer_len,'_'));
GotoXY(Start_X,Y);
Write(in_string);
End;
^V : Insert_Mode := Insert_Mode XOR True; {toggle insert}
^S : If X > Start_X then {non destructive backspace}
X := X - 1;
^H,#127 : If X > Start_X then {destructive backspace}
Begin
Delete(In_String, X - Start_X, 1);
GotoXY(Start_X,Y);
Write(In_String + '_');
X := X - 1;
End;
^D : If (X - Start_X) < Buffer_Len then {forward 1 character}
If (X - Start_X) < Length(In_String) Then
X := X + 1;
^G : Begin
Delete(In_String, X - Start_X + 1,1); {delete character}
GotoXY(Start_X,Y); {under the cursor}
Write(In_String + '_');
End;
^M : Done := True; {**}
{ *** All Done}
^J : Done := True; {**}
' '..'~' : If (X - Start_X) >= Length(In_String) Then
Begin
In_String := In_String + Current_Char;
GotoXY(X,Y);
Write(Current_Char);
If (X - Start_X) < Buffer_Len then
X := X + 1;
End
Else
If Insert_Mode then {Just a run of the mill character}
Begin {Insert Mode}
Insert(Current_Char,In_String, X - Start_X + 1);
In_String := Copy(In_String,1,Buffer_Len);
GotoXY(Start_X,Y);
Write(In_String);
If (X - Start_X) < Buffer_Len then
X := X + 1;
GotoXY(X,Y);
End
Else
Begin {OverWrite Mode}
In_String[X - Start_X + 1] := Current_Char;
GotoXY(X,Y);
Write(Current_Char);
If (X - Start_X) < Buffer_Len then
X := X + 1;
End;
Else
End; {Case}
Until Not Escape;
GotoXY(X,Y);
If KeyClick Then
Click;
Until Done;
Get_Str := Current_Char; {Return the terminator}
In_str := In_string;
End;
{17**************************************************************************}
Function Get_Num ( {* This routine gets number from user *}
var Value : Real; {* Current Value and Returned Value *}
Decimals : Integer;{* Number of Decimal Places *}
Min_Value : Real; {* Minimum Value *}
Max_Value : Real; {* Maximum Value *}
X : Byte; {* Column *}
Y : Byte {* Row *}
) : Char; {* Terminator *}
{* *}
{* This routine does basically the *}
{* thing as Get_Str only for numbers *}
{* There are more options however. *}
{* Basically Min and Max Value allow *}
{* to specify the range of acceptable *}
{* values and DECIMALS allows you to *}
{* specify the number of decimal *}
{* places desired *}
{**************************************}
Const
Valid_Digits : Set of char = ['0'..'9','.','-','+','e'];
Var
I1,I2 : Integer;
S1 : Long_String;
S2 : Long_String;
S3 : Long_String;
Inchar : Char;
Begin
Str(Value:1:Decimals,S1); {Convert to a string}
Str(Max_Value:1:Decimals,S3); {find out how long a string max val is}
Repeat {Main Loop}
S2 := '';
Inchar := Get_Str(S1,Length(S3),X,Y,False); {Get_Str does the }
{work}
For I2 := 1 to Length(S1) do {Strip out non digits}
If S1[I2] in Valid_Digits then
S2 := S2 + S1[I2];
Val(S2,Value,I1); {Find out its value}
Until (Value >= Min_Value) and (Value <= Max_Value) and (I1 = 0); {do it }
{until its right}
GotoXY(X,Y);
Write_Neatly(Output,Value,Length(S3),Decimals); {print the result}
Get_Num := Inchar; {Assign the terminator}
end;
{18**************************************************************************}
procedure Frame( {* Frame the section of screen within *}
UpperLeftX, {* these bounds *}
UpperLeftY, {**************************************}
LowerRightX,
LowerRightY: Integer);
var
i: Integer;
begin
GotoXY(UpperLeftX,UpperLeftY);
Write(Chr(218));
GotoXY(UpperLeftX,LowerRightY);
Write(Chr(192));
GotoXY(LowerRightX,UpperLeftY);
Write(Chr(191));
GotoXY(LowerRightX,LowerRightY);
Write(Chr(217));
For I := UpperLeftX + 1 to LowerRightX - 1 do
Begin
GotoXY(I,UpperLeftY);
Write(Chr(196));
GotoXY(I,LowerRightY);
Write(Chr(196));
End;
For I := UpperLeftY + 1 to LowerRightY - 1 do
Begin
GotoXY(UpperLeftX,I);
Write(Chr(179));
GotoXY(LowerRightX,I);
Write(Chr(179));
End;
end; { Frame }
{19***************************************************************************}
procedure UnFrame( {* This routine does the opposite of *}
UpperLeftX, {* frame *}
UpperLeftY, {*************************************}
LowerRightX,
LowerRightY: Integer);
var
i: Integer;
begin
GotoXY(UpperLeftX, UpperLeftY);
Write(' ');
for i:=UpperLeftX+1 to LowerRightX-1 do
Write(' ');
Write(' ');
for i:=UpperLeftY+1 to LowerRightY-1 do
begin
GotoXY(UpperLeftX , i);
Write(' ');
GotoXY(LowerRightX, i);
Write(' ');
end;
GotoXY(UpperLeftX, LowerRightY);
Write(' ');
for i:=UpperLeftX+1 to LowerRightX-1 do
Write(' ');
Write(' ');
end; {UnFrame }
{****************************************************************************}
Function Menu ( {* Display a Menu *}
Item_List : Menu_Selections; {* List of Options on Menu *}
{* Last Item must be Null *}
{* String for proper operation*}
{* No more than 14 items per *}
Menu_X : Integer; {* X Location of Menu *}
{* If Menu_X = 0 then the *}
{* Menu is centered on the *}
{* Screen *}
Menu_Y : Integer; {* Y Location of Menu *}
Menu_Title : Menu_Item; {* Title of Menu *}
Title_X : Integer; {* X Location of Title *}
{* If Title_X = 0 then the *}
{* Title is centered on the *}
{* screen *}
Title_Y : Integer; {* Y Location of Title *}
Default : Integer {* Default Selection *}
) : Integer; {* Return the index of the *}
{* item selected by the user *}
{* *}
{*********************************************** *
* This Routine Displays a Menu on the screen at the location specified by *
* Menu_X and Menu_Y. The Menu Title is displayed in Reverse Video at the *
* Location specified by Title_X and Title_Y. The User selects an item from *
* the menu by using <CTRL>-E to move a reverse video cursor bar up and *
* <CTRL>-X to move it down. After the cursor is on the item desired by the *
* user, he must press return. At this point the routine returns the item *
* number of the selection. *
*****************************************************************************}
Const
CR = #13;
Up = #5;
Dn = #24;
Var
Inchar : char;
Menu_Pointer : 1..15;
Menu_Length : 1..15;
Last : Integer;
Width : Integer;
Len : Integer;
X1,X2,Y1,Y2 : Integer;
I,j,k : integer;
instr : long_string;
Begin {Menu}
instr := '';
Width := Lower_Right_X - Upper_Left_X + 1; {Calculate Window Size}
Len := Lower_Right_Y - Upper_Left_Y + 1;
If Title_X <> 0 then {position for the title}
GotoXY(Title_X,Title_Y)
Else
GotoXY(1,Title_Y);
RvsOn;
If Title_X = 0 Then {Write the title}
Write (Center(Width,Menu_Title))
Else
Write(Menu_Title);
RvsOff;
If Width > 38 then {If there is enough room, write out instructions}
Begin {otherwise, they is out a luck}
Frame(1,Len-3,Width-1,Len);
GotoXY((Width div 2) - 6,Len-3);
Write(#17);
RvsOn;
Write('Instructions');
RvsOff;
Write(#16);
TextColor(15);
GotoXY(2,Len-2);
Write(Center(Width-3,'Use '+#24+' and '+#25+' to Highlight a Selection'));
GotoXY(2,Len-1);
Write(Center(Width-3,' And '+#17+'DY to make the Selection'));
TextColor(7);
End;
Inchar := ' '; {Initialize variables}
Menu_Pointer := 1;
{Display the actual menu selections and determine how many selections
are available}
While (Menu_pointer <=15) and (length(Item_list[Menu_pointer]) > 0) do
Begin
If Menu_X <> 0 then
Begin
GotoXY(Menu_X,Menu_Y - 1 + Menu_Pointer);
Write(Item_List[Menu_Pointer])
End {If}
Else
Begin
GotoXY(1,Menu_Y - 1 + Menu_Pointer);
Write(Center(Width-1,Item_List[Menu_Pointer]))
End; {Else}
Menu_Pointer := Menu_Pointer + 1;
End; {While}
Menu_Length := Menu_Pointer - 1;
Menu_Pointer := Default;
While inchar <> CR do {Main loop}
Begin
If Menu_X <> 0 then
Begin
GotoXY(Menu_X,Menu_Pointer - 1 + Menu_Y); {Highlight the current menu}
RvsOn; {item}
Write(Item_List[Menu_Pointer]);
RvsOff;
End {If}
Else
Begin
GotoXY(1,Menu_Pointer - 1 + Menu_Y);
RvsOn;
Write(Center(Width-1,Item_List[Menu_Pointer]));
RvsOff;
End; {Else}
Read(Kbd,Inchar); {get a character from the user}
Click;
Last := Menu_Pointer;
If Not (Inchar in [^[,Up,Dn,Cr]) then
Begin
if inchar = #127 then
instr := ''
else
if inchar = ^H then
delete(instr,length(instr),1)
else
instr := instr + inchar;
j := 0;
k := 0;
for i := 1 to Menu_Length do
if lower(instr) = lower(copy(item_list[i],1,length(instr))) then
begin
inc(j);
if k = 0 then
k := i;
end;
if k <> 0 then
menu_pointer := k;
if (j = 1) or (j = 0) then
instr := '';
end;
If (Inchar = ^[) and KeyPressed then {get the escape code}
Read(Kbd, Inchar);
If Inchar = ';' Then
Begin
X1 := Upper_Left_X;
Y1 := Upper_Left_Y;
X2 := Lower_Right_X;
Y2 := Lower_Right_Y;
Help;
Window(X1,Y1,X2,Y2);
End;
If (Inchar = Up) Or (Inchar = 'H') then
Begin {They hit up arrow}
Menu_Pointer := Menu_Pointer - 1;
If Menu_Pointer < 1 then
Menu_Pointer := Menu_Length;
instr := '';
End; {If}
If (Inchar = Dn) Or (Inchar = 'P') then
Begin {They hit down arrow}
Menu_Pointer := Menu_Pointer + 1;
if Menu_Pointer > Menu_Length then
Menu_Pointer := 1;
instr := '';
end; {If}
If Menu_X <> 0 then {UnHighlight the old selection}
Begin
GotoXY(Menu_X, Last - 1 + Menu_Y);
Write(Item_List[Last]);
End {If}
Else
Begin
GotoXY(1, Last - 1 + Menu_Y);
Write(Center(Width-1,Item_List[Last]));
End; {Else}
End; {While}
Beep(440); {They made a selection, beep once}
Menu := Menu_Pointer; {to confirm}
end; {Menu}
{22**************************************************************************}
Procedure Window_Frame(x1,y1, {* Create, frame and title a *}
x2,y2 : Integer; {* window *}
Title : Menu_Item);{**********************************}
Var
Center : Integer;
Begin
Window(1,1,80,25);
Frame(x1 - 1, y1 - 1,
x2 + 1, y2 + 1);
Center := ((x2 - x1) div 2) + x1;
GotoXY(Center - (Length(Title) div 2)-1,y1-1);
Write(#17);
RvsOn;
Write(Title);
RvsOff;
Write(#16);
Window(x1,y1,x2,y2);
Clear_Window;
End;
{23**************************************************************************}
Function Encrypt(Password : Long_String) {* Encrypt a string using the *}
: Long_String; {* following algorithm: *}
{* XOR the ordinal value of each *}
Var {* character in the string with *}
Temp : Long_String; {* that of the next character in *}
I : Integer; {* the string. Multiply by 2 the *}
{* result and convert back to char *}
Begin {* leave the last character of the *}
temp := ''; {* string in plain text as the key *}
For I := 1 to Length(Password) - 1 do{***********************************}
temp := Temp + Chr((ord(password[i]) xor ord(password[i+1])) shl 2);
Encrypt := Temp + Password[Length(Password)];
End;
{24**************************************************************************}
Function Decrypt(Temp : Long_String) {* Decrypt a string encrypted by *}
: Long_String; {* the preceding procedure *}
{***********************************}
Var
Password : Long_String;
I : Integer;
Begin
Password := Replicate(Length(temp),' ');
Password[Length(temp)] := Temp[Length(temp)];
For I := Length(Temp) - 1 downto 1 do
Password[I] := Chr((ord(temp[i]) shr 2) xor ord(password[i+1]));
Decrypt := Password;
End;
{25**************************************************************************}
Function GetChar(Var Done : Boolean) : Char;{* Get a character from the Kbd *}
{********************************}
Var
Inchar : Char;
Begin
Read(Kbd,Inchar);
Done := (Inchar = ^\);
GetChar := Inchar;
End;
{27**************************************************************************}
Function Get_Pass(X,Y : Integer) : Long_String;{* This routine obtains a *}
{* password from the user *}
Var {* nothing more, nothing less*}
Inchar : Char; {*****************************}
Temp : Long_String;
Begin
GotoXY(X,Y);
Write('Password: ');
Temp := '';
TextColor(0);
TextBackGround(0);
Inchar := Get_Str(Temp,10,X + 10,y,True);
RvsOff;
If Temp = Replicate(10,' ') then
Temp := '';
Get_Pass := Temp;
End;
{32**************************************************************************}
Procedure SetUp {Set the UART for communications}
(Portal : Integer;
Baud : Integer;
Parity : Parity_Types;
Stop : Byte;
Word : Byte);
Begin
Port[LCR + Portal] := 128;
{Set Baud Rate}
Baud := Trunc(115200.0 / Baud);
Port[DLL + Portal] := Lo(Baud);
Port[DLM + Portal] := Hi(Baud);
{Set Parity}
Case Parity of
No_Parity : Port[LCR + Portal] := Port[LCR + Portal] And Not(PEN);
Even_Parity : Begin
Port[LCR + Portal] := Port[LCR + Portal] Or PEN;
Port[LCR + Portal] := Port[LCR + Portal] Or EPS;
Port[LCR + Portal] := Port[LCR + Portal] And Not(STPTY);
End;
Odd_Parity : Begin
Port[LCR + Portal] := Port[LCR + Portal] Or PEN;
Port[LCR + Portal] := Port[LCR + Portal] And Not(EPS);
Port[LCR + Portal] := Port[LCR + Portal] And Not(STPTY);
End;
End;
{Set Stop Bits}
Port[LCR + Portal] := Port[LCR + Portal] And (Not(STB) + (STB * (Stop - 1)));
{Set Word Length}
Port[LCR + Portal] := Port[LCR + Portal] And Not(WLS);
Word := (Word - 5) and WLS;
Port[LCR + Portal] := Port[LCR + Portal] or Word;
Port[LCR + Portal] := Port[LCR + Portal] And 127;
End; {Set up}
{36**************************************************************************}
Procedure DosConOut(Ch : Char); {* Write character to video display *}
{* using DOS driver *}
Var {***************************************}
Registers : Reg;
Begin
Registers.AX := $0200;
Registers.DX := Ord(Ch);
MsDos(Registers);
End;
var
serial_buffer : long_string;
{37**************************************************************************}
Procedure SerialOut(Ch : Char); {* This routine sends a character over *}
{* the rs232 using a standard BIOS call*}
Var {* (INT 14) *}
Registers : Reg; {***************************************}
Begin
Registers.AX := $0100 + Ord(Ch); {Set the registers}
Registers.DX := Com;
Intr($14,Registers); {Send out the character}
End;
{40**************************************************************************}
Function Data : Boolean; {* This routine returns true if the *}
{* serial port has valid data *}
Var {***************************************}
Registers : Reg;
portno : integer;
Begin
portno := $3fd - ($100 * Com);
data := (port[portno] and 1) = 1;
End;
{38**************************************************************************}
Function SerialIn : Char; {* This routine reads a character from *}
{* the serial port if one is available *}
Var {* If no character is available, the *}
Registers : Reg; {* returns a null char (^@). *}
ch : char; {***************************************}
Begin
serialin := chr(port[$3f8 - ($100 * com)]);
End;
{41**************************************************************************}
Procedure ColScr; {* Switch to Color Monitor if it is *}
{* available, otherwise leave as is *}
Const {***************************************}
VidReg : Array[0..15] of Integer =
($71,$50,$5A,$0A,$1F,$06,$19,$1C,$02,$07,$06,$07,$00,$00,$00,$00);
Mode = $3B8;
Color = $3B9;
RegNum = $3D4;
RegVal = $3D5;
ColorVal = $30;
ModeVal = $2D;
Var
I : Byte;
Begin
{ Port[Mode] := ModeVal;
Port[Color] := ColorVal;
For I := 0 to 15 do
Begin
Port[RegNum] := I;
Port[RegVal] := VidReg[I];
End;
} Screen := Ptr($B800,0);
End;
{42**************************************************************************}
Procedure MonoScr; {* Switch to MonoChrome Monitor if *}
{* available, otherwise leave as is *}
Const {***************************************}
VidReg : Array[0..15] of Integer =
($61,$50,$52,$0F,$19,$06,$19,$19,$02,$0D,$0B,$0C,$00,$00,$00,$00);
Mode = $3B8;
Color = $3B9;
RegNum = $3B4;
RegVal = $3B5;
ColorVal = $30;
ModeVal = $29;
Var
I : Byte;
Begin
Port[Mode] := ModeVal;
Port[Color] := ColorVal;
For I := 0 to 15 do
Begin
Port[RegNum] := I;
Port[RegVal] := VidReg[I];
End;
Screen := Ptr($B000,0);
End;
{45**************************************************************************}
Procedure Well;
Var
I,J : Integer;
Begin
I := 0;
While Not KeyPressed do
Begin
Click;
Delay(250);
If I = 100 then Write('Well?');
Inc(I);
End;
End;
{47**************************************************************************}
Procedure Siren; {* This is the alarm for intruder alert*}
{***************************************}
var i,j : integer;
begin
for j := 1 to 20 do
begin
for i := 200 to 2300 do
sound(i);
nosound;
delay(100);
end;
end;
{48**************************************************************************}
type
typelist = (ustr,lstr,ulstr,rnum,inum,yn);
function getform( var value;
vtype : typelist;
X,Y,
dp,Len : integer;
Lstrg : long_string;
lx,ly : integer
) : char;
var
realval : real absolute value;
intval : integer absolute value;
strval : long_string absolute value;
boolval : boolean absolute value;
mval : real;
tint : integer;
tstr : long_string;
tchar : char;
begin
gotoxy(lx,ly);
highvideo;
write(lstrg);
case vtype of
ustr : getform := get_str(strval,len,x,y,true);
lstr : begin
getform := get_str(strval,len,x,y,false);
strval := lower(strval);
end;
ulstr : getform := get_str(strval,len,x,y,false);
rnum : begin
val(replicate(len - dp - 1,'9'),mval,tint);
getform := get_num(realval,dp,0,mval,x,y);
end;
inum : begin
getform := get_num(mval,0,-32767,maxint,x,y);
intval := trunc(mval);
end;
yn : begin
gotoxy(x,y);
if boolval then
tstr := 'Y'
else
tstr := 'N';
repeat
tchar := get_str(tstr,1,x,y,true);
until tstr[1] in ['Y','N'];
boolval := tstr = 'Y';
getform := tchar;
end;
end;
gotoxy(lx,ly);
lowvideo;
write(lstrg);
end;
{*********************************************************************}
const monthmask = $000F;
daymask = $001F;
minutemask = $003F;
secondmask = $001F;
type dtstr = string[8];
{49*******************************************************************}
function getdate : dtstr;
var
allregs : register;
month, day,
year : string[2];
i : integer;
tstr : dtstr;
begin
allregs.ax := $2A * 256;
MsDos(allregs);
str((allregs.dx div 256):2,month);
str((allregs.dx mod 256):2,day);
str((allregs.cx - 1900):2,year);
tstr := month + '/' + day + '/' + year;
for i := 1 to 8 do
if tstr[i] = ' ' then
tstr[i] := '0';
getdate := tstr;
end; {getdate}
{50*******************************************************************}
function gettime : dtstr;
var
allregs : register;
hour, minute,
second : string[2];
i : integer;
tstr : dtstr;
begin
allregs.ax := $2C * 256;
MsDos(allregs);
str((allregs.cx div 256):2,hour);
str((allregs.cx mod 256):2,minute);
str((allregs.dx div 256):2,second);
tstr := hour + ':' + minute + ':' + second;
for i := 1 to 8 do
if tstr[i] = ' ' then
tstr[i] := '0';
gettime := tstr;
end; {gettime}
{51*******************************************************************}
procedure push_window(x1,y1,x2,y2 : integer);
var
temp : video_ptr;
i,j,k : integer;
begin
if screen = nil then
screen := ptr($b000,0);
new(Temp);
temp^.x1 := x1;
temp^.y1 := y1;
temp^.x2 := x2;
temp^.y2 := y2;
getmem(temp^.screen_store,((x2 - x1 + 1) * (y2 - y1 + 1)) * 2);
Temp^.Next_Screen := Screen_Stack;
k := 1;
for i := y1 to y2 do
for j := x1 to x2 do
begin
temp^.screen_store^[k] := screen^[i][j];
inc(k);
end;
Screen_Stack := Temp;
end;
{52*******************************}
function elapsed_time(start_time : real) : real;
var
j : integer;
i,k,
endtime : real;
begin
val(copy(gettime,7,2),i,j);
endtime := i * 3600.0;
val(copy(gettime,5,2),i,j);
endtime := endtime + (i * 60);
val(copy(gettime,1,2),i,j);
endtime := endtime + i;
k := endtime - start_time;
elapsed_time := k
end;
