- DBPro Coding Challenges - - GameCreators Forum

Author

Message

Visigoth

20

Years of Service

User Offline

Joined: 8th Jan 2005

Location: Bakersfield, California

Posted: 13th May 2010 07:17

Link

so tempted to get into this..but, I have to stay focused on current project. Also, just my 2 cents, but, I wouldn't consider IanM's plugins "media". Heck, I'd consider them "essential". Looks like he only used one command anyway.

Back to top

Profile PM Email

Mobiius

Valued Member

22

Years of Service

User Offline

Joined: 27th Feb 2003

Location: The Cold North

Posted: 13th May 2010 10:27

Link

It doesn't use outside media... It creates it's own media, saves it, loads it, then deletes it. ('cos advanced terrain is stupid)

And as for the IanM plugin thing, just change the make object plain command to remove the rows and columns bit, like this...

Set Display Mode 800, 600, 32
Sync On : Sync Rate 0 : Sync

Dim TextureLookup( 256 ) As DWord

Global Scale# = 25.0

Do
   Fog On : Fog Color Rgb( 0, 0, 128 ) : Fog Distance 128.0 * Scale#
   Set Camera Range 0.1, 128.0 * Scale#

GenerateHeightScale()
   Det = MakeDetailMap()
   Wat = MakeWaterImg()

Seed = Timer()
   Noise = GenerateNoise( Seed, 256, 7, 1 ) : Save Image "Height.png", Noise
   Col = MakeColourMap( Noise )
   Ter = CreateTerrain( "Height.png", Col, Det )

Water = GetBlankObjNo()
   Make Object Plain Water, 256 * Scale#, 256 * Scale#
   Position Object Water, 0, 16.0 * Scale#, 0
   XRotate Object Water, 90.0
   Fix Object Pivot Water
   Texture Object Water, Wat
   Ghost Object On Water : Fade Object Water, 50
   
   Position Camera 0.0, 256.0 * Scale#, 0.0

While Not ReturnKey()
      OldX# = CurveValue( XPos#, Camera Position X(), 300 )
      OldZ# = CurveValue( ZPos#, Camera Position Z(), 300 )
      XPos# = ( 64 * Scale# ) * Sin( Wrapvalue( Timer() * 0.00625 ) ) : ZPos# = ( 64 * Scale# ) * Cos( Wrapvalue( Timer() * 0.0125 ) )
   
      CamY# = Get Terrain Ground Height( Ter, OldX#, OldZ# )
      PointY# = Get Terrain Ground Height( Ter, XPos#, ZPos# )
      Position Camera OldX#, CamY# + ( 5.0 * Scale# ), OldZ# : Point Camera XPos#, PointY# + ( 5.0 * Scale# ), ZPos#
   
      XRotate Object Water, ( 0.5 * Sin( Wrapvalue( Timer() * 0.025 ) ) )
      ZRotate Object Water, ( 0.5 * Sin( Wrapvalue( Timer() * 0.05 ) ) )
   
      If Spacekey()
         Paste Image Noise, 0, 20
         Paste Image Col, 256, 20
      EndIf
   
      Text 0, 0, Str$( Seed )
      Sync
   EndWhile

Delete Image Noise
   Delete Image Col
   Delete Image Wat
   Destroy Terrain Ter
   Delete Object Water
   Set Display Mode 800, 600, 32
Loop
End
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function MakeWaterImg()
   Bmp = GetBlankBmpNo()
   Create Bitmap Bmp, 256, 256
   Set Current Bitmap Bmp
   Ink Rgb( 0, 0, 255 ), 0
   Box 0, 0, 256, 256
   Sync
   Wat = GetBlankImgNo()
   Get Image Wat, 0, 0, 256, 256, 1
   Set Current Bitmap 0
   Delete Bitmap Bmp
EndFunction Wat
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
`Convert matrix to plain.......
Function MakeColourMap( Img )
   Bmp = GetBlankBmpNo()
   Create Bitmap Bmp, 256, 256
   Set Current Bitmap Bmp
   Cls
   Paste Image Img, 0, 0
   For Y = 0 To 255
      For X = 0 To 255
         Dot X, Y, TextureLookup( RgbR( Point( X, Y ) ) )
      Next X
   Next Y   
   Sync
   Col = GetBlankImgNo()
   Get Image Col, 0, 0, 256, 256
   Set Current Bitmap 0
   Delete Bitmap Bmp
EndFunction Col
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function MakeDetailMap()
   Bmp = GetBlankBmpNo()
   Create Bitmap Bmp, 256, 256
   Set Current Bitmap Bmp
   Set Bitmap Format 21
   Ink Rgb( 128, 128, 128 ), 0
   Box 0, 0, 256, 256
   Sync
   Det = GetBlankImgNo()
   Get Image Det, 0, 0, 256, 256, 1
   Set Current Bitmap 0
   Delete Bitmap Bmp
EndFunction Det
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function CreateTerrain( Height$, Col, Det )
   Ter = GetBlankObjNo()

Make Object Terrain Ter                              ` create the terrain object
   Set Terrain Heightmap Ter, Height$                   ` set the heightmap
   Set Terrain Scale Ter, Scale#, Scale# * 0.2, Scale#  ` set the scale
   Set Terrain Split Ter, 16                            ` split value by 16 * 16
   Set Terrain Tiling Ter, 4                            ` detail map tiling
   Set Terrain Light Ter, 0.15, -1, 0, 0.75, 0.75, 0.75, 0.5        ` light - xdir, ydir, zdir, red, green, blue, intensity
   Set Terrain Texture Ter, Col, Det                    ` base and detail texture
   Build Terrain Ter                                    ` finally build the terrain

Delete File Height$

Position Object Ter, 0.0 - ( ( 256.0 * Scale# ) / 2.0 ), 0.0, 0.0 - ( ( 256.0 * Scale# ) / 2.0 )
EndFunction Ter
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankImgNo()
   For Num = 1 To 65500
      If Image Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankObjNo()
   For Num = 1 To 65500
      If Object Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankBmpNo()
   For Num = 1 To 32
      If Bitmap Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankSprNo()
   For Num = 1 To 65500
      If Sprite Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetImageWidth( ImgNo )
   Spr = GetBlankSprNo()
   Sprite Spr, 0, 0, ImgNo
   Width = Sprite Width( Spr )
   Delete Sprite Spr
EndFunction Width
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetImageHeight( ImgNo )
   Spr = GetBlankSprNo()
   Sprite Spr, 0, 0, ImgNo
   Height = Sprite Height(Spr)
   Delete Sprite Spr
EndFunction Height

`Perlin Noise Courtesy of Dark Coder ;) ()
Function GenerateNoise( Seed, startingRes, totalOctaves, Sampling )
   Randomize Seed
   If startingRes > 512 Then startingRes = 512
   If totalOctaves > 8 Then totalOctaves = 8

