Power-Programmierung/CD1.mdf/magazine/drdobbs/1986/12/shammas.dec

Text File | 1986-12-31 | 29KB | 955 lines

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 <CR> to view array members '); READLN(Dummy); WRITELN;
    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.