03-19-2006, 12:17 AM
Technically it's a matrix, that is seeded with some height's
and then blurred, where the blur method doesn't take the uninitialized
parts of the matrix as valid input.
Maybe I'm gonna use it for a pirate-themed dungeoncrawler...
and then blurred, where the blur method doesn't take the uninitialized
parts of the matrix as valid input.
Maybe I'm gonna use it for a pirate-themed dungeoncrawler...
Code:
option explicit
declare sub showmap()
declare function getcolor(h as integer)
declare sub blur()
declare sub seed(v as integer, n as integer)
declare sub clearmap()
declare sub setborders()
declare function checkmap() as integer
randomize timer
dim shared a(0 to 39, 0 to 24)
dim i as string
do
do:i=inkey$:loop until i=""
clearmap
setborders
seed 255,4
seed 0,6
seed 160,4
dim as integer f, n
do
blur
loop until checkmap()
blur
blur
showmap
do:i=inkey$:sleep 1:loop while i=""
loop until i=chr$(27)
sub showmap()
dim x as integer
dim y as integer
for y=0 to 24
for x=0 to 39
locate y+1, x*2+1
color getcolor(a(x,y))
if len(hex$(abs(a(x,y))))=1 then print "0";
print hex$(abs(a(x,y)));
next
next
end sub
function getcolor(h as integer)
select case h
case 0 to 63
return 1
case 64 to 95
return 9
case 96 to 111
return 3
case 112 to 127
return 14
case 128 to 159
return 10
case 160 to 207
return 2
case 208 to 235
return 8
case 236 to 241
return 7
case 242 to 255
return 15
case else
return 4
end select
end function
sub blur()
dim t(0 to 39, 0 to 24) as integer
dim as integer xx,x
dim as integer yy,y
dim as integer sum, ctr
for yy=0 to 24
for xx=0 to 39
sum=0:ctr=0
for y=yy-1 to yy+1
for x=xx-1 to xx+1
if x>=0 and x<40 and y>=0 and y<25 then
if a(x,y)>-1 then
sum+=a(x,y)
ctr+=1
end if
end if
next
next
if ctr then
t(xx,yy)=sum\ctr+int(rnd*4)-int(rnd*4)
if t(xx,yy)>255 then t(xx,yy)=255
if t(xx,yy)<0 then t(xx,yy)=0
else
t(xx,yy)=a(xx,yy)
end if
next
next
for y=0 to 24
for x=0 to 39
a(x,y)=t(x,y)
next
next
end sub
sub seed (v as integer, n as integer)
dim i as integer
for i=0 to n-1
a(int(rnd*36+2),int(rnd*21+2))=v
next
end sub
sub clearmap()
dim x as integer
dim y as integer
for y=0 to 24
for x=0 to 39
a(x,y)=-1
next
next
end sub
sub setborders()
dim x as integer
dim y as integer
for x=0 to 39
a(x,0)=0
a(x,24)=0
next
for y=0 to 24
a(0,y)=0
a(39,y)=0
next
end sub
function checkmap() as integer
dim x as integer
dim y as integer
for y=0 to 24
for x=0 to 39
if a(x,y)=-1 then return 0
next
next
return 1
end function
/post]