home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 10 / ldm / dataed.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-07-20  |  15.8 KB  |  467 lines
  1. (* ------------------------------------------------------ *)
  2. (*                       DATAED.PAS                       *)
  3. (*              Grafikgestützter Meßdateneditor           *)
  4. (*                  Turbo Pascal ab 5.0                   *)
  5. (*             (C) 1990 Peter Kurzweil & TOOLBOX          *)
  6. (* ------------------------------------------------------ *)
  7.  
  8. PROGRAM Messdateneditor;
  9.  
  10. USES Crt, Dos, Printer, Graph, PGRAPH;
  11.  
  12. TYPE
  13.   ScaleTyp = (linear, lineardown, log, logdown);
  14. CONST
  15.   GraphActiv: BOOLEAN=FALSE;
  16. VAR
  17.   ESC, UP, DOWN, LEFT, RIGHT, RETURN: BOOLEAN;
  18.   ch: CHAR;
  19.   x, y, z: Vektor; a, b: REAL; i, n: WORD; { Stützstellen }
  20.  
  21. PROCEDURE DataEditor(VAR x, y, z: Vektor;
  22.                      VAR n: WORD;
  23.                      xTxt, yTxt, zTxt: strg80;
  24.                      xscal, yscal: ScaleTyp;
  25.                      AngleTrue: BOOLEAN);  FORWARD;
  26.  
  27. PROCEDURE Graphik(x, y: Vektor;
  28.                   n: WORD;
  29.                   xtitel, ytitel: strg80;
  30.                   x1, x2, y1, y2: REAL;
  31.                   UserUscale: BOOLEAN;
  32.                   xscal, yscal: ScaleTyp;
  33.                   Origin, AngleTrue: BOOLEAN;
  34.                   ex: REAL;
  35.                   Lintyp, Thickness, Color, CurvexCol: BYTE;
  36.                   Nr: INTEGER); FORWARD;
  37.  
  38. PROCEDURE ManualScaling(x, y: Vektor; n: WORD;
  39.                         VAR xmin, xmax, ymin, ymax: REAL;
  40.                         VAR UserUscale, AngleTrue: BOOLEAN;
  41.                         xTxt, yTxt: strg80;
  42.                         xscal, yscal: ScaleTyp); FORWARD;
  43.  
  44. {---------------------- Hilfsroutinen -------------------- }
  45.  
  46. FUNCTION FORMAT(x:REAL; f:BYTE): strg80;    { Zahlenformat }
  47. VAR S: strg80;
  48. BEGIN                                         { Gleitkomma }
  49.   IF Abs(LOG10(x))<=5 THEN Str(x:f:5,S) ELSE
  50.   BEGIN                                         { E-Format }
  51.     Str(x:f,S);
  52.     WHILE Length(S)>f DO Delete(S,Pos('E',S)+2,1);
  53.     WHILE Length(S)>f DO Delete(S,Pos('E',S)-1,1);
  54.   END;
  55.   FORMAT:=S;
  56. END;
  57.  
  58. FUNCTION SFORMAT(S: strg80; len: BYTE): strg80;
  59. VAR i,k:BYTE; S1:strg80;
  60. BEGIN
  61.   WHILE Length(S)>len DO Delete(S, Length(S), 1);
  62.   WHILE S[1]=#32 DO Delete(S, 1, 1); S1:=S;
  63.   k:=(len-Length(S)) DIV 2; S:='';
  64.   FOR i:=1 TO k DO S:=S+#32; S:=S+S1;
  65.   FOR i:=Length(S)+1 TO len DO S:=S+#32;
  66.   SFORMAT:=S;
  67. END;
  68.  
  69. PROCEDURE InKey;                         { Tastaturabfrage }
  70. VAR Regs: Registers;
  71. BEGIN
  72.   UP:=FALSE; DOWN:=FALSE; LEFT:=FALSE; RIGHT:=FALSE;
  73.   RETURN:=FALSE; ESC:=FALSE;
  74.   Regs.AX:=$0C00; MsDos(Regs);     { Lösche Tastaturpuffer }
  75.   ch:=UpCase(ReadKey);
  76.   CASE ch OF
  77.     #0:  BEGIN
  78.            ch:=ReadKey;
  79.            CASE ch OF
  80.              #$48:  UP:=TRUE;                  { Cursor UP }
  81.              #$50:  DOWN:=TRUE;              { Cursor DOWN }
  82.              #$4B:  LEFT:=TRUE;              { Cursor LEFT }
  83.              #$4D:  RIGHT:=TRUE             { Cursor RIGHT }
  84.            END;
  85.            ch:=#32;
  86.          END;
  87.     #13: RETURN:=TRUE;                                { CR }
  88.     #27: ESC:=TRUE;                                  { ESC }
  89.   END;
  90. END;
  91.  
  92. PROCEDURE SwapMinMax(VAR x1, x2: REAL);      { Vertauschen }
  93. VAR h: REAL;                                 {   x1 < x2   }
  94. BEGIN
  95.   IF x1>x2 THEN BEGIN h:=x1; x1:=x2; x2:=h; END;
  96. END;
  97.  
  98. PROCEDURE SwapMaxMin(VAR x1, x2: REAL);      { Vertauschen }
  99. VAR h: REAL;                                 {   x1 > x2   }
  100. BEGIN
  101.   IF x1<x2 THEN BEGIN h:=x1; x1:=x2; x2:=h; END;
  102. END;
  103.  
  104. PROCEDURE ExtremaAbs(z: Vektor; n: WORD;
  105.                      VAR zmin, zmax: REAL);
  106. VAR i: WORD; a: REAL;
  107. BEGIN
  108.   zmin:=Abs(z[1]); zmax:=zmin;
  109.   FOR i:=2 TO n DO BEGIN
  110.     a:=Abs(z[i]);
  111.     IF a<zmin THEN zmin:=a;
  112.     IF a>zmax THEN zmax:=a;
  113.   END;
  114. END;
  115.  
  116. PROCEDURE InfoLine(Msg: strg80; Line, TCol, BCol: BYTE);
  117. VAR k: BYTE;                      { Zentrierte Textausgabe }
  118. BEGIN
  119.   TextColor(TCol); TextBackground(BCol);
  120.   k:=(80-Length(Msg)+1) DIV 2;
  121.   GotoXY(1, Line); ClrEol; GotoXY(k, Line); Write(Msg);
  122. END;
  123.  
  124. {----------------------------------------------------------}
  125. {               Graphikgestützer Meßdateneditor            }
  126. {----------------------------------------------------------}
  127.  
  128. {$F+}
  129. PROCEDURE CloseGraphik;   { Verbesserte Version für PGRAPH }
  130. BEGIN
  131.   GraphActiv:=FALSE;
  132.   CloseGraph;
  133. END;
  134. {$F-}
  135.  
  136. PROCEDURE OpenGraphik;    { Verbesserte Version für PGRAPH }
  137. BEGIN                      { Schutz vor mehrmaligem Öffnen }
  138.   IF GraphActiv THEN CloseGraphik;
  139.   GraphActiv:=TRUE; GraphDriver:=Detect;
  140.   InitGraph(GraphDriver, GraphMode, '');
  141.   IF GraphResult<>grOk THEN BEGIN
  142.     WriteLn('FEHLER: ', GraphErrorMsg(ErrorCode)); Halt;
  143.   END;
  144.   IF GraphDriver IN [1, 2, 7] THEN BEGIN
  145.     Black:=0; Blue:=7; Green:=15; Cyan:=15; Red:=15;
  146.     Magenta:=15; Brown:=15; LightGray:=7; DarkGray:=15;
  147.     LightBlue:=15; LightGreen:=15; LightCyan:=15;
  148.     LightRed:=15; LightMagenta:=15; Yellow:=15; White:=15;
  149.   END;
  150.   Uaxmin:=0; Uaxmax:=GetMaxX; Vaxmin:=0; Vaxmax:=GetMaxY;
  151. END;
  152.  
  153. PROCEDURE Cross(x, y: REAL);                  { Fadenkreuz }
  154. CONST len=12;
  155. VAR u, v: INTEGER;
  156. BEGIN
  157.   SetWriteMode(XORPut);
  158.   SetColor(White); Scale(x, y, u, v);
  159.   Line(u-len, v, u+len, v); Line(u, v-len, u, v+len);
  160.   PutPixel(u, v, White);
  161.   SetWriteMode(NormalPut);
  162. END;
  163.  
  164. PROCEDURE InfoLineGraphik(Msg: strg80; Line, Color: BYTE);
  165. VAR h, len, x: WORD;         { Textausgabe im Graphikmodus }
  166. BEGIN
  167.   SetColor(Color); SetTextStyle(Defaultfont, HorizDir, 1);
  168.   SetTextJustify(CenterText, CenterText);
  169.   h:=(GetMaxY DIV 24);
  170.   len:=TextWidth(Msg+'MM') DIV 2; x:=(GetMaxX DIV 2);
  171.   IF Line>=25 THEN
  172.     SetViewPort(0, GetMaxY-h, GetMaxX, GetMaxY, TRUE)
  173.   ELSE SetViewPort(x-len, (Line-1)*h, x+len, Line*h, TRUE);
  174.   ClearViewPort;
  175.   SetViewPort(0, 0, GetMaxX, GetMaxY, TRUE);
  176.   OutTextXY(x, Trunc((Line-0.5)*h), Msg);
  177. END;
  178.  
  179. PROCEDURE DataEditor;   { Graphikgestützter Meßdateneditor }
  180. VAR
  181.   Msg, S: strg80; i: INTEGER; k, i1, i2: WORD;
  182.   x1, x2, y1, y2, a, b, r, da, db, xo, xm, ym, sx, sy: REAL;
  183.   xx, yy: Vektor;
  184.   UserUscale: BOOLEAN; lx, ly: STRING[4];
  185.  
  186.   PROCEDURE Reset;                            { Bildaufbau }
  187.   BEGIN
  188.     Graphik(x, y, n, xTxt, yTxt, x1, x2, y1, y2, UserUscale,
  189.             xscal, yscal, FALSE, AngleTrue, 999, SolidLn,
  190.             NormWidth, Yellow, White, 001);
  191.     InfoLineGraphik('(CURSOR) Kreuz bewegen, (SHIFT CURSOR)'
  192.                  +' schnell bewegen, (ESC) Ende', 1, White);
  193.     InfoLineGraphik('(L)öschen, (A)chsen anpassen,'+
  194.                     ' (N)eu zeichnen', 2, White);
  195.     InfoLineGraphik(xTxt, 24, White);
  196.   END;
  197.  
  198. BEGIN
  199.   UserUscale:=FALSE; Reset;
  200.   lx:=''; ly:=''; i:=1; i1:=0; i2:=0;
  201.   IF xscal IN [linear, lineardown] THEN xx:=x;
  202.   IF yscal IN [linear, lineardown] THEN yy:=y;
  203.   IF xscal IN [log, logdown] THEN BEGIN
  204.     FOR k:=1 TO n DO xx[k]:=LOG10(x[k]); lx:='log ';
  205.   END;
  206.   IF yscal IN [log, logdown] THEN BEGIN
  207.     FOR k:=1 TO n DO yy[k]:=LOG10(y[k]); ly:='log ';
  208.   END;
  209.   Cross(xx[i], yy[i]);
  210.   REPEAT
  211.     Str(i, S);                              { Zahlenleiste }
  212.     Msg:='Wert-Nr. '+S+#32#32+xTxt+' = '+FORMAT(x[i],8)+
  213.          #32#32+yTxt+' = '+FORMAT(y[i],8)+#32#32+zTxt+' = '+
  214.          FORMAT(z[i], 8);
  215.     InfoLineGraphik(Msg, 25, White);
  216.     InKey;
  217.     Cross(xx[i], yy[i]);
  218.     IF UP OR LEFT THEN                      { Cursortasten }
  219.       IF i>1 THEN
  220.         Dec(i);
  221.     IF DOWN OR RIGHT THEN
  222.       IF i<n THEN
  223.         Inc(i);
  224.     CASE ch OF                             { Steuerzeichen }
  225.       '8','4': BEGIN
  226.                  i:=i-5;
  227.                  IF i<=1 THEN BEGIN i:=1;
  228.                    Curve(xx, yy, n, SolidLn,
  229.                          NormWidth, Yellow);
  230.                  END;
  231.                END;
  232.       '6','2': BEGIN
  233.                  i:=i+5;
  234.                  IF i>=n THEN BEGIN i:=n;
  235.                    Curve(xx, yy, n, SolidLn,
  236.                          NormWidth, Yellow);
  237.                  END;
  238.                END;
  239.       'L':     BEGIN                    { Meßpunkt löschen }
  240.                  IF n>3 THEN BEGIN
  241.                    Curve(xx, yy, n, SolidLn,
  242.                          NormWidth, Black);
  243.                    FOR k:=i+1 TO n DO BEGIN
  244.                      x[k-1]:=x[k]; y[k-1]:=y[k];
  245.                      z[k-1]:=z[k]; xx[k-1]:=xx[k];
  246.                      yy[k-1]:=yy[k];
  247.                    END;
  248.                    n:=n-1; IF i>=n THEN i:=n;
  249.                    Curve(xx, yy, n, SolidLn, NormWidth,
  250.                          Yellow);
  251.                  END ELSE Write(#7);
  252.                END;
  253.       'N':     Reset;                  { Kurve auffrischen }
  254.       'A':     BEGIN                 { Manuelle Skalierung }
  255.                  CloseGraphik;
  256.                  ManualScaling(x, y, n, x1, x2, y1, y2,
  257.                                UserUscale, AngleTrue, xTxt,
  258.                                yTxt, xscal, yscal);
  259.                  Reset;
  260.                END;
  261.     END;
  262.     Cross(xx[i], yy[i]);               { Kreuz verschieben }
  263.   UNTIL ESC;
  264.   CloseGraphik;
  265. END;
  266.  
  267. PROCEDURE Graphik;  { Treiberroutine für Graphikbibliothek }
  268. VAR h: INTEGER;
  269.  
  270.   PROCEDURE Scale;            { Skalierung für log. Achsen }
  271.   VAR i: WORD;
  272.   BEGIN
  273.     IF xscal IN [log, logdown] THEN
  274.       FOR i:=1 TO n DO x[i]:=LOG10(x[i]);
  275.     IF yscal IN [log, logdown] THEN
  276.       FOR i:=1 TO n DO y[i]:=LOG10(y[i]);
  277.   END;
  278.  
  279.   PROCEDURE MakeUscale;                { Koordinatensystem }
  280.   BEGIN
  281.     IF (NOT UserUscale) THEN BEGIN        { ...automatisch }
  282.       extrema(x, n, x1, x2); extrema(y, n, y1, y2);
  283.     END;
  284.     IF UserUscale THEN BEGIN               { ...vorgegeben }
  285.       IF xscal IN [log, logdown] THEN BEGIN
  286.         x1:=LOG10(x1); x2:=LOG10(x2);
  287.       END;
  288.       IF yscal IN [log, logdown] THEN BEGIN
  289.         y1:=LOG10(y1); y2:=LOG10(y2);
  290.       END;
  291.     END;
  292.     IF xscal IN [lineardown, logdown] THEN
  293.       SwapMaxMin(x1, x2);
  294.     IF yscal IN [lineardown, logdown] THEN
  295.       SwapMaxMin(y1, y2);
  296.     IF xscal IN [linear, log] THEN SwapMinMax(x1, x2);
  297.     IF yscal IN [linear, log] THEN SwapMinMax(y1, y2);
  298.     IF ex=999 THEN BEGIN                      { Ausweitung }
  299.       ex:=5; IF UserUscale THEN ex:=0;
  300.     END;
  301.     uscale(x1, x2, y1, y2, Origin, AngleTrue, ex);
  302.   END;
  303.  
  304.   PROCEDURE MakeAxis;                   { Achsen bestellen }
  305.   BEGIN
  306.     IF xscal IN [linear, lineardown] THEN { x-Achse linear }
  307.       XAxis(x1, x2, xtitel, Defaultfont, 1);
  308.     IF yscal IN [linear, lineardown] THEN { y-Achse linear }
  309.       YAxis(y1, y2, ytitel, Defaultfont, 1);
  310.     IF xscal IN [log, logdown] THEN         { x-Achse log. }
  311.       LogXAxis(x1, x2, xtitel, Defaultfont, 1);
  312.     IF yscal IN [log, logdown] THEN         { y-Achse log. }
  313.       LogYAxis(y1, y2, ytitel, Defaultfont, 1);
  314.     XGrid(0);                                   { Nullinie }
  315.     YGrid(0);
  316.   END;
  317.  
  318. BEGIN
  319.   Scale;
  320.   IF Nr=1 THEN BEGIN             { Uscale bei erster Kurve }
  321.     OpenGraphik;
  322.     h:=TextHeight('Mg');
  323.     GraphikWindow(5*h, GetMaxX-4*h, 4*h, GetMaxY-2*h);
  324.     MakeUscale;
  325.     MakeAxis;
  326.   END;
  327.   IF Nr<0 THEN MakeUscale;               { Uscale wechseln }
  328.   Curve(x, y, n, Lintyp, Thickness, Color);
  329.   IF (CurvexCol IN [0..15]) THEN Curvex(x, y, n, CurvexCol);
  330.   IF Nr=999 THEN CloseGraphik;              { letztes Bild }
  331. END;
  332.  
  333. PROCEDURE ManualScaling;        { Menü zur Achsenanpassung }
  334. VAR Msg: strg80;
  335.  
  336.   PROCEDURE expand(VAR a, b: REAL; p: REAL;
  337.                    zscal: ScaleTyp);
  338.   VAR zz, z1, z2: REAL;
  339.   BEGIN                           { Vergrößern/Verkleinern }
  340.     z1:=a; z2:=b;
  341.     IF zscal IN [log, logdown] THEN
  342.     BEGIN z1:=LOG10(a); z2:=LOG10(b); END;
  343.     zz:=Abs(z2-z1)*0.005*p; IF z1>z2 THEN zz:=-zz;
  344.     z1:=z1-zz; z2:=z2+zz;
  345.     IF zscal IN [log, logdown] THEN
  346.     BEGIN z1:=exp10(z1); z2:=exp10(z2); END;
  347.     a:=z1; b:=z2;
  348.   END;
  349.  
  350.   PROCEDURE WriteValues;       { Achsenausdehnung anzeigen }
  351.   VAR k: BYTE;
  352.   BEGIN
  353.     IF UserUscale THEN InfoLine(
  354.       'Benutzereigenes Koordinatensystem', 4, White, Black)
  355.     ELSE
  356.       InfoLine('Automatische Skalierung', 4, White, Black);
  357.     TextBackground(Black); TextColor(Yellow);
  358.     WriteLn(#13#10);
  359.     WriteLn('                     Achsenausdehnung        ',
  360.             '    Größe');
  361.     WriteLn('                   Minimum        Maximum   ');
  362.     FOR k:=1 TO 75 DO Write('-'); WriteLn(#13#10);
  363.     WriteLn('X-Achse:      ', FORMAT(xmin, 12), '   ',
  364.             FORMAT(xmax,12), '         ', xTxt, #13#10);
  365.     WriteLn('Y-Achse:      ', FORMAT(ymin, 12), '   ',
  366.           FORMAT(ymax,12), '         ', yTxt, #13#10#10#10);
  367.   END;
  368.  
  369.   PROCEDURE FindExtrema(z: Vektor; n: WORD; zscal: ScaleTyp;
  370.                         VAR zmin, zmax: REAL);
  371.   BEGIN
  372.     IF zscal IN [linear, lineardown] THEN
  373.       extrema(z, n, zmin, zmax)
  374.     ELSE ExtremaAbs(z, n, zmin, zmax);
  375.   END;
  376.  
  377. BEGIN
  378.   TextBackground(0); ClrScr;
  379.   InfoLine('Manuelle Skalierung', 2, Black, White);
  380.   InfoLine('(X)-Achse (Y)-Achse (W)inkeltreu (A)utomatik'+
  381.            ' (+) Größer (-) Kleiner (ESC) Ende',
  382.            3, Black, White);
  383.   IF NOT UserUscale THEN BEGIN
  384.     FindExtrema(x, n, xscal, xmin, xmax);
  385.     FindExtrema(y, n, yscal, ymin, ymax);
  386.   END;
  387.   WriteValues;
  388.   REPEAT
  389.     TextColor(White); TextBackground(Black); InKey;
  390.     CASE ch OF
  391.       'A': BEGIN
  392.              UserUscale:=FALSE;           { Autoskalierung }
  393.              FindExtrema(x, n, xscal, xmin, xmax);
  394.              FindExtrema(y, n, yscal, ymin, ymax);
  395.            END;
  396.       'W': BEGIN
  397.              AngleTrue:=NOT AngleTrue;       { Winkeltreue }
  398.              IF AngleTrue THEN
  399.                InfoLine('Winkeltreue', 23, 0, 15)
  400.               ELSE InfoLine('Winkeltreue AUS', 23, 0, 15);
  401.            END;
  402.       'X': BEGIN                            { x-Ausdehnung }
  403.              UserUscale:=TRUE; AngleTrue:=FALSE;
  404.              Write('X-Achse minimum: ');
  405.              ClrEol; ReadLn(xmin);
  406.              Write('        maximum: ');
  407.              ClrEol; ReadLn(xmax);
  408.              IF (xscal IN [log, logdown]) AND ((xmin<=0) OR
  409.                 (xmax<=0)) OR (xmin=xmax) THEN BEGIN
  410.                Write(#7);
  411.                FindExtrema(x, n, xscal, xmin, xmax);
  412.              END;
  413.            END;
  414.       'Y': BEGIN                            { y-Ausdehnung }
  415.              UserUscale:=TRUE; AngleTrue:=FALSE;
  416.              Write('Y-Achse minimum: ');
  417.              ClrEol; ReadLn(ymin);
  418.              Write('        maximum: ');
  419.              ClrEol; ReadLn(ymax);
  420.              IF (yscal IN [log, logdown]) AND ((ymin<=0) OR
  421.                 (ymax<=0)) OR (ymin=ymax) THEN BEGIN
  422.                Write(#7);
  423.                FindExtrema(y, n, yscal, ymin, ymax);
  424.              END;
  425.            END;
  426.       '-': BEGIN                             { Verkleinern }
  427.             UserUscale:=TRUE;
  428.              InfoLine('Kurve um 10 % verkleinert',
  429.                       23, 0, 15);
  430.              expand(xmin, xmax, 10, xscal);
  431.              expand(ymin, ymax, 10, yscal);
  432.            END;
  433.       '+': BEGIN                              { Vergrößern }
  434.              UserUscale:=TRUE;
  435.              InfoLine('Kurve um 10 % vergrößert',
  436.                       23, 0, 15);
  437.              expand(xmin, xmax, -10, xscal);
  438.              expand(ymin, ymax, -10, yscal);
  439.            END;
  440.     END;
  441.     WriteValues;
  442.   UNTIL ESC;
  443.   ESC:=FALSE;
  444. END;
  445.  
  446. {----------------------------------------------------------}
  447. {           Hauptprogramm: Anwendungsbeispiele             }
  448. {----------------------------------------------------------}
  449.  
  450. BEGIN
  451.   Geraet:=Bildschirm;
  452.   Randomize;
  453.   a:=-2*Pi; b:=2*Pi; n:=100;          { Datensatz erzeugen }
  454.   FOR i:=1 TO n DO BEGIN
  455.     x[i]:=(i-1)*(b-a)/n+a;
  456.     y[i]:=Sin(1.5*x[i])+2*Cos(2.5*x[i])-0.5;
  457.     x[i]:=x[i]*(1.0+0.05*Random);               { Rauschen }
  458.     y[i]:=y[i]*(1.0+0.2*Random);
  459.     z[i]:=Sqrt(x[i]*x[i]+y[i]*y[i]);
  460.   END;
  461.   DataEditor(x, y, z, n, 'A', 'B', 'Betrag', linear,
  462.              linear, TRUE);
  463.   DataEditor(x, y, z, n, 'x [ppm]', 'y-Signal', 'z', linear,
  464.              log, FALSE);
  465.   RestoreCRTMode;
  466. END.
  467.