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