Category : Files from Magazines
Archive   : DDJ8612.ZIP
Filename : SHAMMAS.DEC
Listing 1. Contents of Turbo Pascal included ProcParm.INC file.
{ ProcParm.INC Version 1.1 86/05/07
See ProcParm.PAS for an explanation.
Author: Mike Babulic Compuserve ID: 72307,314 FIDO: 134/1
3827 Charleswood Dr. N.W.
Calgary, Alberta,
CANADA
T2L 2C7
}
procedure Call_ProcParm;
begin
Inline
($89/$EC/ { MOV SP,BP ;Drop down one level }
$5D/ { POP BP }
$8B/$66/$02/ { SS:MOV SP,[BP+2] ;Exchange Return Addr & Procedure Ptr}
$87/$66/$04/ { SS:XCHG SP,[BP+4] }
$89/$66/$02 { SS:MOV [BP+2],SP }
)
end;
_____________________________________________________________________
Listing 2. Contents of file ProcPar.QK.
{ ProcParm.QK Version 1.0 86/04/22
Author: Mike Babulic Compuserve ID: 72307,314 FIDO: 134/1
3827 Charleswood Dr. N.W.
Calgary, Alberta,
CANADA
T2L 2C7
}
Inline(
$8B/$66/$02/ { SS:MOV SP,[BP+2] ;Exchange Return Addr & Procedure Ptr}
$87/$66/$04/ { SS:XCHG SP,[BP+4] }
$89/$66/$02/ { SS:MOV [BP+2],SP }
$89/$EC/ { MOV SP,BP ;Standard Turbo Return (if no Parameters)}
$5D/ { POP BP }
$C3 { RET ;Near Return }
)
_____________________________________________________________________
Listing 3. Turbo Pascal demo program for procedural parameters.
program proc_param_demo;
CONST FIRST = 1;
LAST = 1000;
TYPE Vector = ARRAY [FIRST..LAST] OF INTEGER;
VAR A : Vector;
I, Start, Finish : INTEGER;
(*-------------------------------------------- Shell_Sort -------*)
PROCEDURE Shell_Sort(VAR A : Vector);
VAR I, J, Offset, Skip, Tempo, NData : INTEGER;
In_Order : BOOLEAN;
BEGIN
NDATA := LAST - FIRST + 1;
Skip := NDATA;
WHILE Skip > 1 DO BEGIN
Skip := Skip DIV 2;
REPEAT
In_Order := TRUE;
FOR J := FIRST TO LAST - Skip DO BEGIN
I := J + Skip;
IF A[J] > A[I] THEN BEGIN
In_Order := FALSE;
Tempo := A[I];
A[I] := A[J];
A[J] := Tempo
END; (* IF *)
END; (* FOR *)
UNTIL In_Order;
END; (* WHILE *)
END; (* Shell_Sort *)
(*-------------------------------------------- QuickSort -------*)
PROCEDURE QuickSort(VAR A : Vector);
PROCEDURE Sort(Left, Right : INTEGER);
VAR I, J,
Pivot, Tempo : INTEGER;
BEGIN
I := Left; J := Right;
Pivot := A[(Left + Right) DIV 2];
REPEAT
WHILE A[I] < Pivot DO I := I + 1;
WHILE Pivot < A[J] DO J := J - 1;
IF I <= J THEN BEGIN
Tempo := A[I];
A[I] := A[J];
A[J] := Tempo;
I := I + 1;
J := J - 1
END; (* IF *)
UNTIL I > J;
IF Left < J THEN Sort(Left,J);
IF I < Right THEN Sort(I,Right);
END; (* Sort *)
BEGIN
Sort(FIRST, LAST)
END; (* QuickSort *)
(*----------------- Use the ProcParm Procedure -----------------*)
{$I PROCPARM.INC}
PROCEDURE Dummy1(VAR A : Vector; P : INTEGER);
BEGIN
Call_ProcParm;
END; (* Dummy1 *)
PROCEDURE Sort1(VAR A : Vector; P : INTEGER);
BEGIN
Dummy1(A,P);
END; (* Sort1 *)
(*------------------------- Use Procparm.qk ---------------------*)
PROCEDURE Dummy2(VAR A : Vector; P : INTEGER);
BEGIN
{$I PROCPARM.QK}
END; (* Dummy2 *)
PROCEDURE Sort2(VAR A : Vector; P : INTEGER);
BEGIN
Dummy2(A, P)
END; (* Sort2 *)
(*-------------------------------------------- Create_Array -------*)
PROCEDURE Create_Array(VAR A : Vector; Start, Finish : INTEGER);
(* Create a reverse sorted array *)
VAR I : INTEGER;
BEGIN
FOR I := Start TO Finish DO
A[I] := Finish + 1 - I
END; (* Create_Array *)
(*-------------------------------------------- Display_Array -------*)
PROCEDURE Display_Array(VAR A : Vector; Start, Finish : INTEGER);
VAR I : INTEGER;
Dummy : CHAR;
BEGIN
WRITE('Press
FOR I := Start TO Finish DO
WRITE(A[I]:8);
WRITELN; WRITELN;
END; (* Display_Array *)
(*------------------------------------------------- Show_Time -------*)
PROCEDURE Show_Time;
(* Procedure to dislplay time *)
TYPE REGTYPE = record
AX,BX,CX,DX,BP,
DI,SI,DS,ED,FLAGS : INTEGER
END;
TIME_REC = RECORD
HOUR, MIN, SEC, HSEC : BYTE
END;
VAR REGISTER : REGTYPE;
AH : BYTE;
TIME : TIME_REC;
BEGIN
AH := $2C;
WITH REGISTER, TIME DO BEGIN
AX:= AH SHL 8;
MSDOS(REGISTER);
HOUR := Hi(CX);
MIN := Lo(CX);
SEC := Hi(DX);
HSEC := Lo(DX);
WRITELN(' at ',HOUR,' : ',MIN,' : ',SEC,'.',HSEC);
END;
END; (* Show_Time *)
BEGIN
ClrScr;
WRITELN('Array has index range of ',FIRST,' to ',LAST);
WRITE('Enter index of first element to view '); READLN(Start); WRITELN;
WRITE('Enter index of last element to view '); READLN(Finish); WRITELN;
IF Start < FIRST THEN Start := FIRST;
IF (Finish > LAST) THEN Finish := LAST;
IF Finish < Start THEN Finish := Start + (LAST - FIRST + 1) DIV 10;
WRITELN('Using ProcParm Procedure '); WRITELN; WRITELN;
Create_Array(A, FIRST, LAST);
WRITELN('Using Shell Sort');
WRITE('Start '); Show_Time;
Sort1(A,Ofs(Shell_Sort));
WRITE('Finish'); Show_Time;
Display_Array(A,Start,Finish);
Create_Array(A, FIRST, LAST);
WRITELN('Using QuickSort');
WRITE('Start '); Show_Time;
Sort1(A,Ofs(QuickSort));
WRITE('Finish'); Show_Time;
Display_Array(A,Start,Finish);
WRITELN('Using ProcParm.QK '); WRITELN; WRITELN;
Create_Array(A, FIRST, LAST);
WRITELN('Using Shell Sort');
WRITE('Start '); Show_Time;
Sort2(A,Ofs(Shell_Sort));
WRITE('Finish'); Show_Time;
Display_Array(A,Start,Finish);
Create_Array(A, FIRST, LAST);
WRITELN('Using QuickSort');
WRITE('Start '); Show_Time;
Sort2(A,Ofs(QuickSort));
WRITE('Finish'); Show_Time;
Display_Array(A,Start,Finish);
END.
_____________________________________________________________________
Listing 4. Definition and implementation modules for BestFit library which
uses a local model InnerWorking.
DEFINITION MODULE BestFit;
EXPORT QUALIFIED Regression, Slope, Intercept, R2;
PROCEDURE Regression(VAR X, Y : ARRAY OF REAL; (* input *)
N, LowerBound : CARDINAL (* input *));
(* Procedure to process arrays X and Y *)
PROCEDURE Slope() : REAL;
(* Function that returns the slope of the best fit line *)
PROCEDURE Intercept() : REAL;
(* Function that returns the intercept of the best fit line *)
PROCEDURE R2() : REAL;
(* Function that returns the goodness of the best fit line *)
END BestFit.
IMPLEMENTATION MODULE BestFit;
FROM MathLib0 IMPORT sqrt;
MODULE InnerWorking;
IMPORT sqrt;
EXPORT Regression, Slope, Intercept, R2;
VAR Sum, SumX, SumXX, SumY, SumYY, SumXY, (* Stat summation *)
MeanX, MeanY, SdevX, SdevY : REAL;
PROCEDURE Regression(VAR X, Y : ARRAY OF REAL; (* input *)
N, LowerBound : CARDINAL (* input *));
(* Procedure to process arrays X and Y *)
VAR i : CARDINAL;
Xs, Ys : REAL;
BEGIN
(* Loop for stat summation *)
FOR i := 0 TO N-LowerBound DO
Xs := X[i]; Ys := Y[i];
Sum := Sum + 1.0;
SumX := SumX + Xs;
SumY := SumY + Ys;
SumXX := SumXX + Xs * Xs;
SumYY := SumYY + Ys * Ys;
SumXY := SumXY + Xs * Ys;
END;
(* Calculate intermediate results *)
MeanX := SumX / Sum;
MeanY := SumY / Sum;
SdevX := sqrt((SumXX - SumX * SumX / Sum)/(Sum - 1.0));
SdevY := sqrt((SumYY - SumY * SumY / Sum)/(Sum - 1.0));
END Regression;
PROCEDURE Slope() : REAL;
(* Function that returns the slope of the best fit line *)
BEGIN
IF Sum > 1.0 THEN
RETURN (SumXY - MeanX * MeanY * Sum) / (SdevX * SdevX * (Sum - 1.0))
ELSE RETURN 0.0 (* default value for insufficient data *)
END;
END Slope;
PROCEDURE Intercept() : REAL;
(* Function that returns the intercept of the best fit line *)
BEGIN
IF Sum > 1.0 THEN
RETURN MeanY - Slope() * MeanX
ELSE RETURN 0.0 (* default value for insufficient data *)
END;
END Intercept;
PROCEDURE R2() : REAL;
(* Function that returns the goodness of the best fit line *)
VAR R : REAL;
BEGIN
IF Sum > 1.0 THEN
R := SdevX / SdevY * Slope();
RETURN R * R
ELSE RETURN 0.0 (* default value for insufficient data *)
END;
END R2;
BEGIN
(* Initilaize inner module by setting stat summation equal to zero *)
Sum := 0.0; SumXY := 0.0;
SumX := 0.0; SumXX := 0.0;
SumY := 0.0; SumYY := 0.0;
END InnerWorking;
END BestFit.
_____________________________________________________________________
Listing 5. Turbo Pascal program to demosntrate the first method for
external menu storage.
program test_method1;
(* Program to test first method for external menu storage *)
TYPE
STRING14 = STRING[14];
STRING80 = STRING[80];
Screen_Image = ARRAY [0..24] OF STRING80;
VAR Shift_Row, Shift_Col, Screen_Line_Count : INTEGER;
Screen_Line : Screen_Image;
MenuFile : STRING14;
PROCEDURE Read_Menu(Menu_Filename : STRING14;
VAR Shift_Row, Shift_Col,
Screen_Line_Count : INTEGER;
VAR Screen_Line : Screen_Image);
(* Procedure to read menu image from text file. If file is *)
(* nonexistant the program will halt. *)
CONST MAX_SYMBOL = 255;
TYPE CharSet = Set OF CHAR;
Symbol_Table = ARRAY [0..MAX_SYMBOL] OF INTEGER;
VAR FileVar : TEXT;
Line : STRING80;
Table : Symbol_Table;
I, K, Error_Code : INTEGER;
Symbol_Char : CHAR;
Operation_Set : CharSet;
Duplicate : BOOLEAN;
(*--------------------------------------------------------*)
PROCEDURE INC(VAR A : INTEGER);
(* Increment integer by one *)
BEGIN
A := A + 1
END; (* INC *)
(*--------------------------------------------------------*)
PROCEDURE Upcase_Str(VAR S : STRING80);
(* Convert string to upercase *)
VAR I : INTEGER;
BEGIN
FOR I := 1 TO Length(S) DO
S[I] := Upcase(S[I]);
END; (* Upcase_Str *)
(*--------------------------------------------------------*)
FUNCTION Extract_Number(Line : STRING80; Skip : INTEGER;
VAR ErrorCode : INTEGER) : INTEGER;
(* Function to extract an integer from a text line *)
VAR J : INTEGER;
BEGIN
IF Skip > 0 THEN Delete(Line,1,Skip); (* Remove chars from string *)
(* Remove blanks *)
WHILE Line[1] = ' ' DO
Delete(Line,1,1);
(* END WHILE *)
Line := Line[1] + Line[2] + Line[3];
VAL(Line,J,Error_Code);
Extract_Number := J
END; (* Extract_Number *)
(*--------------------------------------------------------*)
PROCEDURE Build_Screen(Line : STRING80;
VAR Screen_Line_Count : INTEGER;
VAR Screen_Line : Screen_Image);
VAR J : INTEGER;
Ch : CHAR;
BEGIN
IF Length(Line) > 0 THEN BEGIN
FOR J := 1 TO Length(Line) DO BEGIN
Ch := Line[J];
IF Ch IN Operation_Set THEN
Line[J] := CHR(Table[ORD(Ch)]);
END; (* FOR *)
Screen_Line[Screen_Line_Count] := Line;
INC(Screen_Line_Count);
END;
END; (* Build_Screen *)
BEGIN
Assign(FileVar, Menu_Filename);
Reset(FileVar);
IF (IOResult = 0)
THEN BEGIN
Operation_Set := ['!','@','#','$','%','^','&','/','\','|','-','_'];
(* Initialize screen line strings *)
FOR I := 0 TO 24 DO
Screen_Line[I] := '';
(* Initialize symbol table entries *)
FOR I := 0 TO MAX_SYMBOL DO
Table[I] := I;
(* Read first line *)
READLN(FileVar, Line);
Upcase_Str(Line);
WHILE (NOT Eof(FIleVar)) AND (Line <> 'START') DO BEGIN
IF Line[1] IN Operation_set
THEN BEGIN
Symbol_Char := Line[1];
K := ORD(Symbol_Char);
Table[K] := Extract_Number(Line,1,Error_code);
IF (Error_Code > 0) OR
(NOT (Table[K] IN [0..255])) THEN
Table[K] := Ord('*');
END;
(* Read next line *)
READLN(FileVar, Line);
END; (* WHILE *)
Screen_Line_Count := 0;
Shift_Col := 0;
Shift_Row := 0;
(* Read next line that may contain row/column offset *)
FOR I := 1 TO 2 DO BEGIN
READLN(FileVar, Line);
Upcase_Str(Line);
IF Pos('SHIFTROW',Line) > 0 THEN BEGIN
Shift_Row := Extract_Number(Line,8,Error_Code);
IF Error_Code > 0 THEN Shift_Row := 0;
END
ELSE IF Pos('SHIFTCOL',Line) > 0 THEN BEGIN
Shift_Col := Extract_Number(Line,8,Error_Code);
IF Error_Code > 0 THEN Shift_Col := 0;
END
ELSE Build_Screen(Line,Screen_Line_Count,Screen_Line);
END; (* FOR *)
WHILE NOT EOF(FileVar) AND (Screen_Line_Count < 25) DO BEGIN
READLN(FileVar, Line);
Build_Screen(Line,Screen_Line_Count,Screen_Line);
END; (* WHILE *)
Close(FileVar);
END
ELSE Halt;
END; (* Read_Menu *)
(*----------------------------------------------------------------*)
PROCEDURE DISP_STR(S : STRING80; Row, Col : INTEGER);
(* Procedure to write a string to the screen memory *)
TYPE SCREEN80 = ARRAY [1..25,1..80,1..2] OF CHAR;
VAR MONODISP : SCREEN80 Absolute $B000:0000;
COLODISP : SCREEN80 Absolute $B800:0000;
I, J, Mode : INTEGER;
BEGIN
J := Length(S);
Mode := MEM[$0040:$0049];
IF Mode IN [2..3] THEN
FOR I := 1 TO J DO
COLODISP[Row,Col + I - 1,1] := S[I];
IF Mode = 7 THEN
FOR I := 1 TO J DO
MONODISP[Row,Col + I -1,1] := S[I];
END;
(*----------------------------------------------------------------*)
PROCEDURE Show_Menu(VAR Shift_Row, Shift_Col, Screen_Line_Count : INTEGER;
VAR Screen_Line : Screen_Image);
VAR I : INTEGER;
BEGIN
FOR I := 0 TO Screen_Line_Count DO
DISP_STR(Screen_Line[I],(I+Shift_Row+1),(1+Shift_Col));
END; (* Show_Menu *)
BEGIN
ClrScr;
WRITE('Enter filename '); READLN(MenuFile); WRITELN;
Read_Menu(MenuFile, Shift_Row, Shift_Col,
Screen_Line_Count, Screen_Line);
Show_Menu(Shift_Row, Shift_Col,Screen_Line_Count, Screen_Line);
REPEAT UNTIL KeyPressed;
END.
_____________________________________________________________________
Listing 6. Turbo Pascal program to demosntrate the second method for
external menu storage.
program test_method2;
(* Program to test the second method for external menu storage *)
TYPE
STRING14 = STRING[14];
LSTRING = STRING[255];
Screen_Image = ARRAY [0..24] OF LSTRING;
VAR Shift_Row, Shift_Col, Screen_Line_Count : INTEGER;
Screen_Line : Screen_Image;
MenuFile : STRING14;
PROCEDURE Read_Menu(Menu_Filename : STRING14;
VAR Shift_Row, Shift_Col,
Screen_Line_Count : INTEGER;
VAR Screen_Line : Screen_Image);
(* Procedure to read menu image from text file. If file is *)
(* nonexistant the program will halt. *)
CONST MAX_SYMBOL = 255;
TYPE CharSet = Set OF CHAR;
Symbol_Table = ARRAY [0..MAX_SYMBOL] OF INTEGER;
VAR FileVar : TEXT;
Line : LSTRING;
Table : Symbol_Table;
I, K, Error_Code,
Upper_Left_Corner, Upper_Right_Corner, Lower_Left_Corner,
Lower_Right_Corner, Horizontal_Line, Vertical_Line,
Cross_Bar, Left_Tee, Right_Tee,
Up_Tee, Down_Tee,
Left_Edge, Right_Edge,
Vertical_Frames, Horizontal_Frames, Frame_Code,
Number : INTEGER;
Symbol_Char : CHAR;
(*--------------------------------------------------------*)
PROCEDURE INC(VAR A : INTEGER);
(* Increment integer by one *)
BEGIN
A := A + 1
END; (* INC *)
(*--------------------------------------------------------*)
PROCEDURE Upcase_Str(VAR S : LSTRING);
(* Convert string to upercase *)
VAR I : INTEGER;
BEGIN
FOR I := 1 TO Length(S) DO
S[I] := Upcase(S[I]);
END; (* Upcase_Str *)
(*--------------------------------------------------------*)
FUNCTION Extract_Number(Line : LSTRING; Skip : INTEGER) : INTEGER;
(* Function to extract an integer from a text line *)
VAR J, SUM : INTEGER;
BEGIN
IF Skip > 0 THEN Delete(Line,1,Skip); (* Remove chars from string *)
(* Remove blanks *)
WHILE Line[1] = ' ' DO
Delete(Line,1,1);
(* END WHILE *)
SUM := 0;
J := 1;
WHILE (J <= Length(Line)) AND (Line[J] IN ['0'..'9']) DO BEGIN
SUM := 10 * SUM + ORD(Line[J]) - ORD('0');
INC(J)
END;
Extract_Number := SUM
END; (* Extract_Number *)
(*--------------------------------------------------------*)
FUNCTION Get_Char_Code(S : LSTRING) : INTEGER;
(* Function to interpret frame symbol and return its ASCII code *)
VAR I, ASCII_Code : INTEGER;
BEGIN
IF S = 'ULC' THEN ASCII_Code := Upper_Left_Corner
ELSE IF S = 'URC' THEN ASCII_Code := Upper_Right_Corner
ELSE IF S = 'LLC' THEN ASCII_Code := Lower_Left_Corner
ELSE IF S = 'LRC' THEN ASCII_Code := Lower_Right_Corner
ELSE IF S = 'HLN' THEN ASCII_Code := Horizontal_Line
ELSE IF S = 'VLN' THEN ASCII_Code := Vertical_Line
ELSE IF S = 'CRS' THEN ASCII_Code := Cross_Bar
ELSE IF S = 'LFT' THEN ASCII_Code := Left_Tee
ELSE IF S = 'RTT' THEN ASCII_Code := Right_Tee
ELSE IF S = 'UPT' THEN ASCII_Code := Up_Tee
ELSE IF S = 'DNT' THEN ASCII_Code := Down_Tee
ELSE ASCII_Code := ORD('-'); (* error value return 'A' *)
Get_Char_Code := ASCII_Code;
END; (* Get_Char_Code *)
(*--------------------------------------------------------*)
PROCEDURE Build_Screen(Line : LSTRING;
VAR Screen_Line_Count : INTEGER;
VAR Screen_Line : Screen_Image);
VAR I, J, K, Long, Count : INTEGER;
Ch, Symbol : CHAR;
Build_Line, Sub_String : LSTRING;
BEGIN
IF Length(Line) > 0 THEN BEGIN
J := 1;
Long := Length(Line);
Build_Line := '';
Count := 0;
WHILE J <= Long DO BEGIN
Ch := UpCase(Line[J]);
CASE Ch OF
'@' : BEGIN
Sub_String := '';
FOR I := 1 TO 3 DO
Sub_String := Sub_String + Line[J+I];
J := J + 3; (* advance character pointer *)
Symbol := CHR(Get_Char_Code(Sub_String));
Build_Line := Build_Line + Symbol;
INC(Count);
END;
'D' : BEGIN (* Duplicate a frame character *)
Sub_String := Line[J+1] + Line[J+2] + Line[J+3];
J := J + 4; (* advance character pointer *)
Symbol := CHR(Get_Char_Code(Sub_String));
Sub_String := Line[J] + Line[J+1];
J := J + 1;
K := Extract_Number(Sub_String,0);
IF (K > 0) THEN BEGIN
Count := Count + K;
FOR I := 1 TO K DO
Build_Line := Build_Line + Symbol;
END; (* IF *)
END;
'S' : BEGIN (* Skip # column positions *)
Sub_String := Line[J+1] + Line[J+2];
J := J + 2; (* advance character pointer *)
K := Extract_Number(Sub_String,0);
IF (K > 0) THEN BEGIN
Count := Count + K;
FOR I := 1 TO K DO
Build_Line := Build_Line + ' ';
END; (* IF*)
END;
'"' : BEGIN (* Display text *)
INC(J);
WHILE (Line[J] <> '|') AND (J <= Long) DO BEGIN
Build_Line := Build_Line + Line[J];
INC(J); INC(Count)
END; (* WHILE *)
Count := COunt - 1;
END;
'#' : BEGIN
Sub_String := Line[J+1] + Line[J+2];
J := J + 2; (* advance character pointer *)
K := Extract_Number(Sub_String,0);
IF (K < Right_Edge) AND (Count < K) THEN BEGIN
FOR I := 1 TO K - Count DO
Build_Line := Build_Line + ' ';
Count := K;
END; (* IF *)
END;
'V' : BEGIN (* Draw vertical edges *)
Build_Line := CHR(Vertical_Line);
FOR I := Left_Edge+1 TO Right_Edge-1 DO
Build_Line := Build_Line + ' ';
Build_Line := Build_Line + CHR(Vertical_Line);
END;
'H' : BEGIN (* Draw horizontal edge *)
Symbol := CHR(Horizontal_Line);
FOR I := Left_Edge+1 TO Right_Edge-1 DO
Build_Line := Build_Line + Symbol;
END;
END; (* CASE *)
INC(J);
WHILE Line[J] = ' ' DO INC(J);
END; (* FOR *)
Screen_Line[Screen_Line_Count] := Build_Line;
INC(Screen_Line_Count);
END;
END; (* Build_Screen *)
BEGIN
Assign(FileVar, Menu_Filename);
(*$I-*) Reset(FileVar); (*$I+*)
IF (IOResult = 0)
THEN BEGIN
(* Initialize screen line strings *)
FOR I := 0 TO 24 DO
Screen_Line[I] := '';
Left_Edge := 1;
Right_Edge := 80;
Vertical_Frames := 2;
Horizontal_Frames := 2;
(* Read first line *)
READLN(FileVar, Line);
Upcase_Str(Line);
WHILE (NOT Eof(FileVar)) AND (Line <> 'START') DO BEGIN
Symbol_Char := Line[1];
K := ORD(Symbol_Char);
IF Symbol_Char IN ['R','L','H','V'] THEN BEGIN
Number := Extract_Number(Line,1);
IF (Error_Code = 0) THEN
CASE Symbol_Char OF
'R' : Right_Edge := Number;
'L' : Left_Edge := Number;
'H' : IF (Number IN [1..2]) THEN
Horizontal_Frames := Number;
'V' : IF (Number IN [1..2]) THEN
Vertical_Frames := Number;
END; (* CASE *)
END; (* IF *)
(* Read next line *)
READLN(FileVar, Line);
END; (* WHILE *)
(* Check edges *)
IF (Right_Edge - Left_Edge) <= 4 THEN BEGIN
Left_Edge := 1;
Right_Edge := 80;
END; (* IF *)
Frame_Code := 10 * Horizontal_Frames + Vertical_Frames;
(* Select frame type *)
CASE Frame_Code OF
11 : BEGIN
Upper_Left_Corner := 218;
Upper_Right_Corner := 191;
Lower_Left_Corner := 192;
Lower_Right_Corner := 217;
Horizontal_Line := 196;
Vertical_Line := 179;
Cross_Bar := 197;
Left_Tee := 195;
Right_Tee := 180;
Up_Tee := 193;
Down_Tee := 194;
END;
12 : BEGIN
Upper_Left_Corner := 214;
Upper_Right_Corner := 183;
Lower_Left_Corner := 211;
Lower_Right_Corner := 189;
Horizontal_Line := 196;
Vertical_Line := 186;
Cross_Bar := 215;
Left_Tee := 199;
Right_Tee := 182;
Up_Tee := 208;
Down_Tee := 210;
END;
21 : BEGIN
Upper_Left_Corner := 213;
Upper_Right_Corner := 184;
Lower_Left_Corner := 212;
Lower_Right_Corner := 190;
Horizontal_Line := 205;
Vertical_Line := 179;
Cross_Bar := 216;
Left_Tee := 198;
Right_Tee := 181;
Up_Tee := 207;
Down_Tee := 209;
END;
22 : BEGIN
Upper_Left_Corner := 201;
Upper_Right_Corner := 187;
Lower_Left_Corner := 200;
Lower_Right_Corner := 188;
Horizontal_Line := 205;
Vertical_Line := 186;
Cross_Bar := 206;
Left_Tee := 204;
Right_Tee := 185;
Up_Tee := 202;
Down_Tee := 203;
END;
END; (* CASE *)
Screen_Line_Count := 0;
Shift_Col := 0;
Shift_Row := 0;
(* Read next line that may contain row/column offset *)
FOR I := 1 TO 2 DO BEGIN
READLN(FileVar, Line);
Upcase_Str(Line);
IF Pos('SHIFTROW',Line) > 0 THEN BEGIN
Shift_Row := Extract_Number(Line,8);
IF Error_Code > 0 THEN Shift_Row := 0;
END
ELSE IF Pos('SHIFTCOL',Line) > 0 THEN BEGIN
Shift_Col := Extract_Number(Line,8);
IF Error_Code > 0 THEN Shift_Col := 0;
END
ELSE Build_Screen(Line,Screen_Line_Count,Screen_Line);
END; (* FOR *)
WHILE NOT EOF(FileVar) AND (Screen_Line_Count < 25) DO BEGIN
READLN(FileVar, Line);
Build_Screen(Line,Screen_Line_Count,Screen_Line);
END; (* WHILE *)
Screen_Line_Count := Screen_Line_Count - 1;
Close(FileVar);
END
ELSE BEGIN
WRITE(^G^G);
Halt;
END;
END; (* Read_Menu *)
(*----------------------------------------------------------------*)
PROCEDURE DISP_STR(S : LSTRING; Row, Col : INTEGER);
(* Procedure to write a string to the screen memory *)
TYPE SCREEN80 = ARRAY [1..25,1..80,1..2] OF CHAR;
VAR MONODISP : SCREEN80 Absolute $B000:0000;
COLODISP : SCREEN80 Absolute $B800:0000;
I, J, Mode : INTEGER;
BEGIN
J := Length(S);
Mode := MEM[$0040:$0049];
IF Mode IN [2..3] THEN
FOR I := 1 TO J DO
COLODISP[Row,Col + I - 1,1] := S[I];
IF Mode = 7 THEN
FOR I := 1 TO J DO
MONODISP[Row,Col + I -1,1] := S[I];
END; (* DISP_STR *)
(*----------------------------------------------------------------*)
PROCEDURE Show_Menu(VAR Shift_Row, Shift_Col, Screen_Line_Count : INTEGER;
VAR Screen_Line : Screen_Image);
VAR I : INTEGER;
BEGIN
FOR I := 0 TO Screen_Line_Count DO
DISP_STR(Screen_Line[I],(I+Shift_Row+1),(1+Shift_Col));
END; (* Show_Menu *)
(*----------------------------------------------------------------*)
BEGIN (*-------------- M A I N ----------------*)
ClrScr;
WRITE('Enter filename '); READLN(MenuFile); WRITELN;
Read_Menu(MenuFile, Shift_Row, Shift_Col,
Screen_Line_Count, Screen_Line);
Show_Menu(Shift_Row, Shift_Col,Screen_Line_Count, Screen_Line);
REPEAT UNTIL KeyPressed;
END.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/