src/worldgen.mpsrc

   1 //Thanks:
   2 //ZeroNoWing
   3 //Andrey59
   4
   5 unit worldgen;
   6
   7 interface
   8  procedure genworld;//Вызывается из главного модуля для начала генерации мира
   9  procedure gennether;
  10  procedure genflat;
  11  procedure genportal(xx,yy:integer);
  12  function get_up(Xi:integer):integer;
  13
  14  procedure genwood1(xx,yy:integer);//дуб
  15  procedure genwood2(xx,yy:integer);//берёза
  16  procedure genwood3(xx,yy:integer);//ель
  17
  18
  19 implementation
  20
  21   uses maps, randoms, vars, func, player, chest, items_store, Items, Blocks;
  22
  23  function rnd_min:integer;
  24   begin
  25    rnd_min:=rnd(3)-1;
  26   end;
  27
  28 procedure create_bonus_chest(chx,chy:integer);
  29  var
  30    ix,l,id,time:integer;
  31  begin
  32   time:=getcurrenttime;
  33   if ((getmonth(time)=0) and (getday(time)<3)) or ((getmonth(time)=11) and (getday(time)>29)) then
  34    setmap(102,chx,chy);
  35   else
  36    setmap(28,chx,chy);
  37   setmap(26,chx-1,chy);
  38   setmap(26,chx+1,chy);
  39   setmapinfo(31,chx,chy);
  40   id:=chest.create(chx,chy);
  41   debug('Bonus Chest');
  42     for ix:=1 to rnd(10)+1 do
  43      begin
  44       l:=rnd(26);
  45       if rnd(2)=rnd(2) then
  46        begin
  47         chest.setItem(127 ,l, id);
  48         chest.setSum(rnd(6)+1, l, id);
  49        end; else
  50       if rnd(2)=rnd(2) then
  51        begin
  52         chest.setItem(9 ,l, id);
  53         chest.setSum(rnd(4)+1, l, id);
  54        end; else
  55       if rnd(2)=rnd(2) then
  56        begin
  57         chest.setItem(4 ,l, id);
  58         chest.setSum(rnd(4)+1, l, id);
  59        end; else
  60       if rnd(2)=rnd(2) then
  61        begin
  62         chest.setItem(131 ,l, id);
  63         chest.setSum(60, l, id);
  64        end; else
  65       if rnd(2)=rnd(2) then
  66        begin
  67         chest.setItem(132 ,l, id);
  68         chest.setSum(132, l, id);
  69        end;
  70       if rnd(2)=rnd(2) then
  71        begin
  72         chest.setItem(141 ,l, id);
  73         chest.setSum(60, l, id);
  74        end; else
  75       if rnd(2)=rnd(2) then
  76        begin
  77         chest.setItem(142 ,l, id);
  78         chest.setSum(132, l, id);
  79        end;
  80       if rnd(2)=rnd(2) then
  81        begin
  82         chest.setItem(147 ,l, id);
  83         chest.setSum(60, l, id);
  84        end; else
  85       if rnd(2)=rnd(2) then
  86        begin
  87         chest.setItem(201 ,l, id);
  88         chest.setSum(rnd(16), l, id);
  89        end;
  90      end;
  91  end;
  92
  93  procedure genflat;
  94   var
  95    ix,iy:integer;
  96   begin
  97    for ix:=0 to 255 do
  98     begin
  99      setmap(2,ix,121);
 100      setmap(1,ix,122);
 101      setmap(1,ix,123);
 102      setmap(3,ix,124);
 103      setmap(3,ix,125);
 104      setmap(3,ix,126);
 105      setmap(6,ix,127);
 106
 107      setBackMap(121, ix);
 108      setBiomMap(0, ix);
 109     end;
 110    if bon_chest then create_bonus_chest(get_spawn_x,get_spawn_y+1);
 111    delay(200);
 112   end;
 113
 114  procedure drawmap;
 115   var
 116    ix,iy:integer;
 117   begin
 118    for ix:=0 to 255 do
 119    for iy:=0 to 127 do
 120     begin
 121      if getmap(ix,iy)<>0 then setcolor(0,0,0); else setcolor(255,255,255);
 122      plot(ix,iy);
 123     end;
 124    repaint;
 125    delay(1);
 126   end;
 127
 128  procedure gencave(xx,yy:integer);
 129   var
 130    ix,iy:integer;
 131    mask:array [0..63,0..63] of boolean;
 132   begin
 133    for ix:=0 to 63 do
 134    for iy:=0 to 63 do
 135     mask[ix,iy]:=true;
 136    ix:=(63+1)/2-1;
 137    iy:=(63+1)/2-1;
 138    while (ix>=0) and (ix<=63) and (iy>=0) and (iy<=63) do
 139     begin
 140      ix:=ix+rnd_min;
 141      iy:=iy+rnd_min;
 142      if (ix>=0) and (ix<=63) and (iy>=0) and (iy<=63) then mask[ix,iy]:=false;
 143     end;
 144    for ix:=1 to 62 do
 145    for iy:=1 to 62 do
 146     begin
 147      if mask[ix,iy]=true then
 148       if mask[ix-1,iy]=false then
 149        if mask[ix+1,iy]=false then
 150        mask[ix,iy]:=false;
 151     end;
 152
 153    for ix:=0 to 63 do
 154    for iy:=0 to 63 do
 155     begin
 156      if mask[ix,iy]=false then setmap(0,xx+ix,yy+iy);
 157     end;
 158   end;
 159
 160  procedure genportal(xx,yy:integer);
 161   begin
 162    setmap(10,xx+1,yy);
 163    setmap(10,xx+2,yy);
 164    setmap(118,xx,yy+1);
 165    setmap(118,xx+3,yy+1);
 166    setmap(118,xx,yy+2);
 167    setmap(118,xx+3,yy+2);
 168    setmap(118,xx,yy+3);
 169    setmap(118,xx+3,yy+3);
 170    setmap(10,xx+1,yy+4);
 171    setmap(10,xx+2,yy+4);
 172    setmap(110,xx+1,yy+1);
 173    setmap(110,xx+2,yy+1);
 174    setmap(110,xx+1,yy+2);
 175    setmap(110,xx+2,yy+2);
 176    setmap(110,xx+1,yy+3);
 177    setmap(110,xx+2,yy+3);
 178   end;
 179
 180  procedure genportal_big(xx,yy:integer);
 181   begin
 182    setmap(10,xx,yy);
 183    setmap(10,xx+1,yy);
 184    setmap(10,xx+2,yy);
 185    setmap(10,xx+3,yy);
 186    setmap(118,xx,yy+1);
 187    setmap(118,xx+3,yy+1);
 188    setmap(118,xx,yy+2);
 189    setmap(118,xx+3,yy+2);
 190    setmap(118,xx,yy+3);
 191    setmap(118,xx+3,yy+3);
 192    setmap(10,xx,yy+4);
 193    setmap(10,xx+1,yy+4);
 194    setmap(10,xx+2,yy+4);
 195    setmap(10,xx+3,yy+4);
 196    setmap(110,xx+1,yy+1);
 197    setmap(110,xx+2,yy+1);
 198    setmap(110,xx+1,yy+2);
 199    setmap(110,xx+2,yy+2);
 200    setmap(110,xx+1,yy+3);
 201    setmap(110,xx+2,yy+3);
 202   end;
 203
 204  procedure surprisechest(x,y:integer);
 205   var
 206    ix,l,id:integer;
 207   begin
 208    id:=chest.create(x, y);
 209      debug('Surprise!');
 210      setmap(102,x,y);
 211      for ix:=1 to rnd(8) do
 212       begin
 213        l:=rnd(26);
 214        if rnd(22)=1 then
 215         begin
 216          chest.setItem(162 ,l, id);
 217          chest.setSum(rnd(5), l, id);
 218         end; else
 219        if rnd(11)=1 then
 220         begin
 221          chest.setItem(165 ,l, id);
 222          chest.setSum(rnd(6), l, id);
 223         end; else
 224        if rnd(11)=1 then
 225         begin
 226          chest.setItem(181 ,l, id);
 227          chest.setSum(rnd(2), l, id);
 228         end; else
 229        if rnd(11)=1 then
 230         begin
 231          chest.setItem(182 ,l, id);
 232          chest.setSum(rnd(2), l, id);
 233         end; else
 234        if rnd(11)=1 then
 235         begin
 236          chest.setItem(176 ,l, id);
 237          chest.setSum(rnd(32), l, id);
 238         end; else
 239        if rnd(11)=1 then
 240         begin
 241          chest.setItem(183 ,l, id);
 242          chest.setSum(rnd(10)+1, l, id);
 243         end; else
 244        if rnd(11)=1 then
 245         begin
 246          chest.setItem(186 ,l, id);
 247          chest.setSum(1, l, id);
 248         end;
 249       end;
 250   end;
 251
 252  procedure genwood1(xx,yy:integer);//дуб
 253   begin
 254    setmap(75,xx,yy);
 255    setmap(75,xx,yy-1);
 256    setmap(75,xx,yy-2);
 257    setmap(21,xx,yy-3);
 258    setmap(21,xx,yy-4);
 259    setmap(21,xx,yy-5);
 260    setmap(21,xx-1,yy-3);
 261    setmap(21,xx-1,yy-4);
 262    setmap(21,xx+1,yy-3);
 263    setmap(21,xx+1,yy-4);
 264   end;
 265
 266  procedure genwood2(xx,yy:integer);//берёза
 267   begin
 268    setmap(84,xx,yy);
 269    setmap(84,xx,yy-1);
 270    setmap(84,xx,yy-2);
 271    setmap(112,xx,yy-3);
 272    setmap(112,xx,yy-4);
 273    setmap(112,xx,yy-5);
 274    setmap(112,xx-1,yy-3);
 275    setmap(112,xx-1,yy-4);
 276    setmap(112,xx+1,yy-3);
 277    setmap(112,xx+1,yy-4);
 278   end;
 279
 280  procedure genwood3(xx,yy:integer);//ель
 281   var
 282    time:integer;
 283   begin
 284    setmap(87,xx,yy-5);
 285    setmap(87,xx-1,yy-4); setmap(87,xx,yy-4); setmap(87,xx+1,yy-4);
 286    setmap(86,xx,yy-3);
 287    setmap(87,xx-1,yy-2); setmap(86,xx,yy-2); setmap(87,xx+1,yy-2);
 288    setmap(87,xx-2,yy-1); setmap(87,xx-1,yy-1); setmap(86,xx,yy-1); setmap(87,xx+1,yy-1); setmap(87,xx+2,yy-1);
 289    setmap(86,xx,yy);
 290    time:=getcurrenttime;
 291    if ((getmonth(time)=0) and (getday(time)<3)) or ((getmonth(time)=11) and (getday(time)>29)) then
 292     begin
 293      if rnd(3)=1 then surprisechest(xx-1,yy);
 294      if rnd(3)=1 then surprisechest(xx+1,yy);
 295     end;
 296   end;
 297
 298  procedure genfungus1(xx,yy:integer);//красный гриб
 299   begin
 300    setmap(88,xx-1,yy-4); setmap(88,xx,yy-4); setmap(88,xx+1,yy-4);
 301    setmap(88,xx-2,yy-3); setmap(88,xx-1,yy-3); setmap(88,xx,yy-3); setmap(88,xx+1,yy-3); setmap(88,xx+2,yy-3);
 302    setmap(88,xx-2,yy-2); setmap(88,xx-1,yy-2); setmap(88,xx,yy-2); setmap(88,xx+1,yy-2); setmap(88,xx+2,yy-2);
 303    setmap(89,xx,yy-1);
 304    setmap(89,xx,yy);
 305   end;
 306
 307  procedure genfungus2(xx,yy:integer);//коричневый гриб
 308   begin
 309    setmap(90,xx-2,yy-4); setmap(90,xx-1,yy-4); setmap(90,xx,yy-4); setmap(90,xx+1,yy-4); setmap(90,xx+2,yy-4);
 310    setmap(91,xx,yy-3);
 311    setmap(91,xx,yy-2);
 312    setmap(91,xx,yy-1);
 313    setmap(91,xx,yy);
 314   end;
 315
 316  procedure gencactus(xx,yy:integer);
 317   begin
 318    setmap(30,xx,yy);
 319    setmap(30,xx,yy-1);
 320    setmap(30,xx,yy-2);
 321   end;
 322
 323  procedure gencane(xx,yy:integer);
 324   begin
 325    setmap(65,xx,yy);
 326    setmap(65,xx,yy-1);
 327    setmap(65,xx,yy-2);
 328   end;
 329
 330  procedure treasurechest(x,y:integer);
 331   var
 332    ix,l,id:integer;
 333   begin
 334    id:=chest.create(x, y);
 335      debug('Treasure Chest');
 336      setmap(28,x,y);
 337      for ix:=1 to rnd(8) do
 338       begin
 339        l:=rnd(26);
 340        if rnd(22)=rnd(22) then
 341         begin
 342          chest.setItem(161 ,l, id);
 343          chest.setSum(rnd(4)+1, l, id);
 344         end; else
 345        if rnd(11)=rnd(11) then
 346         begin
 347          chest.setItem(164 ,l, id);
 348          chest.setSum(rnd(4)+1, l, id);
 349         end; else
 350        if rnd(11)=rnd(11) then
 351         begin
 352          chest.setItem(183 ,l, id);
 353          chest.setSum(rnd(4)+1, l, id);
 354         end; else
 355        if rnd(11)=rnd(11) then
 356         begin
 357          chest.setItem(167 ,l, id);
 358          chest.setSum(rnd(4)+1, l, id);
 359         end; else
 360        if rnd(11)=rnd(11) then
 361         begin
 362          chest.setItem(171 ,l, id);
 363          chest.setSum(1, l, id);
 364         end; else
 365        if rnd(4)=rnd(4) then
 366         begin
 367          chest.setItem(220 ,l, id);
 368          chest.setSum(rnd(8)+8, l, id);
 369         end;
 370       end;
 371   end;
 372
 373  procedure genteasures(xx,yy:integer);
 374   var
 375    ix,iy:integer;
 376   begin
 377    for ix:=0 to 6 do
 378    for iy:=0 to 6 do
 379     begin
 380      setmap(0,xx+ix,yy+iy);
 381     end;
 382    for ix:=0 to 6 do
 383     begin
 384      setmap(12,xx+ix,yy);
 385      setmap(12,xx+ix,yy+6);
 386      setmap(12,xx,yy+ix);
 387      setmap(12,xx+6,yy+ix);
 388     end;
 389
 390    setmap(76,xx+3,yy+5);
 391    setmapinfo(1,xx+3,yy+5);
 392
 393    if rnd(2)=1 then
 394     treasurechest(xx+1,yy+5);
 395
 396    if rnd(2)=1 then
 397     treasurechest(xx+5,yy+5);
 398   end;
 399
 400  procedure genrude(t,r,xx,yy,xxx,yyy:integer);
 401   var
 402    ix,iy:integer;
 403   begin
 404    for ix:=0 to xxx do
 405    for iy:=0 to yyy do
 406     begin
 407       if getmap(xx+ix,yy+iy)=3 then if rnd(r+1)-1=0 then setmap(t,xx+ix,yy+iy);
 408     end;
 409   end;
 410
 411  // Генерирует чанки руды в камне типа block с максимальной вероятность percent процентов
 412  // Начиная с уровня starty и размером не более maxsize*maxsize
 413  // С ростом глубины вероятность растёт
 414  procedure GenOreChunks(block, percent, starty, maxsize : Integer);
 415    const
 416      preq = 100000;
 417    var
 418      x, y, i, j : Integer;
 419    begin
 420      for x := 0 to MAP_W do
 421      for y := starty to MAP_H do
 422        if RandomBoolean(y * percent * preq / MAP_H, 100 * preq) then
 423          for i := 0 to rnd(maxsize) - 1 do
 424          for j := 0 to rnd(maxsize) - 1 do
 425            if RandomBoolean(50, 100) and (GetMap(x + i, y + j) = 3) then
 426              SetMap(block, x + i, y + j);
 427    end;
 428
 429  procedure genallrudes;
 430   begin
 431    (* Алмазная руда *)
 432    GenOreChunks(19, 1, 111, 3);
 433    (* Золотая руда *)
 434    GenOreChunks(16, 2, 95, 3);
 435    (* Лазуритовая руда *)
 436    GenOreChunks(54, 2, 107, 3);
 437    (* Красная руда *)
 438    GenOreChunks(20, 2, 107, 3);
 439    (* Железная руда *)
 440    GenOreChunks(17, 3, 63, 3);
 441    (* Угольная руда *)
 442    GenOreChunks(18, 4, 0, 6);
 443    (* Гравий *)
 444    GenOreChunks(8, 2, 0, 6);
 445    (* Грязь *)
 446    GenOreChunks(8, 2, 0, 6);
 447   end;
 448
 449  procedure dec_0(ix,iy:integer);
 450   var
 451    t:integer;
 452   begin
 453    t:=rnd(30);
 454    if t=0 then setmap(22,ix,iy); else
 455    if t=1 then setmap(23,ix,iy); else
 456    if t=2 then setmap(24,ix,iy); else
 457    if t=3 then setmap(25,ix,iy); else
 458    if (t>3) and (t<8) then setmap(57,ix,iy); else
 459    if t=8 then genwood1(ix,iy); else
 460    if t=9 then genwood2(ix,iy); else
 461    if t=10 then setmap(66,ix,iy); else
 462    if t=11 then setmap(73,ix,iy); else
 463    if t>11 then begin if (getmap(ix-1,iy+1)=50) or (getmap(ix+1,iy+1)=50) then gencane(ix,iy); end; else
 464    exit;
 465   end;
 466
 467  procedure dec_1(ix,iy:integer);
 468   var
 469    t:integer;
 470   begin
 471    t:=rnd(25);
 472    if t=0 then setmap(58,ix,iy); else
 473    if t=1 then gencactus(ix,iy); else
 474    if t>2 then begin if (getmap(ix-1,iy+1)=50) or (getmap(ix+1,iy+1)=50) then gencane(ix,iy); end; else
 475    exit;
 476   end;
 477
 478  procedure dec_2(ix,iy:integer);
 479   var
 480    t:integer;
 481   begin
 482    t:=rnd(30);
 483    if t=0 then setmap(22,ix,iy); else
 484    if t=1 then setmap(23,ix,iy); else
 485    if t=2 then genwood1(ix,iy); else
 486    if t=3 then genwood2(ix,iy); else
 487    if t=4 then genwood3(ix,iy); else
 488    if t=5 then setmap(66,ix,iy); else
 489    exit;
 490   end;
 491
 492  procedure dec_3(ix,iy:integer);
 493   var
 494    t:integer;
 495   begin
 496    t:=rnd(20);
 497    if t=1 then setmap(24,ix,iy); else
 498    if t=2 then setmap(25,ix,iy); else
 499    if t=3 then genfungus1(ix,iy); else
 500    if t=4 then genfungus2(ix,iy); else
 501    exit;
 502   end;
 503
 504  procedure decorator;
 505   var
 506    ix,iy,t:integer;
 507   begin
 508    for ix:=0 to 255 do
 509    for iy:=0 to 127 do
 510    if getmap(ix,iy)<>0 then
 511     begin
 512      if (getBiomMap(ix)=0) then
 513       begin
 514        iy:=iy-1;
 515        if (getmap(ix,iy+1)=2) and (getmap(ix,iy)=0) then dec_0(ix,iy);
 516        break;
 517       end; else
 518      if (getBiomMap(ix)=1) then
 519       begin
 520        iy:=iy-1;
 521        if (getmap(ix,iy+1)=7) and (getmap(ix,iy)=0) then dec_1(ix,iy);
 522        break;
 523       end; else
 524      if (getBiomMap(ix)=2) then
 525       begin
 526        iy:=iy-1;
 527        if (getmap(ix,iy+1)=48) and (getmap(ix,iy)=0) then dec_2(ix,iy);
 528        break;
 529       end; else
 530      if (getBiomMap(ix)=3) then
 531       begin
 532        iy:=iy-1;
 533        if (getmap(ix,iy+1)=74) and (getmap(ix,iy)=0) then dec_3(ix,iy);
 534        break;
 535       end; else
 536      break;
 537       end;
 538   end;
 539
 540  procedure genwater;
 541   var
 542    ix,iy,i:integer;
 543    g:boolean;
 544   begin
 545    for ix:=0 to 255 do
 546    for iy:=0 to 127 do
 547     begin
 548      if rnd(5)=rnd(6) then g:=not g;
 549      if iy>63 then
 550       if (getmap(ix,iy)=2) or (getmap(ix,iy)=48) or (getmap(ix,iy)=74) then
 551        begin
 552         if g then
 553          for i:=0 to rnd(4) do setmap(64,ix,iy+i);
 554         else setmap(1,ix,iy);
 555         break;
 556        end; else
 557       if (getmap(ix,iy)=7) then
 558        begin
 559         if g then
 560          for i:=0 to rnd(4) do setmap(64,ix,iy+i);
 561         break;
 562        end;
 563      if getmap(ix,iy)<>0 then break;
 564      if iy>=63 then if getmap(ix,iy)=0 then setmap(50,ix,iy);
 565     end;
 566   end;
 567
 568  procedure minechest(x,y:integer);
 569   var
 570    ix,l,id:integer;
 571   begin
 572    id:=chest.create(x,y);
 573      setmap(28,x,y);
 574      for ix:=1 to rnd(6)+4 do
 575       begin
 576        l:=rnd(26);
 577        if rnd(75)=rnd(75) then
 578         begin
 579          chest.setItem(Items.pickaxe3 ,l, id);
 580          chest.setSum(Items.GetMaximum(Items.pickaxe3), l, id);
 581         end; else
 582        if rnd(25)=rnd(25) then
 583         begin
 584          chest.setItem(162 ,l, id);
 585          chest.setSum(rnd(2)+1, l, id);
 586         end; else
 587        if rnd(15)=rnd(15) then
 588         begin
 589          chest.setItem(165 ,l, id);
 590          chest.setSum(rnd(3)+1, l, id);
 591         end; else
 592        if rnd(15)=rnd(15) then
 593         begin
 594          chest.setItem(166 ,l, id);
 595          chest.setSum(rnd(6)+4, l, id);
 596         end; else
 597        if rnd(15)=rnd(15) then
 598         begin
 599          chest.setItem(161 ,l, id);
 600          chest.setSum(rnd(6)+4, l, id);
 601         end; else
 602        if rnd(15)=rnd(15) then
 603         begin
 604          chest.setItem(160 ,l, id);
 605          chest.setSum(rnd(6)+3, l, id);
 606         end; else
 607        if rnd(15)=rnd(15) then
 608         begin
 609          chest.setItem(164 ,l, id);
 610          chest.setSum(rnd(5)+1, l, id);
 611         end; else
 612        if rnd(4)=rnd(4) then
 613         begin
 614          chest.setItem(220 ,l, id);
 615          chest.setSum(rnd(8)+8, l, id);
 616         end;
 617       end;
 618   end;
 619
 620  procedure minestruc0(x,y:integer);
 621   var
 622    ix,iy:integer;
 623   begin
 624    for ix:=0 to 3 do
 625    for iy:=0 to 2 do
 626     setmap(0,x+ix,y+iy);
 627
 628    if rnd(8)=0 then setmap(26,x+1,y+1);
 629
 630    for ix:=0 to 3 do
 631     if getmap(x+ix,y+3)=0 then setmap(4,x+ix,y+3);
 632   end;
 633
 634  procedure minestruc1(x,y:integer);
 635   var
 636    ix,iy:integer;
 637   begin
 638    for ix:=0 to 2 do
 639    for iy:=0 to 2 do
 640     setmap(0,x+ix,y+iy);
 641
 642    if rnd(8)=0 then setmap(59,x,y);
 643    if rnd(8)=0 then setmap(59,x+2,y);
 644    setmap(4,x+1,y);
 645    setmap(93,x+1,y+1);
 646    setmap(93,x+1,y+2);
 647    for ix:=0 to 2 do
 648     if getmap(x+ix,y+3)=0 then setmap(4,x+ix,y+3);
 649   end;
 650
 651  procedure minestruc2(x,y:integer);
 652   var
 653    ix,iy:integer;
 654   begin
 655    for ix:=0 to 2 do
 656    for iy:=0 to 2 do
 657     setmap(0,x+ix,y+iy);
 658
 659    if rnd(8)=0 then setmap(59,x+1,y);
 660
 661    for iy:=0 to 2 do
 662     begin
 663      setmap(94,x,y+iy);
 664      setmap(94,x+2,y+iy);
 665     end;
 666    for ix:=0 to 2 do
 667     if getmap(x+ix,y+3)=0 then setmap(4,x+ix,y+3);
 668   end;
 669
 670  procedure minestruc3(x,y:integer);
 671   var
 672    ix,iy,id,l:integer;
 673   begin
 674    for ix:=0 to 2 do
 675    for iy:=0 to 2 do
 676     setmap(0,x+ix,y+iy);
 677
 678    minechest(x+1,y+2);
 679
 680    for ix:=0 to 2 do
 681     if getmap(x+ix,y+3)=0 then setmap(4,x+ix,y+3);
 682   end;
 683
 684  procedure genmines(x,y:integer);
 685   var
 686    mask:array[0..15,0..15] of integer;
 687    ix,iy,by:integer;
 688   begin
 689    for iy:=0 to 15 do
 690    for ix:=0 to 15 do
 691     mask[ix,iy]:=-1;
 692
 693    for iy:=rnd(8)+8 downto rnd(8) do
 694    for ix:=rnd(8) to rnd(8)+8 do
 695     begin
 696      if ix-1>=0 then
 697       begin
 698        if mask[ix-1,iy]=-1 then mask[ix,iy]:=rnd(3); else
 699        if mask[ix-1,iy]=0 then if rnd(16)=5 then mask[ix,iy]:=2; else mask[ix,iy]:=1; else
 700        if mask[ix-1,iy]=1 then mask[ix,iy]:=0; else
 701        if mask[ix-1,iy]=2 then mask[ix,iy]:=rnd(3); else
 702        if mask[ix-1,iy]=3 then mask[ix,iy]:=rnd(3);
 703       end;
 704
 705      if mask[ix,iy]=0 then
 706       begin
 707        if rnd(16)=0 then mask[ix,iy]:=3;
 708       end;
 709     end;
 710
 711    for iy:=15 downto 0 do
 712    for ix:=0 to 15 do
 713     begin
 714      if rnd(16)=0 then by:=rnd_min;;
 715      if mask[ix,iy]=0 then minestruc0(x+(3*ix),y+(4*iy+by)); else
 716      if mask[ix,iy]=1 then minestruc1(x+(3*ix),y+(4*iy+by)); else
 717      if mask[ix,iy]=2 then minestruc2(x+(3*ix),y+(4*iy+by)); else
 718      if mask[ix,iy]=3 then minestruc3(x+(3*ix),y+(4*iy+by));
 719     end;
 720   end;
 721
 722  function get_up(Xi:integer):integer;
 723   var
 724    iy:integer;
 725   begin
 726    for iy:=127 downto 0 do
 727     if getmap(xi,iy)=0 then begin get_up:=iy; break; end;
 728   end;
 729
 730  function get_down(Xi:integer):integer;
 731   var
 732    iy:integer;
 733   begin
 734    for iy:=2 to 127 do
 735   if getmap(xi,iy)=0 then begin get_down:=iy; break; end;
 736   end;
 737
 738   procedure gensoulsand(gx,gy:integer;);
 739   var
 740     ix2,iy2:integer;
 741   begin
 742     for ix2:=gx-2-rnd(3) to gx+2+rnd(3) do
 743     for iy2:=gy-1-rnd(2) to gy+1+rnd(2) do
 744     setmap(rnd_pr(80,113,getmap(ix2,iy2)),ix2,iy2);
 745   end;
 746
 747   procedure genglowstone(gx,gy:integer;);
 748   var
 749     ix2,iy2:integer;
 750   begin
 751     for ix2:=gx-1-rnd(2) to gx+1+rnd(2) do
 752     for iy2:=gy-1-rnd(2) to gy+rnd(2) do
 753     setmap(rnd_pr(85,111,getmap(ix2,iy2)),ix2,iy2);
 754   end;
 755
 756  procedure gennether;
 757   var
 758    ix,iy,h,wtd,ty,ga,tmp:integer;
 759   begin
 760    for ix:=0 to 255 do
 761    for iy:=1 to 126 do
 762     begin
 763      if (getmap(ix,iy)<>10) or (getmap(ix,iy)<>110) then
 764       setmap(109,ix,iy);
 765     end;
 766    h:=63;
 767    ty:=4;
 768    for ix:=0 to 255 do
 769     begin
 770      wtd:=rnd(100);
 771      if (wtd>0) and (wtd<30) then h:=h+1;
 772      if (wtd>29) and (wtd<60) then h:=h-1;
 773      if wtd=0 then h:=h+(2+rnd(3));
 774      if wtd=99 then h:=h-(2+rnd(3));
 775      if h<30 then h:=31;
 776      if h>70 then h:=69;
 777      setBiomMap(ty, ix);
 778      setBackMap(0, ix);
 779      for iy:=h-10-(1-rnd(3)) to h+rnd(2) do
 780       begin
 781         setmap(0,ix,iy);
 782       end;
 783     end;
 784
 785    for ix:=0 to 255 do
 786    for iy:=65 to 127 do
 787     begin
 788      if getmap(ix,iy)=0 then setmap(51,ix,iy);
 789     end;
 790
 791     for ix:=1 to rnd(3)+3 do begin iy:=rnd(256); debug('SoulSand'); gensoulsand(iy,get_up(iy)); end;
 792     for ix:=1 to rnd(4)+7 do begin iy:=rnd(256); debug('GlowStone - '+iy); genglowstone(iy,get_down(iy)); end;
 793
 794    for ix:=0 to 255 do
 795    begin
 796      setmap(6,ix,127);
 797      setmap(6,ix,0);
 798    end;
 799     player.setX(get_spawn_x*16+4);
 800     player.setY((get_up(get_spawn_x)-1)*16);
 801     setmap(109,get_spawn_x,get_up(get_spawn_x)+1);
 802     setmap(0,get_spawn_x,get_up(get_spawn_x));
 803     setmap(0,get_spawn_x,get_up(get_spawn_x)-1);
 804     genportal_big(get_spawn_x-2,(get_up(get_spawn_x)-1)-2);
 805   end;
 806
 807  procedure genworld;
 808   var
 809    ix,iy,h,wtd,ty,ga,tmp:integer;
 810   begin
 811    pl_world:=0;
 812    for ix:=0 to 255 do
 813    for iy:=0 to 127 do
 814    setmap(0,ix,iy);
 815    h:=63;
 816    ty:=rnd(4);
 817    for ix:=0 to 255 do
 818     begin
 819      wtd:=rnd(100);
 820      if (wtd>0) and (wtd<30) then h:=h+1;
 821      if (wtd>29) and (wtd<60) then h:=h-1;
 822      if wtd=0 then h:=h+(2+rnd(3));
 823      if wtd=99 then h:=h-(2+rnd(3));
 824      if h<0 then h:=0;
 825      if h>80 then h:=80;
 826      if wtd=rnd(100) then begin ty:=rnd(4); debug('Biome:'+ty); end;
 827      setBiomMap(ty, ix);
 828      setBackMap(h, ix);
 829      if getBackMap(ix)>63 then
 830       setBackMap(63, ix);
 831      for iy:=h to 127 do
 832       begin
 833        if ty=0 then
 834         begin
 835          if iy=h then setmap(2,ix,iy);
 836          if (iy>h) and (iy<h+4) then setmap(1,ix,iy);
 837          if iy>h+3 then setmap(3,ix,iy);
 838         end; else
 839        if ty=1 then
 840         begin
 841          if (iy>=h) and (iy<=h+1) then setmap(7,ix,iy);
 842          if iy=h+2 then setmap(rnd_pr(50,56,7),ix,iy);
 843          if iy=h+3 then setmap(56,ix,iy);
 844          if iy>h+3 then setmap(3,ix,iy);
 845         end; else
 846        if ty=2 then
 847         begin
 848          if iy=h then setmap(48,ix,iy);
 849          if (iy>h) and (iy<h+4) then setmap(1,ix,iy);
 850          if iy>h+3 then setmap(3,ix,iy);
 851         end;  else
 852        if ty=3 then
 853         begin
 854          if iy=h then setmap(74,ix,iy);
 855          if (iy>h) and (iy<h+4) then setmap(1,ix,iy);
 856          if iy>h+3 then setmap(3,ix,iy);
 857         end;
 858       end;
 859     end;
 860
 861    genallrudes;
 862
 863    for ix:=1 to rnd(4)+1 do begin debug('Cave'); gencave(rnd(256),64-rnd(10)); end;
 864
 865    for ix:=1 to rnd(3) do begin debug('Mine'); genmines(rnd(256),rnd(64)+64); end;
 866
 867    for ix:=1 to rnd(4) do begin debug('Treasure'); genteasures(rnd(256),rnd(64)+64); end;
 868
 869    genwater;
 870
 871    for ix:=0 to 255 do
 872    for iy:=117 to 127 do
 873     begin
 874      if getmap(ix,iy)=0 then setmap(51,ix,iy);
 875     end;
 876
 877    decorator;
 878
 879    for ix:=0 to 255 do
 880     begin
 881      if getBiomMap(ix)=2 then
 882       for iy:=0 to 127 do
 883        if getmap(ix,iy)<>0 then
 884         begin
 885          if getmap(ix,iy)=50 then setmap(62,ix,iy); else
 886          if (getmap(ix,iy)<>22) and (getmap(ix,iy)<>23) then setmap(63,ix,iy-1);
 887          break;
 888         end;
 889     end;
 890
 891    for ix:=0 to 255 do setmap(6,ix,127);
 892
 893    if bon_chest then create_bonus_chest(get_spawn_x,get_spawn_y+1);
 894
 895    //drawmap;
 896    delay(200);
 897    debug('World Generated!');
 898   end;
 899
 900 initialization
 901
 902 end.