// Generate noise for all octaves
   for octaveID = 1 to totalOctaves
       memblockID  = octaveID
       octaveRes   = startingRes / 2 ^ (octaveID - 1)
       Make Memblock memblockID, octaveRes * octaveRes * 4 // A single float
       for x = 0 to octaveRes - 1
           for y = 0 to octaveRes - 1
               Write Memblock Float memblockID, ( x + y * octaveRes ) * 4, ( Rnd(2000) - 1000 ) * 0.001
           next
       next
   next

// add all layers together
   memblockID  = totalOctaves + 1

Make Memblock memblockID, 12 + startingRes * startingRes * 4
   Write Memblock DWord memblockID, 0, startingRes
   Write Memblock DWord memblockID, 4, startingRes
   Write Memblock DWord memblockID, 8, 32

minHeight#      = -1.9
   maxHeight#      =  1.9
   minInv#         = -minHeight#
   heightRange#    =  maxHeight# - minHeight#
   _255DivRange#   =  255.0 / heightRange#
   sResReciprocal# =    1.0 / (startingRes)

for x = 0 to startingRes - 1
       for y = 0 to startingRes - 1
           x#          = x * sResReciprocal#
           y#          = y * sResReciprocal#
           height#     = 0.0
           Strength#   = 1.0
           `height# = Memblock Float( 1, ( x + y * startingRes ) * 4 )

for OctaveID = totalOctaves to 1 step -1
           `for OctaveID = 7 to 7 step -1
               octaveRes = startingRes / 2 ^ (octaveID - 1)
               // Store the float pixel we are over on the current octave
               memblockX# = x# * octaveRes
               memblockY# = y# * octaveRes
               // Store the int version for pixel sampling
               memblockX  = memblockX#
               memblockY  = memblockY#
               // Get the local offset
               memblockX# = memblockX# mod 1.0
               memblockY# = memblockY# mod 1.0

If Sampling = 1
                 `BiCubic Sampling
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY - 1, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY - 1, octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY - 1, octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY - 1, octaveRes )
                  mHeight1# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY    , octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY    , octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY    , octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY    , octaveRes )
                  mHeight2# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY + 1, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY + 1, octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY + 1, octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY + 1, octaveRes )
                  mHeight3# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY + 2, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY + 2, octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY + 2, octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY + 2, octaveRes )
                  mHeight4# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  mHeight#  = CubicInterpolate( mHeight1#, mHeight2#, mHeight3#, mHeight4#, memblockY# )
               Else
                 `BiLinear Sampling
                  sample1#  = Sample( OctaveID, memblockX    , memblockY, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX + 1, memblockY, octaveRes )
                  mHeightX# = Linear_Interpolate( sample1#, sample2#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX    , memblockY + 1, octaveRes)
                  sample2#  = Sample( OctaveID, memblockX + 1, memblockY + 1, octaveRes)
                  mHeightY# = Linear_Interpolate( sample1#, sample2#, memblockX# )
                  mHeight#  = Linear_Interpolate( mHeightX#, mHeightY#, memblockY# )
               EndIf

height# = height# + mHeight# * Strength#
               Strength# = Strength# * 0.5
           next

