home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 10 / ldm / dataed2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-09-06  |  23.3 KB  |  727 lines
  1. (* ------------------------------------------------------ *)
  2. (*                     DATAED2.PAS                        *)
  3. (*    Grafik- und Histogrammgestützte Meßdateneditoren    *)
  4. (*           (C) 1990 Peter Kurzweil & TOOLBOX            *)
  5. (* ------------------------------------------------------ *)
  6.  
  7. PROGRAM Messdateneditor;
  8.  
  9. USES Crt, Dos, Printer, Graph, PGRAPH;
  10.  
  11. TYPE
  12.   ScaleTyp = (linear, lineardown, log, logdown);
  13. CONST
  14.   GraphActiv: BOOLEAN=FALSE;
  15. VAR
  16.   ESC, UP, DOWN, LEFT, RIGHT, RETURN: BOOLEAN;
  17.   ch: CHAR;
  18.   x, y, z: Vektor; a, b: REAL; i, n: WORD; { Stützstellen }
  19.  
  20. PROCEDURE SMOOTH(VAR z, x, y: Vektor;
  21.          VAR n: WORD; Nr: BYTE;
  22.              Titel1, Titel2, zTxt, xTxt, yTxt: strg80);
  23.                  FORWARD;
  24. PROCEDURE DataEditor(VAR x, y, z: Vektor;
  25.                      VAR n: WORD;
  26.                      xTxt, yTxt, zTxt: strg80;
  27.                      xscal, yscal: ScaleTyp;
  28.                      AngleTrue: BOOLEAN); FORWARD;
  29. PROCEDURE Graphik(x, y: Vektor;
  30.                   n: WORD;
  31.                   xtitel, ytitel: strg80;
  32.                   x1, x2, y1, y2: REAL;
  33.                   UserUscale: BOOLEAN;
  34.                   xscal, yscal: ScaleTyp;
  35.                   Origin, AngleTrue: BOOLEAN;
  36.                   ex: REAL;
  37.                   Lintyp, Thickness, Color, CurvexCol: BYTE;
  38.                   Nr: INTEGER); FORWARD;
  39. PROCEDURE ManualScaling(x, y: Vektor; n: WORD;
  40.                         VAR xmin, xmax, ymin, ymax: REAL;
  41.                         VAR UserUscale, AngleTrue: BOOLEAN;
  42.              xTxt, yTxt: strg80;
  43.             xscal, yscal: ScaleTyp); FORWARD;
  44.  
  45. {---------------------- Hilfsroutinen -------------------- }
  46.  
  47. FUNCTION FORMAT(x:REAL; f:BYTE): strg80;    { Zahlenformat }
  48. VAR S: strg80;
  49. BEGIN                                         { Gleitkomma }
  50.   IF Abs(LOG10(x))<=5 THEN Str(x:f:5,S) ELSE
  51.   BEGIN                                         { E-Format }
  52.     Str(x:f,S);
  53.     WHILE Length(S)>f DO Delete(S,Pos('E',S)+2,1);
  54.     WHILE Length(S)>f DO Delete(S,Pos('E',S)-1,1);
  55.   END;
  56.   FORMAT:=S;
  57. END;
  58.  
  59. FUNCTION SFORMAT(S: strg80; len: BYTE): strg80;
  60. VAR i,k:BYTE; S1:strg80;
  61. BEGIN
  62.   WHILE Length(S)>len DO Delete(S, Length(S), 1);
  63.   WHILE S[1]=#32 DO Delete(S, 1, 1); S1:=S;
  64.   k:=(len-Length(S)) DIV 2; S:='';
  65.   FOR i:=1 TO k DO S:=S+#32; S:=S+S1;
  66.   FOR i:=Length(S)+1 TO len DO S:=S+#32;
  67.   SFORMAT:=S;
  68. END;
  69.  
  70. PROCEDURE InKey;                         { Tastaturabfrage }
  71. VAR Regs: Registers;
  72. BEGIN
  73.   UP:=FALSE; DOWN:=FALSE; LEFT:=FALSE; RIGHT:=FALSE;
  74.   RETURN:=FALSE; ESC:=FALSE;
  75.   Regs.AX:=$0C00; MsDos(Regs);     { Lösche Tastaturpuffer }
  76.   ch:=UpCase(ReadKey);
  77.   CASE ch OF
  78.     #0:  BEGIN
  79.            ch:=ReadKey;
  80.        CASE ch OF
  81.              #$48:  UP:=TRUE;                  { Cursor UP }
  82.          #$50:  DOWN:=TRUE;              { Cursor DOWN }
  83.          #$4B:  LEFT:=TRUE;              { Cursor LEFT }
  84.          #$4D:  RIGHT:=TRUE             { Cursor RIGHT }
  85.        END;
  86.        ch:=#32;
  87.          END;
  88.     #13: RETURN:=TRUE;                                  { CR }
  89.     #27: ESC:=TRUE;                                    { ESC }
  90.   END;
  91. END;
  92.  
  93. PROCEDURE SwapMinMax(VAR x1, x2: REAL);      { Vertauschen }
  94. VAR h: REAL;                                 {   x1 < x2   }
  95. BEGIN
  96.   IF x1>x2 THEN BEGIN h:=x1; x1:=x2; x2:=h; END;
  97. END;
  98.  
  99. PROCEDURE SwapMaxMin(VAR x1, x2: REAL);      { Vertauschen }
  100. VAR h: REAL;                                 {   x1 > x2   }
  101. BEGIN
  102.   IF x1<x2 THEN BEGIN h:=x1; x1:=x2; x2:=h; END;
  103. END;
  104.  
  105. PROCEDURE ExtremaAbs(z: Vektor; n: WORD;
  106.                      VAR zmin, zmax: REAL);
  107. VAR i: WORD; a: REAL;
  108. BEGIN
  109.   zmin:=Abs(z[1]); zmax:=zmin;
  110.   FOR i:=2 TO n DO BEGIN
  111.     a:=Abs(z[i]);
  112.     IF a<zmin THEN zmin:=a;
  113.     IF a>zmax THEN zmax:=a;
  114.   END;
  115. END;
  116.  
  117. PROCEDURE InfoLine(Msg: strg80; Line, TCol, BCol: BYTE);
  118. VAR k: BYTE;                      { Zentrierte Textausgabe }
  119. BEGIN
  120.   TextColor(TCol); TextBackground(BCol);
  121.   k:=(80-Length(Msg)+1) DIV 2;
  122.   GotoXY(1, Line); ClrEol; GotoXY(k, Line); Write(Msg);
  123. END;
  124.  
  125. {----------------------------------------------------------}
  126. {               Graphikgestützer Meßdateneditor            }
  127. {----------------------------------------------------------}
  128.  
  129. {$F+}
  130. PROCEDURE CloseGraphik;   { Verbesserte Version für PGRAPH }
  131. BEGIN
  132.   GraphActiv:=FALSE;
  133.   CloseGraph;
  134. END;
  135. {$F-}
  136.  
  137. PROCEDURE OpenGraphik;    { Verbesserte Version für PGRAPH }
  138. BEGIN                      { Schutz vor mehrmaligem Öffnen }
  139.   IF GraphActiv THEN CloseGraphik;
  140.   GraphActiv:=TRUE; GraphDriver:=Detect;
  141.   InitGraph(GraphDriver, GraphMode, '');
  142.   IF GraphResult<>grOk THEN BEGIN
  143.     WriteLn('FEHLER: ', GraphErrorMsg(ErrorCode)); Halt;
  144.   END;
  145.   IF GraphDriver IN [1, 2, 7] THEN BEGIN
  146.     Black:=0; Blue:=7; Green:=15; Cyan:=15; Red:=15;
  147.     Magenta:=15; Brown:=15; LightGray:=7; DarkGray:=15;
  148.     LightBlue:=15; LightGreen:=15; LightCyan:=15;
  149.     LightRed:=15; LightMagenta:=15; Yellow:=15; White:=15;
  150.   END;
  151.   Uaxmin:=0; Uaxmax:=GetMaxX; Vaxmin:=0; Vaxmax:=GetMaxY;
  152. END;
  153.  
  154. PROCEDURE Cross(x, y: REAL);                  { Fadenkreuz }
  155. CONST len=12;
  156. VAR u, v: INTEGER;
  157. BEGIN
  158.   SetWriteMode(XORPut);
  159.   SetColor(White); Scale(x, y, u, v);
  160.   Line(u-len, v, u+len, v); Line(u, v-len, u, v+len);
  161.   PutPixel(u, v, White);
  162.   SetWriteMode(NormalPut);
  163. END;
  164.  
  165. PROCEDURE InfoLineGraphik(Msg: strg80; Line, Color: BYTE);
  166. VAR h, len, x: WORD;         { Textausgabe im Graphikmodus }
  167. BEGIN
  168.   SetColor(Color); SetTextStyle(Defaultfont, HorizDir, 1);
  169.   SetTextJustify(CenterText, CenterText);
  170.   h:=(GetMaxY DIV 24);
  171.   len:=TextWidth(Msg+'MM') DIV 2; x:=(GetMaxX DIV 2);
  172.   IF Line>=25 THEN
  173.     SetViewPort(0, GetMaxY-h, GetMaxX, GetMaxY, TRUE)
  174.   ELSE SetViewPort(x-len, (Line-1)*h, x+len, Line*h, TRUE);
  175.   ClearViewPort;
  176.   SetViewPort(0, 0, GetMaxX, GetMaxY, TRUE);
  177.   OutTextXY(x, Trunc((Line-0.5)*h), Msg);
  178. END;
  179.  
  180. PROCEDURE DataEditor;   { Graphikgestützter Meßdateneditor }
  181. VAR
  182.   Msg, S: strg80; i: INTEGER; k, i1, i2: WORD;
  183.   x1, x2, y1, y2, a, b, r, da, db, xo, xm, ym, sx, sy: REAL;
  184.   xx, yy: Vektor;
  185.   UserUscale: BOOLEAN; lx, ly: STRING[4];
  186.  
  187.   PROCEDURE Reset;                            { Bildaufbau }
  188.   BEGIN
  189.     Graphik(x, y, n, xTxt, yTxt, x1, x2, y1, y2, UserUscale,
  190.             xscal, yscal, FALSE, AngleTrue, 999, SolidLn,
  191.             NormWidth, Yellow, White, 001);
  192.     InfoLineGraphik('(CURSOR) Kreuz bewegen, (SHIFT CURSOR)'
  193.                  +' schnell bewegen, (ESC) Ende', 1, White);
  194.     InfoLineGraphik('(L)öschen, (A)chsen anpassen,'+
  195.                     ' (N)eu zeichnen', 2, White);
  196.     InfoLineGraphik(xTxt, 24, White);
  197.   END;
  198.  
  199. BEGIN
  200.   UserUscale:=FALSE; Reset;
  201.   lx:=''; ly:=''; i:=1; i1:=0; i2:=0;
  202.   IF xscal IN [linear, lineardown] THEN xx:=x;
  203.   IF yscal IN [linear, lineardown] THEN yy:=y;
  204.   IF xscal IN [log, logdown] THEN BEGIN
  205.     FOR k:=1 TO n DO xx[k]:=LOG10(x[k]); lx:='log ';
  206.   END;
  207.   IF yscal IN [log, logdown] THEN BEGIN
  208.     FOR k:=1 TO n DO yy[k]:=LOG10(y[k]); ly:='log ';
  209.   END;
  210.   Cross(xx[i], yy[i]);
  211.   REPEAT
  212.     Str(i, S);                              { Zahlenleiste }
  213.     Msg:='Wert-Nr. '+S+#32#32+xTxt+' = '+FORMAT(x[i],8)+
  214.      #32#32+yTxt+' = '+FORMAT(y[i],8)+#32#32+zTxt+' = '+
  215.      FORMAT(z[i], 8);
  216.     InfoLineGraphik(Msg, 25, White);
  217.     InKey;
  218.     Cross(xx[i], yy[i]);
  219.     IF UP OR LEFT THEN                      { Cursortasten }
  220.       IF i>1 THEN
  221.         Dec(i);
  222.     IF DOWN OR RIGHT THEN
  223.       IF i<n THEN
  224.         Inc(i);
  225.     CASE ch OF                             { Steuerzeichen }
  226.       '8','4': BEGIN
  227.                  i:=i-5;
  228.          IF i<=1 THEN BEGIN i:=1;
  229.            Curve(xx, yy, n, SolidLn,
  230.                          NormWidth, Yellow);
  231.          END;
  232.            END;
  233.       '6','2': BEGIN
  234.                  i:=i+5;
  235.          IF i>=n THEN BEGIN i:=n;
  236.            Curve(xx, yy, n, SolidLn,
  237.                          NormWidth, Yellow);
  238.          END;
  239.            END;
  240.       'L':     BEGIN                    { Meßpunkt löschen }
  241.          IF n>3 THEN BEGIN
  242.            Curve(xx, yy, n, SolidLn,
  243.                          NormWidth, Black);
  244.            FOR k:=i+1 TO n DO BEGIN
  245.                      x[k-1]:=x[k]; y[k-1]:=y[k];
  246.                      z[k-1]:=z[k]; xx[k-1]:=xx[k];
  247.              yy[k-1]:=yy[k];
  248.            END;
  249.            n:=n-1; IF i>=n THEN i:=n;
  250.            Curve(xx, yy, n, SolidLn, NormWidth,
  251.                          Yellow);
  252.          END ELSE Write(#7);
  253.            END;
  254.       'N':     Reset;                  { Kurve auffrischen }
  255.       'A':     BEGIN                 { Manuelle Skalierung }
  256.          CloseGraphik;
  257.          ManualScaling(x, y, n, x1, x2, y1, y2,
  258.                                UserUscale, AngleTrue, xTxt,
  259.                                yTxt, xscal, yscal);
  260.          Reset;
  261.            END;
  262.     END;
  263.     Cross(xx[i], yy[i]);               { Kreuz verschieben }
  264.   UNTIL ESC;
  265.   CloseGraphik;
  266. END;
  267.  
  268. PROCEDURE Graphik;  { Treiberroutine für Graphikbibliothek }
  269. VAR h: INTEGER;
  270.  
  271.   PROCEDURE Scale;            { Skalierung für log. Achsen }
  272.   VAR i: WORD;
  273.   BEGIN
  274.     IF xscal IN [log, logdown] THEN
  275.       FOR i:=1 TO n DO x[i]:=LOG10(x[i]);
  276.     IF yscal IN [log, logdown] THEN
  277.       FOR i:=1 TO n DO y[i]:=LOG10(y[i]);
  278.   END;
  279.  
  280.   PROCEDURE MakeUscale;                { Koordinatensystem }
  281.   BEGIN
  282.     IF (NOT UserUscale) THEN BEGIN        { ...automatisch }
  283.       extrema(x, n, x1, x2); extrema(y, n, y1, y2);
  284.     END;
  285.     IF UserUscale THEN BEGIN               { ...vorgegeben }
  286.       IF xscal IN [log, logdown] THEN BEGIN
  287.         x1:=LOG10(x1); x2:=LOG10(x2);
  288.       END;
  289.       IF yscal IN [log, logdown] THEN BEGIN
  290.         y1:=LOG10(y1); y2:=LOG10(y2);
  291.       END;
  292.     END;
  293.     IF xscal IN [lineardown, logdown] THEN
  294.       SwapMaxMin(x1, x2);
  295.     IF yscal IN [lineardown, logdown] THEN
  296.       SwapMaxMin(y1, y2);
  297.     IF xscal IN [linear, log] THEN SwapMinMax(x1, x2);
  298.     IF yscal IN [linear, log] THEN SwapMinMax(y1, y2);
  299.     IF ex=999 THEN BEGIN                      { Ausweitung }
  300.       ex:=5; IF UserUscale THEN ex:=0;
  301.     END;
  302.     uscale(x1, x2, y1, y2, Origin, AngleTrue, ex);
  303.   END;
  304.  
  305.   PROCEDURE MakeAxis;                   { Achsen bestellen }
  306.   BEGIN
  307.     IF xscal IN [linear, lineardown] THEN { x-Achse linear }
  308.       XAxis(x1, x2, xtitel, Defaultfont, 1);
  309.     IF yscal IN [linear, lineardown] THEN { y-Achse linear }
  310.       YAxis(y1, y2, ytitel, Defaultfont, 1);
  311.     IF xscal IN [log, logdown] THEN         { x-Achse log. }
  312.       LogXAxis(x1, x2, xtitel, Defaultfont, 1);
  313.     IF yscal IN [log, logdown] THEN         { y-Achse log. }
  314.       LogYAxis(y1, y2, ytitel, Defaultfont, 1);
  315.     XGrid(0);                                   { Nullinie }
  316.     Ygrid(0);
  317.   END;
  318.  
  319. BEGIN
  320.   Scale;
  321.   IF Nr=1 THEN BEGIN             { Uscale bei erster Kurve }
  322.     OpenGraphik;
  323.     h:=TextHeight('Mg');
  324.     GraphikWindow(5*h, GetMaxX-4*h, 4*h, GetMaxY-2*h);
  325.     MakeUscale;
  326.     MakeAxis;
  327.   END;
  328.   IF Nr<0 THEN BEGIN MakeUscale; END;    { Uscale wechseln }
  329.   Curve(x, y, n, Lintyp, Thickness, Color);
  330.   IF (CurvexCol IN [0..15]) THEN Curvex(x, y, n, CurvexCol);
  331.   IF Nr=999 THEN CloseGraphik;              { letztes Bild }
  332. END;
  333.  
  334. PROCEDURE ManualScaling;        { Menü zur Achsenanpassung }
  335. VAR Msg: strg80;
  336.  
  337.   PROCEDURE expand(VAR a, b: REAL; p: REAL;
  338.                    zscal: ScaleTyp);
  339.   VAR zz, z1, z2: REAL;
  340.   BEGIN                           { Vergrößern/Verkleinern }
  341.     z1:=a; z2:=b;
  342.     IF zscal IN [log, logdown] THEN
  343.     BEGIN z1:=LOG10(a); z2:=LOG10(b); END;
  344.     zz:=Abs(z2-z1)*0.005*p; IF z1>z2 THEN zz:=-zz;
  345.     z1:=z1-zz; z2:=z2+zz;
  346.     IF zscal IN [log, logdown] THEN
  347.     BEGIN z1:=exp10(z1); z2:=exp10(z2); END;
  348.     a:=z1; b:=z2;
  349.   END;
  350.  
  351.   PROCEDURE WriteValues;       { Achsenausdehnung anzeigen }
  352.   VAR k: BYTE;
  353.   BEGIN
  354.     IF UserUscale THEN InfoLine(
  355.       'Benutzereigenes Koordinatensystem', 4, White, Black)
  356.     ELSE
  357.       InfoLine('Automatische Skalierung', 4, White, Black);
  358.     TextBackground(Black); TextColor(Yellow);
  359.     WriteLn(#13#10);
  360.     WriteLn('                     Achsenausdehnung        ',
  361.             '    Größe');
  362.     WriteLn('                   Minimum        Maximum   ');
  363.     FOR k:=1 TO 75 DO Write('-'); WriteLn(#13#10);
  364.     WriteLn('X-Achse:      ', FORMAT(xmin, 12), '   ',
  365.             FORMAT(xmax,12), '         ', xTxt, #13#10);
  366.     WriteLn('Y-Achse:      ', FORMAT(ymin, 12), '   ',
  367.           FORMAT(ymax,12), '         ', yTxt, #13#10#10#10);
  368.   END;
  369.  
  370.   PROCEDURE FindExtrema(z: Vektor; n: WORD; zscal: ScaleTyp;
  371.                         VAR zmin, zmax: REAL);
  372.   BEGIN
  373.     IF zscal IN [linear, lineardown] THEN
  374.      extrema(z, n, zmin, zmax)
  375.     ELSE ExtremaAbs(z, n, zmin, zmax);
  376.   END;
  377.  
  378. BEGIN
  379.   TextBackground(0); ClrScr;
  380.   InfoLine('Manuelle Skalierung', 2, Black, White);
  381.   InfoLine('(X)-Achse (Y)-Achse (W)inkeltreu (A)utomatik'+
  382.            ' (+) Größer (-) Kleiner (ESC) Ende',
  383.            3, Black, White);
  384.   IF NOT UserUscale THEN BEGIN
  385.     FindExtrema(x, n, xscal, xmin, xmax);
  386.     FindExtrema(y, n, yscal, ymin, ymax);
  387.   END;
  388.   WriteValues;
  389.   REPEAT
  390.     TextColor(White); TextBackground(Black); InKey;
  391.     CASE ch OF
  392.       'A': BEGIN
  393.              UserUscale:=FALSE;           { Autoskalierung }
  394.                FindExtrema(x, n, xscal, xmin, xmax);
  395.              FindExtrema(y, n, yscal, ymin, ymax);
  396.        END;
  397.       'W': BEGIN
  398.              AngleTrue:=NOT AngleTrue;       { Winkeltreue }
  399.              IF AngleTrue THEN
  400.                InfoLine('Winkeltreue', 23, 0, 15)
  401.                 ELSE InfoLine('Winkeltreue AUS', 23, 0, 15);
  402.            END;
  403.       'X': BEGIN                            { x-Ausdehnung }
  404.              UserUscale:=TRUE; AngleTrue:=FALSE;
  405.              Write('X-Achse minimum: ');
  406.              ClrEol; ReadLn(xmin);
  407.              Write('        maximum: ');
  408.              ClrEol; ReadLn(xmax);
  409.              IF (xscal IN [log,logdown]) AND ((xmin<=0) OR
  410.                 (xmax<=0)) OR (xmin=xmax) THEN BEGIN
  411.                Write(#7); 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); FindExtrema(y,n,yscal,ymin,ymax);
  423.              END;
  424.        END;
  425.       '-': BEGIN                             { Verkleinern }
  426.               UserUscale:=TRUE;
  427.              InfoLine('Kurve um 10 % verkleinert',
  428.                       23, 0, 15);
  429.              expand(xmin, xmax, 10, xscal);
  430.              expand(ymin, ymax, 10, yscal);
  431.            END;
  432.       '+': BEGIN                              { Vergrößern }
  433.               UserUscale:=TRUE;
  434.              InfoLine('Kurve um 10 % vergrossert',
  435.                23, 0, 15);
  436.            expand(xmin,xmax,-10,xscal);
  437.              expand(ymin,ymax,-10,yscal);
  438.            END;
  439.     END;
  440.     WriteValues;
  441.   UNTIL ESC;
  442.   ESC:=FALSE;
  443. END;
  444.  
  445. {----------------------------------------------------------}
  446. {            Histogrammgestützter Meßdateneditor           }
  447. {----------------------------------------------------------}
  448.  
  449. FUNCTION HistoLine(y: Vektor; ymin, ymax: REAL; i, W: WORD):
  450.              strg80;                  { Hilfsroutine }
  451. VAR PosX, PosP, k: INTEGER; S: strg80;   { Histogrammzeile }
  452. BEGIN
  453.   S:=''; {$R-}
  454.   PosX:=Trunc(-ymin/(ymax-ymin)*W+1.5);
  455.   IF PosX>W+1 THEN PosX:=W+1;
  456.   IF PosX<0   THEN PosX:=1;
  457.   PosP:=2;
  458.   IF (ymax-ymin)<>0 THEN
  459.     PosP:=Trunc((y[i]-ymin)/(ymax-ymin)*W+1.5);
  460.   IF y[i]<0 THEN BEGIN
  461.     FOR k:=1 TO PosP-1  DO S:=S+'.';
  462.     FOR k:=PosP TO PosX DO S:=S+Chr(254);
  463.   END;
  464.   IF y[i]>0 THEN BEGIN
  465.     FOR k:=1 TO PosX-1 DO S:=S+'.';
  466.     FOR k:=PosX TO PosP DO S:=S+Chr(254);
  467.   END;
  468.   HistoLine:=S; {$R+}
  469. END;
  470.  
  471. PROCEDURE HISTOGRAM(z, x, y: Vektor; n, i1, i2, Nr: WORD);
  472. VAR i: WORD; h: Vektor; hmin, hmax: REAL; S: strg80;
  473. BEGIN                                    { Histogrammseite }
  474.   CASE Nr OF
  475.     1: h:=z;
  476.     2: h:=x;
  477.     3: h:=y;
  478.   END;
  479.   extrema(h, n, hmin, hmax);
  480.   IF Abs(hmax-hmin)<1E-8 THEN BEGIN
  481.     hmin:=hmin*0.9; hmax:=hmax*1.1;
  482.   END;
  483.   FOR i:=i1 TO i2 DO BEGIN
  484.     S:=HistoLine(h, hmin, hmax, i, 46); ClrEol;
  485.     WriteLn(i:3, ' ', FORMAT(z[i],8), ' ', FORMAT(x[i],8),
  486.             ' ', FORMAT(y[i],8),' ',S);
  487.   END;
  488. END;
  489.  
  490. PROCEDURE QSORT3(VAR x, y, z: Vektor; n: WORD); {$R-,S-}
  491.   PROCEDURE sort(l, r: INTEGER);
  492.   VAR i, j: INTEGER; h, g: REAL;
  493.   BEGIN
  494.     i:=l; j:=r; g:=x[(l+r) DIV 2];
  495.     REPEAT
  496.       WHILE x[i]<g DO i:=Succ(i);
  497.       WHILE g<x[j] DO j:=Pred(j);
  498.       IF i<=j THEN BEGIN
  499.         h:=x[i]; x[i]:=x[j]; x[j]:=h;
  500.         h:=y[i]; y[i]:=y[j]; y[j]:=h;
  501.         h:=z[i]; z[i]:=z[j]; z[j]:=h;
  502.         i:=Succ(i); j:=Pred(j);
  503.       END;
  504.     UNTIL i>j;
  505.     IF l<j THEN sort(l, j);
  506.     IF i<r THEN sort(i, r);
  507.   END;
  508.  
  509. BEGIN
  510.   sort(1, n);
  511. END; {$R+,S+}
  512.  
  513. PROCEDURE QSORT3DOWN(VAR x, y, z: Vektor; n: WORD); {$R-,S-}
  514.   PROCEDURE sort(l, r: INTEGER);
  515.   VAR i, j: INTEGER; h, g: REAL;
  516.   BEGIN
  517.     i:=l; j:=r; g:=x[(l+r) DIV 2];
  518.     REPEAT
  519.       WHILE x[i]>g DO i:=Succ(i);
  520.       WHILE g>x[j] DO j:=Pred(j);
  521.       IF i<=j THEN BEGIN
  522.         h:=x[i]; x[i]:=x[j]; x[j]:=h;
  523.         h:=y[i]; y[i]:=y[j]; y[j]:=h;
  524.         h:=z[i]; z[i]:=z[j]; z[j]:=h;
  525.         i:=Succ(i); j:=Pred(j);
  526.       END;
  527.     UNTIL i>j;
  528.     IF l<j THEN sort(l, j);
  529.     IF i<r THEN sort(i, r);
  530.   END;
  531. BEGIN
  532.   sort(1, n);
  533. END; {$R+,S+}
  534.  
  535. PROCEDURE HISTOGRAMLst(z, x, y: Vektor; n, Nr: WORD;
  536.           Titel1, Titel2, ZTxt, XTxt, YTxt: strg80);
  537. VAR i: WORD; h: Vektor; hmin, hmax: REAL; S: strg80;
  538. BEGIN
  539.   {$I-} WriteLn(Lst); {$I+}              { Drucker online? }
  540.   IF IOResult<>0 THEN Exit;
  541.   CASE Nr OF
  542.     1: h:=z;
  543.     2: h:=x;
  544.     3: h:=y;
  545.   END;
  546.   WriteLn(Lst, SFORMAT(Titel1,80), #13#10#10);
  547.   WriteLn(Lst, #32#32#32#32, ZTxt, XTxt, YTxt,
  548.           Titel2, #13#10);
  549.   Extrema(h, n, hmin, hmax);
  550.   IF hmin=hmax THEN BEGIN
  551.     hmin:=hmin*0.9; hmax:=hmax*1.1;
  552.   END;
  553.   FOR i:=1 TO n DO BEGIN
  554.     S:=HistoLine(h, hmin, hmax, i, 46);
  555.     WriteLn(Lst, i:3, ' ', FORMAT(z[i],8), ' ',
  556.             FORMAT(x[i],8), ' ', FORMAT(y[i],8), ' ', S);
  557.   END;
  558. END;
  559.  
  560. PROCEDURE SMOOTH;     { Histogrammgestützer Meßdateneditor }
  561. VAR
  562.   Line, L, i, YPos: BYTE; Msg: strg80; ch1: CHAR;
  563.   T: ARRAY[1..3] OF STRING[10];
  564.  
  565.   PROCEDURE Normal;                  { Bildschirmattribute }
  566.   BEGIN
  567.     TextColor(7); TextBackground(0);
  568.   END;
  569.  
  570.   PROCEDURE Invers;
  571.   BEGIN
  572.     TextColor(0); TextBackground(15);
  573.   END;
  574.  
  575.   PROCEDURE Histo(FirstPage: BOOLEAN);        { Bildaufbau }
  576.   VAR i1, i2: BYTE;
  577.   BEGIN
  578.     IF FirstPage THEN BEGIN
  579.       L:=1; Line:=1; YPos:=1; Normal; ClrScr;
  580.     END;
  581.     GotoXY(1, 1); Normal;
  582.     i1:=L-YPos+1; i2:=L+(18-YPos);
  583.     WHILE i2>n DO i2:=i2-1;
  584.     HISTOGRAM(z, x, y, n, i1, i2, Nr);
  585.     GotoXY(1, YPos); Invers;
  586.     HISTOGRAM(z, x, y, n, L, L, Nr); GotoXY(1, YPos);
  587.   END;
  588.  
  589.   PROCEDURE Header;                        { Bediener-Kopf }
  590.   BEGIN
  591.     Normal; ClrScr; InfoLine(Titel1, 2, White, black);
  592.     Msg:='(L)öschen (S)ortieren (Ä)ndern (D)rucken '+
  593.          '(H)isto (E)xakt  (ESC) Exit';
  594.     InfoLine(Msg, 3, 0, 15); GotoXY(1, 5); Normal;
  595.     Write('  i ', T[1], T[2], T[3], Titel2);
  596.     Window(1, 6, 80, 24); Histo(TRUE);
  597.   END;
  598.  
  599. BEGIN
  600.   T[1]:=SFORMAT(ZTxt, 9); T[2]:=SFORMAT(XTxt, 9);
  601.   T[3]:=SFORMAT(YTxt, 9);
  602.   Header;
  603.   REPEAT
  604.     Inkey;
  605.     IF Up THEN BEGIN                     { Zeile nach oben }
  606.       IF L>1 THEN BEGIN
  607.         Normal; HISTOGRAM(z, x, y, n, L, L, Nr);
  608.         L:=L-1; Line:=Line-1;
  609.         IF Line<1 THEN BEGIN
  610.          Line:=1; GotoXY(1, 1); InsLine;
  611.         END;
  612.     GotoXY(1, Line); Invers;
  613.         HISTOGRAM(z, x, y, n, L, L, Nr);
  614.         GotoXY(1, Line);
  615.       END;
  616.     END;
  617.     IF Down THEN BEGIN                  { Zeile nach unten }
  618.       IF L<n THEN BEGIN
  619.         Normal; HISTOGRAM(z, x, y, n, L, L, Nr);
  620.         L:=L+1; Line:=Line+1;
  621.         IF Line>=18 THEN BEGIN
  622.           Line:=18; WriteLn;
  623.         END;
  624.         GotoXY(1, Line); Invers;
  625.         HISTOGRAM(z, x, y, n, L, L, Nr);
  626.         GotoXY(1, Line);
  627.       END;
  628.     END;
  629.     CASE ch OF
  630.       'S': BEGIN                               { Sortieren }
  631.               YPos:=WhereY;
  632.            Msg:='Sortieren nach (1) '+T[1]+'  (2) '+T[2]+
  633.               '  (3) '+T[3];
  634.            InfoLine(Msg, 19, black, White);
  635.              Inkey; ch1:=ch;
  636.              Msg:='Sortieren (1) aufsteigend (2) absteigend';
  637.              InfoLine(Msg, 19, black, White); Inkey;
  638.              IF ch='2' THEN ch:=Chr(Ord(ch1)+3) ELSE
  639.                ch:=ch1;
  640.              CASE ch OF
  641.                '1': BEGIN QSort3(z, x, y, n);
  642.                     Histo(TRUE); END;
  643.                '2': BEGIN QSort3(x, z, y, n);
  644.                     Histo(TRUE); END;
  645.                '3': BEGIN QSort3(y, z, x, n);
  646.                     Histo(TRUE); END;
  647.                '4': BEGIN QSort3Down(z, x, y, n);
  648.                     Histo(TRUE); END;
  649.                   '5': BEGIN QSort3Down(x, z, y, n);
  650.                     Histo(TRUE); END;
  651.                '6': BEGIN QSort3Down(y, z, x, n);
  652.                     Histo(TRUE); END;
  653.              ELSE
  654.             BEGIN DelLine; GotoXY(1, YPos); END;
  655.            END;
  656.        END;
  657.       'H': BEGIN                          { Auftragungsart }
  658.             YPos:=WhereY;
  659.              Msg:='Zeichne  (1) '+T[1]+'  (2) '+T[2]+
  660.              '  (3) '+T[3];
  661.            InfoLine(Msg, 19, black, White);
  662.           Inkey;
  663.           CASE ch OF
  664.            '1': BEGIN Nr:=1; Header; END;
  665.                '2': BEGIN Nr:=2; Header; END;
  666.                '3': BEGIN Nr:=3; Header; END;
  667.              ELSE BEGIN DelLine; GotoXY(1,YPos); END;
  668.              END;
  669.            END;
  670.       'L': BEGIN                                 { Löschen }
  671.           YPos:=WhereY;
  672.              IF n>3 THEN BEGIN
  673.                FOR i:=L+1 TO n DO BEGIN
  674.                  z[i-1]:=z[i]; x[i-1]:=x[i]; y[i-1]:=y[i];
  675.                END;
  676.                n:=Pred(n); DelLine;
  677.                IF L<=n THEN Histo(FALSE) ELSE Histo(TRUE);
  678.              END;
  679.            END;
  680.       'ä': BEGIN                                  { Ändern }
  681.               YPos:=WhereY; Invers; GotoXY(1, 17);
  682.           Write(T[1],'= '); ClrEol; ReadLn(z[L]);
  683.              Write(T[2],'= '); ClrEol; ReadLn(x[L]);
  684.              Write(T[3],'= '); ClrEol; ReadLn(y[L]);
  685.              Histo(TRUE);
  686.        END;
  687.       'E': BEGIN                            { Genauer Wert }
  688.            YPos:=WhereY; Invers; GotoXY(1, 17);
  689.              ClrEol; WriteLn(T[1], ' = ', z[L]);
  690.              ClrEol; WriteLn(T[2], ' = ', x[L]);
  691.              ClrEol; Write(T[3], ' = ', y[L]);
  692.              Write('      Weiter mit RETURN'); Inkey;
  693.              Histo(TRUE);
  694.            END;
  695.       'D': HISTOGRAMLst(z, x, y, n, Nr, Titel1, Titel2,
  696.                  T[1], T[2], T[3]);
  697.     END;
  698.   UNTIL ESC;
  699. END;
  700.  
  701. {----------------------------------------------------------}
  702. {           Hauptprogramm: Anwendungsbeispiele          }
  703. {----------------------------------------------------------}
  704.  
  705. BEGIN
  706.   Geraet:=Bildschirm;
  707.   Randomize;
  708.   a:=-2*Pi; b:=2*Pi; n:=100;          { Datensatz erzeugen }
  709.   FOR i:=1 TO n DO BEGIN
  710.     x[i]:=(i-1)*(b-a)/n+a;
  711.     y[i]:=Sin(1.5*x[i])+2*Cos(2.5*x[i])-0.5;
  712.     x[i]:=x[i]*(1.0+0.05*Random);               { Rauschen }
  713.     y[i]:=y[i]*(1.0+0.2*Random);
  714.     z[i]:=Sqrt(x[i]*x[i]+y[i]*y[i]);
  715.   END;
  716.   DataEditor(x, y, z, n, 'A', 'B', 'Betrag', linear,
  717.            linear, TRUE);
  718.   DataEditor(x, y, z, n, 'x [ppm]', 'y-Signal', 'z', linear,
  719.              log, FALSE);
  720.   SMOOTH(x, y, z, n, 2,
  721.          'Histogrammgestützer Meßdateneditor',
  722.          'y = f(x)', 'x', 'y', 'z');
  723.   ClrScr;
  724. END.
  725.  
  726.  
  727.