home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / Analysator / AnaII.p < prev    next >
Encoding:
Text File  |  1994-07-26  |  11.0 KB  |  431 lines
  1. PROGRAM AnalysatorII;
  2. {
  3.     Dies ist ein kleines, harmloses Analysisprogramm, das z. B. Funktionen
  4.     differenzieren und plotten kann. Geschrieben wurde es mal von Jens Gelhar
  5.     im Jahre 1990 (au Mann, ist das lange her!), und 1994 wurde es ordentlich
  6.     an MaxonPascal III angepaßt.
  7.  
  8.     Alles weitere steht im Handbuch.
  9. }
  10.  
  11. USES Intuition, Graphics;
  12.  
  13. {$incl "ana.h" }
  14.  
  15. {$opt b- }
  16.  
  17. LABEL    99,Loop;
  18.  
  19. CONST    CrsrUp        = chr($0b);
  20.         CR                = chr($0d);
  21.         CSI            = chr($9b);
  22.         CrsrDown        = LF;
  23.         CrsrLeft        = chr($81);
  24.         CrsrRight    = chr($82);
  25.  
  26.         Unsichtbar    = #e'0 p';
  27.         Sichtbar        = #e' p';
  28.  
  29. VAR    f:                ARRAY['f'..'h',0..99] OF p; IMPORT;
  30.         x,y:            atyp;
  31.         hi,lo,step:    atyp;
  32.         v:                ARRAY['a'..'d',0..99] OF atyp; IMPORT;
  33.         c1:            char;
  34.         c:                char;            IMPORT;
  35.         i:                integer;
  36.         fx:            p;
  37.         prt:            Boolean;         IMPORT;
  38.         b, prev:        Boolean;
  39.         everr:        Boolean;         IMPORT;
  40.         pr:         FILE OF char;    EXPORT;
  41.         filename:   String[50];
  42.         win:        ^Window;
  43.         Ein:        Buffer;          EXPORT;
  44.         Rast:       Ptr;
  45.         Con:        Ptr;             IMPORT;
  46.         breit,hoch: integer;
  47.         MinX,MaxX,MinY,MaxY: atyp;
  48.         History:    String[histlen]; IMPORT;
  49.         histptr:    integer;         IMPORT;
  50.         vertag:        Str;
  51.         err:            Boolean;
  52.  
  53. PROCEDURE CalcSize;
  54.   { Fenstergröße ermitteln und in "breit" und "hoch" ablegen }
  55.   BEGIN
  56.     WITH win^ DO
  57.       BEGIN breit := width-28; hoch := height-30 END;
  58.   END;
  59.  
  60.  
  61. PROCEDURE KoordSyst;
  62.   { lösche Bildschirm und zeichne Koordinatensystem }
  63.   VAR x, y, x0, y0, xs, ys: integer;
  64.       xf, yf, xt, yt: atyp;
  65.       i: integer;
  66.       s: String;
  67.       er: LongInt;
  68.  
  69.   FUNCTION Log10(x:atyp): atyp;
  70.     BEGIN Log10 := ln(x)/ln(10) END;
  71.  
  72.   FUNCTION Skalierung(range: atyp; dots:integer):atyp;
  73.     VAR r,s,t: atyp;
  74.     BEGIN
  75.       r := range * 30 / dots;  { Anzahl Einheiten auf 30 Bildpunkten }
  76.       s := Log10(r);
  77.       IF s >= 0 THEN t:=  Frac(s)
  78.                 ELSE t:=1-Frac(s);
  79.       IF t < 0.3 THEN Skalierung := 5*DbPwr10(Trunc(s))
  80.                  ELSE Skalierung :=   DbPwr10(Trunc(s))
  81.     END;
  82.  
  83.   BEGIN
  84.     CalcSize;
  85.     FOR i:=0 TO hoch div 8 DO writeC(LF);
  86.     writeC( CrsrUp );
  87.     writeC( Unsichtbar );
  88.     xf := breit/(MaxX-MinX);
  89.     yf := hoch/(MaxY-MinY);
  90.     SetAPen(Rast,1);
  91.     y0 := Round (hoch*MaxY/(MaxY-MinY));
  92.     IF MaxY < 0 THEN ys := 2
  93.     ELSE
  94.     IF MinY > 0 THEN ys := hoch-2;
  95.       BEGIN
  96.         ys := y0;
  97.         Move (Rast,0,y0);
  98.         Draw(Rast,breit-1,y0)
  99.       END;
  100.     x0 := Round (-breit*MinX/(MaxX-MinX));
  101.     IF MaxX < 0 THEN xs := breit-3
  102.     ELSE
  103.     IF MinX > 0 THEN xs := 3
  104.     ELSE
  105.       BEGIN
  106.         xs := x0;
  107.         Move (Rast,x0,0);
  108.         Draw (Rast,x0,hoch-1)
  109.       END;
  110.     xt := Skalierung(MaxX-MinX, breit);
  111.     FOR i:=Round(MinX/xt) TO Round(MaxX/xt) DO
  112.       BEGIN
  113.         x := x0+Round(xf*i*xt);
  114.         Move (Rast, x, ys-2 );
  115.         Draw (Rast, x, ys+2 );
  116.         s := RealStr(i*xt,0);
  117.         IF s[1]=' ' THEN
  118.           Delete(s,1,1);
  119.         IF ys+12 < hoch THEN
  120.           Move (Rast, x-4*Length(s), ys+12)
  121.         ELSE
  122.           Move (Rast, x-4*Length(s), ys-4);
  123.         IF i<>0 THEN
  124.           er :=_Text (Rast, s, Length(s))
  125.       END;
  126.     yt := Skalierung(MaxY-MinY, hoch*2);
  127.     FOR i:=Round(MinY/yt) TO ROUND(MaxY/yt) DO
  128.       BEGIN
  129.         y := y0-round(yf*i*yt);
  130.         Move (Rast, xs-3, y);
  131.         Draw (Rast, xs+3, y);
  132.         s := RealStr(i*yt,0);
  133.         IF s[1]=' ' THEN
  134.           Delete(s,1,1);
  135.         IF xs > 4+8*Length(s) THEN
  136.           Move (Rast, xs-4-8*Length(s), y+4)
  137.         ELSE
  138.           Move (Rast, xs+6, y+4);
  139.         IF i<>0 THEN
  140.           er := _Text (Rast, s, Length(s))
  141.       END;
  142.     writeC( Sichtbar )
  143.   END;
  144.  
  145.  
  146. PROCEDURE Graph(fx: p);
  147.   VAR x, y, xfact, yfact: atyp;
  148.       x0, y0, xs, ys: integer;
  149.   BEGIN
  150.     xfact := breit/(MaxX-MinX);
  151.     yfact := hoch/(MaxY-MinY);
  152.     SetAPen(Rast, 2);
  153.     writeC( Unsichtbar );
  154.     y0 := Round (hoch*MaxY/(MaxY-MinY));
  155.     x0 := Round (-breit*MinX/(MaxX-MinX));
  156.     x := MinX;
  157.     step := 0.5*(MaxX-MinX)/breit;
  158.     prev := false;
  159.     WHILE ReadCon(Con) <> '' DO;
  160.     REPEAT
  161.       everr := false;
  162.       y := eval(fx,x);
  163.       IF everr or (y>MaxY) or (y<MinY) THEN
  164.         prev := false
  165.       ELSE
  166.         BEGIN
  167.           xs := x0 + round( xfact*x );
  168.           ys := y0 - round( yfact*y );
  169.           IF not prev THEN move(Rast,xs,ys);
  170.           draw(Rast,xs,ys);
  171.           prev := true;
  172.         END;
  173.       x := x+step
  174.     UNTIL (x>=MaxX) or (ReadCon(Con)<>chr(0));
  175.     writeC( Sichtbar )
  176.   END;
  177.  
  178. PROCEDURE SynErr;
  179.   BEGIN
  180.     writeC(#10'???');
  181.     GOTO 99
  182.   END;
  183.  
  184.  
  185. BEGIN  { Hauptprogramm }
  186.     vertag := "Analysator 2.10 (25.07.94)";
  187.  
  188.     x := 0+0; { Öffnet mathieeedoubbas.library }
  189.     InitAnalysis;
  190.     breit := 640;
  191.     hoch := 255;
  192.     err := WBenchToFront;
  193.     win := Open_Window (0, 0, 640, 255, 1, _CLOSEWINDOW,
  194.           GIMMEZEROZERO+ACTIVATE+WINDOWSIZING+WINDOWDRAG+WINDOWDEPTH,
  195.           'Analysator II', Nil, breit shr 1, hoch shr 1, breit, hoch);
  196.     con := OpenConsole(win);
  197.     WriteC( #10#e'1m                                 Analysator'\10\10\e'0m'\&
  198.                   '                          Version 2.10 vom 26.07.94'\10\10\&
  199.                   'Geschrieben von '#e'1;32mJens Gelhar'#e'0;31m mit MaxonPascal III - (c) Himpelsoft 1990-94.'\10\10);
  200.     Rast := win^.RPort;
  201.     FOR i:=0 TO 99 DO
  202.      BEGIN
  203.         FOR c:='f' TO 'h' DO f[c,i]:=Nil;
  204.         FOR c:='a' TO 'd' DO v[c,i]:=0
  205.      End;
  206.     MinX := -10;
  207.     MaxX := +10;
  208.     MinY := -5;
  209.     MaxY := +5;
  210.     filename := 'prt:';
  211.     prt:=false;
  212.     HistPtr := 0;
  213.  
  214.     REPEAT
  215.         loop:
  216.         writeC(#10'--> ');
  217.         ReadEin(Ein);
  218.         IF Ein.s <> '' THEN ToHistory(Ein.s);
  219.         getc;
  220.         if c<' ' then goto loop;
  221.  
  222.         CASE c OF
  223.         'a','b','c','d':
  224.             BEGIN
  225.               c1:=c; getc; i:=Getnum(Ein,c);
  226.               IF c<>'=' THEN SynErr;
  227.               Inp(ein,fx);
  228.               IF fx<>NIL THEN
  229.                 BEGIN
  230.                   IF konstant(fx) THEN
  231.                     BEGIN
  232.                       y:=eval(fx,0);
  233.                       IF everr THEN writeln('Error!')
  234.                       ELSE
  235.                         BEGIN
  236.                           v[c1,i]:=y;
  237.                           writeR(y,0)
  238.                         END
  239.                     END
  240.                   ELSE writeC('Variables must be constant expressions.'\n);
  241.                   forget(fx)
  242.                 END
  243.             END
  244.  
  245.         'f','g','h':
  246.             BEGIN
  247.               c1:=c; getc; i:=Getnum(Ein,c);
  248.               IF c<>'=' THEN SynErr;
  249.               Inp(ein,fx);
  250.               IF fx<>NIL THEN
  251.                 BEGIN
  252.                   Forget(f[c1,i]); f[c1,i]:=fx;
  253.                   Infix(fx,0);
  254.                 END
  255.             END
  256.  
  257.         '?': BEGIN
  258.                 getc;
  259.                 IF c<' ' THEN
  260.                     BEGIN                        { Hilfsfunktion }
  261.                         WriteC('Commands:'\n);
  262.                         WriteC('<var>=<expr>  Assign to a variable'\n);
  263.                         WriteC('<fun>=<expr>  Define a function'\n);
  264.                         WriteC('? <expr>      Print function or expression'\n);
  265.                         WriteC('t <expr>      Print table of function values'\n);
  266.                         WriteC('l+            Copy output to printer or file'\n);
  267.                         WriteC('l-            Cancel "l+"'\n);
  268.                         WriteC('l=<name>      Set output filename'\n);
  269.                         WriteC('p <expr>      Plot function'\n);
  270.                         WriteC('r             Set range for plot'\n);
  271.                         WriteC('q             Quit Analysator'\n);
  272.                     END
  273.                 ELSE
  274.                     BEGIN
  275.                         Ein.p:=Ein.p-1;    { gelesenes Zeichen zurückstellen }                
  276.                       Inp(ein,fx);
  277.                       If fx<>Nil Then
  278.                         IF konstant(fx) THEN
  279.                           BEGIN
  280.                             everr:=false;
  281.                             y:=eval(fx,0);
  282.                             IF everr THEN writeC('Error'\n)
  283.                             ELSE
  284.                               BEGIN
  285.                                 writeR(y,0);
  286.                                 IF prt THEN writeln(pr,y)
  287.                               END
  288.                           END
  289.                         ELSE
  290.                           BEGIN
  291.                             Infix(fx,0);
  292.                             IF prt THEN writeln(pr);
  293.                           END;
  294.                       Forget(fx);
  295.                     END
  296.                 END
  297.  
  298.         't':  BEGIN
  299.               Inp(ein,fx);
  300.               IF fx<>NIL Then
  301.                 Begin
  302.                   writeC('Wertetabelle von ');
  303.                   IF prt THEN write(pr,'f(x) = ');
  304.                   Infix(fx,0);
  305.                   IF prt THEN writeln(pr,LF);
  306.                   writeC(#n'untere Grenze: ');readkonst(lo,b);
  307.                   if b then goto loop;
  308.                   writeC('obere Grenze:  ');readkonst(hi,b);
  309.                   if b then goto loop;
  310.                   REPEAT
  311.                     writeC('Schrittweite:  ');readkonst(step,b);
  312.                     if b or (step=0) then goto loop;
  313.                     IF abs(hi-lo)/abs(step)>=1e4 THEN
  314.                       writeC('So viel Zeit hast Du bestimmt nicht.'\n)
  315.                   UNTIL abs(hi-lo)/abs(step)<1e4;
  316.                   i:=0;
  317.                   x:=lo;
  318.                   writeP('          x           |        f(x)    '\n\&
  319.                          '----------------------|--------------------'\n);
  320.                   IF sgn(hi-lo)=sgn(step) THEN
  321.                   Repeat
  322.                     everr:=false;
  323.                     y:=eval(fx,x);
  324.                     IF everr THEN
  325.                       BEGIN
  326.                         WriteRF(x,20,0);
  327.                         writeC('  |  ?'\n);
  328.                         IF prt THEN writeln(pr,x:20,'  |  ?')
  329.                       END
  330.                     ELSE
  331.                       BEGIN
  332.                         WriteRF(x,20,0);
  333.                         writeC('  | ');
  334.                         WriteR(eval(fx,x),0);
  335.                         WriteC(LF);
  336.                         IF prt THEN writeln(pr,x:20,'  | ',eval(fx,x))
  337.                       END;
  338.                     i:=i+1;
  339.                     x:=lo+i*step
  340.                   Until sgn(step)*(x-hi)>1e-5*abs(step);
  341.                   Forget(fx);
  342.                End
  343.             END;
  344.  
  345.         'l':  BEGIN
  346.               getc;
  347.               CASE c OF
  348.                 '+':IF Not prt THEN
  349.                       BEGIN
  350.                         rewrite(pr,filename);
  351.                         IF IoResult<>0 THEN
  352.                           writeC('File Error!'\n)
  353.                         ELSE
  354.                           prt:=true
  355.                       END;
  356.                 '-':IF prt THEN
  357.                       BEGIN
  358.                         close (pr);
  359.                         prt := false
  360.                       END;
  361.                 '=':BEGIN
  362.                       readln(filename);
  363.                       IF prt THEN
  364.                         BEGIN
  365.                           close (pr);
  366.                           rewrite(pr,filename);
  367.                           IF IoResult<>0 THEN writeC(#10'File Error!'\10)
  368.                         END
  369.                     END
  370.               OTHERWISE writeC(#10'?'\10)
  371.               End
  372.             END;
  373.  
  374.         'r': BEGIN
  375.              WriteC('MinX: '); readkonst(MinX,b);
  376.                IF b THEN
  377.                  BEGIN
  378.                    MinX:=MaxX-2*abs(MaxX)-1;
  379.                    GOTO Loop
  380.                  END;
  381.              WriteC('MaxX: '); readkonst(MaxX,b);
  382.                IF b or (MaxX <= MinX) THEN
  383.                  BEGIN
  384.                    IF not b THEN writeC('MinX>=MaxX !!!'\n);
  385.                    MaxX:=MinX+2*abs(MinX)+1;
  386.                    GOTO Loop
  387.                  END;
  388.              WriteC('MinY: '); readkonst(MinY,b);
  389.                IF b THEN
  390.                  BEGIN
  391.                    MinY := MaxY-2*abs(MaxY)-1;
  392.                    GOTO Loop
  393.                  END;
  394.              WriteC('MaxY: '); readkonst(MaxY,b);
  395.                IF b or (MaxY <= MinY) THEN
  396.                  BEGIN
  397.                    IF not b THEN writeC('MinY>=MaxY !!!'\n);
  398.                    MaxY:=MinY+2*abs(MinY)+1;
  399.                    GOTO Loop
  400.                  END;
  401.            END;
  402.  
  403.         'p': BEGIN
  404.              Inp (Ein,fx);
  405.              IF fx=Nil THEN GOTO Loop;
  406.              KoordSyst;
  407.              Graph (fx);
  408.              Forget (fx);
  409.              WHILE Ein.s[Ein.p-1]=',' DO
  410.                BEGIN
  411.                  Inp(Ein,fx);
  412.                  IF fx=Nil THEN GOTO Loop;
  413.                  Graph (fx);
  414.                  Forget(fx)
  415.                END;
  416.            END;
  417.  
  418.         'q':  writeC('See you later, Aligator!')
  419.         OTHERWISE
  420.         SynErr
  421.         END;
  422.         99:
  423.     UNTIL c='q';
  424.  
  425.     FOR i:=0 TO 99 DO
  426.         FOR c:='f' TO 'h' DO
  427.             Forget(f[c,i]);
  428.     IF prt THEN close(pr);
  429. END
  430.  
  431.