height  = (height# + minInv#) * _255DivRange#
           if height > 255 then height = 255
           if height <   0 then height = 0
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4    , height // B
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4 + 1, height // G
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4 + 2, height // R
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4 + 3, 255    // A
       next
   next

// Create image
   Img = GetBlankImgNo()
   Make Image From Memblock Img, memblockID
   
   For octaveID = 1 to totalOctaves
      Delete Memblock octaveID
   Next octaveID
   Delete Memblock totalOctaves + 1
   Cls
EndFunction Img

Function Sample( memblockID, x, y, memblockRes )
   if x < 0 then x = x + memblockRes
   if y < 0 then y = y + memblockRes
   if x > memblockRes-1 then x = x - memblockRes
   if y > memblockRes-1 then y = y - memblockRes
   returnValue# = Memblock Float( memblockID, ( x + y * memblockRes ) * 4 )
Endfunction returnValue#

Function Linear_Interpolate( a as float, b as float, x as float )
   returnValue# =  a * (1.0 - x) + b * x
Endfunction returnValue#

Function CubicInterpolate( aMinOne as float, a as float, b as float, bAddOne as float, acrossAB as float )
   P as float
   Q as float
   R as float
   S as float
   P = (bAddOne - b) - (aMinOne - a)
   Q = (aMinOne - a) - P
   R = b - aMinOne
   S = a
   returnValue# =  P * acrossAB ^ 3 + Q * acrossAB ^ 2 + R * acrossAB + S
EndFunction returnValue#

Function GenerateHeightScale()
   Restore TextureColours:
   For Y = 0 To 255
      Read TextureLookup( Y )
   Next Y
EndFunction

TextureColours:
Data 4278190215, 4278190216, 4278190472, 4278190729, 4278256522, 4278257035, 4278323084, 4278389134, 4278389903, 4278390929
Data 4278457235, 4278523798, 4278590361, 4278656923, 4278789278, 4278790305, 4278857381, 4278989479, 4279056555, 4279123630
Data 4279255986, 4279323062, 4279390138, 4279522493, 4279589569, 4279656644, 4279723464, 4279856075, 4279923150, 4279989970
Data 4280122325, 4280123608, 4280255964, 4280322782, 4280389088, 4280390372, 4280456933, 4280588520, 4280589290, 4280655851
Data 4280721901, 4280722415, 4280722927, 4280788464, 4280723441, 4280789233, 4280723441, 4280788977, 4280920303, 4280986094
Data 4281182701, 4281314282, 4281576679, 4281839331, 4282167520, 4282429916, 4282823640, 4283217619, 4283677133, 4284070856
Data 4284530370, 4284989884, 4285514933, 4286039984, 4286499497, 4286959011, 4287484060, 4288009110, 4288534160, 4288993674
Data 4289453188, 4289977982, 4290371960, 4290765939, 4291225199, 4291553386, 4291881829, 4292209762, 4292472415, 4292734811
Data 4292931673, 4293128790, 4293194325, 4293260117, 4293325652, 4293325651, 4293325652, 4293260116, 4293194579, 4293129043
Data 4292997714, 4292866641, 4292735569, 4292604240, 4292473167, 4292210766, 4292014413, 4291817291, 4291555146, 4291293001
Data 4291030599, 4290702917, 4290440516, 4290112834, 4289784896, 4289391422, 4289129021, 4288735546, 4288407865, 4288014390
Data 4287620916, 4287227698, 4286899760, 4286440750, 4286112811, 4285719337, 4285326119, 4284932645, 4284539171, 4284211489
Data 4283818015, 4283424541, 4283031066, 4282637593, 4282309911, 4281981972, 4281654035, 4281391889, 4280998416, 4280736014
Data 4280408332, 4280211466, 4279949065, 4279686920, 4279490311, 4279227910, 4279096837, 4278965764, 4278768899, 4278637826
Data 4278572289, 4278441217, 4278375681, 4278310144, 4278244608, 4278244352, 4278244352, 4278244353, 4278309632, 4278244097
Data 4278309376, 4278374657, 4278374402, 4278504962, 4278504962, 4278569731, 4278634756, 4278700037, 4278764805, 4278829830
Data 4278960647, 4279025416, 4279090185, 4279155210, 4279285515, 4279350284, 4279480844, 4279545614, 4279610638, 4279740943
Data 4279871248, 4279936017, 4280001043, 4280131348, 4280261652, 4280260886, 4280391446, 4280456471, 4280586776, 4280586521
Data 4280717082, 4280782106, 4280847131, 4280912156, 4280911900, 4280977180, 4281042461, 4281042206, 4281041949, 4281107230
Data 4281107229, 4281107230, 4281172766, 4281107230, 4281107230, 4281172767, 4281172767, 4281238559, 4281238560, 4281304353
Data 4281369889, 4281435427, 4281500964, 4281501221, 4281632294, 4281698343, 4281763881, 4281829419, 4281960748, 4282026542
Data 4282157871, 4282289202, 4282420531, 4282551861, 4282682936, 4282814266, 4282945596, 4283076926, 4283208513, 4283405380
Data 4283536709, 4283733577, 4283799371, 4283996494, 4284127825, 4284324691, 4284521558, 4284718425, 4284850012, 4285046878
Data 4285244002, 4285440869, 4285637736, 4285769067, 4285966190, 4286163057, 4286360180, 4286491255, 4286885245, 4287345029
Data 4287804813, 4288329877, 4288789660, 4289249188, 4289708715, 4290102706, 4290496696, 4290824894, 4291087555, 4291416008
Data 4291612875, 4291809998, 4291941329, 4292137939, 4292138452, 4292138196

+ Code Snippet

Set Display Mode 800, 600, 32
Sync On : Sync Rate 0 : Sync

Dim TextureLookup( 256 ) As DWord

Global Scale# = 25.0


Do
   Fog On : Fog Color Rgb( 0, 0, 128 ) : Fog Distance 128.0 * Scale#
   Set Camera Range 0.1, 128.0 * Scale#

   GenerateHeightScale()
   Det = MakeDetailMap()
   Wat = MakeWaterImg()

   Seed = Timer()
   Noise = GenerateNoise( Seed, 256, 7, 1 ) : Save Image "Height.png", Noise
   Col = MakeColourMap( Noise )
   Ter = CreateTerrain( "Height.png", Col, Det )

   Water = GetBlankObjNo()
   Make Object Plain Water, 256 * Scale#, 256 * Scale#
   Position Object Water, 0, 16.0 * Scale#, 0
   XRotate Object Water, 90.0
   Fix Object Pivot Water
   Texture Object Water, Wat
   Ghost Object On Water : Fade Object Water, 50
   
   Position Camera 0.0, 256.0 * Scale#, 0.0

   While Not ReturnKey()
      OldX# = CurveValue( XPos#, Camera Position X(), 300 )
      OldZ# = CurveValue( ZPos#, Camera Position Z(), 300 )
      XPos# = ( 64 * Scale# ) * Sin( Wrapvalue( Timer() * 0.00625 ) ) : ZPos# = ( 64 * Scale# ) * Cos( Wrapvalue( Timer() * 0.0125 ) )
   
      CamY# = Get Terrain Ground Height( Ter, OldX#, OldZ# )
      PointY# = Get Terrain Ground Height( Ter, XPos#, ZPos# )
      Position Camera OldX#, CamY# + ( 5.0 * Scale# ), OldZ# : Point Camera XPos#, PointY# + ( 5.0 * Scale# ), ZPos#
   
      XRotate Object Water, ( 0.5 * Sin( Wrapvalue( Timer() * 0.025 ) ) )
      ZRotate Object Water, ( 0.5 * Sin( Wrapvalue( Timer() * 0.05 ) ) )
   
      If Spacekey()
         Paste Image Noise, 0, 20
         Paste Image Col, 256, 20
      EndIf
   
      Text 0, 0, Str$( Seed )
      Sync
   EndWhile

   Delete Image Noise
   Delete Image Col
   Delete Image Wat
   Destroy Terrain Ter
   Delete Object Water
   Set Display Mode 800, 600, 32
Loop
End
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function MakeWaterImg()
   Bmp = GetBlankBmpNo()
   Create Bitmap Bmp, 256, 256
   Set Current Bitmap Bmp
   Ink Rgb( 0, 0, 255 ), 0
   Box 0, 0, 256, 256
   Sync
   Wat = GetBlankImgNo()
   Get Image Wat, 0, 0, 256, 256, 1
   Set Current Bitmap 0
   Delete Bitmap Bmp
EndFunction Wat
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
`Convert matrix to plain.......
Function MakeColourMap( Img )
   Bmp = GetBlankBmpNo()
   Create Bitmap Bmp, 256, 256
   Set Current Bitmap Bmp
   Cls
   Paste Image Img, 0, 0
   For Y = 0 To 255
      For X = 0 To 255
         Dot X, Y, TextureLookup( RgbR( Point( X, Y ) ) )
      Next X
   Next Y   
   Sync
   Col = GetBlankImgNo()
   Get Image Col, 0, 0, 256, 256
   Set Current Bitmap 0
   Delete Bitmap Bmp
EndFunction Col
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function MakeDetailMap()
   Bmp = GetBlankBmpNo()
   Create Bitmap Bmp, 256, 256
   Set Current Bitmap Bmp
   Set Bitmap Format 21
   Ink Rgb( 128, 128, 128 ), 0
   Box 0, 0, 256, 256
   Sync
   Det = GetBlankImgNo()
   Get Image Det, 0, 0, 256, 256, 1
   Set Current Bitmap 0
   Delete Bitmap Bmp
EndFunction Det
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function CreateTerrain( Height$, Col, Det )
   Ter = GetBlankObjNo()

   Make Object Terrain Ter                              ` create the terrain object
   Set Terrain Heightmap Ter, Height$                   ` set the heightmap
   Set Terrain Scale Ter, Scale#, Scale# * 0.2, Scale#  ` set the scale
   Set Terrain Split Ter, 16                            ` split value by 16 * 16
   Set Terrain Tiling Ter, 4                            ` detail map tiling
   Set Terrain Light Ter, 0.15, -1, 0, 0.75, 0.75, 0.75, 0.5        ` light - xdir, ydir, zdir, red, green, blue, intensity
   Set Terrain Texture Ter, Col, Det                    ` base and detail texture
   Build Terrain Ter                                    ` finally build the terrain

   Delete File Height$

   Position Object Ter, 0.0 - ( ( 256.0 * Scale# ) / 2.0 ), 0.0, 0.0 - ( ( 256.0 * Scale# ) / 2.0 )
EndFunction Ter
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankImgNo()
   For Num = 1 To 65500
      If Image Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankObjNo()
   For Num = 1 To 65500
      If Object Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankBmpNo()
   For Num = 1 To 32
      If Bitmap Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetBlankSprNo()
   For Num = 1 To 65500
      If Sprite Exist( Num ) = 0
         ExitFunction Num
      EndIf
   Next Num
EndFunction 0
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetImageWidth( ImgNo )
   Spr = GetBlankSprNo()
   Sprite Spr, 0, 0, ImgNo
   Width = Sprite Width( Spr )
   Delete Sprite Spr
EndFunction Width
`============================================================================================================================
`============================================================================================================================
`============================================================================================================================
Function GetImageHeight( ImgNo )
   Spr = GetBlankSprNo()
   Sprite Spr, 0, 0, ImgNo
   Height = Sprite Height(Spr)
   Delete Sprite Spr
EndFunction Height


`Perlin Noise Courtesy of Dark Coder ;) ()
Function GenerateNoise( Seed, startingRes, totalOctaves, Sampling )
   Randomize Seed
   If startingRes > 512 Then startingRes = 512
   If totalOctaves > 8 Then totalOctaves = 8

   // Generate noise for all octaves
   for octaveID = 1 to totalOctaves
       memblockID  = octaveID
       octaveRes   = startingRes / 2 ^ (octaveID - 1)
       Make Memblock memblockID, octaveRes * octaveRes * 4 // A single float
       for x = 0 to octaveRes - 1
           for y = 0 to octaveRes - 1
               Write Memblock Float memblockID, ( x + y * octaveRes ) * 4, ( Rnd(2000) - 1000 ) * 0.001
           next
       next
   next

   // add all layers together
   memblockID  = totalOctaves + 1

   Make Memblock memblockID, 12 + startingRes * startingRes * 4
   Write Memblock DWord memblockID, 0, startingRes
   Write Memblock DWord memblockID, 4, startingRes
   Write Memblock DWord memblockID, 8, 32

   minHeight#      = -1.9
   maxHeight#      =  1.9
   minInv#         = -minHeight#
   heightRange#    =  maxHeight# - minHeight#
   _255DivRange#   =  255.0 / heightRange#
   sResReciprocal# =    1.0 / (startingRes)

   for x = 0 to startingRes - 1
       for y = 0 to startingRes - 1
           x#          = x * sResReciprocal#
           y#          = y * sResReciprocal#
           height#     = 0.0
           Strength#   = 1.0
           `height# = Memblock Float( 1, ( x + y * startingRes ) * 4 )

           for OctaveID = totalOctaves to 1 step -1
           `for OctaveID = 7 to 7 step -1
               octaveRes = startingRes / 2 ^ (octaveID - 1)
               // Store the float pixel we are over on the current octave
               memblockX# = x# * octaveRes
               memblockY# = y# * octaveRes
               // Store the int version for pixel sampling
               memblockX  = memblockX#
               memblockY  = memblockY#
               // Get the local offset
               memblockX# = memblockX# mod 1.0
               memblockY# = memblockY# mod 1.0

               If Sampling = 1
                 `BiCubic Sampling
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY - 1, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY - 1, octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY - 1, octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY - 1, octaveRes )
                  mHeight1# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY    , octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY    , octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY    , octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY    , octaveRes )
                  mHeight2# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY + 1, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY + 1, octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY + 1, octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY + 1, octaveRes )
                  mHeight3# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX - 1, memblockY + 2, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX    , memblockY + 2, octaveRes )
                  sample3#  = Sample( OctaveID, memblockX + 1, memblockY + 2, octaveRes )
                  sample4#  = Sample( OctaveID, memblockX + 2, memblockY + 2, octaveRes )
                  mHeight4# = CubicInterpolate( sample1#, sample2#, sample3#, sample4#, memblockX# )
                  mHeight#  = CubicInterpolate( mHeight1#, mHeight2#, mHeight3#, mHeight4#, memblockY# )
               Else
                 `BiLinear Sampling
                  sample1#  = Sample( OctaveID, memblockX    , memblockY, octaveRes )
                  sample2#  = Sample( OctaveID, memblockX + 1, memblockY, octaveRes )
                  mHeightX# = Linear_Interpolate( sample1#, sample2#, memblockX# )
                  sample1#  = Sample( OctaveID, memblockX    , memblockY + 1, octaveRes)
                  sample2#  = Sample( OctaveID, memblockX + 1, memblockY + 1, octaveRes)
                  mHeightY# = Linear_Interpolate( sample1#, sample2#, memblockX# )
                  mHeight#  = Linear_Interpolate( mHeightX#, mHeightY#, memblockY# )
               EndIf

               height# = height# + mHeight# * Strength#
               Strength# = Strength# * 0.5
           next

           height  = (height# + minInv#) * _255DivRange#
           if height > 255 then height = 255
           if height <   0 then height = 0
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4    , height // B
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4 + 1, height // G
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4 + 2, height // R
           Write Memblock Byte memblockID, 12 + ( x + y * startingRes ) * 4 + 3, 255    // A
       next
   next

   // Create image
   Img = GetBlankImgNo()
   Make Image From Memblock Img, memblockID
   
   For octaveID = 1 to totalOctaves
      Delete Memblock octaveID
   Next octaveID
   Delete Memblock totalOctaves + 1
   Cls
EndFunction Img


Function Sample( memblockID, x, y, memblockRes )
   if x < 0 then x = x + memblockRes
   if y < 0 then y = y + memblockRes
   if x > memblockRes-1 then x = x - memblockRes
   if y > memblockRes-1 then y = y - memblockRes
   returnValue# = Memblock Float( memblockID, ( x + y * memblockRes ) * 4 )
Endfunction returnValue#

Function Linear_Interpolate( a as float, b as float, x as float )
   returnValue# =  a * (1.0 - x) + b * x
Endfunction returnValue#

Function CubicInterpolate( aMinOne as float, a as float, b as float, bAddOne as float, acrossAB as float )
   P as float
   Q as float
   R as float
   S as float
   P = (bAddOne - b) - (aMinOne - a)
   Q = (aMinOne - a) - P
   R = b - aMinOne
   S = a
   returnValue# =  P * acrossAB ^ 3 + Q * acrossAB ^ 2 + R * acrossAB + S
EndFunction returnValue#


Function GenerateHeightScale()
   Restore TextureColours:
   For Y = 0 To 255
      Read TextureLookup( Y )
   Next Y
EndFunction


TextureColours:
Data 4278190215, 4278190216, 4278190472, 4278190729, 4278256522, 4278257035, 4278323084, 4278389134, 4278389903, 4278390929
Data 4278457235, 4278523798, 4278590361, 4278656923, 4278789278, 4278790305, 4278857381, 4278989479, 4279056555, 4279123630
Data 4279255986, 4279323062, 4279390138, 4279522493, 4279589569, 4279656644, 4279723464, 4279856075, 4279923150, 4279989970
Data 4280122325, 4280123608, 4280255964, 4280322782, 4280389088, 4280390372, 4280456933, 4280588520, 4280589290, 4280655851
Data 4280721901, 4280722415, 4280722927, 4280788464, 4280723441, 4280789233, 4280723441, 4280788977, 4280920303, 4280986094
Data 4281182701, 4281314282, 4281576679, 4281839331, 4282167520, 4282429916, 4282823640, 4283217619, 4283677133, 4284070856
Data 4284530370, 4284989884, 4285514933, 4286039984, 4286499497, 4286959011, 4287484060, 4288009110, 4288534160, 4288993674
Data 4289453188, 4289977982, 4290371960, 4290765939, 4291225199, 4291553386, 4291881829, 4292209762, 4292472415, 4292734811
Data 4292931673, 4293128790, 4293194325, 4293260117, 4293325652, 4293325651, 4293325652, 4293260116, 4293194579, 4293129043
Data 4292997714, 4292866641, 4292735569, 4292604240, 4292473167, 4292210766, 4292014413, 4291817291, 4291555146, 4291293001
Data 4291030599, 4290702917, 4290440516, 4290112834, 4289784896, 4289391422, 4289129021, 4288735546, 4288407865, 4288014390
Data 4287620916, 4287227698, 4286899760, 4286440750, 4286112811, 4285719337, 4285326119, 4284932645, 4284539171, 4284211489
Data 4283818015, 4283424541, 4283031066, 4282637593, 4282309911, 4281981972, 4281654035, 4281391889, 4280998416, 4280736014
Data 4280408332, 4280211466, 4279949065, 4279686920, 4279490311, 4279227910, 4279096837, 4278965764, 4278768899, 4278637826
Data 4278572289, 4278441217, 4278375681, 4278310144, 4278244608, 4278244352, 4278244352, 4278244353, 4278309632, 4278244097
Data 4278309376, 4278374657, 4278374402, 4278504962, 4278504962, 4278569731, 4278634756, 4278700037, 4278764805, 4278829830
Data 4278960647, 4279025416, 4279090185, 4279155210, 4279285515, 4279350284, 4279480844, 4279545614, 4279610638, 4279740943
Data 4279871248, 4279936017, 4280001043, 4280131348, 4280261652, 4280260886, 4280391446, 4280456471, 4280586776, 4280586521
Data 4280717082, 4280782106, 4280847131, 4280912156, 4280911900, 4280977180, 4281042461, 4281042206, 4281041949, 4281107230
Data 4281107229, 4281107230, 4281172766, 4281107230, 4281107230, 4281172767, 4281172767, 4281238559, 4281238560, 4281304353
Data 4281369889, 4281435427, 4281500964, 4281501221, 4281632294, 4281698343, 4281763881, 4281829419, 4281960748, 4282026542
Data 4282157871, 4282289202, 4282420531, 4282551861, 4282682936, 4282814266, 4282945596, 4283076926, 4283208513, 4283405380
Data 4283536709, 4283733577, 4283799371, 4283996494, 4284127825, 4284324691, 4284521558, 4284718425, 4284850012, 4285046878
Data 4285244002, 4285440869, 4285637736, 4285769067, 4285966190, 4286163057, 4286360180, 4286491255, 4286885245, 4287345029
Data 4287804813, 4288329877, 4288789660, 4289249188, 4289708715, 4290102706, 4290496696, 4290824894, 4291087555, 4291416008
Data 4291612875, 4291809998, 4291941329, 4292137939, 4292138452, 4292138196

My signature is NOT a moderator plaything! Stop changing it!

Back to top

Profile PM Email Website

baxslash

Valued Member

Bronze Codemaster

18

Years of Service

User Offline

Joined: 26th Dec 2006

Location: Duffield

Posted: 13th May 2010 10:32 Edited at: 13th May 2010 10:35

Link

Quote: "
NOT ALLOWED:

You may not enter code that requires anything that must be downloaded, in order for the code to work, including:

Picture files, like .jpg’s, .bmp’s, .png’s., if they have to be downloaded.
.dll’s which cannot be guaranteed to exist on other users’ machines. For example, you may not enter code which requires Sparky’s Collision dll, as not everybody has it installed."

http://www.andromedus.com/dbp/html/media-rule.html

Sorry @Mobiius...

...also:

Quote: "it should be able to be used for a 2D rpg world, or to texture a planet sphere"

Back to top

Profile PM Email

Mobiius

Valued Member

22

Years of Service

User Offline

Joined: 27th Feb 2003

Location: The Cold North

Posted: 13th May 2010 10:41

Link

Quote: "Quote: "it should be able to be used for a 2D rpg world, or to texture a planet sphere""

It still could. Press space and see the heightmap and colormap. The colormap could be used for a 2D RPG. And if you change the scales you can get a higher resolution image.

Change the 256 here...

+ Code Snippet

Noise = GenerateNoise( Seed, 256, 7, 1 )

To generate a heightmap of a different size.
Change the 7 to increase or decrease the scale of the terrain. Lower numbers make it more bumpy, higher numbers (up to 8) make it more smooth. (A high resolution and small scales can make a huge RPG terrain.)

My signature is NOT a moderator plaything! Stop changing it!

Back to top

Profile PM Email Website

baxslash

Valued Member

Bronze Codemaster

18

Years of Service

User Offline

Joined: 26th Dec 2006

Location: Duffield

Posted: 13th May 2010 11:00

Link

@Mobiius, great work as usual. You are right of course, it could be used for a 2D rpg world, I think people (including me) are getting hung up on the fact it's been designed more for 3D. I don't think it would look anywhere near as impressive used in a 2D game (although I'd be happy to be proved wrong!).

I wouldn't know where to start on something like this so don't think I'm not impressed because I am!!

Back to top

Profile PM Email

chafari

Valued Member

19

Years of Service

User Offline

Joined: 2nd May 2006

Location: Canary Islands

Posted: 13th May 2010 12:44

Link

Quote: "('cos advanced terrain is stupid)"

@Mobiuus
Really good code, but that`s what I meant I didn´t post my 3DTerrain. The picture I showed above was what I had understood to IBOL.

