home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 15 / graphen / pgraph.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-03-29  |  14.0 KB  |  427 lines
  1. unit PGRAPH;
  2. interface
  3. uses CRT,GRAPH;
  4. const
  5.   {$IFDEF CPU87} MaxInt=2147483647; {$ENDIF}
  6.   nmax=200;
  7. const
  8.   Black:byte=0;     Blue:byte=1;          Green:byte=2;       Cyan:byte=3;
  9.   Red:byte=4;       Magenta:byte=5;       Brown:byte=6;       LightGray:byte=7;
  10.   DarkGray:byte=8;  LightBlue:byte=9;     LightGreen:byte=10; LightCyan:byte=11;
  11.   LightRed:byte=12; LightMagenta:byte=13; Yellow:byte=14;     White:byte=15;
  12. type
  13.   {$IFDEF CPU87} real=extended; {$ELSE}
  14.   double=real; single=real; extended=real; comp=real; {$ENDIF}
  15.   GeraetTyp = (Bildschirm,Drucker,Plotter);
  16.   Vektor = array[1..nmax] of real;
  17.   strg80 = string[80];
  18. var
  19.   Geraet:GeraetTyp;                            { fuer AngleTrueScale }
  20.   GraphDriver,GraphMode,ErrorCode:integer;
  21.   OldExitProc:Pointer;
  22.   Xaxmin,Xaxmax,Yaxmin,Yaxmax:real;              { fuer USCALE }
  23.   Uaxmin,Uaxmax,Vaxmin,Vaxmax:integer;              { fuer Graphikwindow }
  24.  
  25.   procedure AngleTrueScale(var x1,x2,y1,y2:real);
  26.   procedure CloseGraphik;
  27.   procedure Curve(var x,y:Vektor; n,Lintyp,Thickness,Color:word);
  28.   procedure Curvex(var x,y:Vektor; n:word; Color:byte);
  29.   function  EXP10(x:real):real;
  30.   function  Exponent(x:real):integer;
  31.   procedure Extrema(z:Vektor; n:word; var zmin,zmax:real);
  32.   procedure GraphikText(Text:strg80; Font, Size, TxtCol, Line:byte);
  33.   procedure GraphikWindow(x1,x2,y1,y2:integer);
  34.   procedure LinaxScale(var a,b,dx,Ex:real; Density:byte; var ExpStrg:strg80);
  35.   function  LOG10(x:real):real;
  36.   procedure LogXAxis(LogX1,LogX2:real; XText:strg80; Font,Size:word);
  37.   procedure LogYAxis(LogY1,LogY2:real; YText:strg80; Font,Size:word);
  38.   procedure OpenGraphik;
  39.   function  RealToString(x:real):strg80;
  40.   procedure Scale(x,y:real; VAR u,v:integer);
  41.   procedure Uscale(var X1,X2,Y1,Y2:real; Origin,AngleTrue:boolean; Expans:real);
  42.   procedure XAxis(VAR x1,x2:real; XText:strg80; Font,Size:word;VAR dx : Real);
  43.                  { ^ Änderung  wie bei yaxis                    ^         }
  44.   procedure Xgrid(x:real);
  45.   procedure Xmark(x:real; var u:integer; Len:byte);
  46.   procedure YAxis(VAR y1,y2:real; YText:strg80; Font,Size:word; VAR dy : Real);
  47.   procedure Ymark(y:real; var v:integer; Len:byte);
  48.   procedure Ygrid(y:real);
  49.  
  50. implementation
  51.  
  52. procedure AngleTrueScale;                    { Winkeltreue Skalierung }
  53. var   C,dx,dy,xx,yy,xm,ym,F:real; Xasp,Yasp:word;
  54. begin
  55.   if Geraet=Bildschirm then begin                { Laenge/Breite-Faktor }
  56.     GetAspectRatio(Xasp,Yasp);
  57.     F:=(Xasp/Yasp)*(ABS(UaxMin-UaxMax)/ABS(VaxMin-VaxMax)); end
  58.   else begin
  59.     F:=(2/3)*(ABS(UaxMin-UaxMax)/ABS(VaxMin-VaxMax))
  60.   end;
  61.   dx:=ABS(x2-x1);
  62.   dy:=ABS(y2-y1);
  63.   if dx>=dy then begin
  64.     yy:=0.5*dx/F;    if y1>y2 then yy:=-yy;         { y-Achse strecken }
  65.     ym:=0.5*(y1+y2); y1:=ym-yy; y2:=ym+yy; end
  66.   else begin
  67.     xx:=0.5*dy*F;    if x1>x2 then xx:=-xx;        { x-Achse strecken }
  68.     xm:=0.5*(x1+x2); x1:=xm-xx; x2:=xm+xx;
  69.   end;
  70. end;
  71.  
  72. {$F+} procedure CloseGraphik;                    { Graphik beenden }
  73. begin
  74.   ExitProc:=OldExitProc;
  75.   SetBkColor(black);
  76.   CloseGraph;
  77.   DirectVideo:=true;
  78.   Window(1,1,80,25);
  79. end; {$F-}
  80.  
  81. procedure Curve;                        { Polygonzug }
  82. var i,u1,v1,u2,v2:integer;
  83. begin
  84.   SetLineStyle(Lintyp,0,Thickness); SetColor(Color);
  85.   Scale(x[1],y[1],u1,v1);
  86.   for i:=2 to n do begin
  87.     Scale(x[i],y[i],u2,v2); Line(u1,v1,u2,v2);
  88.     u1:=u2; v1:=v2;
  89.   end;
  90. end;
  91.  
  92. procedure Curvex;                    { Punkte auftragen }
  93. var i,u,v:integer;
  94. begin
  95.   for i:=1 to n do begin
  96.     Scale(x[i],y[i],u,v); PutPixel(u,v,Color);
  97.   end;
  98. end;
  99.  
  100. function EXP10;
  101. var S:string[80]; E:real; Code:word;
  102. begin
  103.   if x=INT(x) then begin                        { 10 hoch Integer }
  104.     STR(TRUNC(x),S);
  105.     VAL(('1.0E'+S),E,Code); EXP10:=E; Exit;
  106.   end;
  107.   EXP10:=EXP(x*LN(10));                       { 10 hoch Real }
  108. end;
  109.  
  110. function Exponent;                            { Groessenordnung }
  111. var EX,S:string[80]; n,code:integer;             {   einer Zahl    }
  112. begin
  113.   STR(x,S); EX:=COPY(S,POS('E',S)+1,Length(S));
  114.   VAL(EX,n,code); Exponent:=n;
  115. end;
  116.  
  117. procedure Extrema;                            { Maximum und Minimum }
  118. var i:word;                                { des Vektors z[1..n] }
  119. begin
  120.   zmin:=z[1]; zmax:=z[1];
  121.   for i:=2 to n do begin
  122.     if z[i]<zmin then zmin:=z[i];
  123.     if z[i]>zmax then zmax:=z[i];
  124.   end;
  125. end;
  126.  
  127. procedure GraphikText;                    { Textausgabe ins }
  128. var Xpos,Ypos:integer;                    {  Graphikfenster }
  129. begin
  130.   if (Font>4)  or (Font<0) then Font:=1;
  131.   if (Size>10) or (Size<1) then Size:=1;
  132.   if (Line>24) then Line:=24;                       { Zeile 1..24 }
  133.   if (Line<1)  then Line:=1;
  134.   if Font=2 then Size:=Size*2;
  135.   SetViewPort(0,0,GetMaxX,GetMaxY,ClipOn);
  136.   SetColor(TxtCol);
  137.   SetTextStyle(Font,HorizDir,Size);
  138.   SetTextJustify(CenterText,CenterText);              { Zentrieren }
  139.   Xpos:=SUCC(GetMaxX) div 2;
  140.   Ypos:=Line*(GetMaxY div 25);
  141.   OutTextXY(Xpos,Ypos,Text);
  142. end;
  143.  
  144. procedure GraphikWindow;                { Graphikfenster }
  145. var h:integer;
  146. begin
  147.   SetLineStyle(SolidLn,0,NormWidth); SetColor(White);
  148.   if x1>x2 then begin h:=x1; x1:=x2; x2:=h; end;
  149.   if y1>y2 then begin h:=y1; y1:=y2; y2:=h; end;
  150.  
  151.   RecTangle (x1,GetMaxY-y2,x2,GetMaxY-y1);              { Rahmen }
  152.   Uaxmin:=x1; Uaxmax:=x2; Vaxmin:=y1; Vaxmax:=y2;    { Fensterkoordinaten }
  153. end;
  154.  
  155. procedure LinaxScale;                    { Hilfsroutine fuer }
  156. var  x1,x2:real;                    {  Xaxis und Yaxis  }
  157. begin
  158.   if ABS(a)<ABS(b) then EX:=Exponent(b) else EX:=Exponent(a);
  159.   x1:=a; x2:=b; dx:=0.25*EXP10(Exponent(b-a));
  160.   ExpStrg:='0';
  161.   if ABS(Ex)>3 then begin                         { Exponent abtrennen }
  162.     a:=a*EXP10(-EX); b:=b*EXP10(-EX); dx:=dx*EXP10(-EX);
  163.     STR(EX:4:0,ExpStrg); while ExpStrg[1]=#32 do Delete(ExpStrg,1,1);
  164.   end;
  165.   while ((b-a)/dx)>=Density do dx:=2*dx;        { Skalendichte }
  166.   if b<a then dx:=-dx;
  167.   if a=b then begin a:=a-dx; b:=b+dx; end;
  168.   a:=dx*ROUND(a/dx);                               { Guenstig runden }
  169.   b:=dx*ROUND(b/dx);
  170.   if a<b then begin
  171.     if a<x1 then a:=a+dx; if b>x2 then b:=b-dx; end
  172.   else begin
  173.     if a>x1 then a:=a-dx; if b<x2 then b:=b+dx;
  174.   end;
  175. end;
  176.  
  177. function LOG10;                            { dekad. Logarithmus }
  178. begin
  179.   if x<>0 then LOG10:=LN(ABS(x))/LN(10.0) else LOG10:=0;
  180. end;
  181.  
  182. procedure LogXAxis;                            { Log. x-Achse }
  183. const Density=10;                            { Skalendichte }
  184. var dn,n1,n2,n,k,u,v:integer; x:real; S:string[6];
  185. begin
  186.   Line(Uaxmin,GetMaxY-Vaxmin,Uaxmax,GetMaxY-Vaxmin);
  187.   u:=(Uaxmax+Uaxmin) div 2;
  188.   v:=GetMaxY-(Vaxmin-3*TextHeight(XText));
  189.   SetTextStyle(Font,HorizDir,Size);
  190.   SetTextJustify(CenterText,CenterText);
  191.   OutTextXY(u,v,XText);                           { Achsenbeschriftung }
  192.   n1:=TRUNC(LogX1); n2:=TRUNC(LogX2);
  193.   if n1>n2 then begin k:=n1; n1:=n2; n2:=k; end;
  194.   dn:=1; while (n2-n1) div dn>=Density do dn:=Density*dn;
  195.   if dn=1 then begin                              { Log-Skala }
  196.     for n:=n1-1 to n2+1 do
  197.     for k:=2 to 9 do begin x:=n+LOG10(k); Xmark(x,u,3); end;
  198.   end;
  199.   for n:=n1 to n2 do begin
  200.    if (dn<>1) and ((n mod (dn div 10))=0) then Xmark(n,u,3);
  201.    if (n mod dn)=0 then begin
  202.     Xmark(n,u,4);
  203.     STR(n,S);
  204.     OutTextXY(u+TextWidth(S)*4 div 5,GetMaxY-Vaxmin+(TextHeight('0') div 2),S);
  205.     OutTextXY(u-TextWidth('0') div 2,GetMaxY-Vaxmin+TextHeight('0'),'10');
  206.    end;
  207.   end;
  208. end;
  209.  
  210. procedure LogYAxis;                            { log. y-Achse }
  211. const Density=10;                            { Skalendichte }
  212. var dn,n1,n2,n,k,u,v:integer; y:real; S:string[6];
  213. begin
  214.   Line(Uaxmin,GetMaxY-Vaxmin,Uaxmin,GetMaxY-Vaxmax);
  215.   u:=Uaxmin-3*TextHeight(YText);
  216.   v:=(Vaxmax-Vaxmin) div 2;
  217.   SetTextStyle(Font,VertDir,Size);
  218.   SetTextJustify(CenterText,CenterText);
  219.   OutTextXY(u,v,YText);                          { Achsenbeschriftung }
  220.   n1:=TRUNC(LogY1); n2:=TRUNC(LogY2);
  221.   if n1>n2 then begin k:=n1; n1:=n2; n2:=k; end;
  222.   dn:=1; while (n2-n1) div dn>=Density do dn:=Density*dn;
  223.   if dn=1 then begin                               { Log-Skala }
  224.     for n:=n1-1 to n2+1 do
  225.     for k:=2 to 9 do begin y:=n+LOG10(k); Ymark(y,v,3); end;
  226.   end;
  227.   for n:=n1 to n2 do begin
  228.     if (dn<>1) and ((n mod (dn div 10))=0) then Ymark(n,u,3);
  229.     if (n mod dn)=0 then begin
  230.       Ymark(n,v,4);
  231.       STR(n,S);
  232.       OutTextXY(Uaxmin-TextHeight('0'),v-TextWidth(S)*3 div 4,S);
  233.       OutTextXY(Uaxmin-TextHeight('0') div 2,v+TextWidth('0') div 2,'10');
  234.     end;
  235.   end;
  236. end;
  237.  
  238. procedure OpenGraphik;                        { Graphik starten }
  239. begin
  240.   DirectVideo:=false;                            { Graphik- und Textmode }
  241.   OldExitProc:=ExitProc; ExitProc:=ADDR(CloseGraphik);
  242.   GraphDriver:=Detect;
  243.   InitGraph(GraphDriver,GraphMode,'c:\pascal\turbo4\grafik');
  244.   ErrorCode:=GraphResult;
  245.   if ErrorCode<>grOk then begin
  246.     WriteLn('Graphics error: ',GraphErrorMsg(ErrorCode)); ReadLn;
  247.     Halt(1);
  248.   end;
  249.   if GraphDriver=7 then begin
  250.     Black:=0;     Blue:=15;         Green:=15;      Cyan:=15;
  251.     Red:=15;      Magenta:=15;      Brown:=15;      LightGray:=15;
  252.     DarkGray:=15; LightBlue:=15;    LightGreen:=15; LightCyan:=15;
  253.     LightRed:=15; LightMagenta:=15; Yellow:=15;     White:=15;
  254.   end;
  255.   if Geraet in [Bildschirm,Drucker,Plotter] then else Geraet:=Drucker;
  256.   Uaxmin:=0; Uaxmax:=GetMaxX; Vaxmin:=0; Vaxmax:=GetMaxY;
  257. end;
  258.  
  259. function RealToString;                    { Reelle Zahl in    }
  260. var S:strg80; Code:word;                { handlichen String }
  261. begin
  262.   STR(x:16:10,S);
  263.   while s[1]=#32 do Delete(S,1,1);
  264.   while S[Length(s)]='0' do begin Delete(S,Length(S),1); end;
  265.   if POS('.',S)=Length(S) then Delete(S,Length(S),1);
  266.   VAL(S,x,Code); if x=0 then S:='0';
  267.   RealToString:=S;
  268. end;
  269.  
  270. procedure Scale;    { vermutlich Umrechnung der x/y-Werte in Punkte }
  271.                         { bei Absoluter Scalierung                      }
  272. begin
  273.   u:= Uaxmin+ROUND((x-Xaxmin)/(Xaxmax-Xaxmin)*(Uaxmax-Uaxmin));
  274.   v:=GetMaxY-ROUND((y-Yaxmin)/(Yaxmax-Yaxmin)*(Vaxmax-Vaxmin))-Vaxmin;
  275. end;
  276.  
  277. procedure Uscale;                    { Benutzer- }
  278. var xx,yy:real;                        { koordinatensystem }
  279. const Tol = 0.01;
  280. begin
  281.   Expans:=ABS(Expans);
  282.   xx:=ABS(x2-x1)*0.005*Expans; if x1>x2 then xx:=-xx;    { 1. Ausweiten }
  283.   X1:=X1-xx; X2:=X2+xx;
  284.  
  285.   if ABS(x2-x1)<1E-8 then
  286.   begin x1:=x1*(1-0.01*Expans); x2:=x2*(1+0.01*Expans); end;
  287.  
  288.   yy:=ABS(y2-y1)*0.005*Expans; if y1>y2 then yy:=-yy;
  289.   y1:=y1-yy; y2:=y2+yy;
  290.  
  291.   if ABS(y2-y1)<1E-8 then
  292.   begin y1:=y1*(1-0.01*Expans); y2:=y2*(1+0.01*Expans); end;
  293.  
  294.   if Origin then begin                                 { 2. Ursprung }
  295.     if X1<=X2 then begin
  296.       if X2<0 then X2:=0;
  297.       if X1>0 then X1:=0; end
  298.     else begin
  299.       if X2>0 then X2:=0;
  300.       if X1<0 then X1:=0;
  301.     end;
  302.     if Y1<=Y2 then begin
  303.       if Y2<0 then Y2:=0;
  304.       if Y1>0 then Y1:=0; end
  305.     else begin
  306.       if Y2>0 then Y2:=0;
  307.       if Y1<0 then Y1:=0;
  308.     end;
  309.   end;
  310.  
  311.   if AngleTrue then AngleTrueScale(X1,X2,Y1,Y2);    { 3. Winkeltreue }
  312.   if ABS((X2-X1)/X2)<Tol then begin               { 4. Minimalausdehnung }
  313.     if X1<X2 then
  314.     begin X1:=X1*(1-Tol); X2:=X2*(1+Tol); end
  315.     else begin X2:=X2*(1-Tol); X1:=X1*(1+Tol); end;
  316.   end;
  317.  
  318.   if ABS((Y2-Y1)/Y2)<Tol then begin
  319.     if Y1<Y2 then
  320.     begin Y1:=Y1*(1-Tol); Y2:=Y2*(1+Tol); end
  321.     else begin Y2:=Y2*(1-Tol); Y1:=Y1*(1+Tol); end;
  322.   end;
  323.  
  324.   Xaxmin:=X1; Xaxmax:=X2;
  325.   Yaxmin:=Y1; Yaxmax:=Y2;
  326. end;
  327.  
  328. procedure XAxis;                    { lineare x-Achse }
  329. var   Xpos,Ypos:integer;
  330.       Ex,U,V,a,b,x,h:real; E,S:strg80;
  331. const Density=6;                                { Skalendichte }
  332. begin
  333.   Line(Uaxmin,GetMaxY-Vaxmin,Uaxmax,GetMaxY-Vaxmin);
  334.   Xpos:=(Uaxmax+Uaxmin) div 2;
  335.   Ypos:=GetMaxY-(Vaxmin-3*TextHeight(XText));
  336.   a:=x1; b:=x2; if a>b then begin h:=b; b:=a; a:=b; end;
  337.   LinaxScale (x1,x2,dx,Ex,Density,E);
  338.   if x1>x2 then begin h:=x1; x1:=x2; x2:=h; dx:=ABS(dx); end;
  339.   SetTextStyle(Font,HorizDir,Size);
  340.   SetTextJustify(CenterText,CenterText);
  341.   if E='0' then                                     { Achsenbeschriftung }
  342.     OutTextXY(Xpos,Ypos,XText)
  343.   else begin
  344.     U:=Xaxmin; V:=XaxMax;
  345.     OutTextXY(Xpos,Ypos,XText+' *E'+E);
  346.     a:=a*EXP10(-Ex); b:=b*EXP10(-Ex); Xaxmin:=a; Xaxmax:=b;
  347.   end;
  348.   x:=x1;                                         { lineare Skala }
  349.   Xmark (x-dx/2,xpos,3);
  350.   repeat
  351.     Xmark(x+dx/2,xpos,3);
  352.     Xmark(x,xpos,3);
  353.     S:=RealToString(x);
  354.     Line(Xpos,GetMaxY-Vaxmin,Xpos,GetMaxY-Vaxmin-3);
  355.     if Length(S)<6 then OutTextXY(Xpos,GetMaxY-Vaxmin+TextHeight('0'),S);
  356.     x:=x+dx;
  357.   until (x>=b) or (x<=a);
  358.   if E<>'0' then begin Xaxmin:=U; XaxMax:=V; end;
  359.   dx := dx/2; { ÄNDERUNG }
  360. end;
  361.  
  362. procedure Xgrid;                    { Parallele zur }
  363. var u,v:integer;                    {    x-Achse    }
  364. begin
  365.   Scale(x,0,u,v);
  366.   if u>Uaxmin then Line(u,GetMaxY-Vaxmin,u,GetMaxY-Vaxmax);
  367. end;
  368.  
  369. procedure Xmark;                                  {  x-Achsenmarken:   }
  370. var v:integer;                                       { Hilfsroutine fuer  }
  371. begin                             { Xaxis und LogXAxis }
  372.   Scale(x,Yaxmin,u,v);
  373.   if (u>=UaxMin) and (u<=UaxMax) then
  374.   Line(u,GetMaxY-Vaxmin,u,GetMaxY-Vaxmin-Len);
  375. end;
  376.  
  377. procedure YAxis;                    { lineare y-Achse }
  378. var   Xpos,Ypos:integer;
  379.       Ex,U,V,a,b,y,h:real; E,S:strg80;
  380. const Density=8;                                     { Skalendichte }
  381. begin
  382.   Line(Uaxmin,GetMaxY-Vaxmin,Uaxmin,GetMaxY-Vaxmax);
  383.   Xpos:=Uaxmin-3*TextHeight(YText);
  384.   Ypos:=(Vaxmax-Vaxmin) div 2;
  385.   a:=y1; b:=y2; if a>b then begin h:=b; b:=a; a:=b; end;
  386.   LinaxScale(y1,y2,dy,Ex,Density,E);
  387.   if y1>y2 then begin h:=y1; y1:=y2; y2:=h; dy:=ABS(dy); end;
  388.   SetTextStyle(Font,VertDir,Size);
  389.   SetTextJustify(CenterText,CenterText);
  390.   if E='0' then                                     { Achsenbeschriftung }
  391.     OutTextXY(Xpos,Ypos,YText)
  392.   else begin
  393.     U:=Yaxmin; V:=YaxMax;
  394.     OutTextXY(Xpos,Ypos,YText+' *E'+E);
  395.     a:=a*EXP10(-Ex); b:=b*EXP10(-Ex); Yaxmin:=a; Yaxmax:=b;
  396.   end;
  397.   y:=y1;                              { lineare Skala }
  398.   Ymark(y-dy/2,ypos,3);
  399.   repeat
  400.     Ymark(y+dy/2,ypos,3);
  401.     S:=RealToString(y);
  402.     Ymark(y,ypos,3);
  403.     if Length(S)<6 then OutTextXY(Uaxmin-TextHeight('0'),Ypos,S);
  404.     y:=y+dy;
  405.   until (y>=b) or (y<=a);
  406.   if E<>'0' then begin Yaxmin:=U; YaxMax:=V; end;
  407.   dy := dy/2; { ÄNDERUNG }
  408. end;
  409.  
  410. procedure Ygrid;                    { Parallele zur }
  411. var u,v:integer;                    {    y-Achse    }
  412. begin
  413.   Scale(0,y,u,v);
  414.   if v<GetMaxY-Vaxmin then Line(Uaxmin,v,Uaxmax,v);
  415. end;
  416.  
  417. procedure Ymark;                    {  y-Achsenmarken:   }
  418. var u:integer;                        { Hilfsroutine fuer  }
  419. begin                            { Yaxis und LogYAxis }
  420.   Scale(Xaxmin,y,u,v);
  421.   if (v<GetMaxY-Vaxmin) and (v>GetMaxY-Vaxmax) then
  422.   Line(Uaxmin,v,Uaxmin+Len,v);
  423. end;
  424.  
  425. end.
  426.  
  427.