home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 05 / praxis / plgraph.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-09  |  14.3 KB  |  464 lines

  1. (* ------------------------------------------------------ *)
  2. (*                       PLGRAPH.PAS                      *)
  3. (*  Umsetzung von PGRAPH (TOOLBOX 12'88) auf HPGL-Plotter *)
  4. (*    (c) 1989  Peter Kurzweil, Gerd Kraus  &  TOOLBOX    *)
  5. (* ------------------------------------------------------ *)
  6. UNIT PLGRAPH;                  (* erfordert die Unit HPGL *)
  7.  
  8. INTERFACE
  9.  
  10. USES HPGL;
  11.  
  12. CONST
  13.   {$IFDEF CPU87}                 (* math. Coprozessor ??? *)
  14.     MaxInt = 2147483647;
  15.   {$ENDIF}
  16.   nmax = 200;
  17.  
  18. TYPE
  19.   {$IFDEF CPU87}
  20.     REAL = EXTENDED;
  21.   {$ELSE}
  22.     DOUBLE   = REAL;  SINGLE = REAL;
  23.     EXTENDED = REAL;  COMP   = REAL;
  24.   {$ENDIF}
  25.   Vektor = ARRAY[1..nmax] OF REAL;
  26.  
  27. PROCEDURE AngleTrueScale(VAR x1, x2, y1, y2 : REAL);
  28. PROCEDURE Curve(VAR x, y : Vektor;
  29.                 n, Lintyp, Thickness, Color : WORD);
  30. PROCEDURE Curvex(VAR x, y : Vektor; n : WORD; Color : BYTE);
  31. FUNCTION EXP10(x : REAL) : REAL;
  32. FUNCTION Exponent(x : REAL) : INTEGER;
  33. PROCEDURE Extrema(z : Vektor; n : WORD;
  34.                   VAR zmin, zmax : REAL);
  35. PROCEDURE GraphikWindow(x1, x2, y1, y2 : INTEGER);
  36. PROCEDURE LinaxScale(VAR a, b, dx, Ex : REAL;
  37.                      Density : BYTE; VAR ExpStrg : strg80);
  38. FUNCTION LOG10(x : REAL) : REAL;
  39. PROCEDURE LogXAxis(LogX1, LogX2 : REAL; XText : strg80;
  40.                    Font, Size : WORD);
  41. PROCEDURE LogYAxis(LogY1, LogY2 : REAL; YText : strg80;
  42.                    Font, Size : WORD);
  43. FUNCTION RealToString(x : REAL) : strg80;
  44. PROCEDURE Scale(x, y : REAL; VAR u, v : INTEGER);
  45. PROCEDURE Uscale(VAR x1, x2, y1, y2 : REAL;
  46.                 Origin, AngleTrue : BOOLEAN; Expans : REAL);
  47. PROCEDURE XAxis(x1, x2 : REAL; XText : strg80;
  48.                 Font, Size : WORD);
  49. PROCEDURE Xgrid(x : REAL);
  50. PROCEDURE Xmark(x : REAL; VAR u : INTEGER; Len : BYTE);
  51. PROCEDURE YAxis(y1, y2 : REAL; YText : strg80;
  52.                 Font, Size : WORD);
  53. PROCEDURE Ymark(y : REAL; VAR v : INTEGER; Len : BYTE);
  54. PROCEDURE Ygrid(y : REAL);
  55.  
  56. IMPLEMENTATION
  57.  
  58. PROCEDURE AngleTrueScale(VAR x1, x2, y1, y2 : REAL);
  59.                                 (* Winkeltreue Skalierung *)
  60. VAR   C,dx,dy,xx,yy,xm,ym,F:REAL; Xasp,Yasp:WORD;
  61. BEGIN
  62.   F  := (Abs(UaxMin - UaxMax) / Abs(VaxMin - VaxMax));
  63.   dx := Abs(x2 - x1);
  64.   dy := Abs(y2-y1);
  65.   IF dx >= dy THEN BEGIN
  66.     yy := 0.5 * dx / F;
  67.     IF y1 > y2 THEN yy := -yy;        (* y-Achse strecken *)
  68.     ym := 0.5 * (y1 + y2); y1 := ym - yy; y2 := ym + yy;
  69.   END ELSE BEGIN
  70.     xx := 0.5 * dy * F;
  71.     IF x1 > x2 THEN xx := -xx;        (* x-Achse strecken *)
  72.     xm := 0.5 * (x1 + x2); x1 := xm - xx; x2 := xm + xx;
  73.   END;
  74. END;
  75.  
  76. PROCEDURE Curve(VAR x, y : Vektor;
  77.                 n, Lintyp, Thickness, Color : WORD);
  78.                                             (* Polygonzug *)
  79. VAR i, u1, v1, u2, v2 : INTEGER;
  80. BEGIN
  81.   P_SetLineStyle(Lintyp, Thickness, 0);
  82.   (* ^ statt Liniendicke Wiederholschrittweite            *)
  83.   P_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); P_Line(u1, v1, u2, v2);
  87.     u1 := u2; v1 := v2;
  88.   END;
  89. END;
  90.  
  91. PROCEDURE Curvex(VAR x, y : Vektor; n : WORD; Color : BYTE);
  92.                                       (* 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); P_PutPixel(u, v, Color);
  97.   END;
  98. END;
  99.  
  100. FUNCTION EXP10(x : REAL) : REAL;
  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(x : REAL) : INTEGER;
  111.                               (* Größenordnung einer Zahl *)
  112. VAR Ex, S : STRING[80]; n, Code : INTEGER;
  113. BEGIN
  114.   Str(x, S); Ex := Copy(S, Pos('E', S) + 1, Length(S));
  115.   Val(Ex, n, Code); Exponent := n;
  116. END;
  117.  
  118. PROCEDURE Extrema(z : Vektor; n : WORD;
  119.                   VAR zmin, zmax : REAL);
  120.                (* Maximum und Minimum des Vektors z[1..n] *)
  121. VAR i : WORD;
  122. BEGIN
  123.   zmin := z[1]; zmax := z[1];
  124.   FOR i := 2 TO n DO BEGIN
  125.     IF z[i] < zmin THEN zmin := z[i];
  126.     IF z[i] > zmax THEN zmax := z[i];
  127.   END;
  128. END;
  129.  
  130. PROCEDURE GraphikWindow(x1, x2, y1, y2 : INTEGER);
  131.                                         (* Graphikfenster *)
  132. VAR h : INTEGER;
  133. BEGIN
  134.   P_SetColor(Black);
  135.   IF x1 > x2 THEN BEGIN
  136.     h := x1; x1 := x2; x2 := h;
  137.   END;
  138.   IF y1 > y2 THEN BEGIN
  139.     h := y1; y1 := y2; y2 := h;
  140.   END;
  141.   P_Line(x1, y1, x2, y1);
  142.   P_Line(x2, y1, x2, y2);
  143.   P_Line(x2, y2, x1, y2);
  144.   P_Line(x1, y2, x1, y1);
  145.   UaxMin := x1; UaxMax := x2;
  146.   VaxMin := y1; VaxMax := y2;       (* Fensterkoordinaten *)
  147. END;
  148.  
  149. PROCEDURE LinaxScale(VAR a, b, dx, Ex : REAL;
  150.                      Density : BYTE; VAR ExpStrg : strg80);
  151.                    (* Hilfsroutine fuer  Xaxis und Yaxis  *)
  152. VAR  x1, x2 : REAL;
  153. BEGIN
  154.   IF Abs(a) < Abs(b) THEN
  155.     Ex := Exponent(b) ELSE Ex := Exponent(a);
  156.   x1 := a; x2 := b; dx := 0.25 * EXP10(Exponent(b - a));
  157.   ExpStrg := '0';
  158.   IF Abs(Ex) > 3 THEN BEGIN        (*  Exponent abtrennen *)
  159.     a := a * EXP10(-Ex); b := b * EXP10(-Ex);
  160.     dx := dx * EXP10(-Ex);
  161.     Str(Ex:4:0, ExpStrg);
  162.     WHILE ExpStrg[1] = #32 DO Delete(ExpStrg, 1, 1);
  163.   END;
  164.   WHILE ((b - a) / dx) >= Density DO
  165.     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);              (* Günstig runden *)
  169.   b := dx * Round(b / dx);
  170.   IF a < b THEN BEGIN
  171.     IF a < x1 THEN a := a + dx;
  172.     IF b > x2 THEN b := b - dx;
  173.   END ELSE BEGIN
  174.     IF a > x1 THEN a := a - dx;
  175.     IF b < x2 THEN b := b + dx;
  176.   END;
  177. END;
  178.  
  179. FUNCTION LOG10(x : REAL) : REAL;    (* dekad. Logarithmus *)
  180. BEGIN
  181.   IF x <> 0 THEN
  182.     LOG10 := Ln(Abs(x)) / Ln(10.0) ELSE LOG10 := 0;
  183. END;
  184.  
  185. PROCEDURE LogXAxis(LogX1, LogX2 : REAL; XText : strg80;
  186.                    Font,Size : WORD);     (* Log. x-Achse *)
  187. CONST Density = 10;                       (* Skalendichte *)
  188. VAR dn, n1, n2, n, k, u, v : INTEGER;
  189.     x : REAL; S : STRING[6]; PSize : REAL;
  190. BEGIN
  191.   P_Line(UaxMin, VaxMin,UaxMax, VaxMin);
  192.   PSize := Size / 10;                    (* Einheit [cm]! *)
  193.   u := (UaxMax + UaxMin) DIV 2;
  194.   v := (VaxMin - Round (5 * Size));
  195.   P_SetTextStyle(Font, P_HorizDir, PSize);
  196.   P_OutTextXY(u, v, XText);
  197.  
  198.   n1 := Trunc(LogX1);  n2 := Trunc(LogX2);
  199.   IF n1 > n2 THEN BEGIN k := n1; n1 := n2; n2 := k; END;
  200.   dn:=1;
  201.   WHILE (n2 - n1) DIV dn >= Density DO dn := Density * dn;
  202.   IF dn = 1 THEN BEGIN
  203.     FOR n := n1 - 1 TO n2 + 1 DO
  204.       FOR k := 2 TO 9 DO BEGIN
  205.         x := n + LOG10(k); Xmark(x, u, 2);
  206.       END;
  207.   END;
  208.   FOR n := n1 TO n2 DO BEGIN
  209.     IF (dn DIV 10 <> 0) THEN
  210.       IF (dn<>1) AND ((n MOD (dn DIV 10)) = 0) THEN
  211.         Xmark(n, u, 2);
  212.     IF (n MOD dn) = 0 THEN BEGIN
  213.       Xmark(n, u, 4);
  214.       Str(n, S);
  215.       P_OutTextXY(u + Round (8 * PSize),
  216.                   VaxMin - (Round (45 * PSize)) DIV 2, S);
  217.       P_OutTextXY(u - (Round (15 * PSize)) DIV 2,
  218.                   VaxMin - Round (30 * PSize), '10');
  219.     END;
  220.   END;
  221. END;
  222.  
  223. PROCEDURE LogYAxis(LogY1, LogY2 : REAL; YText : strg80;
  224.                    Font, Size : WORD);
  225.                                           (* log. y-Achse *)
  226. CONST Density = 10;
  227. VAR dn, n1, n2, n, k, u, v : INTEGER;
  228.     y : REAL; S : STRING[6]; PSize : REAL;
  229. BEGIN
  230.   P_Line(UaxMin, VaxMin, UaxMin, VaxMax);
  231.   PSize := Size / 10;
  232.   v := (VaxMax + VaxMin) DIV 2;
  233.   u := (UaxMin - Round (5 * Size));
  234.   P_SetTextStyle(Font, P_VertDir, PSize);
  235.   P_OutTextXY(u, v, YText);
  236.  
  237.   n1 := Trunc(LogY1); n2 := Trunc(LogY2);
  238.   IF n1 > n2 THEN BEGIN
  239.     k := n1; n1 := n2; n2 := k;
  240.   END;
  241.   dn := 1;
  242.   WHILE (n2 - n1) DIV dn >= Density DO dn := Density * dn;
  243.   IF dn = 1 THEN BEGIN
  244.     FOR n := n1 - 1 TO n2 + 1 DO
  245.       FOR k := 2 TO 9 DO BEGIN
  246.         y := n + LOG10(k); Ymark(y, v, 2);
  247.       END;
  248.   END;
  249.   FOR n := n1 TO n2 DO BEGIN
  250.     IF (dn DIV 10 <> 0) THEN
  251.       IF (dn <> 1) AND ((n MOD (dn DIV 10)) = 0) THEN
  252.         Ymark(n, u, 2);
  253.     IF (n MOD dn) = 0 THEN BEGIN
  254.       Ymark(n, v, 4);
  255.       Str(n, S);
  256.       P_OutTextXY(UaxMin - Round(25 * PSize),
  257.                   v + Round(PSize), S);
  258.       P_OutTextXY(UaxMin - Round(25 * PSize) DIV 2,
  259.                   v - (Round(20 * PSize)) DIV 2, '10');
  260.     END;
  261.   END;
  262. END;
  263.  
  264. FUNCTION RealToString(x : REAL) : strg80;
  265.                       (* Reelle Zahl in handlichen String *)
  266. VAR S : strg80; Code : WORD;
  267. BEGIN
  268.   Str(x:16:10, S);
  269.   WHILE S[1] = #32 DO Delete(S, 1, 1);
  270.   WHILE S[Length(S)] = '0' DO Delete(S,Length(S),1);
  271.   IF Pos('.', S) = Length(S) THEN Delete(S, Length(S), 1);
  272.   Val(S, x, Code); IF x = 0 THEN S := '0';
  273.   RealToString := S;
  274. END;
  275.  
  276. PROCEDURE Scale(x, y : REAL; VAR u, v : INTEGER);
  277.                                    (* Absolute Skalierung *)
  278. BEGIN
  279.   u := UaxMin + Round((x - Xaxmin) / (Xaxmax - Xaxmin) *
  280.                       (UaxMax - UaxMin));
  281.   v := VaxMin + Round((y - Yaxmin) / (Yaxmax - Yaxmin) *
  282.                       (VaxMax-VaxMin));
  283. END;
  284.  
  285. PROCEDURE Uscale(VAR x1, x2, y1, y2 : REAL;
  286.                 Origin, AngleTrue : BOOLEAN; Expans : REAL);
  287.                             (* Benutzer-Koordinatensystem *)
  288. VAR   xx, yy : REAL;
  289. CONST Tol = 0.01;
  290.       ExpFaktor = 10;  (*  Kompatibilität mit Unit PGraph *)
  291.  
  292. BEGIN
  293.   Expans:= ExpFaktor * Abs(Expans);    (* ! *)
  294.   (* damit bei gleichem Parameter in etwa gleiches        *)
  295.   (* Koordinatensystem !                                  *)
  296.  
  297.   xx := Abs(x2 - x1) * 0.005 * Expans;
  298.   IF x1 > x2 THEN xx := -xx;
  299.   x1 := x1 - xx;  x2 := x2 + xx;
  300.   IF Abs(x2 - x1) < 1E-8 THEN BEGIN
  301.     x1 := x1 * (1 - 0.01 * Expans);
  302.     x2 := x2 * (1 + 0.01 * Expans);
  303.   END;
  304.   yy := Abs(y2 - y1) * 0.005 * Expans;
  305.   IF y1 > y2 THEN yy := -yy;
  306.   y1 := y1 - yy;  y2 := y2 +yy;
  307.   IF Abs(y2 - y1) < 1E-8 THEN BEGIN
  308.     y1 := y1 * (1 - 0.01 * Expans);
  309.     y2 := y2 * (1 + 0.01 * Expans);
  310.   END;
  311.   IF Origin THEN BEGIN                     (* 2. Ursprung *)
  312.     IF x1 <= x2 THEN BEGIN
  313.       IF x2 < 0 THEN x2 := 0;
  314.       IF x1 > 0 THEN x1 := 0;
  315.     END ELSE BEGIN
  316.       IF x2 > 0 THEN x2 := 0;
  317.       IF x1 < 0 THEN x1 := 0;
  318.     END;
  319.     IF y1 <= y2 THEN BEGIN
  320.       IF y2 < 0 THEN y2 := 0;
  321.       IF y1 > 0 THEN y1 := 0;
  322.     END ELSE BEGIN
  323.       IF y2 > 0 THEN y2 := 0;
  324.       IF y1 < 0 THEN y1 := 0;
  325.     END;
  326.   END;
  327.   IF AngleTrue THEN AngleTrueScale(x1, x2, y1, y2);
  328.   IF Abs((x2 - x1) / x2) < Tol THEN BEGIN
  329.     IF x1 < x2 THEN BEGIN
  330.       x1 := x1 * (1 - Tol); x2 := x2 * (1 + Tol);
  331.     END ELSE BEGIN
  332.       x2 := x2 * (1 - Tol); x1 := x1 * (1 + Tol);
  333.     END;
  334.   END;
  335.   IF Abs((y2 - y1) / y2) < Tol THEN BEGIN
  336.     IF y1 < y2 THEN BEGIN
  337.       y1 := y1 * (1 - Tol); y2 := y2 * (1 + Tol);
  338.     END ELSE BEGIN
  339.       y2 := y2 * (1 - Tol); y1 := y1 * (1 + Tol);
  340.     END;
  341.   END;
  342.   Xaxmin := x1; Xaxmax := x2;
  343.   Yaxmin := y1; Yaxmax := y2;
  344. END;
  345.  
  346. PROCEDURE XAxis(x1, x2 : REAL; XText : strg80;
  347.                 Font, Size : WORD);
  348. VAR   Xpos, Ypos : INTEGER;
  349.       Ex, u, v, a, b, x, dx, h : REAL; E, S : strg80;
  350.       PSize : REAL;
  351. CONST Density = 6;
  352. BEGIN
  353.   P_Line(UaxMin, VaxMin,UaxMax, VaxMin);
  354.   PSize := Size / 10;
  355.   Xpos := (UaxMax + UaxMin) DIV 2;
  356.                               (*  - Round (10.0 * PSize); *)
  357.   Ypos := (VaxMin - Round (5 * Size));
  358.   a := x1; b := x2;
  359.   IF a > b THEN BEGIN h := b; b := a; a := b; END;
  360.   LinaxScale(x1, x2, dx, Ex, Density, E);
  361.   IF x1 > x2 THEN BEGIN
  362.     h := x1; x1 := x2; x2 := h; dx := Abs(dx);
  363.   END;
  364.   P_SetTextStyle(Font, P_HorizDir, PSize);
  365.   IF E='0' THEN
  366.     P_OutTextXY(Xpos, Ypos, XText)
  367.   ELSE BEGIN
  368.     u := Xaxmin;  v := Xaxmax;
  369.     P_OutTextXY(Xpos, Ypos, XText + ' *E' + E);
  370.     a := a * EXP10(-Ex);  b := b * EXP10(-Ex);
  371.     Xaxmin := a;  Xaxmax := b;
  372.   END;
  373.   x := x1;
  374.   Xmark(x - dx / 2, Xpos, 2);
  375.   REPEAT
  376.     Xmark(x + dx / 2, Xpos, 2);
  377.     Xmark(x, Xpos, 2);
  378.     S := RealToString(x);
  379.     P_Line(Xpos, VaxMin, Xpos, VaxMin - 2);
  380.     IF Length(S) < 6 THEN
  381.       P_OutTextXY(Xpos, VaxMin - Round (25 * PSize), S);
  382.     x := x + dx;
  383.   UNTIL (x >= b) OR ( x <= a);
  384.   IF E <> '0' THEN BEGIN Xaxmin := u; Xaxmax := v; END;
  385. END;
  386.  
  387. PROCEDURE Xgrid(x : REAL);
  388.                                  (* Parallele zur x-Achse *)
  389. VAR u, v : INTEGER;
  390. BEGIN
  391.   Scale(x, 0, u, v);
  392.   IF u > UaxMin THEN P_Line(u, VaxMin, u, VaxMax);
  393. END;
  394.  
  395. PROCEDURE Xmark(x : REAL; VAR u : INTEGER; Len : BYTE);
  396.                                     (*  x-Achsenmarken:   *)
  397. VAR v : INTEGER;
  398. BEGIN
  399.   Scale(x, Yaxmin, u, v);
  400.   IF (u >= UaxMin) AND (u <= UaxMax) THEN
  401.     P_Line(u, VaxMin, u, VaxMin + Len);
  402. END;
  403.  
  404. PROCEDURE YAxis(y1, y2 : REAL; YText : strg80;
  405.                 Font, Size : WORD);
  406.                                        (* lineare y-Achse *)
  407. VAR   Xpos, Ypos : INTEGER;
  408.       Ex, u, v, a, b, y, dy, h : REAL; E, S : strg80;
  409.       PSize : REAL;
  410. CONST Density = 8;
  411. BEGIN
  412.   P_Line(UaxMin, VaxMin, UaxMin, VaxMax);
  413.   PSize := Size / 10;
  414.   Ypos := (VaxMax + VaxMin) DIV 2;
  415.   Xpos := (UaxMin - Round (5 * Size));
  416.   a := y1; b := y2;
  417.   IF a > b THEN BEGIN h := b; b := a; a := b; END;
  418.   LinaxScale(y1, y2, dy, Ex, Density, E);
  419.   IF y1 > y2 THEN BEGIN
  420.     h := y1; y1 := y2; y2 := h; dy := Abs(dy);
  421.   END;
  422.   P_SetTextStyle(Font, P_VertDir, PSize);
  423.   IF E = '0' THEN P_OutTextXY(Xpos, Ypos, YText)
  424.   ELSE BEGIN
  425.     u := Yaxmin; v := Yaxmax;
  426.     P_OutTextXY(Xpos, Ypos, YText + ' *E' + E);
  427.     a := a * EXP10(-Ex);  b := b * EXP10(-Ex);
  428.     Yaxmin := a; Yaxmax := b;
  429.   END;
  430.   y := y1;
  431.   Ymark(y - dy / 2, Ypos, 2);
  432.   REPEAT
  433.     Ymark(y + dy / 2, Ypos, 2);
  434.     S := RealToString(y);
  435.     Ymark(y, Ypos, 2);
  436.     P_Line(UaxMin, Ypos, UaxMin - 2, Ypos);
  437.     IF Length(S) < 6 THEN
  438.       P_OutTextXY(UaxMin - Round(25 * PSize), Ypos, S);
  439.     y := y + dy;
  440.   UNTIL (y >= b) OR (y <= a);
  441.   IF E <> '0' THEN BEGIN Yaxmin := u; Yaxmax := v; END;
  442. END;
  443.  
  444. PROCEDURE Ygrid(y : REAL);
  445.                               (* Parallele zur y-Achse    *)
  446. VAR u, v : INTEGER;
  447. BEGIN
  448.   Scale(0, y, u, v);
  449.   IF v > VaxMin THEN P_Line(UaxMin, v, UaxMax, v);
  450. END;
  451.  
  452. PROCEDURE Ymark(y : REAL; VAR v : INTEGER; Len : BYTE);
  453.                                     (*  y-Achsenmarken:   *)
  454. VAR u : INTEGER;
  455. BEGIN
  456.   Scale(Xaxmin, y, u, v);
  457.   IF (v > VaxMin) AND (v < VaxMax) THEN
  458.     P_Line(UaxMin, v, UaxMin + Len, v);
  459. END;
  460.  
  461. END.
  462. (* ------------------------------------------------------ *)
  463. (*                Ende von PLGRAPH.PAS                    *)
  464.