Ani way, with some arrangements you can achieved the same

cheers.

I'm not a grumpy grandpa

Back to top

Profile PM Email

owlman

16

Years of Service

User Offline

Joined: 8th Apr 2009

Location: Italy

Posted: 13th May 2010 20:19

Link

hi, can i just check what is being asked for here? is it a series of dots on a 200 *200 pixel base - each color-coded to represent different terrain types or is it more complex than that?

Back to top

Profile PM Email

IBOL

Retired Moderator

21

Years of Service

User Offline

Joined: 30th Mar 2004

Location: @IBOL17

Posted: 14th May 2010 01:19

Link

owlman, that is a wonderfully concise description !
yes.

Back to top

Profile PM Email Website

IBOL

Retired Moderator

21

Years of Service

User Offline

Joined: 30th Mar 2004

Location: @IBOL17

Posted: 15th May 2010 19:43

Link

hey all,
i'm really sorry about this challenge.
no one wants to do it, so i'd like to ask:

does anyone else have a more desirable challenge idea?
i certainly don't want to kill this thread!

so please post an idea, and as soon as a good one comes along,
we'll go with that.

Back to top

Profile PM Email Website

owlman

16

Years of Service

User Offline

Joined: 8th Apr 2009

Location: Italy

Posted: 15th May 2010 20:17 Edited at: 20th May 2010 10:30

