home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Programmieren / Kurztests / PascalPCQ / Examples / Snow.p < prev    next >
Text File  |  1990-07-20  |  4KB  |  184 lines
  1. Program Snowflake;
  2.  
  3. { This program draws a fractal snowflake pattern.  I think I got it out
  4. of some magazine years ago.  It was written, as I remember it, for the
  5. PC in BASIC, which I converted to AmigaBASIC.  I have long since
  6. forgotten the details of how it worked, so I could not give the
  7. variables meaningful names.  To the original author, by the way, goes
  8. the credit for those names.  Invoke the program with the line "Snow
  9. <level>", where <level> is a digit between 1 and 6.  In order to get a
  10. feel for what's going on, try running the levels in order.  Level 6
  11. takes a long time, and frankly doesn't look as good as level 5.  }
  12.  
  13. {$I "Include:Exec/Ports.i" for GetMsg and WaitPort }
  14. {$I "Include:Intuition/Intuition.i" for the windows }
  15. {$I "Include:Graphics/Pens.i" for move() and draw() }
  16. {$I "Include:Graphics/Graphics.i" for GfxBase }
  17. {$I "Include:Exec/Libraries.i" just for OpenLibrary and CloseLibrary }
  18. {$I "Include:Exec/Interrupts.i" for Forbid() and Permit() }
  19.  
  20. var
  21.     dx : array [0..11] of real;
  22.     dy : array [0..11] of real;
  23.     sd : array [0..6] of integer;
  24.     rd : array [0..6] of integer;
  25.     sn : array [0..6] of integer;
  26.     ln : array [0..6] of real;
  27.     a  : real;
  28.     nc : integer;
  29.     x, y, t : real;
  30.     w  : WindowPtr;
  31.     rp : RastPortPtr;
  32.     n  : integer;
  33.     d, ns, i, j : integer;
  34.     l : real;
  35.     m : MessagePtr;
  36.  
  37. Procedure usage;
  38. begin
  39.     writeln('Usage: Snow <level>');
  40.     writeln('       where <level> is between 1 and 6');
  41.     exit(20);
  42. end;
  43.  
  44. Function readcycles(): integer;
  45. var
  46.     index : integer;
  47.     cycles : integer;
  48. begin
  49.     index := 0;
  50.     while ((commandline[index] = ' ') or (commandline[index] = chr(9))) and
  51.     (index < 128) do
  52.     index := index + 1;
  53.     if index >= 128 then
  54.     usage;
  55.     cycles := ord(commandline[index]) - ord('0');
  56.     if (cycles > 6) or (cycles < 1) then
  57.     usage;
  58.     readcycles := cycles;
  59. end;
  60.  
  61. Function OpenTheWindow() : Boolean;
  62. var
  63.     nw : NewWindowPtr;
  64. begin
  65.     new(nw);
  66.  
  67.     nw^.LeftEdge := 0;
  68.     nw^.TopEdge := 0;
  69.     nw^.Width := 640;
  70.     nw^.Height := 200;
  71.  
  72.     nw^.DetailPen := -1;
  73.     nw^.BlockPen  := -1;
  74.     nw^.IDCMPFlags := CLOSEWINDOW_f;
  75.     nw^.Flags := WINDOWDEPTH + WINDOWCLOSE + SMART_REFRESH + ACTIVATE;
  76.     nw^.FirstGadget := nil;
  77.     nw^.CheckMark := nil;
  78.     nw^.Title := "Fractal Snowflake";
  79.     nw^.Screen := nil;
  80.     nw^.BitMap := nil;
  81.     nw^.MinWidth := 50;
  82.     nw^.MaxWidth := -1;
  83.     nw^.MinHeight := 20;
  84.     nw^.MaxHeight := -1;
  85.     nw^.WType := WBENCHSCREEN_f;
  86.  
  87.     w := OpenWindow(nw);
  88.     dispose(nw);
  89.     OpenTheWindow := w <> nil;
  90. end;
  91.  
  92. procedure initarrays;
  93. begin
  94.     sd[0] := 0;
  95.     rd[0] := 0;
  96.     sd[1] := 1;
  97.     rd[1] := 0;
  98.     sd[2] := 1;
  99.     rd[2] := 7;
  100.     sd[3] := 0;
  101.     rd[3] := 10;
  102.     sd[4] := 0;
  103.     rd[4] := 0;
  104.     sd[5] := 0;
  105.     rd[5] := 2;
  106.     sd[6] := 1;
  107.     rd[6] := 2;
  108.  
  109.     for n := 0 to 6 do
  110.     ln[n] := 1.0 / 3.0;
  111.     ln[2] := sqrt(ln[1]);
  112.     a := 0.0;
  113.     for n := 6 to 11 do begin
  114.     dy[n] := sin(a);
  115.     dx[n] := cos(a);
  116.         a := a + 0.52359;
  117.     end;
  118.     for n := 0 to 5 do begin
  119.     dx[n] := -(dx[n + 6]);
  120.     dy[n] := -(dy[n + 6]);
  121.     end;
  122.     x := 534.0;
  123.     y := 151.0;
  124.     t := 324.0;
  125. end;
  126.  
  127. begin
  128.     nc := readcycles();
  129.     initarrays;
  130.  
  131.     GfxBase := OpenLibrary("graphics.library", 0);
  132.     if GfxBase = nil then begin
  133.     writeln('Could not open Graphics.library');
  134.     exit(20);
  135.     end;
  136.  
  137.     if OpenTheWindow() then begin
  138.     rp := w^.RPort;
  139.  
  140.     for n := 0 to nc do
  141.         sn[n] := 0;
  142.  
  143.     Move(rp, trunc(x), trunc(y));
  144.  
  145.     repeat
  146.         d := 0;
  147.         l := t;
  148.         ns := 0;
  149.  
  150.         for n := 1 to nc do begin
  151.         i := sn[n];
  152.         l := l * ln[i];
  153.         j := sn[n - 1];
  154.         ns := ns + sd[j];
  155.         if odd(ns) then
  156.             d := (d + 12 - rd[i]) mod 12
  157.         else
  158.             d := (d + rd[i]) mod 12;
  159.         end;
  160.  
  161.         x := x + 1.33 * l * dx[d];
  162.         y := y - 0.5 * l * dy[d];
  163.  
  164.         Draw(rp, trunc(x), trunc(y));
  165.         sn[nc] := sn[nc] + 1;
  166.         n := nc;
  167.         while (n >= 1) and (sn[n] = 7) do begin
  168.         sn[n] := 0;
  169.         sn[n - 1] := sn[n - 1] + 1;
  170.         n := n - 1;
  171.         end;
  172.     until sn[0] <> 0;
  173.     m := WaitPort(w^.UserPort);
  174.     forbid;
  175.     repeat
  176.         m := GetMsg(w^.UserPort);
  177.     until m = nil;
  178.     permit;
  179.     CloseWindow(w);
  180.     end else
  181.     writeln('Could not open the window');
  182.     CloseLibrary(GfxBase);
  183. end.
  184.