home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 09 / 2d / plgraph.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1989-05-01  |  13.1 KB  |  403 lines
  1. UNIT PLGRAPH;
  2. (* Umsetzung der UNIT PGraph aus TOOLBOX 12/88 für Plotter mit HPGL *)
  3. (* es wurde auf eine größtmögliche Befehlsgleichheit geachtet *)
  4. (* erfordert die UNIT HPGL *)
  5. (* Compiler : Turbo-Pascal 5.0
  6.    Pgm.Vers.: 1.0.f
  7.    Stand    : 01.05.89         *)
  8.  
  9. INTERFACE
  10.  
  11. USES HPGL;
  12.  
  13. CONST
  14.   {$IFDEF CPU87} MaxInt=2147483647; {$ENDIF}
  15.   nmax=200;
  16. type
  17.   {$IFDEF CPU87} real=extended; {$ELSE}
  18.   double=real; single=real; extended=real; comp=real; {$ENDIF}
  19.   Vektor = array[1..nmax] of real;
  20. (*-----------------------------------------------*)
  21.   PROCEDURE AngleTrueScale(VAR x1,x2,y1,y2:real);
  22.   PROCEDURE Curve(VAR x,y:Vektor; n,Lintyp,Thickness,Color:word);
  23.   PROCEDURE Curvex(VAR x,y:Vektor; n:word; Color:byte);
  24.   FUNCTION EXP10(x:real):real;
  25.   FUNCTION Exponent(x:real):integer;
  26.   PROCEDURE Extrema(z:Vektor; n:word; VAR zmin,zmax:real);
  27.   PROCEDURE GraphikWindow(x1,x2,y1,y2:integer);
  28.   PROCEDURE LinaxScale(VAR a,b,dx,Ex:real; Density:byte; VAR ExpStrg:strg80);
  29.   FUNCTION LOG10(x:real):real;
  30.   PROCEDURE LogXAxis(LogX1,LogX2:real; XText:strg80; Font,Size:word);
  31.   PROCEDURE LogYAxis(LogY1,LogY2:real; YText:strg80; Font,Size:word);
  32.   FUNCTION RealToString(x:real):strg80;
  33.   PROCEDURE Scale(x,y:real; VAR u,v:integer);
  34.   PROCEDURE Uscale(VAR X1,X2,Y1,Y2:real; Origin,AngleTrue:boolean; Expans:real);
  35.   PROCEDURE XAxis(x1,x2:real; XText:strg80; Font,Size:word);
  36.   PROCEDURE Xgrid(x:real);
  37.   PROCEDURE Xmark(x:real; VAR u:integer; Len:byte);
  38.   PROCEDURE YAxis(y1,y2:real; YText:strg80; Font,Size:word);
  39.   PROCEDURE Ymark(y:real; VAR v:integer; Len:byte);
  40.   PROCEDURE Ygrid(y:real);
  41. IMPLEMENTATION
  42. (*----------------------------------------------------*)
  43. (*----------------------------------------------------*)
  44. PROCEDURE AngleTrueScale(VAR x1,x2,y1,y2:real);
  45. { Winkeltreue Skalierung }
  46. VAR   C,dx,dy,xx,yy,xm,ym,F:real; Xasp,Yasp:word;
  47. BEGIN
  48.   F:= (ABS(UaxMin-UaxMax)/ABS(VaxMin-VaxMax));
  49.   dx:=ABS(x2-x1);
  50.   dy:=ABS(y2-y1);
  51.  
  52.   if dx> dy then BEGIN
  53.     yy:=0.5*dx/F;    if y1>y2 then yy:=-yy;     { y-Achse strecken }
  54.     ym:=0.5*(y1+y2); y1:=ym-yy; y2:=ym+yy;
  55.     END
  56.   else BEGIN
  57.     xx:=0.5*dy*F;    if x1>x2 then xx:=-xx;    { x-Achse strecken }
  58.     xm:=0.5*(x1+x2); x1:=xm-xx; x2:=xm+xx;
  59.   END;
  60. END;
  61. (*-----------------------------------------------*)
  62. PROCEDURE Curve(VAR x,y:Vektor; n,Lintyp,Thickness,Color:word);
  63. { Polygonzug }
  64. VAR i,u1,v1,u2,v2:integer;
  65. BEGIN
  66.   P_SetLineStyle (Lintyp, Thickness, 0);
  67.   (* ^ statt der Liniendicke wird hier die Wiederholschrittweite def. !!! *)
  68.   P_SetColor (Color);
  69.   Scale(x[1],y[1],u1,v1);
  70.   for i:=2 to n do BEGIN
  71.     Scale(x[i],y[i],u2,v2); P_Line(u1,v1,u2,v2);
  72.     u1:=u2; v1:=v2;
  73.   END;
  74. END;
  75. (*-----------------------------------------------*)
  76. PROCEDURE Curvex(VAR x,y:Vektor; n:word; Color:byte);
  77. { Punkte auftragen }
  78. VAR i,u,v:integer;
  79. BEGIN
  80.   for i:=1 to n do BEGIN
  81.     Scale(x[i],y[i],u,v); P_PutPixel(u,v,Color);
  82.   END;
  83. END;
  84. (*-----------------------------------------------*)
  85. FUNCTION EXP10(x:real):real;
  86. VAR S:string[80]; E:real; Code:word;
  87. BEGIN
  88.   if x=INT(x) then BEGIN    { 10 hoch Integer }
  89.     STR(TRUNC(x),S);
  90.     VAL(('1.0E'+S),E,Code); EXP10:=E; Exit;
  91.   END;
  92.   EXP10:=EXP(x*LN(10)); { 10 hoch Real }
  93. END;
  94. (*-----------------------------------------------*)
  95. FUNCTION Exponent(x:real):integer;
  96. { Groessenordnung einer Zahl }
  97. VAR EX,S:string[80]; n,code:integer;
  98. BEGIN
  99.   STR(x,S); EX:=COPY(S,POS('E',S)+1,Length(S));
  100.   VAL(EX,n,code); Exponent:=n;
  101. END;
  102. (*-----------------------------------------------*)
  103. PROCEDURE Extrema(z:Vektor; n:word; VAR zmin,zmax:real);
  104. { Maximum und Minimum des Vektors z[1..n] }
  105. VAR i:word;
  106. BEGIN
  107.   zmin:=z[1]; zmax:=z[1];
  108.   for i:=2 to n do BEGIN
  109.     if z[i]<zmin then zmin:=z[i];
  110.     if z[i]>zmax then zmax:=z[i];
  111.   END;
  112. END;
  113. (*-----------------------------------------------*)
  114. PROCEDURE GraphikWindow(x1,x2,y1,y2:integer);
  115. { Graphikfenster }
  116. VAR h:integer;
  117. BEGIN
  118.   P_SetColor (Black);
  119.   if x1>x2 then BEGIN h:=x1; x1:=x2; x2:=h; END;
  120.   if y1>y2 then BEGIN h:=y1; y1:=y2; y2:=h; END;
  121.   P_Line(x1, y1, x2, y1);
  122.   P_Line(x2, y1, x2, y2);
  123.   P_Line(x2, y2, x1, y2);
  124.   P_Line(x1, y2, x1, y1);
  125.   Uaxmin:=x1; Uaxmax:=x2; Vaxmin:=y1; Vaxmax:=y2;  { Fensterkoordinaten }
  126. END;
  127. (*-----------------------------------------------*)
  128. PROCEDURE LinaxScale(VAR a,b,dx,Ex:real; Density:byte; VAR ExpStrg:strg80);
  129.  { Hilfsroutine fuer  Xaxis und Yaxis  }
  130. VAR  x1,x2:real;
  131. BEGIN
  132.   if ABS(a)<ABS(b) then EX:=Exponent(b) else EX:=Exponent(a);
  133.   x1:=a; x2:=b; dx:=0.25*EXP10(Exponent(b-a));
  134.   ExpStrg:='0';
  135.   if ABS(Ex)>3 then BEGIN                         { Exponent abtrennen }
  136.     a:=a*EXP10(-EX); b:=b*EXP10(-EX); dx:=dx*EXP10(-EX);
  137.     STR(EX:4:0,ExpStrg); while ExpStrg[1]=#32 do Delete(ExpStrg,1,1);
  138.   END;
  139.   while ((b-a)/dx)>=Density do dx:=2*dx;        { Skalendichte }
  140.   if b<a then dx:=-dx;
  141.   if a=b then BEGIN a:=a-dx; b:=b+dx; END;
  142.   a:=dx*ROUND(a/dx);                               { Guenstig runden }
  143.   b:=dx*ROUND(b/dx);
  144.   if a<b then BEGIN
  145.     if a<x1 then a:=a+dx; if b>x2 then b:=b-dx; END
  146.   else BEGIN
  147.     if a>x1 then a:=a-dx; if b<x2 then b:=b+dx;
  148.   END;
  149. END;
  150. (*-----------------------------------------------*)
  151. FUNCTION LOG10(x:real):real;
  152.     { dekad. Logarithmus }
  153. BEGIN
  154.   IF x<>0 THEN LOG10 := LN (ABS(x)) / LN(10.0) ELSE LOG10 := 0;
  155. END;
  156. (*-----------------------------------------------*)
  157. PROCEDURE LogXAxis(LogX1,LogX2:real; XText:strg80; Font,Size:word);
  158. { Log. x-Achse }                                      (* ^ mm *)
  159. CONST Density=10;    { Skalendichte }
  160. VAR dn,n1,n2,n,k,u,v:integer; x:real; S:string[6];
  161.     PSize : REAL;
  162. BEGIN
  163.   P_Line(Uaxmin, Vaxmin,Uaxmax, Vaxmin);
  164.   PSize := Size / 10;  (* Textstyle (SI) erfordert Einheit 'cm' ! *)
  165.   u := (Uaxmax+Uaxmin) div 2;
  166.   v := (Vaxmin - ROUND (5 * Size));
  167.   P_SetTextStyle (Font, P_HorizDir, PSize);
  168.   P_OutTextXY(u, v, XText);
  169.  
  170.   n1:=TRUNC(LogX1); n2:=TRUNC(LogX2);
  171.   if n1>n2 then BEGIN k:=n1; n1:=n2; n2:=k; END;
  172.   dn:=1; while (n2-n1) div dn>=Density do dn:=Density*dn;
  173.   if dn=1 then BEGIN
  174.     for n:=n1-1 to n2+1 do
  175.     for k:=2 to 9 do BEGIN x:=n+LOG10(k); Xmark(x,u,2); END;
  176.   END;
  177.  
  178.   for n:=n1 to n2 do BEGIN
  179.  
  180.    IF (dn DIV 10 <> 0) THEN
  181.        if (dn<>1) and ((n mod (dn div 10))=0) then Xmark(n,u,2);
  182.    if (n mod dn)=0 then BEGIN
  183.     Xmark(n,u,4);
  184.     STR(n,S);
  185.     P_OutTextXY (u + ROUND (8 * PSize), Vaxmin - (ROUND (45 * PSize)) DIV 2, S);
  186.     P_OutTextXY (u - (ROUND (15 * PSize)) DIV 2, Vaxmin - ROUND (30 * PSize), '10');
  187.    END;
  188.   END;
  189. END;
  190. (*-----------------------------------------------*)
  191. PROCEDURE LogYAxis(LogY1,LogY2:real; YText:strg80; Font,Size:word);
  192. { log. y-Achse }
  193. CONST Density=10;
  194. VAR dn,n1,n2,n,k,u,v:integer; y:real; S:string[6];
  195.     PSize : REAL;
  196. BEGIN
  197.   P_Line(Uaxmin, Vaxmin, Uaxmin, Vaxmax);
  198.   PSize := Size / 10;  (* Textstyle (SI) erfordert Einheit 'cm' ! *)
  199.   v := (Vaxmax+Vaxmin) div 2;
  200.   u := (Uaxmin - ROUND (5 * Size));
  201.   P_SetTextStyle (Font, P_VertDir, PSize);
  202.   P_OutTextXY (u, v, YText);
  203.  
  204.   n1:=TRUNC(LogY1); n2:=TRUNC(LogY2);
  205.   if n1>n2 then BEGIN k:=n1; n1:=n2; n2:=k; END;
  206.   dn:=1; while (n2-n1) div dn>=Density do dn:=Density*dn;
  207.   if dn=1 then BEGIN
  208.     for n:=n1-1 to n2+1 do
  209.     for k:=2 to 9 do BEGIN y:=n+LOG10(k); Ymark(y,v,2); END;
  210.   END;
  211.   for n:=n1 to n2 do BEGIN
  212.     IF (dn DIV 10 <> 0) THEN
  213.        if (dn<>1) and ((n mod (dn div 10))=0) then Ymark(n,u,2);
  214.     if (n mod dn)=0 then BEGIN
  215.       Ymark(n,v,4);
  216.       STR(n,S);
  217.       P_OutTextXY (Uaxmin - ROUND (25 * PSize), v + Round (PSize), S);
  218.       P_OutTextXY (Uaxmin - ROUND (25 * PSize) DIV 2, v - (Round (20 * PSize)) DIV 2, '10');
  219.     END;
  220.   END;
  221. END;
  222. (*-----------------------------------------------*)
  223. FUNCTION RealToString(x:real):strg80;
  224. { Reelle Zahl in handlichen String }
  225. VAR S:strg80; Code:word;
  226.  
  227. BEGIN
  228.   STR(x:16:10,S);
  229.   while s[1]=#32 do Delete(S,1,1);
  230.   while S[Length(s)]='0' do BEGIN Delete(S,Length(S),1); END;
  231.   if POS('.',S)=Length(S) then Delete(S,Length(S),1);
  232.   VAL(S,x,Code); if x=0 then S:='0';
  233.   RealToString:=S;
  234. END;
  235. (*-----------------------------------------------*)
  236. PROCEDURE Scale(x,y:real; VAR u,v:integer);
  237. { Absolute Skalierung }
  238. BEGIN
  239.   u:= Uaxmin+ROUND((x-Xaxmin)/(Xaxmax-Xaxmin)*(Uaxmax-Uaxmin));
  240.   v:= VaxMin + ROUND((y-Yaxmin)/(Yaxmax-Yaxmin)*(Vaxmax-Vaxmin));
  241. END;
  242. (*-----------------------------------------------*)
  243. PROCEDURE UScale(VAR X1,X2,Y1,Y2:real; Origin,AngleTrue:boolean; Expans:real);
  244. { Benutzer-Koordinatensystem }
  245. VAR   xx,yy:real;
  246. CONST Tol = 0.01;
  247.       ExpFaktor = 10;  (* zur Kompatibilität mit UNIT PGraph *)
  248.  
  249. BEGIN
  250.   Expans:= ExpFaktor * ABS(Expans);    (* ! *)
  251.   (* damit bei gleichem Parameter in etwa gleiches Koordinatensystem ! *)
  252.  
  253.   xx:=ABS(x2-x1)*0.005*Expans; if x1>x2 then xx:=-xx;
  254.   X1:=X1-xx; X2:=X2+xx;
  255.   if ABS(x2-x1)<1E-8 then
  256.   BEGIN x1:=x1*(1-0.01*Expans); x2:=x2*(1+0.01*Expans); END;
  257.   yy:=ABS(y2-y1)*0.005*Expans; if y1>y2 then yy:=-yy;
  258.   y1:=y1-yy; y2:=y2+yy;
  259.   if ABS(y2-y1)<1E-8 then
  260.   BEGIN y1:=y1*(1-0.01*Expans); y2:=y2*(1+0.01*Expans); END;
  261.  
  262.   if Origin then BEGIN                                 { 2. Ursprung }
  263.     if X1<=X2 then BEGIN
  264.       if X2<0 then X2:=0;
  265.       if X1>0 then X1:=0; END
  266.     else BEGIN
  267.       if X2>0 then X2:=0;
  268.       if X1<0 then X1:=0;
  269.     END;
  270.     if Y1<=Y2 then BEGIN
  271.       if Y2<0 then Y2:=0;
  272.       if Y1>0 then Y1:=0; END
  273.     else BEGIN
  274.       if Y2>0 then Y2:=0;
  275.       if Y1<0 then Y1:=0;
  276.     END;
  277.   END;
  278.   if AngleTrue then AngleTrueScale(X1,X2,Y1,Y2);
  279.   if ABS((X2-X1)/X2)<Tol then BEGIN
  280.     if X1<X2 then
  281.     BEGIN X1:=X1*(1-Tol); X2:=X2*(1+Tol); END
  282.     else BEGIN X2:=X2*(1-Tol); X1:=X1*(1+Tol); END;
  283.   END;
  284.   if ABS((Y2-Y1)/Y2)<Tol then BEGIN
  285.     if Y1<Y2 then
  286.     BEGIN Y1:=Y1*(1-Tol); Y2:=Y2*(1+Tol); END
  287.     else BEGIN Y2:=Y2*(1-Tol); Y1:=Y1*(1+Tol); END;
  288.   END;
  289.   Xaxmin:=X1; Xaxmax:=X2;
  290.   Yaxmin:=Y1; Yaxmax:=Y2;
  291. END;
  292. (*-----------------------------------------------*)
  293. PROCEDURE XAxis(x1,x2:real; XText:strg80; Font,Size:word);
  294. VAR   Xpos,Ypos:integer;
  295.       Ex,U,V,a,b,x,dx,h:real; E,S:strg80;
  296.       PSize : REAL;
  297. CONST Density=6;
  298. BEGIN
  299.   P_Line(Uaxmin, Vaxmin,Uaxmax, Vaxmin);
  300.   PSize := Size / 10;  (* Textstyle (SI) erfordert Einheit 'cm' ! *)
  301.   XPos := (Uaxmax+Uaxmin) div 2;  (*  - Round (10.0 * PSize); *)
  302.   YPos := (Vaxmin - ROUND (5 * Size));
  303.   a:=x1; b:=x2; if a>b then BEGIN h:=b; b:=a; a:=b; END;
  304.   LinaxScale(x1,x2,dx,Ex,Density,E);
  305.   if x1>x2 then BEGIN h:=x1; x1:=x2; x2:=h; dx:=ABS(dx); END;
  306.   P_SetTextStyle (Font, P_HorizDir, PSize);
  307.  
  308.   if E='0' then
  309.      P_OutTextXY (Xpos,Ypos,XText)
  310.   else BEGIN
  311.     U:=Xaxmin; V:=XaxMax;
  312.     P_OutTextXY (Xpos, Ypos, XText+' *E'+E);
  313.     a:=a*EXP10(-Ex); b:=b*EXP10(-Ex); Xaxmin:=a; Xaxmax:=b;
  314.   END;
  315.  
  316.   x:=x1;
  317.   Xmark(x-dx/2,xpos,2);
  318.  
  319.   repeat
  320.     Xmark(x+dx/2,xpos,2);
  321.     Xmark(x,xpos,2);
  322.     S:=RealToString(x);
  323.     P_Line (Xpos, Vaxmin, Xpos, Vaxmin-2);
  324.     if Length(S)<6 then P_OutTextXY (Xpos, Vaxmin - ROUND (25 * PSize), S);
  325.     x:=x+dx;
  326.   until (x>=b) or (x<=a);
  327.   if E<>'0' then BEGIN Xaxmin:=U; XaxMax:=V; END;
  328. END;
  329. (*-----------------------------------------------*)
  330. PROCEDURE Xgrid(x:real);
  331. { Parallele zur x-Achse }
  332. VAR u,v:integer;
  333. BEGIN
  334.   Scale(x,0,u,v);
  335.   if u > Uaxmin then P_Line(u, Vaxmin, u, Vaxmax);
  336. END;
  337. (*-----------------------------------------------*)
  338. PROCEDURE Xmark(x:real; VAR u:integer; Len:byte);
  339. {  x-Achsenmarken:   }
  340. VAR v:integer;
  341. BEGIN
  342.   Scale(x,Yaxmin,u,v);
  343.   if (u>=UaxMin) and (u<=UaxMax) then
  344.   P_Line(u, Vaxmin, u, Vaxmin + Len);
  345. END;
  346. (*-----------------------------------------------*)
  347. PROCEDURE YAxis(y1,y2:real; YText:strg80; Font,Size:word);
  348. { lineare y-Achse }
  349. VAR   Xpos,Ypos:integer;
  350.       Ex,U,V,a,b,y,dy,h:real; E,S:strg80;
  351.       PSize : REAL;
  352. CONST Density=8;
  353. BEGIN
  354.   P_Line(Uaxmin, Vaxmin, Uaxmin, Vaxmax);
  355.   PSize := Size / 10;  (* Textstyle (SI) erfordert Einheit 'cm' ! *)
  356.   YPos := (Vaxmax+Vaxmin) div 2;
  357.   XPos := (Uaxmin - ROUND (5 * Size));
  358.   a:=y1; b:=y2; if a>b then BEGIN h:=b; b:=a; a:=b; END;
  359.   LinaxScale(y1,y2,dy,Ex,Density,E);
  360.   if y1>y2 then BEGIN h:=y1; y1:=y2; y2:=h; dy:=ABS(dy); END;
  361.   P_SetTextStyle (Font, P_VertDir, PSize);
  362.   if E='0' then
  363.    P_OutTextXY (Xpos, Ypos, YText)
  364.   else BEGIN
  365.     U:=Yaxmin; V:=YaxMax;
  366.     P_OutTextXY (Xpos, Ypos, YText+' *E'+E);
  367.     a:=a*EXP10(-Ex); b:=b*EXP10(-Ex); Yaxmin:=a; Yaxmax:=b;
  368.   END;
  369.  
  370.   y:=y1;
  371.   Ymark(y-dy/2,ypos,2);
  372.   repeat
  373.     Ymark(y+dy/2,ypos,2);
  374.     S:=RealToString(y);
  375.     Ymark(y,ypos,2);
  376.     P_Line (UaXmin, YPos, UaXmin - 2, YPos);
  377.     if Length(S)<6 then P_OutTextXY (Uaxmin - ROUND (25 * PSize), YPos, S);
  378.     y:=y+dy;
  379.   until (y>=b) or (y<=a);
  380.   if E<>'0' then BEGIN Yaxmin:=U; YaxMax:=V; END;
  381. END;
  382. (*-----------------------------------------------*)
  383. PROCEDURE Ygrid(y:real);
  384. { Parallele zur y-Achse    }
  385. VAR u,v:integer;
  386. BEGIN
  387.   Scale(0,y,u,v);
  388.   if v > Vaxmin then P_Line (Uaxmin, v, Uaxmax, v);
  389. END;
  390. (*-----------------------------------------------*)
  391. PROCEDURE Ymark(y:real; VAR v:integer; Len:byte);
  392. {  y-Achsenmarken:   }
  393.  
  394. VAR u:integer;
  395. BEGIN
  396.   Scale(Xaxmin,y,u,v);
  397.   if (v > Vaxmin) and (v < Vaxmax) then
  398.        P_Line (Uaxmin, v, Uaxmin+Len, v);
  399. END;
  400. (*-----------------------------------------------*)
  401. (*-----------------------------------------------*)
  402. END.
  403.