home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sampler / 01 / curves / curve.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-09-09  |  13.3 KB  |  497 lines
  1. {
  2.                        F i l e    I n f o r m a t i o n
  3.  
  4. * DESCRIPTION
  5. Curve ++ (version T1.0) by Stephen Callender is a Turbo Pascal 3.0 program
  6. that performs multiple regression on X and Y data and then draws a line that
  7. will best match the data. The user can choose from four lines - straight,
  8. exponential, logarithmic or power.
  9.  
  10. * ASSOCIATED FILES
  11. CURVE.PAS
  12. ASSAY.TXT
  13. CURVE.COM
  14. CURVE4.EXE
  15. CURVE4.PAS
  16. PRINTOUT.INC
  17. PT.LAS
  18. README
  19. SAMPLE.INC
  20. SAMPLE2.INC
  21. SAMPLE4.INC
  22. SAMPLE4B.INC
  23. SPACER.INC
  24. TOOLS.INC
  25. TOOLS4.INC
  26.  
  27. ==========================================================================
  28. }
  29. { June 8, 1987 proofed by Stephen }
  30. { June 18, 1987 compiled          }
  31. { CURVE++.PAS   FROM APPLESOFT BASIC  --> TURBO PASCAL  SEPT. 12, 1986  }
  32. { STEPHEN C. CALLENDER  MODIFIED AND ENHANCED BASIC PROGRAM FROM PUBLIC DOMAIN }
  33. { UNDER DEVELOPMENT     9/16/86     SAMPLE ROUTINE ADDED                   }
  34. { ADD THE LAST ROUTINES SPACE, HARDCOPY PRINTOUT CURVE   10/27/86   11/21/86  }
  35.  
  36. PROGRAM CURVE;
  37.  
  38.   CONST BELL = #7;
  39.  
  40.     TYPE
  41.       STR25 = STRING[25];
  42.       CALC  = ARRAY[1..4] OF REAL;
  43.       MARK  = ARRAY[1..14] OF STRING[20];
  44.  
  45.    VAR
  46.      X,Y,Y1,Y2,X1,X2 : ARRAY[1..50] OF REAL;
  47.      B, M, C : CALC;
  48.      ENTRY, FLAG, POINT : INTEGER;
  49.  
  50.  
  51. {$ITOOLS.INC}
  52.  
  53. PROCEDURE TITLE;
  54.   BEGIN
  55.     CLRSCR;
  56.       WRITELN('           CURVE TURBO PASCAL IBM VERSION 1.01 ');
  57.       WRITELN('           [C] 6/18/87 BY STEPHEN C. CALLENDER ');
  58.        INVERSE;
  59.     WRITE('              <+> MULTIPLE REGRESSION ON X,Y DATA <+>           ');
  60.    no_inverse; WRITELN;
  61.     WRITELN('                   DRAWS THE BEST LINE.');
  62.     WRITELN; WRITELN;
  63.     WRITELN('                  FOUR FITS ARE AVAILABLE: ');
  64.     WRITELN('                    LINEAR : y = b + mx');
  65.     WRITELN('                     POWER : y = bx ^ m ');
  66.     WRITELN('               LOGARITHMIC : y = b + b ln(x)');
  67.     WRITELN('               EXPONENTIAL : y = b exp(mx) ');
  68.     WRITELN;
  69.     PAUSE
  70. END;
  71.  
  72. PROCEDURE INITIALIZE;
  73.   VAR
  74.       N : INTEGER;
  75.     BEGIN
  76.       FOR N := 1 TO 4 DO
  77.           BEGIN
  78.                C[N] := 0; B[N] := 0; M[N] := 0
  79.         END
  80. END;
  81.  
  82. PROCEDURE LABELS(FFLAG : INTEGER; VAR BRAND : MARK);
  83.           VAR NAME : MARK;
  84.       BEGIN
  85.         CASE FFLAG OF
  86.         1 : NAME[1] := ' LINEAR ';
  87.         2 : NAME[2] := ' POWER ';
  88.         3 : NAME[3] := ' LOGARITHMIC ';
  89.         4 : NAME[4] := ' EXPONENTIAL ';
  90.         5 : NAME[5] := ' DATA UNSUITED TO ';
  91.         6 : NAME[6] := ' DATA ERROR ';
  92.         7 : NAME[7] := ' COMPUTE ';
  93.     END; { CASE }
  94.         WRITELN(NAME[FFLAG])
  95. END;
  96.  
  97. PROCEDURE SAVE;
  98.   VAR N : INTEGER;
  99.     FILER : TEXT;
  100.   BEGIN
  101.   WRITELN; WRITELN;
  102.  INVERSE;   WRITE('------SAVING TO THE DISK AS: ASSAY.TXT-----');
  103.      NO_INVERSE;
  104.     ASSIGN(FILER,'ASSAY.TXT');
  105.     REWRITE(FILER);
  106.       WRITELN(FILER,ENTRY);
  107.         FOR N:= 1 TO ENTRY DO
  108.             BEGIN
  109.               WRITELN(FILER,X[N]);
  110.               WRITELN(FILER,Y[N])
  111.               END;
  112.             CLOSE(FILER)
  113. END;
  114.  
  115. PROCEDURE LOAD;
  116.   VAR N : INTEGER;
  117.    FILER : TEXT;
  118.  BEGIN
  119.  WRITELN;
  120.  WRITELN;  INVERSE;
  121.  WRITE('-----LOADING THE FILE: ASSAY.TXT -----'); NO_INVERSE;
  122.    ASSIGN(FILER,'ASSAY.TXT');
  123.    RESET(FILER);
  124.     READLN(FILER);
  125.        FOR N := 1 TO ENTRY DO
  126.           BEGIN
  127.             READLN(FILER,X[N]);
  128.             READLN(FILER,Y[N])
  129.             END;
  130.          CLOSE(FILER)
  131. END;
  132.  
  133. PROCEDURE X_SINGLE_ENTRY;
  134. { X IS THE INDEX NO PAIRS }
  135.   VAR N : INTEGER;
  136.   BEGIN
  137.   N := 0; X[N] := 0;     { JUNE 6, 1987 revision of former x index procedure }
  138.   REPEAT                 { previous pascal procedure probably did not work   }
  139.        N := N + 1;       { Version 1.43 Apple CP/M                           }
  140.     WRITELN('N =  ',N);
  141.     WRITELN('X =  ',X[N]:1:1);
  142.     WRITELN; WRITE('Y = ?  ');
  143.     READLN(Y[N]); WRITELN;
  144.     X[N] := X[N] + N;
  145.   UNTIL N = ENTRY;
  146.   POINT := 1
  147. END;
  148.  
  149. PROCEDURE X_PAIRED_ENTRY;
  150. { X IS THE INDEX AND PAIRED NUMBERS  }
  151.   VAR N : INTEGER;
  152.     BEGIN
  153.       N :=0; X[N] := 0;     { this revision allows this procedure to work }
  154.       REPEAT                { unlike the original version from Basic      }
  155.        N := N + 1;          { Integer and real numbers can not be mixed   }
  156.        WRITELN('N =  ',N);                { in Pascal                     }
  157.        WRITELN('X =  ',X[N]:1:1);
  158.        WRITE('Y1 = ?  '); READLN(Y1[N]);
  159.        WRITE('Y2 = ?  '); READLN(Y2[N]);
  160.        Y[N] := (Y1[N] + Y2[N]) / 2;
  161.        { DISPLAY VALUES }
  162.          WRITELN('X =  ',N); WRITELN;
  163.          WRITELN('AVERAGE OF ',Y[N]:3:3,' & ',Y2[N]:3:3,' = ',Y[N]:3:3);
  164.          X[N] := X[N] + 1;
  165.       UNTIL N = ENTRY;
  166.       POINT :=2
  167. END;
  168.  
  169. PROCEDURE Y_SINGLE_ENTRY;
  170.   VAR N : INTEGER;
  171.   BEGIN
  172.     N := 0;
  173.     REPEAT
  174.       N := N + 1;
  175.       WRITELN('N =  ',N);
  176.       WRITE('X = ?   ');
  177.       READLN(X[N]);
  178.       WRITE('Y = ?   ');
  179.       READLN(Y[N]);
  180.        WRITELN;
  181.          UNTIL N = ENTRY;
  182.       POINT :=3
  183. END;
  184.  
  185. PROCEDURE Y_PAIRED_ENTRY;
  186.   VAR N : INTEGER;
  187.   BEGIN
  188.     N := 0;
  189.     REPEAT
  190.       N := N + 1;
  191.       WRITELN('N =   ',N);
  192.       WRITE('X = ?  ');
  193.       READLN(X[N]);
  194.       WRITE('Y1 = ?   ');
  195.       READLN(Y1[N]);
  196.       WRITE('Y2 = ?   ');
  197.       READLN(Y2[N]); WRITELN;
  198.       Y[N] := (Y1[N] + Y2[N]) / 2;
  199.     WRITELN(X[N]:3:3); WRITELN;
  200.     WRITELN('average of ',Y1[N]:3:3,' & ',Y2[N]:3:3,' = ',Y[N]:3:3);
  201.     UNTIL N = ENTRY;
  202.   PAUSE;
  203.   POINT :=4
  204. END;
  205.  
  206. PROCEDURE DATA_ENTRY;
  207.   VAR
  208.    CHOICE : CHAR;
  209.    BEGIN
  210.      CLRSCR;
  211.      INVERSE;
  212.     WRITE('DATA ENTRY MODE');
  213.     NO_INVERSE;
  214.      WRITELN;
  215.      WRITE('enter the number of data points for standard curve  ');
  216.      READLN(ENTRY);
  217.      WRITELN('DATA POINT SELECTION:  ');
  218.      WRITELN('x (index) single points press < a > ' );
  219.      WRITELN('x (index) paired points press < b > ' );
  220.      WRITELN('y (index) single points press < c > ' );
  221.      WRITELN('y (index) paired points press < d > ' );
  222.      WRITELN;
  223.       INVERSE;
  224.      WRITE( 'CHOOSE YOUR SELECTION:  ');
  225.      NO_INVERSE;
  226.      READLN(CHOICE);
  227.        CASE CHOICE OF
  228.        'A','a' : X_SINGLE_ENTRY;
  229.        'B','b' : X_PAIRED_ENTRY;
  230.        'C','c' : Y_SINGLE_ENTRY;
  231.        'D','d' : Y_PAIRED_ENTRY;
  232.        END; { CASE }
  233.      save;
  234. END;
  235.  
  236. PROCEDURE MENU;
  237.  FORWARD;
  238.  
  239. PROCEDURE EDIT_LIST;
  240.    FORWARD;
  241.  
  242. PROCEDURE EDIT_DATA;
  243.   VAR N : INTEGER;
  244.     CHOICE : CHAR;
  245.   BEGIN
  246.     CLRSCR;
  247.  INVERSE;
  248.      WRITE('which data pair ?   ');
  249.      NO_INVERSE;
  250.      READ(N);
  251.      WRITELN;
  252.    WRITELN(' DATA ',N,' PRESENTLY ');
  253.    WRITELN;
  254.       WRITELN('X =  ',X[N]:3:3);
  255.       WRITELN('Y =  ',Y[N]:3:3); WRITELN;
  256.       WRITELN('INPUT NEW DATA: ');
  257.       IF (POINT = 1) OR (POINT = 2) THEN
  258.         BEGIN
  259.          WRITELN('X =  ',N); WRITELN;
  260.          WRITE('Y = ?  ');
  261.          READLN(Y[N]); WRITELN
  262.        END
  263.      ELSE
  264.        BEGIN
  265.          WRITE('X = ?  ');
  266.          READLN(X[N]);
  267.          WRITELN;
  268.          WRITE('Y = ?  ');
  269.          READLN(Y[N]); WRITELN
  270.      END;
  271.      WRITELN;
  272.      WRITE('press (return) = more or O = options ');
  273.      READ(CHOICE);
  274.      IF CHOICE IN ['O','o'] THEN MENU
  275.        ELSE EDIT_LIST
  276. END;
  277.  
  278. PROCEDURE LIST_DATA;
  279.    VAR N : INTEGER;
  280.      BEGIN
  281.        CLRSCR;
  282.          FOR N := 1 TO ENTRY DO BEGIN
  283.            WRITELN; WRITELN('# OF POINTS =  ',ENTRY);
  284.            WRITELN('N =  ',N);
  285.            WRITELN; WRITELN('X =  ',X[N]:3:3);
  286.            WRITELN('Y =  ',Y[N]:3:3);
  287.          PAUSE
  288.      END
  289. END;
  290.  
  291. PROCEDURE EDIT_LIST;
  292.   VAR CHOOSE  :  CHAR;
  293.     BEGIN
  294.     CLRSCR;
  295.     WRITELN('do you wish to E)dit or L)ist data points of standard curve ');
  296.     READ(CHOOSE);
  297.             CASE CHOOSE OF
  298.             'E','e' : EDIT_DATA;
  299.             'L','l' : LIST_DATA
  300.         END
  301. END;
  302.  
  303. {"passed in" flag for displaying the final results of the standard curve }
  304.  
  305. PROCEDURE DISPLAY_CURVE(FFLAG : INTEGER);
  306.           VAR
  307.             NAME : MARK;
  308.           BEGIN
  309.           CLRSCR;
  310.             WRITELN;
  311.               LABELS(FFLAG,NAME); WRITELN;
  312.               WRITELN('Y - INTERCEPT =  ',B[FFLAG]:3:3); WRITELN;
  313.               WRITELN('SLOPE         =  ',M[FFLAG]:3:3); WRITELN;
  314.               WRITELN('CORR.COEFF    =  ',C[FFLAG]:3:3);
  315.            PAUSE
  316. END;
  317.  
  318. PROCEDURE COMPUTE(FFLAG : INTEGER);
  319.  
  320.        VAR FLAG2, N, BEST  :  INTEGER;
  321.     XX, YY, CC, XL, XY, YL, YS, XS  :  REAL;
  322.            NAME  :  MARK;
  323.     BEGIN
  324.       INITIALIZE;
  325.        XX := 0;
  326.         XS := 0;
  327.          YY := 0;
  328.          CC := 0;
  329.         XL := 0;
  330.        XY := 0;
  331.       YL := 0;
  332.      YS := 0;
  333.         CASE FFLAG OF
  334.         1 : BEGIN
  335.             FOR N := 1 TO ENTRY DO
  336.              BEGIN
  337.              XX := XX + X[N];
  338.              YY := YY + Y[N];
  339.              XY := (XY + (X[N] * Y[N]));
  340.              XS := XS + SQR(X[N]);
  341.              YS := YS + SQR(Y[N]);
  342.           END;
  343.   {    DEBUG;    }
  344. M[1] := XY - ((XX * YY) / ENTRY);
  345. M[1] :=M[1] / (XS - (SQR(XX) / ENTRY));
  346. B[1] :=(YY / ENTRY) - (M[1] * (XX / ENTRY));
  347. C[1] :=SQR(XY - ((XX * YY) / ENTRY));
  348. C[1] :=C[1]/(XS-(SQR(XX)/ENTRY));
  349. C[1] :=C[1]/(YS - (SQR(YY)/ENTRY));
  350. { display the computation  }
  351. DISPLAY_CURVE(1);
  352. WRITE(BELL)
  353. END;
  354.  
  355.     2 : BEGIN
  356.             FOR N := 1 TO ENTRY DO
  357.             BEGIN
  358.               XL :=LN(X[N]);
  359.               YL :=LN(Y[N]);
  360.               XX :=XX + XL;
  361.               YY :=YY + YL;
  362.               XY :=XY + (XL * YL);
  363.               XS :=XS + SQR(XL);
  364.               YS :=YS + SQR(YL)
  365.            END;
  366.        {    debug; }
  367.         M[2] := XY-(XX * YY/ENTRY);
  368.         M[2] := M[2]/(XS-(SQR(XX)/ENTRY));
  369.         B[2] := EXP((YY/ENTRY)-(M[2] * XX/ENTRY));
  370.         C[2] := SQR(XY-(XX * YY/ENTRY));
  371.         C[2] := C[2]/(XS-(SQR(XX)/ENTRY));
  372.         C[2] := C[2]/(YS-(SQR(YY)/ENTRY));
  373.         DISPLAY_CURVE(2);
  374.         WRITE(BELL)
  375.           END;
  376.  
  377.      3  :  BEGIN
  378.               FOR N := 1 TO ENTRY DO
  379.                 BEGIN
  380.                   XL := LN(X[N]);
  381.                   YL := Y[N];
  382.                   XX := XX + XL;
  383.                   YY := YY + YL;
  384.                   XY := XY + (XL * YL);
  385.                   XS := XS + SQR(XL);
  386.                   YS := YS + SQR(YL)
  387.               END;
  388.          {    debug;  }
  389.             M[3] := ((XY-(1/ENTRY)* XX * YY));
  390.             M[3] := M[3] / (XS-((1/ENTRY) * SQR(XX) ));
  391.             B[3] := (1/ENTRY) * (YY-(M[3] * XX));
  392.             C[3] := SQR(XY-((1/ENTRY) * XX * YY));
  393.             C[3] := C[3]/(XS-((1/ENTRY) * SQR(XX)));
  394.             C[3] := C[3]/(YS-((1/ENTRY) * SQR(YY)));
  395.             DISPLAY_CURVE(3);
  396.             WRITE(BELL)
  397.           END;
  398.  
  399.      4  :  BEGIN
  400.               FOR N := 1 TO ENTRY DO
  401.                 BEGIN
  402.                   XL := X[N];
  403.                   YL := LN(Y[N]);
  404.                   XX := XX + XL;
  405.                   YY := YY + YL;
  406.                   XY := XY + (XL * YL);
  407.                   XS := XS + SQR(XL);
  408.                   YS := YS + SQR(YL)
  409.               END;
  410.            {   debug;   }
  411.               M[4] := ((XY-((1/ENTRY) * XX * YY))/(XS-((1/ENTRY) * SQR(XX))));
  412.               B[4] := EXP((YY/ENTRY)-(M[4] * (XX/ENTRY)));
  413.               C[4] := SQR(XY-((1/ENTRY) * XX * YY));
  414.               C[4] := C[4]/(XS-(SQR(XX)/ENTRY));
  415.               C[4] := C[4]/(YS-(SQR(YY)/ENTRY));
  416.               DISPLAY_CURVE(4);
  417.             END;
  418.  
  419.      5 : BEGIN
  420.             FOR N := 1 TO 4 DO
  421.             COMPUTE(N);
  422.             if c[1] < c[2] then best := 2
  423.                 else best := 1;
  424.                    if c[3] < c[4] then best := 4
  425.                       else best := 3;
  426.                            writeln;
  427.                              compute(best);
  428.                              CLRSCR;
  429.                           display_curve(best);
  430.                  INVERSE; WRITE('     B E S T    F I T     '); NO_INVERSE;
  431.                  WRITELN;
  432.               WRITE(BELL);
  433.                  PAUSE
  434.              END;
  435.          END; {CASE}
  436. END; { procedure compute }
  437.  
  438. {$ISAMPLE.INC}
  439. {$ISAMPLE2.INC}
  440. {$IPRINTOUT.INC}
  441.  
  442. PROCEDURE MENU;
  443.     VAR CHOICE, FIT :  INTEGER;
  444.   BEGIN
  445.      CLRSCR;
  446.    WRITELN(' options:  '); WRITELN;
  447.      WRITELN('          (1) compute linear curve');
  448.      WRITELN('          (2) compute power curve');
  449.      WRITELN('          (3) compute logarithmic curve');
  450.      WRITELN('          (4) compute exponential curve');
  451.      WRITELN('          (5) compute & find the best fit');
  452.      WRITELN('          (6) LIST AND/OR EDIT DATA');
  453.      WRITELN('          (7) ENTER DATA TABLE FOR STANDARD CURVE');
  454.      WRITE('          (8)  '); INVERSE;
  455.      WRITE('  SAMPLES  '); NO_INVERSE;
  456.      WRITE('  FOR CALCULATIONS  '); WRITELN;
  457.      WRITELN('          (9) hardcopy of standard curve');
  458.      WRITELN('          (10)  load previous saved standard curve');
  459.      WRITELN('          (11)  exit to the system'); WRITELN;
  460.    INVERSE; WRITELN('  please make your selection:  '); NO_INVERSE;
  461.      READ(CHOICE);
  462.           CASE CHOICE OF
  463.           1 : BEGIN
  464.                  COMPUTE(1);
  465.                FLAG :=1
  466.              END;
  467.           2 : BEGIN
  468.                COMPUTE(2);
  469.              FLAG := 2
  470.             END;
  471.           3 : BEGIN
  472.                 COMPUTE(3);
  473.               FLAG := 3
  474.               END;
  475.           4 : BEGIN
  476.                 COMPUTE(4);
  477.               FLAG := 4
  478.                 END;
  479.           5 : COMPUTE(5);
  480.           6 : EDIT_LIST;
  481.           7 : DATA_ENTRY;
  482.           8 : SAMPLE_PREP(FIT);
  483.           9 : HARDCOPY;
  484.          10 : LOAD;
  485.          11 : HALT
  486.          END;  {CASE}
  487.        MENU
  488. END;
  489.  
  490. BEGIN
  491.  TITLE;
  492.  MENU
  493. END.
  494.  
  495.  
  496. 
  497.