home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 09 / praxis / kristall.mod < prev    next >
Encoding:
Text File  |  1989-07-07  |  2.6 KB  |  106 lines
  1. (* ====================================================== *)
  2. (*                   Kristallwachstum                     *)
  3. (* Hardware: IBM-kompatibler PC/AT, EGA-Grafik            *)
  4. (* Compiler: TopSpeed Modula 2, Version 1.14              *)
  5. (*           (C) 1989 Matthias Uphoff & TOOLBOX           *)
  6. (* ====================================================== *)
  7.  
  8. MODULE Kristall;
  9.  
  10. (*$B-*)          (* User-Break Off *)
  11.  
  12. FROM Graph IMPORT InitEGA,GraphMode,TextMode,Plot,Point;
  13. FROM IO IMPORT KeyPressed;
  14.  
  15. CONST
  16.    scrwd = 640;      (* Bildschirmbreite *)
  17.    scrhi = 350;      (* Bildschirmhöhe *)
  18.    xm = scrwd DIV 2; (* Mitte horizontal *)
  19.    ym = scrhi DIV 2; (* Mitte vertikal *)
  20.    schwarz = 0;      (* Hintergrundfarbe *)
  21.    col0  = 9;        (* Blau *)
  22.    col1  = 12;       (* Rot *)
  23.    col2  = 14;       (* Gelb *)
  24.  
  25. VAR
  26.    coltab: ARRAY[0..2] OF CARDINAL;
  27.            (* Farben für Generation n, n-1, n-2 *)
  28.    col,gen: CARDINAL;
  29.  
  30. PROCEDURE Vier_Punkte(x,y,c: CARDINAL);
  31.  
  32. BEGIN
  33.    Plot(xm+x,ym+y,c);
  34.    Plot(xm-x,ym+y,c);
  35.    Plot(xm+x,ym-y,c);
  36.    Plot(xm-x,ym-y,c);
  37. END Vier_Punkte;
  38.  
  39. PROCEDURE Nachbarn(x,y,c: CARDINAL): CARDINAL;
  40. (* Zählt die Nachbarn von x,y mit der Farbe c *)
  41.    VAR n: CARDINAL;
  42.  
  43. BEGIN
  44.    n := 0;
  45.    x := xm+x; y := ym+y;
  46.    IF Point(x,y-1) = c THEN INC(n) END;
  47.    IF Point(x,y+1) = c THEN INC(n) END;
  48.    IF Point(x+1,y) = c THEN INC(n) END;
  49.    IF Point(x-1,y) = c THEN INC(n) END;
  50.    RETURN n
  51. END Nachbarn;
  52.  
  53. PROCEDURE Setze_Punkte;
  54. (* Erzeugt Generation n *)
  55.    VAR x,y,g: CARDINAL;
  56.  
  57. BEGIN
  58.   FOR g := 0 TO gen DO
  59.     FOR x := 0 TO g DO
  60.       y := g - x;
  61.       IF Point(xm+x,ym+y) = schwarz THEN
  62.         IF Nachbarn(x,y,coltab[1]) = 1 THEN
  63.            Vier_Punkte(x,y,coltab[0]);
  64.         END;
  65.       END;
  66.     END;
  67.   END;
  68. END Setze_Punkte;
  69.  
  70. PROCEDURE Loesche_Punkte;
  71. (* Löscht Generation n-2 *)
  72.    VAR x,y,g: CARDINAL;
  73.  
  74. BEGIN
  75.   FOR g := gen TO 0 BY -1 DO
  76.     FOR x := 0 TO g DO
  77.       y := g - x;
  78.       IF Point(xm+x,ym+y) = coltab[2] THEN
  79.         Vier_Punkte(x,y,schwarz);
  80.       END;
  81.     END;
  82.   END;
  83. END Loesche_Punkte;
  84.  
  85. BEGIN
  86.    InitEGA;
  87.    GraphMode;
  88.    coltab[0] := col0;
  89.    coltab[1] := col1; (* Farben festlegen *)
  90.    coltab[2] := col2;
  91.    Plot(xm,ym,coltab[0]); (* Keim setzen *)
  92.    gen := 0;
  93.    REPEAT
  94.        (* Farben zyklisch vertauschen *)
  95.      col := coltab[2];
  96.      coltab[2] := coltab[1];
  97.      coltab[1] := coltab[0];
  98.      coltab[0] := col;
  99.        (* Generationswechsel *)
  100.      IF gen < scrhi DIV 2 THEN INC(gen) END;
  101.      Setze_Punkte;
  102.      Loesche_Punkte;
  103.    UNTIL KeyPressed();
  104.    TextMode;
  105. END Kristall.
  106.