SPACE 2/SPACE - Library 2 - Volume 1.iso/music/194/pascal/xyplot.pas

Pascal/Delphi Source File | 1987-11-19 | 39.1 KB | 1,158 lines

PROGRAM XYPlotter;
                        {By: Merlin Hanson
                        Genie: M.L.Hanson
                        Version 1.0
                        Date: 08/16/87}
  CONST
    {$i gemconst.pas}
  TYPE
    {$i gemtype.pas}

  {$i gemsubs.pas}

   {----------- Following imported from CURSOR.PAS ----------------}

  { Put a single character to the console device (the character's value is
    received as an integer!) }
  PROCEDURE out_char( c: integer );
    CONST
      screen = 2;
    PROCEDURE bconout( device, c: integer );
      BIOS(3);
    BEGIN
      bconout( screen, c );
    END;

  { Put a two-character escape sequence to the console device (an escape
    followed by a single character) }
  PROCEDURE out_escape( c: char );
    CONST
      escape = 27;
    BEGIN
      out_char( escape );
      out_char( ord(c) );
    END;

  { Clear the screen and move the cursor to the upper left position }
  PROCEDURE ClrScr;
    BEGIN out_escape( 'E' ) END;

  { Move the cursor up one line }
  PROCEDURE CursUp;
    BEGIN out_escape( 'A' ) END;

  { Move the cursor to the upper left corner of the screen }
  PROCEDURE CursHome;
    BEGIN out_escape( 'H' ) END;

   {---------------------- end of import ---------------------------}

  FUNCTION ColorMonitor : boolean;
    {I couldn't test this. Hope it works.}
    FUNCTION GetRez : integer;
      XBIOS (4);
    BEGIN {colormonitor}
      CASE GetRez OF
        0,1 : ColorMonitor := TRUE;
        3   : ColorMonitor := FALSE;
      END {case}
    END {colormonitor};

  PROCEDURE XYPlotDemo;
    CONST
      Blk = 384;      {Replace mode, color = Black.  (256 * Black + 128)}
      NoBorder = 0;
      LB = 1;
      UB = 10;
    TYPE
      T1 = (FunctionKind,ArrKind);
      T2 = ARRAY [LB..UB] OF real;
    VAR
      XMax,XMin         : real;
      PlotArr           : T2;
      PlotKind          : T1;
      OK1,OK2,NumbersOK : boolean;
      Done : boolean;
      Func : (Sinusoid,Parabola,Polynomial,NormalDist,ArrayPlot);
      NumbersFudged : boolean;

    PROCEDURE ChooseFunction;
      CONST
        W = 44;
        H = 10;
      VAR
        Box : dialog_ptr;
        Line : ARRAY [1..16] OF integer;
        Msg : ARRAY [1..16] OF string;
        LineNbr : integer;
        Choice : tree_index;
        HeaderLine : integer;
      BEGIN {choosefunction}
        Box := New_Dialog(20,0,0,W,H);
        {Headers}
        HeaderLine := Add_DItem(Box,G_String,None,
                      1,1,30,1,    0,Blk);
        Set_DText(Box,HeaderLine,
                 '     FUNCTION          BOUNDS',
                 System_Font,TE_Left);
        {Left side buttons}
        Msg[1] := '   Sinusoid   ';
        Msg[2] := '   Parabola   ';
        Msg[3] := '  Polynomial  ';
        Msg[4] := ' Normal dist. ';
        Msg[5] := '    Array     ';
        FOR LineNbr := 1 TO 5 DO
          BEGIN
            Line[LineNbr] := Add_DItem(Box,G_Button,Selectable | Exit_Btn,
                             4,LineNbr + 2,14,1,    0,384);
            Set_DText(Box,Line[LineNbr],Msg[lineNbr], System_Font,TE_Left);
          END;
        {Now the crib sheet on the right side}
        Msg[11] := '  0   6.28  (radians)    ' ;
        Msg[12] := ' -7    4                  ' ;
        Msg[13] := ' -6    5                  ' ;
        Msg[14] := ' -4    4                  ' ;
        Msg[15] := '  1   10   (dimension)  ' ;
        FOR lineNbr := 11 TO 15 DO
          BEGIN
            Line[LineNbr] := Add_DItem(Box,G_String,None,
                             21,LineNbr + 2 - 10,25,1,    0,384);
            Set_DText(Box,Line[LineNbr],Msg[LineNbr], System_Font,TE_Left);
          END;
        Center_Dialog(Box);
        Choice := Do_Dialog(Box,0);
        CASE Choice - Line[1] + 1 OF
          1 : Func := Sinusoid;
          2 : Func := Parabola;
          3 : Func := Polynomial;
          4 : Func := NormalDist;
          5 : Func := ArrayPlot;
        END {case};
        End_Dialog(Box);
      END {choosefunction};

    PROCEDURE DisplayArrayMessage;
      CONST
        W = 41;
        H = 9;
      VAR
        Msg : ARRAY[1..3]OF string;
        Line : ARRAY [1..3] OF integer;
        Box : dialog_ptr;
        LineNumber,ExitButton : integer;
        Pushed : tree_index;
      BEGIN
        Box := New_Dialog(3, 0,0,W,H);
        Msg[1] := '  The array function plots an array '    ;
        Msg[2] := '   of 10 elements.  The values are  '    ;
        Msg[3] := 'provided by a random number generator ';
        FOR LineNumber := 1 TO 3 DO
          BEGIN
            Line[LineNumber] := Add_DItem(Box,G_String,None,2,LineNumber + 1,
                                30,1,   0,Blk);
            Set_DText(Box,Line[lineNumber],Msg[LineNumber],
                     System_Font,TE_Left);
          END;
        ExitButton := Add_DItem(Box,G_Button,
                                Selectable | Default |Exit_Btn,
                                15,6,10,1,        0,Blk);
        Set_DText(Box,ExitButton,' So be it ', System_Font,TE_Left);
        Center_Dialog(Box);
        Pushed := Do_Dialog(Box,0);
        End_Dialog(Box);
      END {displayarraymessage};

    PROCEDURE FillArray;
      VAR
        i    :  integer;
        Seed : long_integer;

      FUNCTION Random : long_integer;
        XBIOS (17);

      BEGIN  {fillarray}
        FOR i := LB To UB DO
          PlotArr[i] := Random;
      END{fillarray};

    PROCEDURE GetBoundsOfX
          (VAR LowerBound : real;
           VAR UpperBound : real);
      CONST
        Width = 25;
        Height = 7;
      TYPE
        T118 = (integertype,longtype,realtype);
      VAR
        Box : Dialog_Ptr;
        Line1,Line2,Line3 : integer;
        LinePushed : integer;
        UserString : str255;
        dummyint :integer;
        dummylong : long_integer;

      PROCEDURE ConvertStringToNumber
                        (S   : string;  {ASCII string to convert}
                 VAR Success : boolean; {All errors reflected here}
                  ResultType : T118;    {Select 1 of 3 possible types}
          VAR  IntegerResult : integer;
          VAR     LongResult : long_integer;
          VAR     RealResult : real);
        CONST
          TerminatorChar = '%';
        TYPE
          T1 = ARRAY [1..80] OF char;
        VAR
          C : ARRAY[1..80] OF char;
          LeftPart,RightPart,ExponentArray : T1;
          LeftPartIx,RightPartIx,ExpIx : integer;
          ParsingError : boolean;
          PositiveNumber,PositiveExponent : boolean;
          i : integer;
          Exponent : integer;
          X1    : real;

        PROCEDURE ProcessError
                   (Signature : integer); {A unique, meaningless number
                                           Large enough so that a search
                                           with a text editor can find it
                                           easily.  The numbers are all
                                           of the form '12dd'         .}
          {Sets the global error flag and records the signature
          for possible debug ouput.                          }
          BEGIN
            (*WriteLn('Error in ConvertStringToNumber. Error code:',
                       Signature);*)
            Success     := FALSE;
          END;

        PROCEDURE TestTrailingBlank(i : integer);
          VAR
            j : integer;
          BEGIN
            IF c[i] = ' '
              THEN TestTrailingBlank(i + 1)
            ELSE
              IF c[i] = TerminatorChar
                THEN BEGIN  {do nothing}  END
                ELSE
                  BEGIN
                    ParsingError := TRUE;
                    ProcessError(1201);
                  END;
          END{TestTrailingBlank};

        PROCEDURE TestExponentDigit(i : integer);
          BEGIN
            IF c[i] IN ['0'..'9'] THEN
              BEGIN
                ExpIx := ExpIx + 1;
                IF ExpIx > 2 THEN
                  BEGIN
                    ParsingError := TRUE;
                    ProcessError(1202);
                  END;
                ExponentArray[ExpIx] := C[i];
                TestExponentDigit(i + 1);
              END
            ELSE
              TestTrailingBlank(i);
          END{testexponentdigit};

        PROCEDURE TestSignOfExponent(i : integer);
          BEGIN
            CASE c[i] OF
              '-' : BEGIN
                      PositiveExponent := FALSE;
                      TestExponentDigit(i + 1);
                    END;
              '+' : TestExponentDigit(i + 1);
              OTHERWISE : TestExponentDigit(i);
            END{case};
          END{testsignofexponent};

        PROCEDURE TestLetterE(i : integer);
          BEGIN
            IF c[i] IN ['e','E']
              THEN TestSignOfExponent(i + 1)
              ELSE TestTrailingBlank(i);
          END{TestLetterE};

        PROCEDURE Test4TrailingDigit(i : integer);
          BEGIN
            IF c[i] IN ['0'..'9'] THEN
              BEGIN
                RightPartIx := RightPartIx + 1;
                RightPart[RightPartIx] := c[i];
                Test4TrailingDigit(i + 1);
              END
            ELSE
              TestLetterE(i);
          END{test4trailingdigit};

        PROCEDURE TestDecimal(i : integer);
          BEGIN
            IF c[i]= '.'
            THEN Test4TrailingDigit(i + 1)
            ELSE TestLetterE(i);
          END{testdecimal};

        PROCEDURE TestLeadingDigit(i : integer);
          BEGIN
            IF c[i] IN ['0'..'9']
              THEN
                BEGIN
                  LeftPartIx := LeftPartIx + 1;
                  LeftPart[LeftPartIx] := c[i];
                  TestLeadingDigit(i + 1);
                END
              ELSE
                TestDecimal(i);
          END{testleadingdigit};

        PROCEDURE Test2SignOfNumber(i : integer);
          BEGIN
            CASE C[i] OF
              '-' : BEGIN
                      PositiveNumber := FALSE;
                      TestLeadingDigit(i + 1);
                    END;
              '+' : TestLeadingDigit (i + 1);
              OTHERWISE : TestLeadingDigit(i);
            END{case};
          END{test2signofnumber};

        PROCEDURE Test3LeadingBlank(i: integer);
          BEGIN
            IF c[i] = ' '
            THEN Test3LeadingBlank(i+1)
            ELSE Test2SignOfNumber(i);
          END {test3leadingblank};

        FUNCTION StringToLongInteger
                               (Arr : T1;
                                  N : integer
                                   ): long_integer;
          VAR
            Temp : long_integer;
            i    : integer;
          BEGIN
            Temp := 0;
            {Don't count excess digits in real as an error.
            Simply discard them.  They are treated as an
            error in the case of integers and long_integers.
            Its harder for the user to
            deal with real numbers so give him /her a little leeway.}
            IF (N > 10) THEN
              N := 10;
            IF (N = 10) AND (Arr[1] > '2') THEN
              N := 9;
            FOR i := 1 TO N DO
              BEGIN
                Temp := Temp * 10;
                Temp := Temp + ORD(Arr[i]) - ORD('0');
              END;
            StringToLongInteger := Temp;
          END{stringtolonginteger};

        PROCEDURE ConvertLong;
          VAR
            SignChange : boolean;
          BEGIN
            IF (LeftPartIx > 10)
              OR
                ((LeftPartIx = 10) AND (LeftPart[1] > '2'))
              OR
                (RightPartIx > 0)
              OR
                (ExpIx > 0)
              THEN ProcessError(1203)
              ELSE
                BEGIN
                  LongResult := StringToLongInteger(LeftPart,LeftPartIx);
                  IF ResultType = IntegerType
                    THEN
                      IF (LongResult > 32767) OR (LongResult < -32767)
                        THEN ProcessError(1204)
                        ELSE IntegerResult := INT(LongResult);
                END {success};
            IF NOT(PositiveNumber) THEN
              BEGIN   {Affix the proper sign.}
                IntegerResult := - IntegerResult;
                LongResult    := - LongResult;
              END;
            {Overflow will cause sign inversion on
            numbers > 2,147,483,647 but only 10 digits long.}
            SignChange := NOT PositiveNumber AND (LongResult > 0);
            SignChange := SignChange
                             OR
                          PositiveNumber AND (LongResult < 0);
            IF (ResultType = LongType) AND SignChange
              THEN ProcessError(1205);
          END{ConvertLong};

        PROCEDURE ConvertReal
                   (VAR X1 : real);
          VAR
            i,j        : integer;
            LongTemp   : long_integer;

          PROCEDURE ScalePositiveExponent;
            VAR
              BigNumber : real;
            BEGIN
              {Next statement due to flaw in level 1.0 compiler.
              Compiler tries to generate large constants and fails.
              Have to make a big number out of little numbers.     }
              BigNumber := 1.7E7 * 1.0E10 * 1.0E10
                           * 1.0E10 ;     {(2 ^ 127 - 1) / 10.0}
              WHILE (X1 < BigNumber) AND (Exponent > 0) DO
                BEGIN
                  X1 := X1 * 10.0;
                  Exponent := Exponent - 1;
                END;
              IF Exponent > 0 THEN
                ProcessError(1206);
            END {sclaepositiveexponent};

          PROCEDURE ScaleNegativeExponent;
            BEGIN
              {Don't detect underflows.}
              WHILE (Exponent <> 0) DO
                BEGIN
                  X1 := X1 / 10.0;
                  Exponent := Exponent + 1;
                END;
            END {scalenegativeexponent};

          PROCEDURE JoinTwoNumbers;
            VAR
              i, j : integer;
              LeftNonZero,RightNonZero : boolean;

            FUNCTION NonZeroDigit
                            (Arr : T1;
                               N : integer)
                                 : boolean;
              VAR
                i    : integer;
                Find : boolean;
              BEGIN {nonzerodigit}
                Find := FALSE;
                FOR i := 1 TO N DO
                  IF Arr[i] In ['1'..'9'] THEN
                    Find := TRUE;
                NonZeroDigit := Find;
              END {nonzerodigit};

            BEGIN   {jointwonumbers}
              {The combined result will appear in LeftPart,LeftPartIx
              and Exponent}
              LeftNonZero  := NonZeroDigit(LeftPart,LeftPartIx);
              RightNonZero := NonZeroDigit(RightPart,RightPartIx);
              CASE LeftNonZero OF
                TRUE : CASE RightNonZero OF
                         TRUE  : BEGIN
                                   {Append the part after the
                                   decimal to the part
                                   before the decimal.}
                                   j := 0;
                                   FOR i := LeftPartIx + 1 TO
                                     LeftPartIx + RightPartIx DO
                                     BEGIN
                                       j := j + 1;
                                       LeftPart[i] := RightPart[j];
                                       Exponent := Exponent - 1;
                                     END;
                                   LeftPartIx := LeftPartIx + RightPartIx;
                                 END {true};
                         FALSE : {Nothing to do} ;
                       END {case};
                FALSE : CASE RightNonZero OF
                          TRUE : BEGIN
                                   {A once in a lifetime chance to use
                                   the following statement!}
                                   LeftPart := RightPart;
                                   LeftPartIx := RightPartIx;
                                   Exponent := Exponent - RightPartIx;
                                 END;

                          FALSE : BEGIN {'0.0' and its variants}
                                    LeftPart[1] := '0';
                                    LeftPartIx := 1;
                                    Exponent := 0;
                                  END;
                        END {case};
              END {case};
            END {jointwonumbers};

          FUNCTION StringToReal
                          (Arr : T1;
                             N : integer)
                               : real;
            VAR
              i : integer;
              x : real;
            BEGIN {stringtoreal}
              X := 0;
              FOR i := 1 TO N DO
                BEGIN
                  x := x * 10.0;
                  x := x + ORD(Arr[i]) - ORD('0');
                END;
              StringToReal := X;
            END {stringtoreal};

          BEGIN {convertreal}
            IF PositiveExponent
              THEN Exponent :=
                            INT(StringToLongInteger(ExponentArray,ExpIx))
              ELSE Exponent :=
                          - INT(StringToLongInteger(ExponentArray,ExpIx));
            JoinTwoNumbers;
            {Now convert an array of characters into a positive real number.}
            X1 := StringToReal(LeftPart,LeftPartIx);
            IF Exponent <> 0 THEN
              CASE Exponent >= 0 OF
                TRUE  : ScalePositiveExponent;
                FALSE : ScaleNegativeExponent;
              END {case};
            {Now affix the proper sign.}
            IF NOT PositiveNumber THEN
              X1 := - X1;
          END{convertreal};

        PROCEDURE ParseTheString;
          BEGIN
      {The next statement is the first in a series of calls to evaluate
      the input.  They all work on array c and use i as an index into the
      array.  If, on return to this point, the error flag is not set,
      the components of the number have been isolated into sign flags and
      arrays containing digits. Many of the calls are recursive. }
            Test3LeadingBlank(i + 1);
      {Parsing is done.  The string has been 'atomized' into its
      fundamental components.                                    }
          END {parsethestring};

        BEGIN {convertstringtonumber}
          {Move string to array since Personal Pascal strings in level 1.0
          are flakey.}
          FOR i := 1 TO LENGTH(S) DO
            C[i] := S[i];
          C[LENGTH(S) + 1] := TerminatorChar;
          i := 0;
          LeftPartIx := 0;   RightPartIx := 0;   ExpIx := 0;
          ParsingError     := FALSE;
          PositiveNumber   := TRUE;     PositiveExponent := TRUE;
          ParseTheString;
          Success := NOT ParsingError AND
                     ( (LeftPartIx > 0) OR (RightPartIx > 0)  );
          {There is a valid Pascal number.  It is not necessarily
          convertible to the type wanted.}
          IF Success THEN
            CASE ResultType OF
              IntegerType, LongType : ConvertLong;
              RealType              : ConvertReal(RealResult);
            END;
        END {Convertstringtonumber};

      BEGIN   {getboundsofx}
        Box := New_Dialog(4,0,0,Width,Height);
        Line1 := Add_DItem(Box,G_String,None,7,2,11,1,0,Black);
        Set_DText(Box,Line1,'RANGE OF X',System_Font,TE_Left);
        Line2 := Add_DItem(Box,G_FText,Editable,1,3,21,1,   NoBorder,Blk);
        Set_DEdit(Box,Line2,
           'Lower bound:_________', 'xxxxxxxxx', '',
           System_Font,TE_Center);
        Line3 := Add_DItem(Box,G_FText,Editable | Default,
                 1,4,21,1,   noBorder,Blk);
        Set_DEdit(Box,Line3,
             'Upper bound:_________', 'xxxxxxxxx', '',
             System_Font,TE_Center);
        Center_Dialog(Box);
        End_Dialog(Box);
        LinePushed := Do_Dialog(Box,Line2);
        Get_DEdit(Box,Line2,UserString);
        ConvertStringToNumber(UserString,OK1,realtype,dummyint,
                              dummylong,LowerBound);
        Get_DEdit(Box,Line3,UserString);
        ConvertStringToNumber(UserString,OK2,realtype,dummyint,
                              dummylong,UpperBound);
      END{getboundsofx};

    PROCEDURE FudgeNumber(VAR X : real);
      BEGIN
        {This is needed becuase of the rather cavalier way
        Personal Pascal treats error messages on ROUND(X).}
        IF X > MAXINT THEN
          BEGIN
            X := MAXINT;
            NumbersFudged := TRUE;
          END;
        IF X < - MAXINT THEN
          BEGIN
            X := - MAXINT;
            NumbersFudged := TRUE;
          END;
      END {fudgenumbers};

    PROCEDURE DisplayInputRules;
      CONST
        W = 45;
        H = 10;
      VAR
        Box : dialog_ptr;
        Line : ARRAY [1..10] OF integer;
        Msg : ARRAY [1..10] OF string;
        LineNbr : integer;
        Choice : tree_index;
        Retry,Abort : integer;
      BEGIN {displayinputrules}
        Msg[1] := '        Faulty format on input data.        ';
        Msg[2] := '        Use the rules of Pascal for         ';
        Msg[3] := 'integers, long integers, or real variables. ';
        Msg[4] := '            Valid examples:                 ';
        Msg[5] := '     25          18.3            -85.34     ';
        Msg[6] := '   139.e5      -37E-18          1234567.8   ';
        Box := New_Dialog(10,0,0,W,H);
        FOR LineNbr := 1 TO 6 DO
          BEGIN
            Line[LineNbr] := Add_DItem(Box,G_String,None,
                         1,LineNbr,30,1,       NoBorder,Blk);
            Set_DText(Box,Line[LineNbr],Msg[lineNbr], System_Font,TE_Left);
          END;
        Abort :=  Add_Ditem(Box,G_Button,Selectable | Exit_Btn,
                8,8,7,1,     NoBorder,Blk);
        Set_DText(Box,Abort,' ABORT ',System_Font,TE_CEnter);
        Retry := Add_DItem(Box,G_Button,Selectable | Default | Exit_btn,
                 30,8,7,1,     NoBorder,Blk);
        Set_DText(Box,Retry,' RETRY ',System_Font,TE_Center);
        Center_Dialog(Box);
        Choice := Do_Dialog(Box,0);
        End_Dialog(Box);
        IF choice = Abort THEN
          HALT;
      END {displayinputrules};

    PROCEDURE DisplayUpperVsLower;
      CONST
        W = 45;
        H = 10;
      VAR
        Box : dialog_ptr;
        Line : ARRAY [1..10] OF integer;
        Msg : ARRAY [1..10] OF string;
        LineNbr : integer;
        Choice : tree_index;
        Retry,Abort : integer;
      BEGIN {displayinputrules}
        Msg[3] := '          The upper bound must be           ';
        Msg[4] := '       greater than the lower bound.        ';
        Box := New_Dialog(10,0,0,W,H);
        FOR LineNbr := 3 TO 4 DO
          BEGIN
            Line[LineNbr] := Add_DItem(Box,G_String,None,
                         1,LineNbr,30,1,    NoBorder,Blk);
            Set_DText(Box,Line[LineNbr],Msg[lineNbr],
                      System_Font,TE_Left);
          END;
        Abort :=  Add_Ditem(Box,G_Button,Selectable | Exit_Btn,
                 8,7,7,1,   NoBorder,Blk);
        Set_DText(Box,Abort,' ABORT ',System_Font,TE_CEnter);
        Retry := Add_DItem(Box,G_Button,Selectable | Default | Exit_btn,
                30,7,7,1,   NoBorder,Blk);
        Set_DText(Box,Retry,' RETRY ',System_Font,TE_Center);
        Center_Dialog(Box);
        Choice := Do_Dialog(Box,0);
        End_Dialog(Box);
        IF choice = Abort THEN
           HALT;
      END {displayuppervslower};

    PROCEDURE Display2ArrayBounds;
      CONST
        W = 45;
        H = 10;
      TYPE
        S06 = string[6];
      VAR
        Box  : dialog_ptr;
        Line : ARRAY [1..10] OF integer;
        Msg  : ARRAY [1..10] OF string;
        LineNbr : integer;
        Choice : tree_index;
        Retry,Abort : integer;
        S1, S2 : S06;

      PROCEDURE IntegerToString
                       (VAR S : S06;
                            N : integer);
        VAR
          M, i, Digit : integer;
          SIndex : integer;
          NbrDeleted : integer;
        BEGIN
          IF N < 0
           THEN
             BEGIN
               IntegerToString(S, - N);   {Note recursion.}
               S[1] := '-';
             END
           ELSE
             BEGIN  {conversion of positive number}
               S := '' ;
               M := 10000;
               FOR i := 1 TO 5 DO
                 BEGIN
                   Digit := N DIV M;
                   S := CONCAT(S, CHR(Digit + ORD ('0'))  );
                   N := N MOD M;
                   M := M DIV 10;
                 END;
               {Create a space for a possible minus sign.}
               S := CONCAT('0', S);
               {Change leading zeros to blanks.}
               i := 1;
               WHILE (i < 6) AND (S[i] = '0') DO
                 BEGIN
                   s[i] := ' ';
                   i := i + 1;
                 END;
             END;
        END {integertostring};

      BEGIN {display2arraybounds}
        Msg[1] := '             BOUNDS OF ARRAY';
        Msg[2] := '           LOWER           UPPER';
        IntegerToString(S1,LB);
        IntegerToString(S2,UB);
        Msg[3] := CONCAT('Actual     ',  S1, '          ',   S2 );
        IntegerToString(S1,ROUND(XMin));
        IntegerToString(S2,ROUND(XMax));
        IF NumbersFudged THEN
          BEGIN
            S1 := '   ???';
            S2 := '   ???';
          END;
        Msg[4] := CONCAT('You want   ', S1,  '          ',   S2 );
        Msg[5] := '  ';
        Msg[6] := '    ';
        Box := New_Dialog(10,0,0,W,H);
        FOR LineNbr := 1 TO 6 DO
          BEGIN
            Line[LineNbr] := Add_DItem(Box,G_String,None,
                         1,LineNbr,30,1,       NoBorder,Blk);
            Set_DText(Box,Line[LineNbr],Msg[lineNbr], System_Font,TE_Left);
          END;
        Abort :=  Add_Ditem(Box,G_Button,Selectable | Exit_Btn,
               11,6,7,1,     NoBorder,Blk);
        Set_DText(Box,Abort,' ABORT ',System_Font,TE_CEnter);
        Retry := Add_DItem(Box,G_Button,Selectable | Default | Exit_btn,
                 27,6,7,1,     NoBorder,Blk);
        Set_DText(Box,Retry,' RETRY ',System_Font,TE_Center);
        Center_Dialog(Box);
        Choice := Do_Dialog(Box,0);
        End_Dialog(Box);
        IF choice = Abort THEN
          HALT;
      END {display2arraybounds};

    FUNCTION GofX
              (X : real)
                 : real;
      {Caution: You might try other functions here so be warned.
                1. Personal Pascal sometimes prints a dissembling message
                   on the computation of LN.
                2. TAN(X) does not detect overflow. }


      FUNCTION PolyFunction
                        (X : real
                          ): real;
        VAR
          OddPower : boolean;

        FUNCTION XToTheY
                     (X : real;
                      Y : integer)
                        : real;
          VAR
            Product : real;
            i : integer;
          BEGIN     {xtothey}
            IF Y < 0 THEN
              XToTheY := 1.0 / XToTheY(X, - Y);
            Product := 1;
            FOR i := 1 TO Y DO
              Product := Product * X;
            IF X < 0
              THEN
                IF ODD(Y)
                  THEN XToTheY := - Product
                  ELSE XToTheY :=   Product
              ELSE
                XToTheY := Product;
          END {xtothey};

        BEGIN {polyfunction}
          {x^4 -7x^3 +11x^2 - 12 }
          PolyFunction := xtothey(x,4) -7*xtothey(x,3) + 11*x*x + 7*x -12;
        END {polyfunction};

      FUNCTION NormalFunction
                          (X : real)
                             : real;
        VAR
          K : real;
        BEGIN
          K := 1.0 / SQRT(2.0* 3.1415926536);
          IF x < 0.0
            THEN NormalFunction := NormalFunction( - X)
            ELSE NormalFunction := K * EXP(-(X * X * 0.5));
        END {normaldistfunction} ;


      BEGIN {GofX}
        CASE Func OF
          Sinusoid   : GofX := SIN(X);
          Parabola   : GofX := X * X + 3 * X - 4;
          Polynomial : GofX := PolyFunction(X);
          NormalDist : GofX := NormalFunction(X);
        END {case};
      END {GofX};

    {---------- This is the procedure being demonstrated -------------
    In addition to the parameters listed, There must be available a
    real FUNCTION, GofX which will evaluate the value of the function
    at any point in the interval: lower bound .. upper bound.  Provide
    a dummy function if plotting an array.
    Sample Function:
                FUNCTION GofX(X : real):real;


    Editorial.  ISO standard Pascal permits the inclusion of FUNCTIONs
    and PROCEDUREs as parameters to procedures. See, for example,
    'Standard Pascal Reference Manual' by Doug Cooper, pp 83-86.
    Personal Pascal claims to meet the ISO standard, but doesn't permit
    this. (At least, Level 1.0 doesn't).  As a matter of fact, it responds
    in a rather ugly fashion.  Despite this, the guys at OSS did a
    good job!
    }

    PROCEDURE XYPlot(
              X1, X2 : real;
             PlotArr : T2;   {Provide a dummy array if plotting a function}
     FunctionOrArray : T1);
      CONST
        TopMargin = 8;
      VAR
        X,Y,W,H : integer;
        mwindow : integer;
        XScaleFactor,YScaleFactor : real;
        XCorrection,YCorrection : long_integer;
        LineNumber : integer;

      PROCEDURE MakeWindow;
        VAR
         Title : string;

        PROCEDURE PaintWhite;
          BEGIN
            Paint_Color(White);
            Paint_Style(1);     {Normal GEM desktop dither pattern is 5.}
            Hide_Mouse;
            Paint_Rect(X,Y,W,H);
          END {paintwhite};

        BEGIN {makewindow}
          ClrScr;
          Text_Color(Black);
          Line_Color(Black);
          X := 100;
          Y := 20;
          W := 540;
          H := 380;
          Title := ' X-Y Plotter ';
          mwindow := new_window(G_Name | G_Close,title,X,Y,W,H);
          open_window(mwindow,X,Y,W,H);
          work_rect(mwindow,X,Y,W,H);
          set_clip(x,y,w,h);
          {The net drawing area is W = 538, H = 360 on monochrome monitor}
          PaintWhite;
          {Allow a margin of 8 pixels on top and bottom.}
          H := H - (2 * TopMargin);
        END {makewindow};

      PROCEDURE FillWindow;
        VAR
          RangeX,DeltaX,Biggest,Smallest,Y,RangeY,X : real;
          Xbias,YBias : long_integer;

        FUNCTION FofX(x : real) : real;

          FUNCTION Interpolate
                           (X : real;
                           X1 : integer;
                           X2 : integer)
                              : real;
            VAR
              Xinc,Y,YQuantum,LowerValue,UpperValue : real;
              LowerIndex,UpperIndex : integer;
            BEGIN
              LowerIndex := TRUNC(X);
              IF (LowerIndex + 1) > X2
                THEN UpperIndex := X2
                ELSE UpperIndex := LowerIndex + 1;
              LowerValue := PlotArr[LowerIndex];
              UpperValue := PlotArr[UpperIndex];
              Xinc       := x - LowerIndex;
              YQuantum := PlotArr[UpperIndex] - PlotArr[LowerIndex];
              Y := PlotArr[LowerIndex] + XInc * YQuantum;
              Interpolate := Y;
            END {arrayfunction};

          BEGIN   {FofX}
            IF FunctionOrArray = ArrKind
              THEN FofX := Interpolate(X,ROUND(X1),ROUND(X2))
              ELSE FofX := GofX(X);
          END {FofX};

        PROCEDURE ComputeRangeXandY;
          BEGIN
            RangeX := XMax - XMin;
            DeltaX := RangeX / W;
            X := XMin;
            Biggest := FofX(XMin);
            Smallest := Biggest;
            REPEAT
              x := x + DeltaX;
              y := FofX(x);
              IF y > Biggest THEN
                Biggest := y;
              IF y < Smallest THEN
                Smallest := y;
            UNTIL x >= XMax;
            RangeY := Biggest - Smallest;
          END {computerangexandy};

        BEGIN  {fillwindow}
          ComputeRangeXandY;
          {Use absolute addressing on the window.}
          XBias := 640 - W;
          YBias := 400 - H ;
          {Note negtive sign. It corrects for the fact that more
          positive numbers
          yield a downward, i.e., negative, deflection on the screen.}
          YScaleFactor := - H / RangeY;
          XScaleFactor := W / RangeX;
          {Now plot the curve.}
          x := XMin;
          XCorrection := XBias - LONG_ROUND(XMin * XScaleFactor);
          YCorrection := YBias - (TopMargin) -
                               LONG_ROUND(Biggest * YScaleFactor);
          REPEAT
            y := FofX(x);
            PLOT (
              INT( LONG_ROUND(x * XScaleFactor) + XCorrection ),
              INT( LONG_ROUND(y * YScaleFactor) + YCorrection )       );
            x := x + DeltaX;
          UNTIL x >= XMax;
          {Draw a Y axis.  If its outside the boundary established
          by set clip,
          it won't show, but no harm done.  We tried.}
          Line_Style(4);  {dash, dot}
          Line(INT(Xbias),INT(YCorrection),  640, INT(YCorrection));
        END{fillwindow};

      PROCEDURE TidyScreen;
        BEGIN
          Show_Mouse;
          {Erase the 'compute' message.'}
          CursUp;
          WriteLn('         ');
          CursHome;
          LineNumber := 1;
        END {tidyscreen};

      PROCEDURE DetermineCoordinates;
        VAR
          MouseX,MouseY : integer;
          ExitPressed : boolean;
          XatMouse,YatMouse : real;

        PROCEDURE GetMEvent
            (VAR MouseX : integer;
             VAR MouseY : integer;
             VAR Stop   : boolean);
          LABEL
            100;
          VAR
            event,dummy,mx,my,emask:integer;
            longdummy : long_integer;
            bdummy   : boolean;
            msg      : message_buffer;
            c        : char;
            key      : integer;
          BEGIN {getmevent}
            100:
            emask := E_Button | E_Message;
            event := get_event(
                    emask,
                    $1,     {left button}
                    $1,     {wait for button down}
                    $1,     {wait for 1 event}
                    longdummy,
                    bdummy,dummy,dummy,dummy,dummy,
                    bdummy,dummy,dummy,dummy,dummy,
                    msg,
                    key,
                    dummy,dummy,
                    MouseX,MouseY,
                    dummy);
            IF (  ((Event & E_Message) > 0 ) AND (Msg[0] = WM_Closed)  )
              THEN
                Stop := TRUE
              ELSE
                Stop := FALSE;
            IF ((MouseX < 100) AND (NOT(Stop))) THEN {discard it}
              GOTO 100;
          END {getmevent};

        PROCEDURE PrintupArrows;
          CONST
            Device  = 5;   {display control characters on console}
            UpArrow = 1;        {upward pointing arrow head.}
          VAR
            ChPosition : integer;
            dummy      : integer;

          FUNCTION BiosConsoleOutput
                  (DeviceNumber : integer;
                   ChCode       : integer)
                                : integer;
            BIOS (3);

          BEGIN {printuparrows}
            FOR ChPosition := 1 TO 11 Do
              dummy := BiosConsoleOutput(Device,UpArrow);
              WriteLn;
          END {printuparrows};

        PROCEDURE PrintNice
                    (X : real);
          {Minimize the chance that the printing will use the 'E' format.}
          BEGIN
            IF (X > -1000) AND (X < 1000)
              THEN WriteLn(X:9:4)
              ELSE WriteLn(X:9);
            END {printnice};

        BEGIN {determinecoordinates}
          Set_Mouse(M_Outln_Cross);
          {Empty the trash.}
          GetMEvent(MouseX,MouseY,ExitPressed);
          LineNumber := 1;
          REPEAT
            GetMEvent(MouseX,MouseY,ExitPressed);
            XatMouse := (MouseX - XCorrection) / XScaleFactor;
            YatMouse := ( MouseY - YCorrection) / YScaleFactor;
            {Erase old line of arrowheads.}
            IF LineNumber > 1 THEN
              BEGIN
                CursUp;
                WriteLn('            ');
              END;
            IF LineNumber > 23 THEN
              BEGIN
                CursHome;
                LineNumber := 1;
              END;
            PrintNice(XatMouse);
            PrintNice(YatMouse);
            PrintUpArrows;
            LineNumber := LineNumber + 3;
          UNTIL ExitPressed;
        END {determinecoordinates};

      PROCEDURE CleanUp;
        BEGIN
          Close_window(MWindow);
          Delete_Window(MWindow);
          ClrScr;
          {Return mouse to its usual form.}
          Set_Mouse(M_Arrow);
        END {cleanup};

      BEGIN {XYPlot  procedure}
        MakeWindow;
        WriteLn('computing');
        FillWindow;
        TidyScreen;
        DetermineCoordinates;
        CleanUp;
      END{xyplotprocedure};

     {------------- end of procedure being demonstrated -------------}

    BEGIN {XYPlotDemo}
      ChooseFunction;
      IF Func = ArrayPlot THEN
        BEGIN
          DisplayArrayMessage;
          FillArray;
        END;
      LOOP
        GetBoundsOfX(XMin,XMax);
        NumbersOK := OK1 AND OK2;
        IF Func = ArrayPlot
          THEN
            BEGIN
              NumbersFudged := FALSE;
              FudgeNumber(XMin);
              FudgeNumber(XMax);
              IF NumbersOK AND (XMax > XMin) AND
              NOT NumbersFudged AND
              (ROUND(XMin) >= LB) AND (ROUND(XMax) <= UB)
                THEN
                  Done := TRUE
                ELSE
                  Done := FALSE
            END  {array plot}
          ELSE {function plot}
            IF NumbersOK AND (XMax > XMin)
              THEN
                Done := TRUE
              ELSE
                Done := FALSE;
        EXIT IF Done;
        IF NOT NumbersOK
          THEN
            DisplayInputRules
          ELSE
            IF XMax <= XMin
              THEN
                DisplayUppervsLower
              ELSE         {out of bounds and array plot wanted}
                Display2ArrayBounds;
      END {loop};
      IF Func = ArrayPlot
        THEN PlotKind := ArrKind
        ELSE PlotKind := FunctionKind;
      XYPlot(XMin,XMax,PlotArr,PlotKind);
    END {xyplotdemo};

  BEGIN     {main program}
    IF ColorMonitor THEN
      BEGIN
        WriteLn('Program only works with monochrome monitor.');
        WriteLn('Sorry.');
        ReadLn;
        HALT;
      END;
    IF init_gem >= 0 THEN
      BEGIN
        XYPlotDemo;
        Exit_GEM;
      END{of gem};
  END{program}.