home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 02 / tricks / schneefl.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-11-15  |  6.0 KB  |  244 lines
  1. (* ------------------------------------------------------ *)
  2. (*                   SCHNEEFL.PAS                         *)
  3. (*        (c) 1989 Uwe Peter Schmit & TOOLBOX             *)
  4. (* ------------------------------------------------------ *)
  5. PROGRAM Schneeflocke;
  6.  
  7. USES Crt, Graph;
  8.  
  9. TYPE
  10.   Punkte = RECORD
  11.              x, y : INTEGER
  12.            END;
  13.   Zeiger = ^Ecke;
  14.   Ecke   = RECORD
  15.              Punkt : Punkte;
  16.              Next  : Zeiger
  17.            END;
  18. VAR
  19.   Itermax                   : BYTE;
  20.   GraphDriver, GraphMode, i : INTEGER;
  21.   Ydif                      : REAL;
  22.   p1, p2, p3                : Punkte;
  23.   s                         : Zeiger;
  24.   p                         : POINTER;
  25.  
  26.   PROCEDURE Init;
  27.   VAR
  28.     Xasp, Yasp : WORD;
  29.   BEGIN
  30.     GraphDriver := Detect;
  31.     InitGraph(GraphDriver, GraphMode, 'C:\TURBO');
  32.     IF GraphResult <> grOk THEN BEGIN
  33.       WriteLn('Graphics init error: ',
  34.                                 GraphErrorMsg(GraphDriver));
  35.       Halt(1);
  36.     END;
  37.     SetGraphMode(GraphMode);
  38.     GetAspectRatio(Xasp, Yasp);
  39.     Ydif := Xasp/Yasp;
  40.   END;
  41.  
  42.   PROCEDURE Dreieck;
  43.   VAR
  44.     h1, h2 : Zeiger;
  45.   BEGIN
  46.     Mark(p);
  47.     New(s);
  48.     s^.Punkt  := p1;
  49.     New(h1);
  50.     h1^.Punkt := p3;
  51.     s^.Next   := h1;
  52.     New(h2);
  53.     h2^.Punkt := p2;
  54.     h1^.Next  := h2;
  55.     h2^.Next  := s;
  56.   END;
  57.  
  58.   PROCEDURE Zeichne_Dreieck;
  59.   VAR
  60.     h : Zeiger;
  61.   BEGIN
  62.     SetColor(white);
  63.     h := s^.Next;
  64.     MoveTo(s^.Punkt.x, ROUND(Ydif*s^.Punkt.y));
  65.     WHILE h <> s DO BEGIN
  66.       LineTo(h^.Punkt.x, ROUND(Ydif*h^.Punkt.y));
  67.       h := h^.Next
  68.     END;
  69.     LineTo(s^.Punkt.x, ROUND(Ydif*s^.Punkt.y));
  70.   END;
  71.  
  72.   PROCEDURE Abketten;
  73.   BEGIN
  74.     Release(p);
  75.   END;
  76.  
  77.   PROCEDURE Berechne_P3;
  78.   CONST
  79.     m = 0.8660254;       {0.5 * SQRT(3) / Höhe des Dreiecks}
  80.   VAR
  81.     h, hs  : Punkte;
  82.   BEGIN
  83.     h.x  := p2.x-p1.x; {h-senkrecht: (-h.y, h.x)}
  84.     h.y  := p2.y-p1.y; {p3 = p1+h+m*h-senkrecht}
  85.     p3.x := ROUND(p1.x + 0.5*h.x - m*h.y);
  86.     p3.y := ROUND(p1.y + 0.5*h.y + m*h.x)
  87.   END;
  88.  
  89.   PROCEDURE Koch;
  90.   VAR
  91.     h1, h2, e1, e2  : Zeiger;
  92.     i, j            : SHORTINT;
  93.     x, y            : INTEGER;
  94.   BEGIN
  95.     h1 := s;
  96.     h2 := h1^.Next;
  97.     REPEAT
  98.       x    := h2^.Punkt.x - h1^.Punkt.x;
  99.       y    := h2^.Punkt.y - h1^.Punkt.y;
  100.       p1.x := ROUND(h1^.Punkt.x + x/3);
  101.       p1.y := ROUND(h1^.punkt.y + y/3);
  102.       p2.x := ROUND(h2^.punkt.x - x/3);
  103.       p2.y := ROUND(h2^.punkt.y - y/3);
  104.       SetColor(black);
  105.       FOR i := -1 TO 1 DO
  106.         FOR j := -1 TO 1 DO BEGIN
  107.           MoveTo(p1.x, ROUND(Ydif * p1.y) + i);
  108.           LineTo(p2.x, ROUND(Ydif * p2.y) + j);
  109.         END;                            {alte Linie löschen}
  110.       Berechne_P3;
  111.       SetColor(white);
  112.       MoveTo(p1.x, ROUND(Ydif * p1.y));     { neues }
  113.       LineTo(p3.x, ROUND(Ydif * p3.y));     { Dreieck }
  114.       LineTo(p2.x, ROUND(Ydif * p2.y));     { zeichnen }
  115.       New(e1);
  116.       e1^.Punkt := p1;
  117.       h1^.Next  := e1;
  118.       New(e2);
  119.       e2^.Punkt := p3;
  120.       e1^.Next  := e2;
  121.       New(e1);
  122.       e1^.Punkt := p2;
  123.       e2^.Next  := e1;
  124.       e1^.Next  := h2;
  125.       h1        := h2;
  126.       h2        := h1^.Next;
  127.     UNTIL h1 = s;
  128.   END;
  129.  
  130.   PROCEDURE Schnee_;
  131.   VAR
  132.     i, j                      : BYTE;
  133.     h1, h2, Pkt1, Pkt2, Mitte : Punkte;
  134.  
  135.     PROCEDURE Berechne_Mitte;
  136.     CONST
  137.       m1 = 0.8660254; { SQRT(3) / 2 }
  138.       m2 = 0.2886751; { SQRT(3) / 6 }
  139.     VAR
  140.       h, hs  : Punkte;
  141.     BEGIN
  142.       h.x     := p2.x-p1.x;
  143.       h.y     := p2.y-p1.y; {h-senkrecht: (-h.y, h.x)}
  144.       p3.x    := ROUND(p1.x + h.x/2 - m1*h.y);
  145.       p3.y    := ROUND(p1.y + h.y/2 + m1*h.x);
  146.       Mitte.x := ROUND(p1.x + h.x/2 - m2*h.y);
  147.       Mitte.y := ROUND(p1.y + h.y/2 + m2*h.x)
  148.     END;
  149.  
  150.   BEGIN
  151.     Berechne_Mitte;
  152.     Pkt1 := p1;
  153.     Pkt2 := p2;
  154.     h1.x := Mitte.x - p1.x;
  155.     h1.y := Mitte.y - p1.y;
  156.     h2.x := Mitte.x - p2.x;
  157.     h2.y := Mitte.y - p2.y;
  158.     FOR i := 0 TO 9 DO BEGIN
  159.       p1.x := ROUND(Pkt1.x + i/10 * h1.x);
  160.       p1.y := ROUND(Pkt1.y + i/10 * h1.y);
  161.       p2.x := ROUND(Pkt2.x + i/10 * h2.x);
  162.       p2.y := ROUND(Pkt2.y + i/10 * h2.y);
  163.       Berechne_P3;
  164.       Dreieck;
  165.       Zeichne_Dreieck;
  166.       FOR j := 1 TO IterMax DO Koch;
  167.       Abketten;
  168.     END;
  169.   END;
  170.  
  171.   PROCEDURE Lese_Daten_Ein;
  172.   BEGIN
  173.     WriteLn(^J^J^J^J);
  174.     WriteLn('------------------------------------------',
  175.             ^J);
  176.     Write('   Punkt 1 (X-Koordinate) : ');
  177.     ReadLn(p1.x);
  178.     Write('   Punkt 1 (Y-Koordinate) : ');
  179.     ReadLn(p1.y);
  180.     WriteLn;
  181.     Write('   Punkt 2 (X-Koordinate) : ');
  182.     ReadLn(p2.x);
  183.     Write('   Punkt 2 (Y-Koordinate) : ');
  184.     ReadLn(p2.y);
  185.     Berechne_P3;
  186.     WriteLn;
  187.     WriteLn('   Punkt 3 (X-Koordinate) : ', p3.x);
  188.     WriteLn('   Punkt 3 (Y-Koordinate) : ', p3.y);
  189.     Write(^J, '   Iterationen : ');
  190.     ReadLn(IterMax)
  191.   END;
  192.  
  193.   PROCEDURE Menue;
  194.   VAR
  195.     ch : CHAR;
  196.  
  197.     PROCEDURE K;
  198.     VAR
  199.       i : BYTE;
  200.     BEGIN
  201.       Lese_Daten_Ein;
  202.       SetGraphMode(GraphMode);
  203.       Dreieck;
  204.       Zeichne_Dreieck;
  205.       FOR i := 1 TO IterMax DO Koch;
  206.       Abketten;
  207.       ch := ReadKey
  208.     END;
  209.  
  210.     PROCEDURE S;
  211.     BEGIN
  212.       Lese_Daten_Ein;
  213.       SetGraphMode(GraphMode);
  214.       Schnee_;
  215.       ch := ReadKey
  216.     END;
  217.  
  218.   BEGIN
  219.     REPEAT RestoreCrtMode;
  220.       WriteLn(^J^J^J^J);
  221.       WriteLn('------------------------------------------',
  222.               ^J);
  223.       WriteLn('   [K]och''sche Schneeflocke',^J);
  224.       WriteLn('   [S]chneeflocke',^J);
  225.       WriteLn('   [E]nde',^J);
  226.       WriteLn('------------------------------------------',
  227.               ^J);
  228.       REPEAT
  229.         ch := UpCase(ReadKey);
  230.       UNTIL ch IN ['K', 'S', 'E', #27];
  231.       CASE ch OF
  232.         'K' : K;
  233.         'S' : S;
  234.       END;
  235.     UNTIL ch IN ['E', #27];
  236.   END;
  237.  
  238. BEGIN Init;
  239.       Menue;
  240.       CloseGraph;
  241. END.
  242. (* ------------------------------------------------------ *)
  243. (*                Ende von SCHNEEF.PAS                    *)
  244.