Link

i've had a quick go at the challenge - the first time i've taken part or posted anything to this website - please dont slaughter me anyone

.. also let me know what you think of my attempt

I have changed the challenge function a little and i hope that doesn't disqualify me lol .. i wanted to limit ice caps to the north and south extremes - i have also added two levels of mountains and arable farmland. if you press the spacebar you generate a new map and mouse clicking on the map writes the type of terrain under the cursor to screen.

rem code challenge by owlman
  
set display mode 1024,768,32

randomize timer()

#constant total_terrain_types =8
#constant xrows = 200
#constant yrows = 200

global dim array1(xrows) as integer
global dim array2(xrows) as integer
global dim w(xrows,yrows) as integer
startup = 1

sync on: sync rate 0

do
set text font "arial"
set text size 36
 ink rgb (255,255,255),0
   text 500,10,"click on map for terrain details"
   text 500, 60, "press spacebar to generate new map"

if spacekey()=1 or startup = 1
cls
     for Y = 0 to yrows

reit_array(Y)

if Y > 0

for T = 1 to xrows
                        array1(T) = array2(T)
                           if array1(T)=0 then array1(T)=1
                        w(Y,T) = array1(T)
                     next T

endif

next Y

display_world()
   startup =0
 endif
if mouseclick()=1 then say_terrain_type(mousex(),mouseY())
sync
loop
end

