Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Nice little island/terrain generator
#1
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...



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]
Reply
#2
Just looking at the output gives me a Robert Louis Stevenson feel.
Reply
#3
I love pirates.
Reply
#4
Quote:Maybe I'm gonna use it for a pirate-themed dungeoncrawler...[code cut]
Maybe that would be really sweet. :lol:
nice code. Smile
[Image: freebasic.png]
Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)