home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 11 / dtp / bezanim.pas < prev    next >
Pascal/Delphi Source File  |  1990-10-04  |  9KB  |  326 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      BEZANIM.PAS                       *)
  3. (* Animiertes Demo zur Demonstration der Unit BEZIER.PAS  *)
  4. (*                Turbo Pascal 5.0 und 5.5                *)
  5. (*                   (c) 1990 TOOLBOX                     *)
  6. (* ------------------------------------------------------ *)
  7.  
  8. {$B-,D-,E-,F+,I-,L-,N-,O-,R-,S-,V-}
  9. {$M 16384,0,655360}
  10.  
  11. PROGRAM BezDemo;
  12.  
  13. USES Graph, Crt, Bezier, txKeys;
  14.  
  15. CONST BGIPath            = '';
  16.       CursorOK : BOOLEAN = TRUE;
  17.       AnzKurven          = 100;
  18.       PunktePerKurve     = 300;
  19.  
  20. TYPE  LineType           = ARRAY[1..PunktePerKurve] OF PointType;
  21.       LinePointer        = ^LineType;
  22.  
  23. VAR   i                 : WORD;
  24.       GD, GM, AnzPunkte : INTEGER;
  25.       Punkte            : BezPoints;
  26.       x, y, MaxY        : INTEGER;
  27.       DemoLineColor,
  28.       StartColor,
  29.       StuetzColor,
  30.       BezierColor       : WORD;
  31.       Taste             : KeyRec;
  32.       Kurve             : ARRAY[1..AnzKurven] OF LinePointer;
  33.  
  34.       KurveNr,
  35.       KurveIndex        : WORD;
  36.  
  37. PROCEDURE InitGrafik;
  38. BEGIN
  39.   DetectGraph(GD, GM);
  40.   CASE GD OF
  41.     MCGA,
  42.     CGA: BEGIN
  43.            GM            := CGAC0;
  44.            StartColor    := 3;
  45.            StuetzColor   := 2;
  46.            BezierColor   := 1;
  47.            DemoLineColor := 2;
  48.          END;
  49.     EGA,
  50.     EGA64,
  51.     VGA: BEGIN
  52.            StartColor    := Yellow;
  53.            StuetzColor   := LightRed;
  54.            BezierColor   := LightGreen;
  55.            DemoLineColor := Green;
  56.          END;
  57.     HercMono:
  58.          BEGIN
  59.            StartColor    := 1;
  60.            StuetzColor   := 1;
  61.            BezierColor   := 1;
  62.            DemoLineColor := 1;
  63.          END;
  64.   END;
  65.   InitGraph(GD, GM, BGIPath);
  66.   SetTextStyle(DefaultFont, HorizDir, 1);
  67.   SetTextJustify(CenterText, TopText);
  68.   MaxY:=GetMaxY - 3 * TextHeight('X');
  69.   SetColor(BezierColor);
  70.   Rectangle(0, 0, GetMaxX, MaxY);
  71.   Rectangle(0, MaxY, GetMaxX, GetMaxY);
  72.   SetViewPort(1, 1, GetMaxX-1, MaxY-1, TRUE);
  73. END;
  74.  
  75. PROCEDURE CloseGrafik;
  76. BEGIN
  77.   CloseGraph;
  78. END;
  79.  
  80. PROCEDURE SpeicherePunkte(x, y : BezRealTyp);  { Linie ziehen }
  81. BEGIN
  82.   Inc(KurveIndex);
  83.   Kurve[KurveNr]^[KurveIndex].x := Round(x);
  84.   Kurve[KurveNr]^[KurveIndex].y := Round(y);
  85.   WITH BezDat^ DO BEGIN
  86.     LastPoint.x := x;
  87.     LastPoint.y := y;
  88.   END;
  89. END;
  90.  
  91. PROCEDURE Schrift(Zeile1, Zeile2: STRING);
  92. { schreibt Text am unteren Bildschirmrand }
  93. BEGIN
  94.   SetViewPort(1, MaxY+1, GetMaxX-1, GetMaxY-1, ClipOn);
  95.   ClearViewPort;
  96.   SetColor(StartColor);
  97.   OutTextXY(GetMaxX DIV 2, 1, Zeile1);
  98.   OutTextXY(GetMaxX DIV 2,
  99.             3*TextHeight('X') DIV 2+1, Zeile2);
  100.   SetViewPort(1, 1, GetMaxX-1, MaxY-1, ClipOn);
  101. END;
  102.  
  103. PROCEDURE Add(VAR Source: INTEGER; Min, Max: INTEGER;
  104.               Step: SHORTINT; Wrap: BOOLEAN);
  105.  { Add erhöht oder erniedrigt die als "Source" übergebene
  106.    Variable. Min und Max sind die erlaubten Grenzen, Wrap
  107.    schaltet das Wrapping bei Über- und Unterschreitung
  108.    der zulässigen Minimal- oder Maximalwerte ein und aus   }
  109. VAR
  110.   WrapNoetig : BOOLEAN;
  111.   SourceAlt  : BYTE;
  112. BEGIN
  113.   WrapNoetig := (Source+Step > Max) OR (Source+Step < Min);
  114.   CASE WrapNoetig OF
  115.     TRUE:   IF Wrap THEN
  116.               IF Step > 0 THEN
  117.                 Source := Min
  118.               ELSE
  119.                 Source := Max
  120.             ELSE
  121.               IF Step > 0 THEN
  122.                 Source := Max
  123.               ELSE
  124.                 Source := Min;
  125.     FALSE:  Inc(Source, Step);
  126.   END;
  127. END;
  128.  
  129. PROCEDURE Cursor(VAR x, y: INTEGER; VAR OK: BOOLEAN);
  130.          { Fadenkreuz-Cursor; übergibt die
  131.            Bildschirm-Koordinaten in den Variablen x und y }
  132. VAR
  133.   ch         : CHAR;
  134.   XAlt, YAlt : INTEGER;
  135. CONST
  136.   Step: BYTE = 2;
  137.  
  138.   PROCEDURE Draw;                    { zeichnet den Cursor }
  139.   BEGIN
  140.     Line(0, y, GetMaxX, y);
  141.     Line(x, 0, x, MaxY);
  142.   END;
  143.  
  144. BEGIN
  145.   XAlt:=x;                  { Original-Koordinaten sichern }
  146.   YAlt:=y;
  147.   SetWriteMode(XORPut);
  148.   SetColor(BezierColor);
  149.   REPEAT
  150.     Draw;
  151.     ScanKey(Taste);
  152.     Draw;
  153.     CASE Taste.Typ OF
  154.       KeyLinks  : Add(x, 0, GetMaxX, -Step, TRUE);
  155.       KeyRechts : Add(x, 0, GetMaxX, Step, TRUE);
  156.       KeyOben   : Add(y, 0, MaxY, -Step, TRUE);
  157.       KeyUnten  : Add(y, 0, MaxY, Step, TRUE);
  158.       KeySpace  : IF Step = 2 THEN   { Schrittweite ändern }
  159.                     Step := 15
  160.                   ELSE
  161.                     Step := 2;
  162.     END;
  163.   UNTIL Taste.Typ IN [KeyReturn, KeyEsc];
  164.   OK := (Taste.Typ = KeyReturn);
  165.   IF NOT OK THEN BEGIN              { Mit <Esc> verlassen: }
  166.     x:=XAlt;           { Original-Koordinaten restaurieren }
  167.     y:=YAlt;
  168.   END;
  169.   SetWriteMode(CopyPut);
  170. END;
  171.  
  172. PROCEDURE ShowPoint(x, y : INTEGER; Color: WORD);
  173.                 { zeichnet die Markierungen für die Punkte }
  174. BEGIN
  175.  SetColor(Color);
  176.  Circle(Round(x), Round(y), 6);
  177.  PutPixel(Round(x), Round(y), Color);
  178. END;
  179.  
  180. PROCEDURE GetPoint(VAR x, y: INTEGER; Index, Color: WORD);
  181.    { Eingabe der einzelnen Punkte mittels Fadenkreuzcursor }
  182. CONST
  183.   OK: BOOLEAN = FALSE;
  184. BEGIN
  185.   REPEAT
  186.     Cursor(x, y, OK);
  187.     IF NOT OK THEN                   { Abbruch durch <ESC> }
  188.       CloseGrafik;
  189.   UNTIL OK;
  190.   ShowPoint(x, y, Color);
  191.   Punkte[Index].x := x;
  192.   Punkte[Index].y := y;
  193. END;
  194.  
  195. PROCEDURE MakeMovie;             { Prozedur erzeugt "Film" }
  196. VAR
  197.   Index  : INTEGER;
  198.   Winkel,
  199.   SinW,
  200.   CosW   : REAL;
  201. CONST
  202.   Step  : BYTE = 5;
  203.  
  204. BEGIN
  205.   Index:=2;
  206.   FOR KurveNr:=1 TO AnzKurven DO
  207.   BEGIN
  208.     Winkel:=KurveNr*2*Pi/AnzKurven;
  209.     SinW := Sin(Winkel);
  210.     CosW := Cos(Winkel);
  211.     BezDat^.TempPoints^[1]^[1].x := Punkte[1].x;
  212.     BezDat^.TempPoints^[1]^[1].y := Punkte[1].y;
  213.     BezDat^.TempPoints^[1]^[AnzPunkte].x := Punkte[AnzPunkte].x;
  214.     BezDat^.TempPoints^[1]^[AnzPunkte].y := Punkte[AnzPunkte].y;
  215.     FOR Index := 1 TO AnzPunkte DO
  216.       IF Odd(Index) THEN BEGIN
  217.         BezDat^.TempPoints^[1]^[Index].x := GetMaxX DIV 2 + (Punkte[Index].x - GetMaxX DIV 2) * SinW;
  218.         BezDat^.TempPoints^[1]^[Index].y := GetMaxY DIV 2 + (Punkte[Index].y - GetMaxY DIV 2) * CosW;
  219.       END ELSE BEGIN
  220.         BezDat^.TempPoints^[1]^[Index].x := GetMaxX DIV 2 + (Punkte[Index].x - GetMaxX DIV 2) * CosW;
  221.         BezDat^.TempPoints^[1]^[Index].y := GetMaxY DIV 2 + (Punkte[Index].y - GetMaxY DIV 2) * SinW;
  222.       END;
  223.     KurveIndex := 0;
  224.     BezDoBeziere;
  225.   END;
  226. END;
  227.  
  228. PROCEDURE ShowMovie;
  229. VAR
  230.   AlteKurve: WORD;
  231.  
  232.   PROCEDURE DrawKurve(KurveNr, KurveAlt: WORD);
  233.   VAR
  234.     Index: WORD;
  235.     xa, ya, xn, yn: INTEGER;
  236.   BEGIN
  237.     xn := Kurve[KurveNr]^[1].x;
  238.     yn := Kurve[KurveNr]^[1].y;
  239.     IF KurveAlt>0 THEN BEGIN
  240.       xa := Kurve[KurveAlt]^[1].x;
  241.       ya := Kurve[KurveAlt]^[1].y;
  242.     END;
  243.  
  244.     MoveTo(Kurve[KurveNr]^[1].x, Kurve[KurveNr]^[1].y);
  245.     FOR Index:=2 TO PunktePerKurve DO
  246.     BEGIN
  247.       IF (KurveAlt > 0) AND (Kurve[KurveAlt]^[Index].x > -1) THEN BEGIN
  248.         SetColor(0);
  249.         MoveTo(xa, ya);
  250.         LineTo(Kurve[KurveAlt]^[Index].x, Kurve[KurveAlt]^[Index].y);
  251.         xa := GetX;
  252.         ya := GetY;
  253.       END;
  254.       IF Kurve[KurveNr]^[Index].x > -1 THEN BEGIN
  255.         SetColor(BezierColor);
  256.         MoveTo(xn, yn);
  257.         LineTo(Kurve[KurveNr]^[Index].x, Kurve[KurveNr]^[Index].y);
  258.         xn := GetX;
  259.         yn := GetY;
  260.       END;
  261.     END;
  262.   END;
  263.  
  264. BEGIN
  265.   ClearDevice;
  266.   AlteKurve := 0;
  267.   REPEAT
  268.     FOR KurveNr := 1 TO AnzKurven DO
  269.     BEGIN
  270.       DrawKurve(KurveNr, AlteKurve);
  271.       AlteKurve:=KurveNr;
  272.       IF KeyPressed THEN
  273.         IF ReadKey=#27 THEN
  274.           EXIT;
  275.     END;
  276.   UNTIL FALSE;
  277. END;
  278.  
  279.  
  280. BEGIN
  281.   BezMaxIt := 4;
  282.   FOR KurveNr := 1 TO AnzKurven DO BEGIN
  283.     New(Kurve[KurveNr]);
  284.     FOR KurveIndex := 1 TO PunktePerKurve DO BEGIN
  285.       Kurve[KurveNr]^[KurveIndex].x := -1;
  286.     END;
  287.   END;
  288.  
  289.   ClrScr;
  290.   HighVideo;
  291.   Writeln(^J, 'toolbox Bézier-Demonstration');
  292.   Writeln('============================', ^J^J);
  293.   LowVideo;
  294.   Writeln('Geben Sie bitte Sie bitte '+
  295.           'die Anzahl aller Punkte');
  296.   Write('incl. der Stützstellen ein (3 bis 10) : ');
  297.   Readln(AnzPunkte);
  298.   IF (AnzPunkte<3) OR (AnzPunkte>10) THEN
  299.     Halt;
  300.   InitGrafik;
  301.   BezInitBezier(AnzPunkte);
  302.   BezDat^.DrawPoint := SpeicherePunkte;
  303.   BezDat^.SetLastPoint := SpeicherePunkte;
  304.   BezDat^.SetFirstPoint := SpeicherePunkte;
  305.   x := GetMaxX DIV 2;
  306.   y := MaxY DIV 2;
  307.   Schrift('Start- und Endpunkt definieren',
  308.           '<SPACE> Schrittweite <ESC> Abbruch');
  309.   GetPoint(x, y, 1, StartColor);
  310.   GetPoint(x, y, AnzPunkte, StartColor);
  311.   Schrift('Stützpunkte definieren',
  312.           '<SPACE> Schrittweite <ESC> Abbruch');
  313.   FOR i := 2 TO AnzPunkte - 1 DO
  314.     GetPoint(x, y, i, StuetzColor);
  315.   Schrift('Animation wird berechnet',
  316.           'Bitte einen Moment Geduld...');
  317.   MakeMovie;
  318.   Schrift('', 'Animation mit Tastendruck starten');
  319.   REPEAT
  320.   UNTIL ReadKey>'';
  321.   ShowMovie;
  322.   BezDisposeBezier;
  323.   CloseGraph;
  324. END.
  325.  
  326.