Function Display_World()
  cls
 for x=1 to 200
  for y=1 to 200
   a=w(x,y)
   if a=1 then ink rgb(1,0,205),0 : ` WATER
   if a=2 then ink rgb(125,150,50),0 : ` GRASS-LAND
   if a=3 then ink rgb(34,139,34),0 : ` FOREST
   if a=4 then ink rgb(139,69,19),0 : ` MOUNTAINS
   if a=5 then ink rgb(218,165,32),0 : ` DESERT

if a=6
        if y < 5 + rnd(5) or y> 195 -rnd(5)
               ink rgb(238,233,233),0 : ` ICE-CAPS / FROZEN TUNDRA
         else
               ink rgb(165,100,45),0 : rem arable farm land
        endif
   endif
   if a=7 then ink rgb(110,49,19),0 : `mountains in excess of 2000 metres

dot x*2,y*2
   dot x*2+1,y*2
   dot x*2,y*2+1
   dot x*2+1,y*2+1

next y
 next x
  sync
Endfunction

function reit_array(Y as integer)

for X = 1 to xrows

if Y = 0
              i = rnd(total_terrain_types -1)+1
         array1(X)= i
      else
      R = rnd(10)
         T=X+rnd(R)
         M=X+rnd(R)

while X< T

inc X

if X =< xrows
                           if M=<xrows
                              array2(X) = array1(M)
                           else
                              array2(X)=array1(M - xrows)
                           endif
                     endif

endwhile

endif

next X

endfunction

function say_terrain_type(X as integer,Y as integer)

ink rgb(0,0,0),0 : for t= 500 to 1000
      for m = 0 to 500 : dot t,m : next m
    next t

ink rgb(255,255,255),0

if rgbr (point(X,Y)) = 1     then saystring$ = "water"    		    : rem water
     if rgbr (point(X,Y)) = 125   then saystring$ = "grass land" 		: rem grass land
     if rgbr (point(X,Y)) = 34    then saystring$ = "forests"           : rem forests
     if rgbr (point(X,Y)) = 139   then saystring$ = "low mountains"     : rem mountains
     if rgbr (point(X,Y)) = 218   then saystring$ = "desert"            : rem desert
     if rgbr (point(X,Y)) = 238   then saystring$ = "ice/ frozen tundra": rem ice
     if rgbr (point(X,Y)) = 110   then saystring$ = "high mountains"    : rem high mounts
     if rgbr (point(X,Y)) = 165   then saystring$ = "arable farmland"   : rem arable farmland

text  500,150,  "Terrain type: " +saystring$

endfunction

+ Code Snippet


rem code challenge by owlman
  
set display mode 1024,768,32

randomize timer()

#constant total_terrain_types =8
#constant xrows = 200
#constant yrows = 200

global dim array1(xrows) as integer
global dim array2(xrows) as integer
global dim w(xrows,yrows) as integer
startup = 1

sync on: sync rate 0

 do
set text font "arial"
set text size 36
 ink rgb (255,255,255),0
   text 500,10,"click on map for terrain details"
   text 500, 60, "press spacebar to generate new map"

if spacekey()=1 or startup = 1
cls
     for Y = 0 to yrows

                      reit_array(Y)


            if Y > 0

                     for T = 1 to xrows
                        array1(T) = array2(T)
                           if array1(T)=0 then array1(T)=1
                        w(Y,T) = array1(T)
                     next T

               endif



     next Y


    display_world()
   startup =0
 endif
if mouseclick()=1 then say_terrain_type(mousex(),mouseY())
sync
loop
end



Function Display_World()
  cls
 for x=1 to 200
  for y=1 to 200
   a=w(x,y)
   if a=1 then ink rgb(1,0,205),0 : ` WATER
   if a=2 then ink rgb(125,150,50),0 : ` GRASS-LAND
   if a=3 then ink rgb(34,139,34),0 : ` FOREST
   if a=4 then ink rgb(139,69,19),0 : ` MOUNTAINS
   if a=5 then ink rgb(218,165,32),0 : ` DESERT

   if a=6
        if y < 5 + rnd(5) or y> 195 -rnd(5)
               ink rgb(238,233,233),0 : ` ICE-CAPS / FROZEN TUNDRA
         else
               ink rgb(165,100,45),0 : rem arable farm land
        endif
   endif
   if a=7 then ink rgb(110,49,19),0 : `mountains in excess of 2000 metres
 

   dot x*2,y*2
   dot x*2+1,y*2
   dot x*2,y*2+1
   dot x*2+1,y*2+1

  next y
 next x
  sync
Endfunction


function reit_array(Y as integer)


   for X = 1 to xrows

      if Y = 0
              i = rnd(total_terrain_types -1)+1
         array1(X)= i
      else
      R = rnd(10)
         T=X+rnd(R)
         M=X+rnd(R)

            while X< T

               inc X

                     if X =< xrows
                           if M=<xrows
                              array2(X) = array1(M)
                           else
                              array2(X)=array1(M - xrows)
                           endif
                     endif

             endwhile

         endif


   next X

