API tools faq
paste
Advertisement
Guest User

level carver

a guest
Sep 4th, 2015
101
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 44.39 KB | None | 0 0
raw download clone embed print report
  1. #!/usr/bin/perl
  2.  
  3. use strict;
  4. use Term::ANSIColor;
  5. use Carp;
  6.  
  7. my ($ROWNO, $COLNO) = (21, 79);
  8. my $roomcount = 0;
  9. my $domonsters = 0;
  10. my $pillarprob = 12;
  11. my (@carvepoint, @room);
  12.  
  13. # TODO list:
  14. # 1. The pillar placement probably ought to check that it's possible
  15. # to go around the pillar, and that it does not block any doors.
  16. # 2. Parallel walls look ugly due to unnecessary cross connections.
  17.  
  18. my $corr = +{ t => 'CORR',
  19. b => 'on_black',
  20. f => 'white',
  21. c => '#',
  22. };
  23. my $ecorr = $corr;
  24. #+{ t => 'CORR',
  25. # b => 'on_black',
  26. # f => 'cyan',
  27. # c => '#',
  28. # };
  29. my $scorr = +{ t => 'CORR',
  30. b => 'on_black',
  31. f => 'blue',
  32. c => '#',
  33. };
  34. sub roomfloor {
  35. my ($roomno) = @_;
  36. return +{
  37. t => 'ROOM',
  38. b => 'on_black',
  39. f => 'white',
  40. c => '·',
  41. r => $roomno,
  42. };
  43. }
  44. my $floor = +{ t => 'ROOM',
  45. b => 'on_black',
  46. f => 'white',
  47. c => '·',
  48. };
  49. # Some colored floors for debugging purposes:
  50. my $redfloor = +{ t => 'ROOM',
  51. b => 'on_black',
  52. f => 'red',
  53. c => '·',
  54. };
  55. my $bluefloor = +{ t => 'ROOM',
  56. b => 'on_black',
  57. f => 'blue',
  58. c => '·',
  59. };
  60. my $greenfloor = +{ t => 'ROOM',
  61. b => 'on_black',
  62. f => 'green',
  63. c => '.',
  64. };
  65. my $stone = +{ c => ' ',
  66. b => 'on_black',
  67. f => 'white',
  68. t => 'STONE',
  69. };
  70. my $door = +{ c => '+',
  71. b => 'on_black',
  72. f => 'yellow',
  73. t => 'DOOR' };
  74. my $sdoor = +{ c => '+',
  75. b => 'on_black',
  76. f => 'blue',
  77. t => 'DOOR' };
  78. my $hwall = +{ c => '-',
  79. b => 'on_black',
  80. f => 'white',
  81. t => 'WALL' };
  82. my $vwall = +{ c => '|',
  83. b => 'on_black',
  84. f => 'white',
  85. t => 'WALL' };
  86. #my $northexit = +{ c => 'N',
  87. # b => 'on_black',
  88. # f => 'yellow',
  89. # t => 'DOOR' };
  90. #my $southexit = +{ c => 'S',
  91. # b => 'on_black',
  92. # f => 'yellow',
  93. # t => 'DOOR' };
  94. #my $eastexit = +{ c => 'E',
  95. # b => 'on_black',
  96. # f => 'yellow',
  97. # t => 'DOOR' };
  98. #my $westexit = +{ c => 'W',
  99. # b => 'on_black',
  100. # f => 'yellow',
  101. # t => 'DOOR' };
  102.  
  103. my %wdir = ( E => +{ bit => 1, dx => 1, dy => 0, clockwise => 'S', },
  104. N => +{ bit => 2, dx => 0, dy => -1, clockwise => 'E', },
  105. W => +{ bit => 4, dx => -1, dy => 0, clockwise => 'N', },
  106. S => +{ bit => 8, dx => 0, dy => 1, clockwise => 'W', },
  107. );
  108. my @wallglyph = qw/! ─ │ └ ─ ─ ┘ ┴ │ ┌ │ ├ ┐ ┬ ┤ ┼/;
  109. $wallglyph[0] = '-';
  110.  
  111.  
  112. my @map = (map {
  113. [ map { $stone } 0 .. $ROWNO ],
  114. } 0 .. $COLNO);
  115.  
  116.  
  117.  
  118. my @carvemethod =
  119. (
  120. +{ name => 'onespot',
  121. type => 'corridor',
  122. make => sub {
  123. my ($ox, $oy, $odx, $ody, $parent) = @_;
  124. return carveonespot($ox, $oy, $odx, $ody, $parent,
  125. (20 > int rand 100) ? $scorr : $corr);
  126. },
  127. },
  128. +{ name => 'spiral',
  129. type => 'corridor',
  130. make => sub {
  131. return carvespiral(@_);
  132. },
  133. },
  134. +{ name => 'basic_short_corridor',
  135. type => 'corridor',
  136. make => sub {
  137. my ($ox, $oy, $odx, $ody, $parent) = @_;
  138. return carvebasiccorridor($ox, $oy, $odx, $ody, $parent, $corr);
  139. },
  140. },
  141. +{ name => 'secret_corridor',
  142. type => 'corridor',
  143. make => sub {
  144. my ($ox, $oy, $odx, $ody, $parent) = @_;
  145. return carvebasiccorridor($ox, $oy, $odx, $ody, $parent, $scorr, 1 + int rand rand 2);
  146. },
  147. },
  148. +{ name => 'marketplace',
  149. type => 'room',
  150. make => sub {
  151. return carvemarketplace(@_);
  152. },
  153. },
  154. +{ name => 'tee',
  155. type => 'room',
  156. make => sub {
  157. return carvetee(@_);
  158. },
  159. },
  160. +{ name => 'Y',
  161. type => 'room',
  162. make => sub {
  163. return carveyroom(@_);
  164. },
  165. },
  166. +{ name => 'rhombus',
  167. type => 'room',
  168. make => sub {
  169. return carverhombus(@_);
  170. },
  171. },
  172. +{ name => 'octagon',
  173. type => 'room',
  174. make => sub {
  175. return carveoctagon(@_);
  176. },
  177. },
  178. (+{
  179. name => 'rectangle',
  180. type => 'room',
  181. make => sub {
  182. return carverectangle(@_);
  183. },
  184. }) x 2,
  185. );
  186.  
  187. my %count = map { $_ => 0 } qw(marketplace spiral);
  188. #use Data::Dumper; print Dumper(+{ cmarray => \@carvemethod });
  189. my $x = 10 + int rand($COLNO - 20);
  190. my $y = 3 + int rand($ROWNO - 6);
  191. my ($dx, $dy) = choosedir();
  192. recursivecarve($x, $y, $dx, $dy, undef);
  193. recursivecarve($x - $dx, $y - $dy, 0 - $dx, 0 - $dy, undef);
  194.  
  195. #$map[$x][$y] = $map[$x - $dx][$y - $dy] = $greenfloor; # for debug purposes
  196.  
  197. #showmap();
  198. #print "\n";
  199. #print color "green";
  200. #print "--------------------------------------------------------------------";
  201. #print color "reset";
  202. #print "\n";
  203.  
  204. my $iota;
  205. my $needswork = 1;
  206. while ($needswork) {
  207. die "iota" if $iota++ > 1000;
  208. my $delta;
  209. while (@carvepoint) {
  210. die "delta" if $delta++ > 10000;
  211. my $e = shift @carvepoint;
  212. recursivecarve(@$e);
  213. }
  214. showmap();
  215. $needswork = 0;
  216. # But if there's a *huge* rectangle still unused, we can reseed in
  217. # the middle of it and go some more...
  218. my $maxyoff = int($ROWNO / 4);
  219. for my $yoff (1 .. $maxyoff) {
  220. if (rectisempty(1,$yoff,int($COLNO/5),$ROWNO+$yoff-$maxyoff-1)) {
  221. #print color "on_red"; print "NEEDS WORK (WEST)"; print color "reset"; print "\n";
  222. my $x = 0;
  223. my $y = int(($ROWNO + $yoff - ($maxyoff/2)) / 2);
  224. my $kappa;
  225. while (($map[$x][$y]{t} eq 'STONE') and ($x + 2 < $COLNO)) {
  226. die "kappa" if $kappa++ > 1000;
  227. $x++;
  228. }
  229. recursivecarve($x, $y, -1, 0, undef);
  230. recursivecarve($x, $y, 0, -1, undef);
  231. recursivecarve($x, $y, 0, 1, undef);
  232. #$map[$x][$y] = $greenfloor;
  233. $needswork++;
  234. }
  235. if (rectisempty(int($COLNO * 4 / 5), $yoff, $COLNO - 1, $ROWNO+$yoff-$maxyoff-1)) {
  236. #print color "on_red"; print "NEEDS WORK (EAST)"; print color "reset"; print "\n";
  237. my $x = $COLNO - 1;
  238. my $y = int(($ROWNO + $yoff - ($maxyoff/2)) / 2);
  239. my $lambda;
  240. while (($map[$x][$y]{t} eq 'STONE') and ($x > 2)) {
  241. die "lambda" if $lambda++ > 1000;
  242. $x--;
  243. }
  244. recursivecarve($x, $y, 1, 0, undef);
  245. recursivecarve($x, $y, 0, -1, undef);
  246. recursivecarve($x, $y, 0, 1, undef);
  247. #$map[$x][$y] = $greenfloor;
  248. $needswork++;
  249. }
  250. }
  251. }
  252. # Some rooms might should have pillars...
  253. my $rno = 0;
  254. for my $r (@room) {
  255. $rno++;
  256. if (($$r{type} eq 'room') and ($pillarprob > int rand 100)) {
  257. my $tries = 0;
  258. my ($cx, $cy) = (0, 0);
  259. while ((($cx == 0) or
  260. ($map[$cx][$cy]{r} ne $rno) or
  261. ($map[$cx][$cy]{t} ne 'ROOM')) and
  262. ($tries++ < 1000)) {
  263. $cx = 1 + int rand ($COLNO - 2);
  264. $cy = 1 + int rand ($ROWNO - 2);
  265. }
  266. for my $x (($cx - 1) .. ($cx + 1)) {
  267. for my $y (($cy - 1) .. ($cy + 1)) {
  268. if ($map[$x][$y]{t} eq 'ROOM') {
  269. $map[$x][$y] = $stone;
  270. } elsif ($map[$x][$y]{t} eq 'CORR') {
  271. $map[$x][$y] = $scorr;
  272. } elsif ($map[$x][$y]{t} eq 'DOOR') {
  273. $map[$x][$y] = $sdoor;
  274. }
  275. }
  276. }
  277. }
  278. }
  279.  
  280. # Final Cleanup:
  281. my $anychanges = 1;
  282. while ($anychanges) {
  283. $anychanges = 0;
  284. for my $x (0 .. $COLNO) {
  285. for my $y (0 .. $ROWNO) {
  286. my $snc = solidneighborcount($x, $y, 1, 1, 1);
  287. if (($map[$x][$y]{t} eq 'WALL') and
  288. ($snc == 8)) {
  289. $anychanges++;
  290. $map[$x][$y] = $stone;
  291. } elsif (($map[$x][$y]{t} eq 'STONE') and
  292. ($snc < 8)) {
  293. $map[$x][$y] = $hwall;
  294. }
  295. if ($map[$x][$y]{t} eq 'CORR') {
  296. my $ofc = orthogonalfloorcount($x, $y);
  297. if ($ofc >= 3) {
  298. $map[$x][$y] = $floor;
  299. $anychanges++;
  300. #} elsif (($ofc == 1) and
  301. # solidneighborcount($x,$y,0,0,0) <= 5) {
  302. # $map[$x][$y] = $door;
  303. }
  304. for my $dirone (keys %wdir) {
  305. my $dirtwo = $wdir{$dirone}{clockwise};
  306. my $none = neighbor($x, $y, $dirone);
  307. my $ntwo = neighbor($x, $y, $dirtwo);
  308. if ($none and $ntwo and
  309. ($$none{t} eq 'ROOM') and
  310. ($$ntwo{t} eq 'ROOM')) {
  311. # Check the diagonal neighbor between those two orthogonals;
  312. # if it _also_ is room floor, then convert this corridor.
  313. # Because dirone and dirtwo are adjacent orthogonals, we
  314. # can just add their dx and dy together to get the diag;
  315. # and by similar reasoning, we know the diagonal isn't
  316. # out of bounds, because we checked the orthogonals.
  317. my $nx = $x + $wdir{$dirone}{dx} + $wdir{$dirtwo}{dx};
  318. my $ny = $y + $wdir{$dirone}{dy} + $wdir{$dirtwo}{dy};
  319. if ($map[$nx][$ny]{t} eq 'ROOM') {
  320. $map[$x][$y] = $floor;
  321. $anychanges++;
  322. }
  323. }
  324. }
  325. }
  326. if ($map[$x][$y]{t} eq 'DOOR') {
  327. # This check doesn't seem to work as intended.
  328. #print "DOOR($x,$y): ";
  329. for my $dirone (keys %wdir) {
  330. my $dirtwo = $wdir{$dirone}{clockwise};
  331. my $none = neighbor($x, $y, $dirone);
  332. my $ntwo = neighbor($x, $y, $dirtwo);
  333. #print "[$dirone: $$none{t}; $dirtwo: $$none{t}]";
  334. if ($none and $ntwo and
  335. ($$none{t} eq 'ROOM') and
  336. ($$ntwo{t} eq 'ROOM')) {
  337. #print " => FLOOR ";
  338. $map[$x][$y] = $floor;
  339. $anychanges++;
  340. }
  341. }
  342. }
  343. }
  344. }
  345. }
  346. for my $x (0 .. $COLNO) {
  347. for my $y (0 .. $ROWNO) {
  348. fixwalldirs($x, $y);
  349. }
  350. }
  351. # Place Stairs:
  352. my ($upstair, $dnstair, $tries);
  353. while ((not $dnstair) and ($tries++ < 4000)) {
  354. my $x = 2 + int rand ($COLNO - 4);
  355. my $y = 1 + int rand ($ROWNO - 2);
  356. if (($map[$x][$y]{t} eq 'ROOM') or
  357. (($tries > 1000) and ($map[$x][$y]{t} eq 'CORR')) or
  358. ($tries > 3000)) {
  359. if ($upstair) {
  360. $dnstair = [$x, $y];
  361. $map[$x][$y] = +{ b => 'on_black',
  362. t => 'STAIR',
  363. c => '>',
  364. f => 'red',
  365. };
  366. } else {
  367. $upstair = [$x, $y];
  368. $map[$x][$y] = +{ b => 'on_black',
  369. t => 'STAIR',
  370. c => '<',
  371. f => 'red',
  372. };
  373. }
  374. }
  375. }
  376. # Other Dungeon Features...
  377. my @randfeature = (+{ name => 'fountain',
  378. tile => +{ b => 'on_black',
  379. f => 'cyan',
  380. t => 'FOUNTAIN',
  381. c => '{',
  382. },
  383. prob => 55,
  384. count => 3, },
  385. +{ name => 'altar',
  386. center => 1,
  387. tile => +{ b => 'on_black',
  388. f => 'yellow',
  389. c => '_',
  390. t => 'ALTAR',
  391. },
  392. count => 1,
  393. prob => 15,
  394. },
  395. +{ name => 'sink',
  396. count => 1,
  397. prob => 10,
  398. onwall => 1,
  399. tile => +{ b => 'on_black',
  400. f => 'cyan',
  401. c => '#',
  402. t => 'SINK',
  403. },
  404. },
  405. +{ name => 'monster',
  406. count => 50,
  407. prob => ($domonsters ? 100 : 0),
  408. tile => $floor,
  409. monst => 1,
  410. },
  411. );
  412. my @monster = ( # This is just for visual flavor. The actual game
  413. # will of course generate monsters via its own
  414. # mechanisms, using difficulty etc.
  415. +{ name => 'insect',
  416. mlet => 'a',
  417. color => ['yellow', 'blue', 'red', 'green', 'magenta'],
  418. },
  419. +{ name => 'chicken',
  420. mlet => 'c',
  421. color => ['yellow', 'red'],
  422. },
  423. +{ name => 'gremlin',
  424. mlet => 'g',
  425. color => ['green', 'magenta'],
  426. },
  427. +{ name => 'humanoid',
  428. mlet => 'h',
  429. color => ['green', 'red', 'blue', 'magenta'],
  430. },
  431. +{ name => 'nymph',
  432. mlet => 'n',
  433. color => ['green', 'blue', 'cyan'],
  434. },
  435. +{ name => 'Centaur',
  436. mlet => 'C',
  437. color => ['green', 'cyan'],
  438. },
  439. +{ name => 'Dragon',
  440. mlet => 'D',
  441. color => ['black', 'white', 'yellow', 'red', 'blue', 'green'],
  442. },
  443. +{ name => 'Giant',
  444. mlet => 'H',
  445. color => ['white', 'cyan', 'yellow', 'blue', 'magenta'],
  446. },
  447. +{ name => 'Troll',
  448. mlet => 'T',
  449. color => ['white', 'cyan', 'magenta'],
  450. },
  451. +{ name => 'Vampire',
  452. mlet => 'V',
  453. color => ['red', 'blue'],
  454. },
  455. +{ name => 'Human',
  456. mlet => '@',
  457. color => ['green', 'green', 'white', 'blue', 'red'],
  458. },
  459. );
  460. my $rno = 0;
  461. for my $r (@room) {
  462. my $tries = 0;
  463. $rno++;
  464. if ($$r{type} eq 'room') {
  465. my $f = $randfeature[int rand @randfeature];
  466. if ($$f{prob} > rand 100) {
  467. my $multi = 1 + int rand rand $$f{count};
  468. my $placed = 0;
  469. while (($tries++ < 1000) and $placed < $multi) {
  470. my $x = int rand $COLNO;
  471. my $y = int rand $ROWNO;
  472. my $tile = $map[$x][$y];
  473. if (($$tile{r} == $rno) and
  474. ($$tile{t} == 'ROOM') and
  475. ((orthogonalfloorcount($x,$y) >= int((1000 - $tries) / 200))
  476. or not $$f{center}) and
  477. ((solidneighborcount($x,$y,0,0,0) >= int((1000 - $tries) / 333))
  478. or not $$f{onwall})
  479. ) {
  480. $map[$x][$y] = +{ %$tile,
  481. %{$$f{tile}},
  482. };
  483. if ($$f{monst}) {
  484. my $m = $monster[int rand @monster];
  485. my $c = $$m{color}[int rand @{$$m{color}}];
  486. $map[$x][$y] = +{ %$tile,
  487. f => $c || 'cyan',
  488. c => $$m{mlet} || 'I',
  489. };
  490. }
  491. $placed++;
  492. }
  493. }
  494. }
  495. }
  496. }
  497. showmap();
  498.  
  499. sub rectisempty {
  500. my ($minx, $miny, $maxx, $maxy) = @_;
  501. my ($x, $y);
  502. #print "Checking for empty rectangle ($minx, $miny, $maxx, $maxy)...";
  503. for $x ($minx .. $maxx) {
  504. for $y ($miny .. $maxy) {
  505. if (($map[$x][$y]{t} || 'STONE') ne 'STONE') {
  506. #print "Not empty. ($x, $y) is $map[$x][$y]{t}\n";
  507. return;
  508. }
  509. }
  510. }
  511. #print color "green";
  512. #print "EMPTY";
  513. #print color "reset";
  514. #print "\n";
  515. return "empty";
  516. }
  517.  
  518. sub choosedir {
  519. my ($xdir, $ydir) = (0, 0);
  520. my $epsilon;
  521. while (($xdir == 0) and ($ydir == 0)) {
  522. die "epsilon" if $epsilon++ > 10000;
  523. $xdir = (int rand 3) - 1;
  524. $ydir = (int rand 3) - 1;
  525. }
  526. return ($xdir, $ydir);
  527. }
  528.  
  529. sub recursivecarve {
  530. my ($ox, $oy, $dx, $dy, $parent) = @_;
  531. if ($ox < 0 or $ox > $COLNO) {
  532. #warn "recursivecarve: invalid x: $ox ($ox, $oy, $dx, $dy, $parent)\n";
  533. return;
  534. }
  535. if ($oy < 0 or $oy > $ROWNO) {
  536. #warn "recursivecarve: invalid y: $oy ($ox, $oy, $dx, $dy, $parent)\n";
  537. return;
  538. }
  539. my $tries = 0;
  540. my $cx = $ox + $dx;
  541. my $cy = $oy + $dy;
  542. my $roomno = undef;
  543. my $zeta;
  544. while ($tries++ < 55 and not defined $roomno) {
  545. die "zeta" if $zeta++ > 1000; # impossible
  546. my $carvemethod = $carvemethod[int rand @carvemethod];
  547. #use Data::Dumper; print Dumper(+{ carvemethod => $carvemethod });
  548. croak "Illegal direction ($dx,$dy)" if ($dx == 0 and $dy == 0);
  549. $roomno = $$carvemethod{make}->($cx, $cy, $dx, $dy, $parent);
  550. }
  551. if ($roomno) {
  552. # We have successfully carved a room.
  553. # Make the entrance:
  554. if ($ox > 0 and $oy > 0 and $ox < $COLNO and $oy < $ROWNO) {
  555. if ($dx and $dy) {
  556. $map[$ox][$oy] = $ecorr;
  557. $map[$cx][$cy] = $ecorr;
  558. if (50 > int rand 100) {
  559. $map[$cx][$oy] = $ecorr;
  560. } else {
  561. $map[$ox][$cy] = $ecorr;
  562. }
  563. if (50 > int rand 100) {
  564. $map[$ox][$oy - $dy] = $ecorr;
  565. } else {
  566. $map[$ox - $dx][$oy] = $ecorr;
  567. }
  568. if (50 > int rand 100) {
  569. $map[$cx][$cy + $dy] = $ecorr;
  570. } else {
  571. $map[$cx + $dx][$cy] = $ecorr;
  572. }
  573. } else {
  574. if ($room[$roomno]{type} eq 'corridor') {
  575. $map[$cx][$cy] = ($map[$cx][$cy]{t} eq 'WALL') ? $sdoor : $scorr;
  576. } else {
  577. $map[$cx][$cy] = (20 > int rand 100) ? $sdoor : $door;
  578. }
  579. $map[$ox][$oy] = #($map[$ox][$oy]{t} eq 'WALL') ? $sdoor : $ecorr;
  580. ($room[$roomno]{type} eq 'corridor') ? $ecorr : roomfloor($roomno)
  581. #+{ t => 'ROOM',
  582. # b => 'on_black',
  583. # f => 'cyan',
  584. # c => '.',
  585. # }
  586. unless $map[$ox][$oy]{t} eq 'CORR';
  587. }
  588. }
  589. #showmap();
  590. #<STDIN>;
  591. # And now recursion...
  592. if ($roomno) {
  593. my @e = randomorder(@{$room[$roomno]{exit}});
  594. if (50 > int rand 100) {
  595. # Try to carve further from here now:
  596. if (@e) {
  597. my $e = shift @e;
  598. push @carvepoint, $_ for @e;
  599. return recursivecarve(@$e);
  600. }
  601. } else {
  602. push @carvepoint, $_ for @e;
  603. if (10 > int rand 100) {
  604. @carvepoint = randomorder(@carvepoint);
  605. }
  606. if (@carvepoint) {
  607. my $e = shift @carvepoint;
  608. recursivecarve(@$e);
  609. }
  610. if (@carvepoint) {
  611. my $e = shift @carvepoint;
  612. recursivecarve(@$e);
  613. }
  614. }
  615. }
  616. }
  617. }
  618.  
  619. sub showmap {
  620. print "\n\n";
  621. for $y (0 .. $ROWNO) {
  622. for $x (0 .. $COLNO) {
  623. my $m = $map[$x][$y];
  624. print color $$m{b};
  625. print color $$m{f};
  626. print $$m{c};
  627. }
  628. print color "reset";
  629. print "\n";
  630. }
  631. }
  632.  
  633. sub randomorder {
  634. return map {
  635. $$_[0]
  636. } sort {
  637. $$a[1] <=> $$b[1]
  638. } map {
  639. [$_ => rand 1776]
  640. } @_;
  641. }
  642.  
  643. sub dist {
  644. my ($xone, $yone, $xtwo, $ytwo, $xscale, $yscale) = @_;
  645. my $xdist = int(abs($xone - $xtwo) * $xscale / 100);
  646. my $ydist = int(abs($yone - $ytwo) * $yscale / 100);
  647. return int sqrt(($xdist * $xdist) + ($ydist * $ydist));
  648. }
  649.  
  650. sub carveonespot {
  651. my ($ox, $oy, $odx, $ody, $parent, $tile) = @_;
  652. $tile ||= $corr;
  653. my ($x, $y) = ($ox + $odx, $oy + $ody);
  654. if ($x > 0 and $x < $COLNO and $y > 0 and $y < $ROWNO and
  655. $map[$x][$y]{t} eq 'STONE') {
  656. $map[$x][$y] = $tile;
  657. $roomcount++;
  658. my $room = +{ type => 'corridor',
  659. name => 'onespot',
  660. entr => [$ox, $oy, $odx, $ody],
  661. posn => [[$x, $y]],
  662. exit => [[$x + $odx, $y + $ody, $odx, $ody, $roomcount], ],
  663. parent => $parent,
  664. };
  665. $room[$roomcount] = $room;
  666. return $roomcount;
  667. }
  668. }
  669.  
  670. sub carvespiral {
  671. my ($ox, $oy, $odx, $ody, $parent) = @_;
  672. my ($x, $y, $dx, $dy) = ($ox, $oy, $odx, $ody);
  673. if ($count{spiral} > 1) {
  674. push @carvepoint, [$ox, $oy, $odx, $ody, $parent];
  675. return;
  676. }
  677. my ($tillturn, $nexttillturn) = (1, 2);
  678. my @exit;
  679. my ($len, $turns) = (0, 0);
  680. my $doublethick = (65 > int rand 100) ? 1 : 0;
  681. $roomcount++;
  682. my $tile = (35 > int rand 100)
  683. ? +{ r => $roomcount, %$floor }
  684. : +{ r => $roomcount, %$corr };
  685. while (($x > 0) and ($x < $COLNO) and
  686. ($y > 0) and ($y < $ROWNO) and
  687. ($map[$x][$y]{t} eq 'STONE')) {
  688. $map[$x][$y] = $tile;
  689. #+{ %$tile, c => ($nexttillturn % 10) };
  690. if ($doublethick) {
  691. my ($pdx, $pdy) = plusfortyfive($dx, $dy);
  692. my $px = $x + $pdx;
  693. my $py = $y + $pdy;
  694. if (($px > 1) and ($px + 1 < $COLNO) and
  695. ($py > 1) and ($py + 1 < $ROWNO) and
  696. ($map[$px][$py]{t} eq 'STONE')) {
  697. $map[$px][$py] = $tile;
  698. }
  699. }
  700. # Now advance to the next position:
  701. $x += $dx; $y += $dy;
  702. $tillturn--; $len++;
  703. if ($len == 3) { $count{spiral}++; }
  704. if ($tillturn <= 0) {
  705. my ($edx, $edy) = lessninety($dx, $dy);
  706. push @exit, [$x, $y, $dx, $dy, $roomcount];
  707. ($dx, $dy) = plusfortyfive($dx, $dy);
  708. $tillturn = $nexttillturn;
  709. $nexttillturn++;
  710. $turns++;
  711. }
  712. }
  713. if (($x > 0) and ($x < $COLNO) and
  714. ($y > 0) and ($y < $ROWNO)) {
  715. if ($map[$x][$y]{t} eq 'WALL') {
  716. $map[$x][$y] = $sdoor;
  717. }
  718. }
  719. my $room = +{ type => 'corridor',
  720. name => 'spiral',
  721. entr => [$ox, $oy, $odx, $ody],
  722. len => $len,
  723. exit => [@exit],
  724. };
  725. $room[$roomcount] = $room;
  726. return $roomcount;
  727. }
  728.  
  729. sub carvebasiccorridor {
  730. my ($ox, $oy, $odx, $ody, $parent, $corr, $length) = @_;
  731. if (($ox < 5 and $odx < 1) or
  732. ($ox > ($COLNO - 5) and $odx > -1) or
  733. ($oy < 3 and $ody < 1) or
  734. ($oy > ($ROWNO - 3) and $ody > -1)
  735. ) {
  736. return;
  737. }
  738. my ($x, $y, $dx, $dy) = ($ox, $oy, $odx, $ody);
  739. my ($minx, $miny, $maxx, $maxy) = ($x, $y, $x, $y);
  740. my $turncount = 0;
  741. my @proposed;
  742. $length ||= 3 + int rand 4;
  743. for my $p (1 .. $length) {
  744. if ($dx and (50 > int rand 100)) {
  745. $x += $dx;
  746. } elsif ($dy) {
  747. $y += $dy;
  748. } else {
  749. $x += $dx;
  750. }
  751. $proposed[$p] = [$x, $y];
  752. $minx = $x if $x < $minx;
  753. $miny = $y if $y < $miny;
  754. $maxx = $x if $x > $maxx;
  755. $maxy = $y if $y > $maxy;
  756. if ($turncount < 1 and (12 > int rand 100)) {
  757. my ($olddx, $olddy) = ($dx, $dy);
  758. my $alpha = 0;
  759. while ($dx == $olddx and $dy == $olddy) {
  760. ($dx, $dy) = choosedir();
  761. die "alpha" if $alpha++ > 1000;
  762. }
  763. $turncount++;
  764. }
  765. }
  766. my $cando = 1;
  767. for my $p (1 .. $length) {
  768. my ($x, $y) = @{$proposed[$p]};
  769. if (($x <= 1) or ($x + 1 >= $COLNO) or
  770. ($y <= 1) or ($y + 1 >= $COLNO) or
  771. $map[$x][$y]{t} ne 'STONE') {
  772. $cando = 0;
  773. return;
  774. }
  775. }
  776. my @exit = ([$x, $y, $dx, $dy, $roomcount]);
  777. my %hasexit;
  778. if ($cando) {
  779. for my $p (1 .. $length) {
  780. my ($x, $y) = @{$proposed[$p]};
  781. $map[$x][$y] = $corr;
  782. if ($x == $minx and $x > 5
  783. and not $hasexit{minx}++) {
  784. push @exit, [$x, $y, -1, 0, $roomcount];
  785. } elsif ($x == $maxx and $x + 5 < $COLNO
  786. and not $hasexit{maxx}++) {
  787. push @exit, [$x, $y, 1, 0, $roomcount];
  788. } elsif ($y == $miny and $y > 5
  789. and not $hasexit{miny}++) {
  790. push @exit, [$x, $y, 0, -1, $roomcount];
  791. } elsif ($y == $maxy and $y + 5 < $ROWNO
  792. and not $hasexit{maxy}++) {
  793. push @exit, [$x, $y, 0, 1, $roomcount];
  794. }
  795. }
  796. }
  797. $roomcount++;
  798. my $room = +{ type => 'corridor',
  799. name => 'basic_corridor',
  800. entr => [$ox, $oy, $odx, $ody],
  801. exit => [@exit],
  802. posn => [@proposed],
  803. parent => $parent,
  804. };
  805. $room[$roomcount] = $room;
  806. return $roomcount;
  807. }
  808.  
  809. sub plusfortyfive {
  810. # This function is designed under the assumption that the only valid
  811. # coordinates are -1, 0, 1. It rotates a rectangular-coordinate
  812. # vector with respect to the origin, one eighth turn (forty-five
  813. # degrees), counterclockwise.
  814. my ($x, $y) = @_;
  815. if (($x > 0) and ($y > 0)) {
  816. return (0, $y);
  817. } elsif (($x == 0) and ($y > 0)) {
  818. return (-1, $y);
  819. } elsif (($x < 0) and ($y > 0)) {
  820. return ($x, 0);
  821. } elsif (($x < 0) and ($y == 0)) {
  822. return ($x, -1);
  823. } elsif (($x < 0) and ($y < 0)) {
  824. return (0, $y);
  825. } elsif (($x == 0) and ($y < 0)) {
  826. return (1, $y);
  827. } elsif (($x > 0) and ($y < 0)) {
  828. return ($x, 0);
  829. } elsif (($x > 0) and ($y == 0)) {
  830. return ($x, 1);
  831. }
  832. }
  833.  
  834. sub plusninety {
  835. # This function is designed under the assumption that the only valid
  836. # coordinates are -1, 0, 1. It rotates a rectangular-coordinate
  837. # vector with respect to the origin, one quarter turn (ninety
  838. # degrees), counterclockwise.
  839. my ($x, $y) = @_;
  840. if ($y > 0) {
  841. return ($y, (0 - $x));
  842. } elsif (not $y) {
  843. return ($y, (0 - $x));
  844. } else {
  845. if ($x > 0) {
  846. return ((0 - $x), $y);
  847. } else {
  848. return ($y, (0 - $x))
  849. }
  850. }
  851. }
  852.  
  853. sub lessninety {
  854. # This function is designed under the assumption that the only valid
  855. # coordinates are -1, 0, 1. It rotates a rectangular-coordinate
  856. # vector, with respect to the origin, one quarter turn (ninety
  857. # degrees), clockwise.
  858. my ($x, $y) = @_;
  859. if ($x >= 0) {
  860. return ((0 - $y), $x);
  861. } else {
  862. if ($y > 0) {
  863. return ($x, (0 - $y));
  864. } elsif (not $y) {
  865. return ($y, $x);
  866. } else {
  867. return ((0 - $x), $y);
  868. }
  869. }
  870. }
  871.  
  872. sub carverhombus {
  873. my ($ox, $oy, $dx, $dy, $parent) = @_;
  874. my $size = 3 + int rand rand 15;
  875. my ($orthodx, $orthody);
  876. if ($dx and $dy) {
  877. push @carvepoint, [$ox, $oy, $dx, $dy, $parent];
  878. return;
  879. }
  880. if (50 < rand 100) {
  881. ($orthodx, $orthody) = lessninety($dx, $dy);
  882. } else {
  883. ($orthodx, $orthody) = plusninety($dx, $dy);
  884. }
  885. my (@propose, @exit);
  886. my $conflict = 0;
  887. for my $row (1 .. $size) {
  888. my $cx = $ox + $dx * $row;
  889. my $cy = $oy + $dy * $row;
  890. my $offset = $row - int($size / 2);
  891. for my $o ($offset .. $offset + $size) {
  892. my $px = $cx + $orthodx * $o;
  893. my $py = $cy + $orthody * $o;
  894. push @propose, [$px, $py];
  895. if (($px <= 0) or ($px >= $COLNO) or
  896. ($py <= 0) or ($py >= $ROWNO) or
  897. $map[$px][$py]{t} ne 'STONE') {
  898. $conflict++;
  899. }
  900. }
  901. if ($row == $size) {
  902. my $ex = $cx + $orthodx * ($offset + int($size / 2));
  903. my $ey = $cy + $orthody * ($offset + int($size / 2));
  904. push @exit, [$ex, $ey, $dx, $dy, $parent];
  905. } elsif ($row == int($size / 2)) {
  906. # TODO: add side exits.
  907. }
  908. }
  909. if (not $conflict) {
  910. $roomcount++;
  911. for my $p (@propose) {
  912. my ($x, $y, $clr) = @$p;
  913. $map[$x][$y] = roomfloor($roomcount);
  914. }
  915. my $room = +{ type => 'room',
  916. name => 'rhombus',
  917. entr => [$ox, $oy, $dx, $dy],
  918. #orth => [$orthodx, $orthody],
  919. exit => [@exit],
  920. };
  921. $room[$roomcount] = $room;
  922. return $roomcount;
  923. }
  924. }
  925.  
  926. sub carveyroom {
  927. my ($ox, $oy, $dx, $dy, $parent) = @_;
  928. if ($dx and $dy) {
  929. if (50 > int rand 100) {
  930. $dx = 0;
  931. } else {
  932. $dy = 0;
  933. }
  934. }
  935. my $thickness = 2 + int rand 5;
  936. my $stemlen = 1 + int rand 5;
  937. my $branchlen = 3 + int rand 8;
  938. my $diverge = 0;
  939. my ($dxa, $dya) = lessninety($dx, $dy);
  940. my ($dxb, $dyb) = plusninety($dx, $dy);
  941. my $conflict;
  942. my @propose; # Note: some tiles will get added twice.
  943. my @exit;
  944. for my $row (1 .. ($stemlen + $branchlen)) {
  945. if ($row > $stemlen) { $diverge++; }
  946. my $cx = $ox + $dx * $row;
  947. my $cy = $oy + $dy * $row;
  948. for my $offset ((0 - int($thickness / 2)) .. int($thickness / 2)) {
  949. # Branch A:
  950. my $xa = $cx + $dxa * ($offset + $diverge);
  951. my $ya = $cy + $dya * ($offset + $diverge);
  952. push @propose, [$xa, $ya];
  953. if (($xa <= 0) or ($xa >= $COLNO) or
  954. ($ya <= 0) or ($ya >= $ROWNO) or
  955. $map[$xa][$ya]{t} ne 'STONE') {
  956. $conflict++;
  957. }
  958. # Branch B:
  959. my $xb = $cx + $dxb * ($offset + $diverge);
  960. my $yb = $cy + $dyb * ($offset + $diverge);
  961. push @propose, [$xb, $yb];
  962. if (($xb <= 0) or ($xb >= $COLNO) or
  963. ($yb <= 0) or ($yb >= $ROWNO) or
  964. $map[$xb][$yb]{t} ne 'STONE') {
  965. $conflict++;
  966. }
  967. }
  968. if ($row == ($stemlen + $branchlen)) {
  969. push @exit, [$cx + $dxa * $diverge, $cy + $dya * $diverge, $dx, $dy, $roomcount];
  970. push @exit, [$cx + $dxb * $diverge, $cy + $dyb * $diverge, $dx, $dy, $roomcount];
  971. }
  972. }
  973. if (not $conflict) {
  974. $roomcount++;
  975. for my $p (@propose) {
  976. my ($x, $y, $clr) = @$p;
  977. $map[$x][$y] = roomfloor($roomcount);
  978. }
  979. my $room = +{ type => 'room',
  980. name => 'Y',
  981. entr => [$ox, $oy, $dx, $dy],
  982. exit => [@exit],
  983. };
  984. $room[$roomcount] = $room;
  985. return $roomcount;
  986. }
  987. }
  988.  
  989. sub carvemarketplace {
  990. my ($ox, $oy, $dx, $dy, $parent) = @_;
  991. if (($count{marketplace} > 3) or (50 > int rand 100)) {
  992. push @carvepoint, [$ox, $oy, $dx, $dy, $parent];
  993. return;
  994. }
  995. my ($x, $y);
  996. my $radius = rand 5;
  997. my $xscale = 50;# + int rand 50;
  998. my $yscale = 30;# + int rand 30;
  999. my $beta;
  1000. while ($radius > 2) {
  1001. die "beta" if $beta++ > 1000;
  1002. my ($cx, $cy) = ($ox, $oy);
  1003. my $gamma;
  1004. while (dist($cx, $cy, $ox, $oy, $xscale, $yscale) <= $radius) {
  1005. die "gamma" if $gamma++ > 10000;
  1006. $cx += $dx;
  1007. $cy += $dy;
  1008. }
  1009. my $cando = 1;
  1010. my $worthdoing = 0;
  1011. my ($minx, $miny, $maxx, $maxy) = ($cx, $cy, $cx, $cy);
  1012. for $x (1 .. $COLNO - 1) {
  1013. for $y (1 .. $ROWNO - 1) {
  1014. if (dist($cx, $cy, $x, $y, $xscale, $yscale) <= $radius) {
  1015. if ($map[$x][$y]{t} ne 'STONE') {
  1016. $cando = 0;
  1017. } else {
  1018. $worthdoing++;
  1019. }
  1020. $minx = $x if $x < $minx;
  1021. $maxx = $x if $x > $maxx;
  1022. $miny = $y if $y < $miny;
  1023. $maxy = $y if $y > $maxy;
  1024. }
  1025. }
  1026. }
  1027. if ($cando and ($worthdoing > 4)) {
  1028. my @exit;
  1029. $roomcount++;
  1030. for $x (1 .. $COLNO - 1) {
  1031. for $y (1 .. $ROWNO - 1) {
  1032. if (dist($cx, $cy, $x, $y, $xscale, $yscale) <= $radius) {
  1033. $map[$x][$y] = roomfloor($roomcount);
  1034. #} elsif (dist($cx, $cy, $x, $y, $xscale, $yscale) <= ($radius + 1) and
  1035. # $map[$x][$y]{t} eq 'STONE') {
  1036. # # TODO: try to work out exactly which kind of wall...
  1037. # $map[$x][$y] = +{ t => 'WALL',
  1038. # b => 'on_black',
  1039. # f => 'cyan',
  1040. # c => '-',
  1041. # };
  1042. }
  1043. }
  1044. }
  1045. $count{marketplace}++;
  1046. push @exit, [$minx, $cy, -1, 0, $roomcount];
  1047. push @exit, [$maxx, $cy, 1, 0, $roomcount];
  1048. push @exit, [$cx, $miny, 0, -1, $roomcount];
  1049. push @exit, [$cx, $maxy, 0, 1, $roomcount];
  1050. my $room = +{ type => 'room',
  1051. name => 'marketplace',
  1052. minx => $minx,
  1053. miny => $miny,
  1054. maxx => $maxx,
  1055. maxy => $maxy,
  1056. cntr => [$cx, $cy],
  1057. size => $radius,
  1058. xsca => $xscale,
  1059. ysca => $yscale,
  1060. entr => [$ox, $oy, $dx, $dy],
  1061. exit => [@exit],
  1062. parent => $parent,
  1063. };
  1064. $room[$roomcount] = $room;
  1065. return $roomcount;
  1066. }
  1067. $radius--; # try smaller
  1068. }
  1069. return;
  1070. }
  1071.  
  1072. sub carvetee {
  1073. my ($ox, $oy, $odx, $ody, $parent) = @_;
  1074. #my @propose;
  1075. my ($dx, $dy) = ($odx, $ody);
  1076. my ($x, $y);
  1077. if ($dx and $dy) {
  1078. if (50 > int rand 100) {
  1079. $dx = 0;
  1080. } else {
  1081. $dy = 0;
  1082. }
  1083. }
  1084. # First, put together the base of the T:
  1085. my ($bminx, $bminy, $bmaxx, $bmaxy) = ($ox, $oy, $ox, $oy);
  1086. my $basewidth = 2 + int rand 4;
  1087. my $baseheight = 2 + int rand 4;
  1088. if ($odx) {
  1089. $bmaxx += $basewidth * $odx;
  1090. } else {
  1091. $bminx -= int($basewidth / 2);
  1092. $bmaxx += int($basewidth / 2);
  1093. }
  1094. if ($ody) {
  1095. $bmaxy += $baseheight * $ody;
  1096. } else {
  1097. $bminy -= int($baseheight / 2);
  1098. $bmaxy += int($baseheight / 2);
  1099. }
  1100. # Then the crosspiece:
  1101. my ($tminx, $tminy, $tmaxx, $tmaxy) = ($bmaxx, $bmaxy, $bmaxx, $bmaxy);
  1102. my $outdent = 2 + int rand 3;
  1103. if ($dx) {
  1104. if ($bmaxy < $bminy) { ($bminy, $bmaxy) = ($bmaxy, $bminy); }
  1105. $tmaxx += $dx * (3 + int rand 2);
  1106. $tminy = $bminy - $outdent;
  1107. $tmaxy = $bmaxy + $outdent;
  1108. } else {
  1109. if ($bmaxx < $bminx) { ($bminx, $bmaxx) = ($bmaxx, $bminx); }
  1110. $tmaxy += $dy * (3 + int rand 2);
  1111. $tminx = $bminx - $outdent;
  1112. $tmaxx = $bmaxx + $outdent;
  1113. }
  1114. # Make sure min and max are the right way 'round:
  1115. if ($bmaxx < $bminx) { ($bminx, $bmaxx) = ($bmaxx, $bminx); }
  1116. if ($bmaxy < $bminy) { ($bminy, $bmaxy) = ($bmaxy, $bminy); }
  1117. if ($tmaxx < $tminx) { ($tminx, $tmaxx) = ($tmaxx, $tminx); }
  1118. if ($tmaxy < $tminy) { ($tminy, $tmaxy) = ($tmaxy, $tminy); }
  1119. # Can we actually place this tee?
  1120. my $cando = 1;
  1121. for $x ($bminx .. $bmaxx) {
  1122. for $y ($bminy .. $bmaxy) {
  1123. if ($x < 0 or $x > $COLNO or $y < 0 or $y > $ROWNO or
  1124. $map[$x][$y]{t} ne 'STONE') {
  1125. $cando = 0;
  1126. }
  1127. }
  1128. }
  1129. for $x ($tminx .. $tmaxx) {
  1130. for $y ($tminy .. $tmaxy) {
  1131. if ($x < 0 or $x > $COLNO or $y < 0 or $y > $ROWNO or
  1132. $map[$x][$y]{t} ne 'STONE') {
  1133. $cando = 0;
  1134. }
  1135. }
  1136. }
  1137. if ($cando) {
  1138. $roomcount++;
  1139. for $x ($tminx .. $tmaxx) {
  1140. for $y ($tminy .. $tmaxy) {
  1141. $map[$x][$y] = ($y == $tminy or $y == $tmaxy)
  1142. ? $hwall : ($x == $tminx or $x == $tmaxx)
  1143. ? $vwall : roomfloor($roomcount);
  1144. }
  1145. }
  1146. for $x ($bminx .. $bmaxx) {
  1147. for $y ($bminy .. $bmaxy) {
  1148. $map[$x][$y] = (($x >= $tminx) and ($x <= $tmaxx) and
  1149. ($y >= $tminy) and ($y <= $tmaxy))
  1150. ? roomfloor($roomcount) : ($y == $bminy or $y == $bmaxy)
  1151. ? $hwall : ($x == $bminx or $x == $bmaxx)
  1152. ? $vwall : roomfloor($roomcount);
  1153. }
  1154. }
  1155. my @exit;
  1156. if ($dx) {
  1157. my $tmidx = $tminx + 1 + int rand($tmaxx - $tminx - 2);
  1158. #$map[$tmidx][$tminy] = $northexit;
  1159. #$map[$tmidx][$tmaxy] = $southexit;
  1160. push @exit, [$tmidx, $tminy, 0, -1, $roomcount];
  1161. push @exit, [$tmidx, $tmaxy, 0, 1, $roomcount];
  1162. } else {
  1163. my $tmidy = $tminy + 1 + int rand($tmaxy - $tminy - 2);
  1164. #$map[$tminx][$tmidy] = $westexit;
  1165. #$map[$tmaxx][$tmidy] = $eastexit;
  1166. push @exit, [$tminx, $tmidy, -1, 0, $roomcount];
  1167. push @exit, [$tmaxx, $tmidy, 1, 0, $roomcount];
  1168. }
  1169. my $room = +{ type => 'room',
  1170. name => 'tee',
  1171. #tdim => ($dx ? 'x' : 'y'),
  1172. minx => $bminx,
  1173. maxx => $bmaxx,
  1174. miny => $bminy,
  1175. maxy => $bmaxy,
  1176. tmnx => $tminx,
  1177. tmxx => $tmaxx,
  1178. tmny => $tminy,
  1179. tmxy => $tmaxy,
  1180. entr => [$ox, $oy, $odx, $ody],
  1181. exit => [@exit],
  1182. };
  1183. $room[$roomcount] = $room;
  1184. return $roomcount;
  1185. }
  1186. }
  1187.  
  1188. sub carveoctagon {
  1189. # xxx
  1190. # xxxxx
  1191. # xxxxxxx
  1192. # xxxxxxx
  1193. # xxxxxxx
  1194. # xxxxx
  1195. # xxx
  1196. my ($ox, $oy, $dx, $dy, $parent) = @_;
  1197. if ($dx and $dy) {
  1198. # Don't want to code diagonal octagon tonight, try something else here later:
  1199. push @carvepoint, [$ox, $oy, $dx, $dy, $parent];
  1200. return;
  1201. }
  1202. for my $size (reverse (1 .. 2 + int rand rand 5)) {
  1203. my (@propose, @exit, $row, $conflict);
  1204. my @w = (($size .. (2 * $size)), ((2 * $size) x ($size - 2)), reverse ($size .. (2 * $size)));
  1205. for my $w (@w) {
  1206. $row++;
  1207. if ($dx) {
  1208. my $x = $ox + $row * $dx;
  1209. for my $y (($oy - int($w / 2)) .. ($oy + int($w / 2))) {
  1210. push @propose, [$x, $y];
  1211. if (($x <= 0) or ($y <= 0) or
  1212. ($x >= $COLNO) or ($y >= $ROWNO) or
  1213. $map[$x][$y]{t} ne 'STONE') {
  1214. $conflict++;
  1215. }
  1216. }
  1217. } else {
  1218. my $y = $oy + $row * $dy;
  1219. for my $x (($ox - int($w / 2)) .. ($ox + int($w / 2))) {
  1220. push @propose, [$x, $y];
  1221. if (($x < 0) or ($y < 0) or
  1222. ($x > $COLNO) or ($y > $ROWNO) or
  1223. $map[$x][$y]{t} ne 'STONE') {
  1224. $conflict++;
  1225. }
  1226. }
  1227. }
  1228. }
  1229. if (not $conflict) {
  1230. $roomcount++;
  1231. my $half = int((scalar @w) / 2);
  1232. if ($dx) {
  1233. push @exit, [$ox + (scalar @w) * $dx, $oy, $dx, $dy, $roomcount];
  1234. push @exit, [$ox + $half * $dx, $oy - $half, 0, -1, $roomcount];
  1235. push @exit, [$ox + $half * $dx, $oy + $half, 0, 1, $roomcount];
  1236. } else {
  1237. push @exit, [$ox, $oy + (scalar @w) * $dy, $dx, $dy, $roomcount];
  1238. push @exit, [$ox - $half, $oy + $half * $dy, -1, 0, $roomcount];
  1239. push @exit, [$ox + $half, $oy * $half * $dy, 1, 0, $roomcount];
  1240. }
  1241. for my $p (@propose) {
  1242. my ($x, $y) = @$p;
  1243. $map[$x][$y] = roomfloor($roomcount);
  1244. }
  1245. my $room = +{ type => 'room',
  1246. name => 'octagon',
  1247. size => $size,
  1248. entr => [$ox, $oy, $dx, $dy],
  1249. exit => [@exit],
  1250. };
  1251. $room[$roomcount] = $room;
  1252. return $roomcount;
  1253. }
  1254. }
  1255. }
  1256.  
  1257. sub carverectangle {
  1258. my ($ox, $oy, $dx, $dy, $parent) = @_;
  1259. #print "Trying rectangle";
  1260. for my $try (1 .. 8) {
  1261. my ($x, $y) = ($ox, $oy);
  1262. my ($minx, $miny) = ($x, $y);
  1263. my $xsize = (3 + int rand 15);
  1264. my $ysize = (3 + int rand 5);
  1265. my $maxx = $x + ($dx * $xsize);
  1266. my $maxy = $y + ($dy * $ysize);
  1267. if ($dx == 0) {
  1268. $minx -= int($xsize / 2);
  1269. $maxx += int($xsize / 2);
  1270. }
  1271. if ($dy == 0) {
  1272. $miny -= int($ysize / 2);
  1273. $maxy += int($ysize / 2);
  1274. }
  1275. if ($minx > $maxx) { ($minx, $maxx) = ($maxx, $minx); }
  1276. if ($miny > $maxy) { ($miny, $maxy) = ($maxy, $miny); }
  1277. if ($minx < 0 or $maxx >= $COLNO or $miny < 0 or $maxy >= $ROWNO) {
  1278. #print ".";
  1279. next;
  1280. }
  1281. #print "($minx,$miny,$maxx, $maxy)";
  1282. my $cando = 1;
  1283. for $x ($minx .. $maxx) {
  1284. for $y ($miny .. $maxy) {
  1285. if ($map[$x][$y]{t} ne 'STONE') {
  1286. $cando = 0;
  1287. }
  1288. }
  1289. }
  1290. if ($cando) {
  1291. #print " Yep.\n";
  1292. $roomcount++;
  1293. for $x ($minx .. $maxx) {
  1294. for $y ($miny .. $maxy) {
  1295. $map[$x][$y] =
  1296. ($x == $minx or $y == $miny # or $x == $maxx or $y == $maxy
  1297. )
  1298. #? +{ t => 'WALL',
  1299. # b => 'on_black',
  1300. # f => 'white',
  1301. # c => (($y == $miny or $y == $maxy) ? '-' : '|'),
  1302. # }
  1303. ? $hwall
  1304. : roomfloor($roomcount);
  1305. }
  1306. }
  1307. # Now assemble a list of exit points...
  1308. my @exit;
  1309. my $midx = $minx + 1 + int rand($maxx - $minx - 2);
  1310. my $midy = $miny + 1 + int rand($maxy - $miny - 2);
  1311. if ($dx == 0) {
  1312. # Entrance is on the north or south edge
  1313. if (50 > int rand 100) {
  1314. # two potential exits, on the corners opposite the entrance
  1315. my $exity = ($dy > 0) ? $maxy : $miny;
  1316. push @exit, [$minx, $exity, -1, $dy, $roomcount];
  1317. push @exit, [$maxx, $exity, 1, $dy, $roomcount];
  1318. } else {
  1319. # three potential exits, on the other sides
  1320. push @exit, [$minx, $midy, -1, 0, $roomcount];
  1321. push @exit, [$maxx, $midy, 1, 0, $roomcount];
  1322. push @exit, [$midx, (($dy > 0) ? $maxy : $miny), 0, $dy, $roomcount];
  1323. }
  1324. } elsif ($dy == 0) {
  1325. # Entrance is on the east or west edge
  1326. if (50 > int rand 100) {
  1327. # two potential exits, on the corners opposite the entrance
  1328. my $exitx = ($dx > 0) ? $maxx : $minx;
  1329. push @exit, [$exitx, $miny, $dx, -1, $roomcount];
  1330. push @exit, [$exitx, $maxy, $dx, -1, $roomcount];
  1331. } else {
  1332. # three potential exits, on the other sides
  1333. push @exit, [(($dx > 0) ? $maxx : $minx), $oy, $dx, $dy, $roomcount];
  1334. push @exit, [$midx, $miny, 0, -1, $roomcount];
  1335. push @exit, [$midx, $maxy, 0, 1, $roomcount];
  1336. }
  1337. } else {
  1338. # Entrance is on a corner.
  1339. if (50 > int rand 100) {
  1340. # three potential exits on the other corners
  1341. # opposite corner:
  1342. push @exit, [(($dx > 0) ? $maxx : $minx), (($dy > 0) ? $maxy : $miny), $dx, $dy, $roomcount];
  1343. # adjacent corners:
  1344. push @exit, [$ox, (($dy > 0) ? $maxy : $miny), 0 - $dx, $dy, $roomcount];
  1345. push @exit, [(($dx > 0) ? $maxx : $minx), $oy, $dx, 0 - $dy, $roomcount];
  1346. } else {
  1347. # two potential exits on the sides not adjacent to the entrance
  1348. push @exit, [$midx, (($dy > 0) ? $maxy : $miny), 0, $dy, $roomcount];
  1349. push @exit, [(($dx > 0) ? $maxx : $minx), $midy, $dx, 0, $roomcount];
  1350. }
  1351. }
  1352. my $room = +{
  1353. type => 'room',
  1354. name => 'rectangle',
  1355. minx => $minx,
  1356. maxx => $maxx,
  1357. miny => $miny,
  1358. maxy => $maxy,
  1359. entr => [$ox, $oy, $dx, $dy],
  1360. exit => [@exit],
  1361. parent => $parent,
  1362. };
  1363. $room[$roomcount] = $room;
  1364. return $roomcount;
  1365. } else {
  1366. #print "x";
  1367. }
  1368. }
  1369. #print " Nope.\n";
  1370. return;
  1371. }
  1372.  
  1373. sub neighbor {
  1374. my ($x, $y, $wd) = @_;
  1375. my $nx = $x + $wdir{$wd}{dx};
  1376. my $ny = $y + $wdir{$wd}{dy};
  1377. if (($nx < 0) or ($nx > $COLNO) or
  1378. ($ny < 0) or ($ny > $ROWNO)) {
  1379. return;
  1380. }
  1381. #print "[$wd of ($x,$y): ($nx,$ny)] ";
  1382. return $map[$nx][$ny];
  1383. }
  1384.  
  1385. sub solidneighborcount {
  1386. my ($x, $y, $countsecrets, $countdoors, $countcorridors) = @_;
  1387. my $count = 0;
  1388. for my $nx (($x - 1) .. ($x + 1)) {
  1389. for my $ny (($y - 1) .. ($y + 1)) {
  1390. if (($nx == $x) and ($ny == $y)) {
  1391. # The tile itself is not a neighbor.
  1392. } elsif (($nx < 0) or ($nx > $COLNO) or
  1393. ($ny < 0) or ($ny > $ROWNO) or
  1394. ($map[$nx][$ny]{t} eq 'WALL') or
  1395. ($map[$nx][$ny]{t} eq 'STONE') or
  1396. ($map[$nx][$ny]{f} eq 'blue' and $countsecrets) or
  1397. ($map[$nx][$ny]{t} eq 'DOOR' and $countdoors) or
  1398. ($map[$nx][$ny]{t} eq 'CORR' and $countcorridors)) {
  1399. $count++;
  1400. }
  1401. }
  1402. }
  1403. return $count;
  1404. }
  1405.  
  1406. sub orthogonalfloorcount {
  1407. my ($x, $y) = @_;
  1408. my $count;
  1409. for my $wd (keys %wdir) {
  1410. my $neighbor = neighbor($x, $y, $wd);
  1411. #my $nx = $x + $wdir{$wd}{dx};
  1412. #my $ny = $y + $wdir{$wd}{dy};
  1413. #if (($nx >= 0) and ($nx <= $COLNO) and
  1414. # ($ny >= 0) and ($ny <= $ROWNO) and
  1415. # $map[$nx][$ny]{t} eq 'ROOM') {
  1416. if ($neighbor and $$neighbor{t} eq 'ROOM') {
  1417. $count++;
  1418. }
  1419. }
  1420. return $count;
  1421. }
  1422.  
  1423. sub fixwalldirs {
  1424. my ($x, $y) = @_;
  1425. if ($map[$x][$y]{t} eq 'WALL') {
  1426. my $wdirs = 0;
  1427. for my $wd (keys %wdir) {
  1428. my $neighbor = neighbor($x, $y, $wd);
  1429. #my $nx = $x + $wdir{$wd}{dx};
  1430. #my $ny = $y + $wdir{$wd}{dy};
  1431. #if (($nx >= 0) and ($nx <= $COLNO) and
  1432. # ($ny >= 0) and ($ny <= $ROWNO) and
  1433. # ($map[$nx][$ny]{t} eq 'WALL' or
  1434. # $map[$nx][$ny]{t} eq 'DOOR')) {
  1435. if ($neighbor and (($$neighbor{t} eq 'WALL') or
  1436. ($$neighbor{t} eq 'DOOR') or
  1437. # treat secret corridors as walls here:
  1438. ($$neighbor{t} eq 'CORR' and $$neighbor{f} eq 'blue'))) {
  1439. $wdirs += $wdir{$wd}{bit};
  1440. }
  1441. }
  1442. $map[$x][$y] = +{ t => 'WALL',
  1443. c => ($wallglyph[$wdirs] || $map[$x][$y]{c} || '-'),
  1444. b => 'on_black',
  1445. f => 'white',
  1446. };
  1447. }
  1448. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!