Subversion Repositories forest

Rev

Blame | Last modification | View Log | RSS feed

  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7.   Dialogs, ExtCtrls, StdCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     Button1: TButton;
  12.     PaintBox1: TPaintBox;
  13.     Button2: TButton;
  14.     Button3: TButton;
  15.     Memo1: TMemo;
  16.     Button4: TButton;
  17.     Button5: TButton;
  18.     Button6: TButton;
  19.     Button7: TButton;
  20.     CheckBox1: TCheckBox;
  21.     procedure Button1Click(Sender: TObject);
  22.     procedure Button2Click(Sender: TObject);
  23.     procedure FormCreate(Sender: TObject);
  24.     procedure Button3Click(Sender: TObject);
  25.     procedure Button4Click(Sender: TObject);
  26.     procedure Button5Click(Sender: TObject);
  27.     procedure Button6Click(Sender: TObject);
  28.     procedure Button7Click(Sender: TObject);
  29.   private
  30.     { Private declarations }
  31.   public
  32.     { Public declarations }
  33.   end;
  34.  
  35. var
  36.   Form1: TForm1;
  37.  
  38. implementation
  39.  
  40. {$R *.dfm}
  41.  
  42. uses
  43.   Math;
  44.  
  45. procedure TForm1.Button1Click(Sender: TObject);
  46. const
  47.   mapsizex = 400;
  48.   mapsizey = 400;
  49.  
  50.   procedure _(size: integer);
  51.   var
  52.     posx, posy: integer;
  53.   begin
  54.     posx := Random(mapsizex);
  55.     posy := Random(mapsizey);
  56.     paintbox1.Canvas.Ellipse(posx, posy, posx+size, posy+size);
  57.   end;
  58.  
  59. var
  60.   i: integer;
  61. begin
  62.   paintbox1.Canvas.Rectangle(0,0,mapsizex,mapsizey);
  63.  
  64.   for i := 0 to 1 do
  65.   begin
  66.   _(100);
  67.   _(100);
  68.   _(100);
  69.   _(100);
  70.  
  71.   _(50);
  72.   _(50);
  73.   _(50);
  74.   _(50);
  75.   _(50);
  76.   _(50);
  77.   _(50);
  78.   _(50);
  79.  
  80.   _(25);
  81.   _(25);
  82.   _(25);
  83.   _(25);
  84.   _(25);
  85.   _(25);
  86.   _(25);
  87.   _(25);
  88.   _(25);
  89.   _(25);
  90.   _(25);
  91.   _(25);
  92.   _(25);
  93.   _(25);
  94.   _(25);
  95.   _(25);
  96.   end;
  97. end;
  98.  
  99. function RandomBetween(a, b: integer): integer;
  100. begin
  101.   result := RandomRange(a,b+1);
  102. end;
  103.  
  104. function IsInCircle(p, q: TPoint; pr: integer): boolean;
  105. begin
  106.   result := sqrt((p.x-q.x)*(p.x-q.x) + (p.y-q.y)*(p.y-q.y)) <= pr;
  107. end;
  108.  
  109. procedure TForm1.Button2Click(Sender: TObject);
  110. const
  111.   maxB = 50;
  112.   r = 30;
  113.   maxX = 400;
  114.   maxY = 400;
  115.  
  116.   procedure _Draw(p: TPoint);
  117.   begin
  118.     paintbox1.Canvas.Ellipse(p.X-r,p.Y-r, p.X+r,p.Y+r);
  119.   end;
  120.  
  121.   function findRandomOutline(p: TPoint): TPoint;
  122.   var
  123.     yg, xg: integer;
  124.   begin
  125.     xg := RandomBetween(p.X-r, p.X+r);
  126.     if RandomBetween(0,1) = 0 then
  127.       yg := Floor(p.y - sqrt(r*r - (p.x-xg)*(p.x-xg)))
  128.     else
  129.       yg := Floor(p.y + sqrt(r*r - (p.x-xg)*(p.x-xg)));
  130.     result.X := xg;
  131.     result.Y := yg;
  132.   end;
  133.  
  134.   function CirclesOverlap(p, q: TPoint): boolean;
  135.   begin
  136.     result := (abs(p.x-q.x) < 2*r) and (abs(p.y-q.y) < 2*r);
  137.   end;
  138.  
  139. var
  140.   Circles: array[0..maxB] of TPoint;
  141.   i, j: integer;
  142.   p: TPoint;
  143.   feck: boolean;
  144. begin
  145.   paintbox1.Canvas.Rectangle(0,0,maxx,maxy);
  146.  
  147.   Circles[0].X := maxX div 2;
  148.   Circles[0].Y := maxY div 2;
  149.   _Draw(Circles[0]);
  150.  
  151.   for i := 1 to maxB do
  152.   begin
  153.  
  154.     repeat
  155.       feck := false;
  156.       p := findRandomOutline(Circles[i-1]);
  157.       for j := 0 to i-2 do
  158.       begin
  159.         if CirclesOverlap(p, Circles[j]) then
  160.         begin
  161.           feck := true;
  162.           break;
  163.         end;
  164.       end;
  165.     until not feck;
  166.  
  167.     Circles[i] := p;
  168.     _Draw(Circles[i]);
  169.   end;
  170. end;
  171.  
  172. procedure TForm1.FormCreate(Sender: TObject);
  173. begin
  174.   Randomize;
  175. end;
  176.  
  177. procedure TForm1.Button3Click(Sender: TObject);
  178. const
  179.   maxB = 50;
  180.   r = 30;
  181.   maxX = 400;
  182.   maxY = 400;
  183.   klebfaktor = 0.9;
  184.  
  185.   procedure _Draw(p: TPoint);
  186.   begin
  187.     paintbox1.Canvas.Ellipse(p.X-r,p.Y-r, p.X+r,p.Y+r);
  188.   end;
  189.  
  190.   function findRandomOutline(p: TPoint): TPoint;
  191.   var
  192.     yg, xg: integer;
  193.     newr: integer;
  194.   begin
  195.     newr := Round(1.5*r);
  196.     xg := RandomBetween(p.X-newr, p.X+newr);
  197.     if RandomBetween(0,1) = 0 then
  198.       yg := Floor(p.y - sqrt(newr*newr - (p.x-xg)*(p.x-xg)))
  199.     else
  200.       yg := Floor(p.y + sqrt(newr*newr - (p.x-xg)*(p.x-xg)));
  201.     result.X := xg;
  202.     result.Y := yg;
  203.   end;
  204.  
  205.   function CirclesOverlap(p, q: TPoint): boolean;
  206.   begin
  207.     result := (abs(p.x-q.x) < 2*r) and (abs(p.y-q.y) < 2*r);
  208.   end;
  209.  
  210. var
  211.   Circles: array[0..maxB] of TPoint;
  212.   i, j: integer;
  213.   c: integer;
  214.   feck: boolean;
  215.   p: tpoint;
  216. begin
  217.   memo1.lines.clear;
  218.   paintbox1.Canvas.Rectangle(0,0,maxx,maxy);
  219.  
  220.   Circles[0].X := maxX div 2;
  221.   Circles[0].Y := maxY div 2;
  222.   _Draw(Circles[0]);
  223.  
  224.  
  225.  
  226.   for i := 1 to maxB do
  227.   begin
  228.       c := RandomBetween(0,i-1);
  229.  
  230.     repeat
  231. //      memo1.lines.add(IntTostr(i)+ ' -> ' + inttostr(c));
  232.  
  233.       Circles[i] := findRandomOutline(Circles[c]);
  234.  
  235.  
  236.       feck := false;
  237.       (*
  238.       for j := 1 to i-2 do
  239.       begin
  240.         if CirclesOverlap(Circles[i], Circles[j]) then
  241.         begin
  242.           inc(fc);
  243.           feck := true;
  244.           break;
  245.         end;
  246.       end;
  247.  
  248.       if fc > 100 then
  249.       begin
  250.         c := RandomBetween(0,i-1);
  251.         fc := 0;
  252.       end;
  253.       *)
  254.  
  255. //   Application.ProcessMessages;
  256. //    Sleep(500);
  257.  
  258.     until not feck;
  259.     _Draw(Circles[i]);
  260.  
  261.           memo1.lines.add('Draw '+IntTostr(i)+ ' based on ' + inttostr(c));
  262.  
  263.   end;
  264.  
  265.   exit;
  266.  
  267.   for i := 1 to maxB do
  268.   begin
  269.  
  270.     repeat
  271.       feck := false;
  272.       p := findRandomOutline(Circles[i-1]);
  273.       for j := 0 to i-2 do
  274.       begin
  275.         if CirclesOverlap(p, Circles[j]) then
  276.         begin
  277.           feck := true;
  278.           break;
  279.         end;
  280.       end;
  281.     until not feck;
  282.  
  283.     Circles[i] := p;
  284.     _Draw(Circles[i]);
  285.   end;
  286. end;
  287.  
  288. procedure TForm1.Button4Click(Sender: TObject);
  289. const
  290.   mapsizex = 400;
  291.   mapsizey = 400;
  292.  
  293.   procedure _(size: integer);
  294.   var
  295.     posx, posy: integer;
  296.   begin
  297.     posx := Random(mapsizex);
  298.     posy := Random(mapsizey);
  299.     paintbox1.Canvas.Ellipse(posx, posy, posx+size, posy+size);
  300.   end;
  301.  
  302. var
  303.   i: integer;
  304. begin
  305.   paintbox1.Canvas.Rectangle(0,0,mapsizex,mapsizey);
  306.  
  307.   for i := 0 to 20 do
  308.   begin
  309.     _(RandomBetween(10,100));
  310.   end;
  311. end;
  312.  
  313. procedure TForm1.Button5Click(Sender: TObject);
  314. const
  315.   r = 5;
  316.   maxX = 545;
  317.   maxY = 545;
  318. var
  319.   drawnCircles: integer;
  320.  
  321.   procedure _Draw(p: TPoint);
  322.   begin
  323.     paintbox1.Canvas.Brush.Color := clGray;
  324.     paintbox1.Canvas.Pen.Color := clGray;
  325.     paintbox1.Canvas.Ellipse(p.X-r,p.Y-r, p.X+r,p.Y+r);
  326.     inc(drawnCircles);
  327.  
  328. //    Sleep(10);
  329. //    application.processmessages;
  330.   end;
  331.  
  332.   function RandBetween(a, b: integer): integer;
  333.   begin
  334.     result := Random(b-a+1)+a;
  335.   end;
  336.  
  337.   procedure BeginAdventure(startx, starty, angle, dep: integer);
  338.   const
  339.     maxB = 200;
  340.     flexi = 25;
  341.     maxdep = 2;
  342.     anzahlZweige = 2;
  343.     rand = 2;
  344.     zielBaumZahl = 1000;
  345.   var
  346.     Circles: array[0..maxB] of TPoint;
  347.     Rad: array[0..maxB] of integer;
  348.     i: integer;
  349.     x: integer;
  350.     maxdrawn: integer;
  351.   begin
  352.     if dep > maxdep then exit;
  353.     if drawncircles >= zielBaumZahl then exit;
  354.  
  355.     Rad[0] := angle;
  356.     Circles[0].X := startx;
  357.     Circles[0].Y := starty;
  358.     _Draw(Circles[0]);
  359.  
  360.     repeat
  361.     maxdrawn := 0;
  362.     for i := 1 to maxB{ div (dep+1)} do
  363.     begin
  364.       Rad[i] := RandBetween(Rad[i-1]-flexi, Rad[i-1]+flexi);
  365.       Circles[i].X := Circles[i-1].X + round(r*cos(Rad[i]/360*2*pi));
  366.       Circles[i].Y := Circles[i-1].Y + round(r*sin(Rad[i]/360*2*pi));
  367.  
  368.       if Circles[i].X > maxX-rand*r then break;
  369.       if Circles[i].Y > maxY-rand*r then break;
  370.       if Circles[i].X < rand*r then break;
  371.       if Circles[i].Y < rand*r then break;
  372.  
  373.       maxdrawn := i;
  374.     end;
  375.     until maxdrawn = maxB div (dep+1);
  376.  
  377.     for i := 1 to maxdrawn do
  378.     begin
  379.       _Draw(Circles[i]);
  380.     end;
  381.  
  382.     if maxdrawn > dep*50 then
  383.     for i := 1 to anzahlZweige do
  384.     begin
  385.       x := RandBetween(maxdrawn div 2, maxdrawn);
  386.       if RandBetween(0,1)=0 then
  387.       BeginAdventure(Circles[x].X, Circles[x].Y, Rad[x]-90, dep+1)
  388.       else
  389.       BeginAdventure(Circles[x].X, Circles[x].Y, Rad[x]+90, dep+1);
  390.     end;
  391.   end;
  392.  
  393. begin
  394.   Randomize;
  395.  
  396.   memo1.lines.clear;
  397.   drawnCircles := 0;
  398.  
  399.     paintbox1.Canvas.Brush.Color := clGreen;
  400.     paintbox1.Canvas.Pen.Color := clBlack;
  401.       paintbox1.Canvas.Rectangle(0,0,maxx,maxy);
  402.  
  403.   BeginAdventure(maxX div 2, maxY div 2, RandBetween(0, 360), 0);
  404. end;
  405.  
  406. procedure TForm1.Button6Click(Sender: TObject);
  407. const
  408.   r = 5;
  409.   maxX = 545;
  410.   maxY = 545;
  411.   zielBaumZahl = 1000;
  412. var
  413.   drawnCircles: integer;
  414.   Circles: array[0..zielBaumZahl-1] of TPoint;
  415.   Rad: array[0..zielBaumZahl-1] of integer;
  416.  
  417.   procedure _Draw(p: TPoint);
  418.   begin
  419.     paintbox1.Canvas.Brush.Color := clGray;
  420.     paintbox1.Canvas.Pen.Color := clGray;
  421.     paintbox1.Canvas.Ellipse(p.X-r,p.Y-r, p.X+r,p.Y+r);
  422.     inc(drawnCircles);
  423.  
  424. //    Sleep(10);
  425. //    application.processmessages;
  426.   end;
  427.  
  428.   function RandBetween(a, b: integer): integer;
  429.   begin
  430.     result := Random(b-a+1)+a;
  431.   end;
  432.  
  433.   procedure BeginAdventure(startx, starty, angle: integer);
  434.   const
  435.     maxB = 200;
  436.     flexi = 15;
  437.     rand = 2;
  438.   var
  439.     i: integer;
  440.     x: integer;
  441.     maxdrawn: integer;
  442.     beg: integer;
  443.   begin
  444.     if drawncircles >= zielBaumZahl then exit;
  445.  
  446.     Rad[0] := angle;
  447.     Circles[0].X := startx;
  448.     Circles[0].Y := starty;
  449.     _Draw(Circles[0]);
  450.  
  451.     beg := 1;
  452.  
  453.     while true do
  454.     begin
  455.  
  456.       maxdrawn := 0;
  457.       for i := beg to beg+maxB do
  458.       begin
  459.         if i > High(Rad) then Exit;
  460.  
  461.         Rad[i] := RandBetween(Rad[i-1]-flexi, Rad[i-1]+flexi);
  462.         Circles[i].X := Circles[i-1].X + round(r*cos(Rad[i]/360*2*pi));
  463.         Circles[i].Y := Circles[i-1].Y + round(r*sin(Rad[i]/360*2*pi));
  464.  
  465.         if Circles[i].X > maxX-rand*r then break;
  466.         if Circles[i].Y > maxY-rand*r then break;
  467.         if Circles[i].X < rand*r then break;
  468.         if Circles[i].Y < rand*r then break;
  469.  
  470.         _Draw(Circles[i]);
  471.  
  472.         maxdrawn := i;
  473.       end;
  474.  
  475.       x := RandBetween(0, maxdrawn);
  476.       Circles[maxdrawn+1] := Circles[x]; // virtual tree (not drawn)
  477.  
  478.       if RandBetween(0,1) = 0 then
  479.         Rad[maxdrawn+1] := Rad[x]-90
  480.       else
  481.         Rad[maxdrawn+1] := Rad[x]+90;
  482.  
  483.       beg := maxdrawn+2;
  484.  
  485.     end;
  486.   end;
  487.  
  488. begin
  489.   Randomize;
  490.  
  491.   memo1.lines.clear;
  492.   drawnCircles := 0;
  493.  
  494.     paintbox1.Canvas.Brush.Color := clGreen;
  495.     paintbox1.Canvas.Pen.Color := clBlack;
  496.       paintbox1.Canvas.Rectangle(0,0,maxx,maxy);
  497.  
  498.   BeginAdventure(maxX div 2, maxY div 2, RandBetween(0, 360));
  499. end;
  500.  
  501.  
  502. function TreePos(nTrees, treeRadius, mapX, mapY: integer; memblock: Pointer; debug: boolean): dword; cdecl; external 'd:\tdn\mapgen\mapgen32.dll';
  503.  
  504. procedure DrawCircle(x, y, r: integer);
  505. begin
  506.   form1.paintbox1.Canvas.Brush.Color := clMaroon;
  507.   form1.paintbox1.Canvas.Pen.Color := clMaroon;
  508.   form1.paintbox1.Canvas.Ellipse(X-r,Y-r, X+r,Y+r);
  509. end;
  510.  
  511. procedure TForm1.Button7Click(Sender: TObject);
  512. const
  513.   miniature_factor = 20; // only viewer
  514.   treeradius = 100;
  515.   ntrees = 5000;
  516.   mapX = 10000;
  517.   mapY = 10000;
  518. var
  519.   i: integer;
  520.   mb: array[0..ntrees-1, 0..1] of dword;
  521. begin
  522.   paintbox1.Repaint;
  523.  
  524.   TreePos(ntrees, treeradius, mapx, mapy, @mb[0][0], checkbox1.checked);
  525.  
  526.   paintbox1.Canvas.Brush.Color := clGreen;
  527.   paintbox1.Canvas.Pen.Color := clBlack;
  528.   paintbox1.Canvas.Rectangle(0,0,mapx div miniature_factor,mapy div miniature_factor);
  529.  
  530.   for i := 0 to ntrees-1 do
  531.   begin
  532.     DrawCircle(mb[i][0] div miniature_factor, mb[i][1] div miniature_factor, treeradius div miniature_factor);
  533.   end;
  534. end;
  535.  
  536. end.
  537.