endfunction

function say_terrain_type(X as integer,Y as integer)


    ink rgb(0,0,0),0 : for t= 500 to 1000
      for m = 0 to 500 : dot t,m : next m
    next t

   ink rgb(255,255,255),0

     if rgbr (point(X,Y)) = 1     then saystring$ = "water"    		    : rem water
     if rgbr (point(X,Y)) = 125   then saystring$ = "grass land" 		: rem grass land
     if rgbr (point(X,Y)) = 34    then saystring$ = "forests"           : rem forests
     if rgbr (point(X,Y)) = 139   then saystring$ = "low mountains"     : rem mountains
     if rgbr (point(X,Y)) = 218   then saystring$ = "desert"            : rem desert
     if rgbr (point(X,Y)) = 238   then saystring$ = "ice/ frozen tundra": rem ice
     if rgbr (point(X,Y)) = 110   then saystring$ = "high mountains"    : rem high mounts
     if rgbr (point(X,Y)) = 165   then saystring$ = "arable farmland"   : rem arable farmland

 text  500,150,  "Terrain type: " +saystring$

endfunction

if effort>reward : gosub home : endif

Back to top

Profile PM Email

acelepage

20

Years of Service

User Offline

Joined: 2nd Jun 2004

Location: Plattsville

Posted: 16th May 2010 00:38

Link

@IBOL,
I'm still in. I have an idea to improve on my entry based on your feedback. I just have to find some time to put it into code. I am aiming to meet the 20th deadline.

( 2b || !2b ), that is the question. The answer: true

Back to top

Profile PM Email

IBOL

Retired Moderator

21

Years of Service

User Offline

Joined: 30th Mar 2004

Location: @IBOL17

Posted: 16th May 2010 23:04

Link

@acelpage,
all right, great!
i certainly won't change it then.

your signature reminds me of another one i saw:
"there are 10 kinds of people in the world. those that understand binary, and those that don't."

Back to top

Profile PM Email Website

Neuro Fuzzy

17

Years of Service

User Offline

Joined: 11th Jun 2007

Location:

Posted: 16th May 2010 23:26

Link

Is more out-of-the-box stuff OK? I was thinking scalable perlin noise generator, for the surface of a planet that is a 2d circle. 3d would be... meh...

is weird stuff like that OK?

Back to top

Profile PM Email

IBOL

Retired Moderator

21

Years of Service

User Offline

Joined: 30th Mar 2004

Location: @IBOL17

Posted: 17th May 2010 03:12

Link

if you can write it in DBPro, and it approximates the idea of the challenge, then DO IT!

Back to top

Profile PM Email Website

acelepage

20

Years of Service

User Offline

Joined: 2nd Jun 2004

Location: Plattsville

Posted: 18th May 2010 20:19

Link

