Creating a random Country map

BlitzMax Forums/BlitzMax Programming/Creating a random Country map

TomToad (Posted 2010) [#1]

I am trying to think of the best way to create a random map of countries. Sort of like the map on Risk, but I want the countries to be different every game. Anybody have an idea on how to go about it?

TomToad (Posted 2010) [#2]

Hmm, a Voronoi diagram might work. http://en.wikipedia.org/wiki/Voronoi_diagram SuperStrict Graphics 800,600 Type TPoint Field x:Float Field y:Float Field red:Int Field green:Int Field blue:Int End Type Local List:TList = CreateList() For Local i:Int = 0 To 30 Local point:TPoint = New TPoint Point.x = Rand(100,700) Point.y = Rand(100,500) Point.Red = Rand(0,3)*(255.0/3.0) Point.Green = Rand(0,3)*(255.0/3.0) Point.Blue = Rand(0,3)*(255.0/3.0) List.AddLast(Point) Next Local Distance:Float = 1000.0 Local ClosestPoint:TPoint For Local x:Int = 0 To 799 For Local y:Int = 0 To 599 For Local Point:TPoint = EachIn List Local DX:Float = Point.x - x Local DY:Float = Point.y - y Local D:Float = Sqr(DX*DX+DY*DY) If D < Distance Distance = D ClosestPoint = Point End If Next SetColor ClosestPoint.Red,ClosestPoint.Green,ClosestPoint.Blue Plot x,y Distance = 1000.0 Next Next Flip WaitKey Just need to get rid of the cells near the edges and randomize the borders a bit.

TomToad (Posted 2010) [#3]

Experimenting some more, this code will randomize the borders a bit. Just need to fill the edge cells with water and speed things up a bit and this should work nicely. SuperStrict SeedRnd MilliSecs() Graphics 800,480 Type TPoint Field x:Float Field y:Float Field red:Int Field green:Int Field blue:Int End Type Global List:TList = CreateList() For Local i:Int = 0 To 30 Local point:TPoint = New TPoint Point.x = Rand(0,799) Point.y = Rand(0,479) Point.Red = Rand(0,3)*(255.0/3.0) Point.Green = Rand(0,3)*(255.0/3.0) Point.Blue = Rand(0,3)*(255.0/3.0) List.AddLast(Point) Next For Local i:Int = 1 To 4 Deeper() Next Local Distance:Float = 1000.0 Local ClosestPoint:TPoint For Local x:Int = 0 To 799 DebugLog x For Local y:Int = 0 To 479 For Local Point:TPoint = EachIn List Local DX:Float = Point.x - x Local DY:Float = Point.y - y Local D:Float = Sqr(DX*DX+DY*DY) If D < Distance Distance = D ClosestPoint = Point End If Next SetColor ClosestPoint.Red,ClosestPoint.Green,ClosestPoint.Blue Plot x,y Distance = 1000.0 Next Next Flip WaitKey Function Deeper() For Local i:Int = 0 To 30 Local NewPoint:TPoint = New TPoint NewPoint.x = Rand(100,700) NewPoint.y = Rand(100,380) Local Distance:Float = 1000 Local Closest:TPoint For Local Point:TPoint = EachIn List Local DX:Float = Point.x - NewPoint.x Local DY:Float = Point.y = NewPoint.y Local D:Float = Sqr(DX*DX+DY*DY) If D < Distance Distance = D Closest = Point End If Next NewPoint.Red = Closest.Red NewPoint.Green = Closest.Green NewPoint.Blue = Closest.Blue List.AddLast(NewPoint) Next End Function

TomToad (Posted 2010) [#4]

Ok, my latest version. Looks pretty good, but I need to figure out what to do about the pointy peninsulas that are created and also still need to make things faster. Otherwise it looks nice. Makes little continents and islands. SuperStrict SeedRnd MilliSecs() Graphics 800,480 Type TPoint Field x:Float Field y:Float Field red:Int Field green:Int Field blue:Int End Type Global List:TList = CreateList() For Local i:Int = 0 To 30 Local point:TPoint = New TPoint Point.x = Rand(0,799) Point.y = Rand(0,479) Point.Red = Rand(0,3)*(255.0/3.0) Point.Green = Rand(0,3)*(255.0/3.0) Point.Blue = Rand(0,3)*(255.0/3.0) List.AddLast(Point) Next For Local i:Int = 1 To 4 Deeper() Next Local Distance:Float = 1000.0 Local ClosestPoint:TPoint For Local x:Int = 0 To 799 DebugLog x For Local y:Int = 0 To 479 For Local Point:TPoint = EachIn List Local DX:Float = Point.x - x Local DY:Float = Point.y - y Local D:Float = Sqr(DX*DX+DY*DY) If D < Distance Distance = D ClosestPoint = Point End If Next SetColor ClosestPoint.Red,ClosestPoint.Green,ClosestPoint.Blue Plot x,y Distance = 1000.0 Next Next Local Image:TImage = CreateImage(800,480) GrabImage(Image,0,0) Local Pixmap:TPixmap = LockImage(Image) For Local x:Int = 0 To 799 DebugLog "Filling x = "+x Floodfill(Pixmap,x,0) floodfill(Pixmap,x,479) Next For Local y:Int = 0 To 479 DebugLog "Filling y = "+y Floodfill(Pixmap,0,y) Floodfill(Pixmap,799,y) Next UnlockImage(Image) DrawImage Image,0,0 Flip WaitKey Function Deeper() For Local i:Int = 0 To 30 Local NewPoint:TPoint = New TPoint NewPoint.x = Rand(100,700) NewPoint.y = Rand(100,380) Local Distance:Float = 1000 Local Closest:TPoint For Local Point:TPoint = EachIn List Local DX:Float = Point.x - NewPoint.x Local DY:Float = Point.y = NewPoint.y Local D:Float = Sqr(DX*DX+DY*DY) If D < Distance Distance = D Closest = Point End If Next NewPoint.Red = Closest.Red NewPoint.Green = Closest.Green NewPoint.Blue = Closest.Blue List.AddLast(NewPoint) Next End Function Function FloodFill(Pixmap:TPixmap,x:Int,y:Int) Local FillColor:Int = ReadPixel(Pixmap,x,y) & $FFFFFF If FillColor = $FF Then Return Local FillList:TList = CreateList() Local Point:TPoint = New TPoint FillList.AddLast(Point) Point.x = x point.y = y While FillList.Count() Point = TPoint(FillList.RemoveFirst()) Local TestX:Int Local TestY:Int For Local Direction:Int = 0 To 3 Select Direction Case 0 TestX = Point.X TestY = Point.y - 1 Case 1 TestX = Point.X + 1 TestY = Point.Y Case 2 TestX = Point.x TestY = Point.Y+1 Case 3 TestX = Point.x - 1 TestY = Point.y End Select If TestX > 799 Or TestX < 0 Or TestY > 479 Or TestY < 0 Then Continue Local Color:Int = ReadPixel(Pixmap,TestX,TestY) & $FFFFFF If Color = $FF Or Color <> FillColor Then Continue WritePixel(Pixmap,TestX,TestY,$FF0000FF) Local NewPoint:TPoint = New TPoint NewPoint.X = TestX NewPoint.y = TestY FillList.AddLast(NewPoint) Next Wend End Function

xlsior (Posted 2010) [#5]

Perhaps you can use the same principle as used by the 'game of life' algorithm -- those tend to cluster together, with some islands here and there. Possibly run several iterations and blend them together, to enable you to subdivide landmasses into multiple countries dynamically as well.

TomToad (Posted 2010) [#6]

@xlsior. Thought I'd give your idea a try. After some tweeking, came up with some interesting landmasses. Now to figure out how to subdivide into countries. edit: Pressing space will iterate the creation phase again. Escape will end the program. SuperStrict SeedRnd MilliSecs() Graphics 800,480 Const DotOdds:Int = 50 Const NeighborsBorn:Int = 6 Const NeighborsDie:Int = 2 Const LandWidth:Int = 20 Const LandHeight:Int = 12 Local Pixmap:TPixmap = CreatePixmap(LandWidth,LandHeight,PF_RGBA8888) For Local x:Int = 0 Until LandWidth DebugLog "Filling. X = "+x For Local y:Int = 0 Until LandHeight If Rand(0,100) > DotOdds Then WritePixel(Pixmap,x,y,$FFFFFFFF) Next Next Local Key:Int While Key <> KEY_ESCAPE Local TempPixmap:TPixmap = CopyPixmap(Pixmap) For Local x:Int = 0 Until LandWidth DebugLog "Creating. x = "+x For Local y:Int = 0 Until LandHeight Local Neighbors:Int = CountNeighbors(TempPixmap,x,y) If Neighbors >= NeighborsBorn Then WritePixel(Pixmap,x,y,$FFFFFFFF) If Neighbors <= NeighborsDie Then WritePixel(Pixmap,x,y,$FF000000) Next Next Local Image:TImage = LoadImage(Pixmap,0) Cls SetScale 800.0/LandWidth,480/LandHeight DrawImage Image,0,0 Flip Key = WaitKey() Wend Function CountNeighbors:Int(Pixmap:TPixmap,x:Int,y:Int) Local Count:Int = 0 Local DX:Int Local DY:Int For Local direction:Int = 0 To 7 Select Direction Case 0 If y = 0 Then Continue DX = X DY = Y-1 Case 1 If y = 0 Or x = Pixmap.Width-1 Then Continue DX = x + 1 DY = Y - 1 Case 2 If x = Pixmap.Width-1 Then Continue DX = X+1 DY = y Case 3 If x = Pixmap.Width-1 Or y = Pixmap.Height - 1 Then Continue DX = x+1 DY = Y+1 Case 4 If y = Pixmap.Height - 1 Then Continue DX = x DY = y + 1 Case 5 If y = Pixmap.Height - 1 Or x = 0 Then Continue DX = x - 1 DY = y + 1 Case 6 If X = 0 Then Continue DX = x - 1 DY = y Case 7 If x = 0 Or y = 0 Then Continue DX = x - 1 DY = y - 1 End Select If ReadPixel(Pixmap,DX,DY) & $FFFFFF > 0 Then Count :+ 1 Next Return Count End Function

slenkar (Posted 2010) [#7]

the previous one produces an interesting map, the latest one just produces blank and white squares