OK, here is an updated entry.
The code is rather iterative, so it takes a bit to render the map (haven't optimized it). Basically it starts with pools of water, and builds out from there.

global dim w(200,200)

dim lake_x(4)
dim lake_y(4)
lakes=rnd(2)+2
for i=1 to lakes
  lakeradius=int(25/lakes)
  lake_x(i)=(rnd(9)+1)*int((180-lakeradius)/10)+lakeradius
  lake_y(i)=(rnd(9)+1)*int((180-lakeradius)/10)+lakeradius
  for x=lake_x(i)-lakeradius to lake_x(i)+lakeradius
    for y=lake_y(i)-lakeradius to lake_y(i)+lakeradius
      if sqrt((lake_x(i)-x)^2+(lake_y(i)-y)^2)<lakeradius
        w(x,y)=1
      endif
    next y
  next x
next i
if lakes>1
  i=1
  diff_x=lake_x(i)-lake_x(i+1)
  diff_y=lake_y(i)-lake_y(i+1)
  if diff_x=0
    for y=lake_y(i+1) to lake_y(i) step sgn(diff_y)
      w(lake_x(i),y)=1
    next y
  endif
  if diff_y=0
    for x=lake_x(i+1) to lake_x(i) step sgn(diff_x)
      w(x,lake_y(i))=1
    next x
  endif
  if diff_x<>0 and diff_y<>0
    slope#=(diff_x*1.0)/(diff_y*1.0)
    if abs(slope#) >1
      for x=lake_x(i+1) to lake_x(i) step sgn(diff_x)
        move_x=x-lake_x(i+1)
        y=int(move_x/slope#)+lake_y(i+1)
        w(x,y)=1
        w(x,y-1)=1
        w(x,y+1)=1
      next x
    else
      for y=lake_y(i+1) to lake_y(i) step sgn(diff_y)
        move_y=y-lake_y(i+1)
        x=int(move_y*slope#)+lake_x(i+1)
        w(x,y)=1
        w(x-1,y)=1
        w(x+1,y)=1
      next y
    endif
  endif
endif
for x=1 to 200
  for y=1 to 200
    if w(x,y)=0
      found=0
      margin=30-int((abs(100-x)*abs(100-y))/500)
      for x1=x-margin to x+margin
        for y1=y-margin to y+margin
          if x1>0 and x1<=200 and y1>0 and y1<200
            if w(x1,y1)=1
              found=1
              x1=200
              y1=200
            endif
          endif
        next y1
      next x1
      if found=1
        w(x,y)=2
      else
        w(x,y)=3
      endif
    endif
  next y
next x
for x=1 to 200
  for y=1 to 200
    if w(x,y)=3
      found=0
      margin=50-int((abs(100-x)*abs(100-y))/500)
      for x1=x-margin to x+margin
        for y1=y-margin to y+margin
          if x1>0 and x1<=200 and y1>0 and y1<200
            if w(x1,y1)=2
              found=1
              x1=200
              y1=200
            endif
          endif
        next y1
      next x1
      if found=0
        w(x,y)=4
      endif
    endif
  next y
next x
for x=1 to 200
  for y=1 to 200
    if w(x,y)=4
      found=0
      margin=60-int((abs(100-x)*abs(100-y))/500)
      for x1=x-margin to x+margin
        for y1=y-margin to y+margin
          if x1>0 and x1<=200 and y1>0 and y1<200
            if w(x1,y1)=3
              found=1
              x1=200
              y1=200
            endif
          endif
        next y1
      next x1
      if found=0
        w(x,y)=5
      endif
    endif
  next y
next x
Display_World()
wait key
end

Function Display_World()
dim color(5) as dword
dim legend$(5)
color(1)=rgb(0,0,128)
color(2)=rgb(32,128,64)
color(3)=rgb(64,255,64)
color(4)=rgb(128,64,0)
color(5)=rgb(255,255,255)
legend$(1)="Water"
legend$(2)="Grassland"
legend$(3)="Forest"
legend$(4)="Mountains"
legend$(5)="Ice caps"
 set text font "arial"
 set text size 12

cls
 for x=1 to 200
  for y=1 to 200
   a=w(x,y)
   ink color(a),0
   dot x*2,y*2
   dot x*2+1,y*2
   dot x*2,y*2+1
   dot x*2+1,y*2+1
  next y
 next x
 for a=1 to 5
   ink color(a),0
   box 410,a*15+1,420,a*15+13
   ink rgb(255,255,255),0
   text 430,a*15+1,legend$(a)
 next a
Endfunction

function sgn(num)
  if num<0
    sign=-1
  else
    if num>0
      sign=1
    else
      sign=0
    endif
  endif
endfunction sign

+ Code Snippet

global dim w(200,200)

dim lake_x(4)
dim lake_y(4)
lakes=rnd(2)+2
for i=1 to lakes
  lakeradius=int(25/lakes)
  lake_x(i)=(rnd(9)+1)*int((180-lakeradius)/10)+lakeradius
  lake_y(i)=(rnd(9)+1)*int((180-lakeradius)/10)+lakeradius
  for x=lake_x(i)-lakeradius to lake_x(i)+lakeradius
    for y=lake_y(i)-lakeradius to lake_y(i)+lakeradius
      if sqrt((lake_x(i)-x)^2+(lake_y(i)-y)^2)<lakeradius
        w(x,y)=1
      endif
    next y
  next x
next i
if lakes>1
  i=1
  diff_x=lake_x(i)-lake_x(i+1)
  diff_y=lake_y(i)-lake_y(i+1)
  if diff_x=0
    for y=lake_y(i+1) to lake_y(i) step sgn(diff_y)
      w(lake_x(i),y)=1
    next y
  endif
  if diff_y=0
    for x=lake_x(i+1) to lake_x(i) step sgn(diff_x)
      w(x,lake_y(i))=1
    next x
  endif
  if diff_x<>0 and diff_y<>0
    slope#=(diff_x*1.0)/(diff_y*1.0)
    if abs(slope#) >1
      for x=lake_x(i+1) to lake_x(i) step sgn(diff_x)
        move_x=x-lake_x(i+1)
        y=int(move_x/slope#)+lake_y(i+1)
        w(x,y)=1
        w(x,y-1)=1
        w(x,y+1)=1
      next x
    else
      for y=lake_y(i+1) to lake_y(i) step sgn(diff_y)
        move_y=y-lake_y(i+1)
        x=int(move_y*slope#)+lake_x(i+1)
        w(x,y)=1
        w(x-1,y)=1
        w(x+1,y)=1
      next y
    endif
  endif
endif
for x=1 to 200
  for y=1 to 200
    if w(x,y)=0
      found=0
      margin=30-int((abs(100-x)*abs(100-y))/500)
      for x1=x-margin to x+margin
        for y1=y-margin to y+margin
          if x1>0 and x1<=200 and y1>0 and y1<200
            if w(x1,y1)=1
              found=1
              x1=200
              y1=200
            endif
          endif
        next y1
      next x1
      if found=1
        w(x,y)=2
      else
        w(x,y)=3
      endif
    endif
  next y
next x
for x=1 to 200
  for y=1 to 200
    if w(x,y)=3
      found=0
      margin=50-int((abs(100-x)*abs(100-y))/500)
      for x1=x-margin to x+margin
        for y1=y-margin to y+margin
          if x1>0 and x1<=200 and y1>0 and y1<200
            if w(x1,y1)=2
              found=1
              x1=200
              y1=200
            endif
          endif
        next y1
      next x1
      if found=0
        w(x,y)=4
      endif
    endif
  next y
next x
for x=1 to 200
  for y=1 to 200
    if w(x,y)=4
      found=0
      margin=60-int((abs(100-x)*abs(100-y))/500)
      for x1=x-margin to x+margin
        for y1=y-margin to y+margin
          if x1>0 and x1<=200 and y1>0 and y1<200
            if w(x1,y1)=3
              found=1
              x1=200
              y1=200
            endif
          endif
        next y1
      next x1
      if found=0
        w(x,y)=5
      endif
    endif
  next y
next x
Display_World()
wait key
end

Function Display_World()
dim color(5) as dword
dim legend$(5)
color(1)=rgb(0,0,128)
color(2)=rgb(32,128,64)
color(3)=rgb(64,255,64)
color(4)=rgb(128,64,0)
color(5)=rgb(255,255,255)
legend$(1)="Water"
legend$(2)="Grassland"
legend$(3)="Forest"
legend$(4)="Mountains"
legend$(5)="Ice caps"
 set text font "arial"
 set text size 12

 cls
 for x=1 to 200
  for y=1 to 200
   a=w(x,y)
   ink color(a),0
   dot x*2,y*2
   dot x*2+1,y*2
   dot x*2,y*2+1
   dot x*2+1,y*2+1
  next y
 next x
 for a=1 to 5
   ink color(a),0
   box 410,a*15+1,420,a*15+13
   ink rgb(255,255,255),0
   text 430,a*15+1,legend$(a)
 next a
Endfunction

function sgn(num)
  if num<0
    sign=-1
  else
    if num>0
      sign=1
    else
      sign=0
    endif
  endif
endfunction sign

( 2b || !2b ), that is the question. The answer: true

Back to top

Profile PM Email

IBOL

Retired Moderator

21

Years of Service

User Offline

Joined: 30th Mar 2004

Location: @IBOL17

Posted: 19th May 2010 06:25

Link

@acelpage,
yes! that's much more like what i was talking about.
i wonder if anyone else will submit?
if not, get thinking on the next challenge.

Back to top

Profile PM Email Website

owlman

16

Years of Service

User Offline

Joined: 8th Apr 2009

Location: Italy

Posted: 19th May 2010 09:05

Link

@IBOL - did my effort not count as a submission for your challenge? was it totally off ball for some reason? It uses the function you stipulated should be used in the challenge, draws random terrain-specific landmasses as is required by the challenge and .. well whatever .. it was fun to make lol ..

@acelpage - well done. nice code.

I can't wait for the next challenge ...

if effort>reward : gosub home : endif

Back to top

Profile PM Email

Mobiius

Valued Member

22

Years of Service

User Offline

Joined: 27th Feb 2003

Location: The Cold North

Posted: 19th May 2010 10:25 Edited at: 19th May 2010 10:44

Link

Quote: "did my effort not count as a submission for your challenge? "

Mine too, it generates a random colormap which can be used as a 2d terrain? If all you want is a bunch of areas of different colours then I'll reduce the colours in my height scale to make the image look poorer, but more like acelepage's entry?

*Edit*
Right, I've converted mine to generate a 5 colour colourmap to signify Deep water, shallow water, sand, grassland, and ice caps. All I did was to take my 256 colour gradient, reduce it to 5 colours, and replace the data at the end with the new data et voila!