Road drawing system, similar to SimCity

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Road drawing system, similar to SimCity

Post by angros47 »

This simple program allows to draw road tiles, in a way similar to SimCity roads: draw with your mouse (left button draws, right button erases).

The "map" is stored into RoadMatrix.

Code: Select all

screenres 800,600

dim x as integer
dim y as integer

dim b as integer

dim RoadMatrix (100,100) as ubyte

sub DrawTile (x as integer,y as integer,i as integer)

	if i and 1 then 
		'line (x*32,y*32)-(x*32+32,y*32+32),0,bf
		select case i
			case 1
			case 3,5,7
				line (x*32,y*32)-(x*32,y*32+32)
				line (x*32+32,y*32)-(x*32+32,y*32+32)
				line (x*32+16,y*32)-(x*32+16,y*32+32),,,49159
			case 11
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				circle (x*32+32,y*32+32),32,,90 / 180 * 3.14159,180 / 180 * 3.14159
			case 13
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				circle (x*32+32,y*32),32,,180 / 180 * 3.14159,270 / 180 * 3.14159
			case 15
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				line (x*32,y*32)-(x*32,y*32+32)
				line (x*32+32,y*32+1)-(x*32+32,y*32+16)
				line (x*32+16,y*32)-(x*32+16,y*32+32),,,49159
			case 19
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				circle (x*32,y*32+32),32,,0 / 180 * 3.14159,90 / 180 * 3.14159
			case 21
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				circle (x*32,y*32),32,,270 / 180 * 3.14159,360 / 180 * 3.14159
			case 23
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				line (x*32,y*32+16)-(x*32,y*32+31)
				line (x*32+32,y*32)-(x*32+32,y*32+32)
				line (x*32+16,y*32)-(x*32+16,y*32+32),,,49159
			case 25,9,17
				line (x*32,y*32)-(x*32+32,y*32)
				line (x*32,y*32+32)-(x*32+32,y*32+32)
				line (x*32,y*32+16)-(x*32+32,y*32+16),,,49159
			case 27
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				line (x*32,y*32)-(x*32+32,y*32)
				line (x*32+16,y*32+32)-(x*32+31,y*32+32)
				line (x*32,y*32+16)-(x*32+32,y*32+16),,,49159
			case 29
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				line (x*32+1,y*32)-(x*32+16,y*32)
				line (x*32,y*32+32)-(x*32+32,y*32+32)
				line (x*32,y*32+16)-(x*32+32,y*32+16),,,49159
			case 31
				line (x*32,y*32)-(x*32+32,y*32+32),0,bf
				line (x*32+1,y*32)-(x*32+16,y*32)
				line (x*32,y*32+16)-(x*32,y*32+31)
				line (x*32+16,y*32+32)-(x*32+31,y*32+32)
				line (x*32+32,y*32+1)-(x*32+32,y*32+16)
		case else
			draw string (x*32,y*32),str(i)
		end select
	end if


end sub








do
	'Bit:
	'1o=centro, 2o=nord, 3o=sud, 4o=est, 5o=ovest
	getmouse x,y,,b
	x=x/32:y=y/32


	
	if b=1 then
		RoadMatrix(x,y)=RoadMatrix(x,y) or 1
		RoadMatrix(x+1,y)=RoadMatrix(x+1,y) or 16
		RoadMatrix(x-1,y)=RoadMatrix(x-1,y) or 8
		RoadMatrix(x,y+1)=RoadMatrix(x,y+1) or 4
		RoadMatrix(x,y-1)=RoadMatrix(x,y-1) or 2

		DrawTile x,y+1,RoadMatrix(x,y+1)
		DrawTile x,y-1,RoadMatrix(x,y-1)
		DrawTile x-1,y,RoadMatrix(x-1,y)
		DrawTile x+1,y,RoadMatrix(x+1,y)

		DrawTile x,y,RoadMatrix(x,y)

	elseif b=2 then
		RoadMatrix(x,y)=RoadMatrix(x,y) and not 1
		RoadMatrix(x+1,y)=RoadMatrix(x+1,y) and not 16
		RoadMatrix(x-1,y)=RoadMatrix(x-1,y) and not 8
		RoadMatrix(x,y+1)=RoadMatrix(x,y+1) and not 4
		RoadMatrix(x,y-1)=RoadMatrix(x,y-1) and not 2

		line (x*32-31,y*32+1)-(x*32+63,y*32+31),0,bf
		line (x*32+1,y*32-31)-(x*32+31,y*32+63),0,bf

		DrawTile x,y+1,RoadMatrix(x,y+1)
		DrawTile x,y-1,RoadMatrix(x,y-1)
		DrawTile x-1,y,RoadMatrix(x-1,y)
		DrawTile x+1,y,RoadMatrix(x+1,y)

		DrawTile x,y,RoadMatrix(x,y)

	end if


loop until inkey=chr(27)
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Post by duke4e »

Nice!
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Post by D.J.Peters »

short and nice.

add a Sleep(100) command if no mouse button are pressed.

without an sleep one coure of my CPU are running with 100%

Joshy

Code: Select all

screenres 800,600

Dim x As Integer
Dim y As Integer

Dim b As Integer

Dim RoadMatrix (100,100) As Ubyte

Sub DrawTile (x As Integer,y As Integer,i As Integer)
  If i And 1 Then
    'line (x*32,y*32)-(x*32+32,y*32+32),0,bf
    Select Case as const i
      Case 1
      Case 3,5,7
        Line (x*32,y*32)-(x*32,y*32+32)
        Line (x*32+32,y*32)-(x*32+32,y*32+32)
        Line (x*32+16,y*32)-(x*32+16,y*32+32),,,49159
      Case 11
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Circle (x*32+32,y*32+32),32,,90 / 180 * 3.14159,180 / 180 * 3.14159
      Case 13
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Circle (x*32+32,y*32),32,,180 / 180 * 3.14159,270 / 180 * 3.14159
      Case 15
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Line (x*32,y*32)-(x*32,y*32+32)
        Line (x*32+32,y*32+1)-(x*32+32,y*32+16)
        Line (x*32+16,y*32)-(x*32+16,y*32+32),,,49159
      Case 19
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Circle (x*32,y*32+32),32,,0 / 180 * 3.14159,90 / 180 * 3.14159
        Case 21
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Circle (x*32,y*32),32,,270 / 180 * 3.14159,360 / 180 * 3.14159
      Case 23
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Line (x*32,y*32+16)-(x*32,y*32+31)
        Line (x*32+32,y*32)-(x*32+32,y*32+32)
        Line (x*32+16,y*32)-(x*32+16,y*32+32),,,49159
      Case 25,9,17
        Line (x*32,y*32)-(x*32+32,y*32)
        Line (x*32,y*32+32)-(x*32+32,y*32+32)
        Line (x*32,y*32+16)-(x*32+32,y*32+16),,,49159
      Case 27
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Line (x*32,y*32)-(x*32+32,y*32)
        Line (x*32+16,y*32+32)-(x*32+31,y*32+32)
        Line (x*32,y*32+16)-(x*32+32,y*32+16),,,49159
      Case 29
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Line (x*32+1,y*32)-(x*32+16,y*32)
        Line (x*32,y*32+32)-(x*32+32,y*32+32)
        Line (x*32,y*32+16)-(x*32+32,y*32+16),,,49159
      Case 31
        Line (x*32,y*32)-(x*32+32,y*32+32),0,bf
        Line (x*32+1,y*32)-(x*32+16,y*32)
        Line (x*32,y*32+16)-(x*32,y*32+31)
        Line (x*32+16,y*32+32)-(x*32+31,y*32+32)
        Line (x*32+32,y*32+1)-(x*32+32,y*32+16)
      Case Else
        Draw String (x*32,y*32),Str(i)
    End Select
  End If
End Sub

Do
  'Bit:
   '1o=centro, 2o=nord, 3o=sud, 4o=est, 5o=ovest
  if getmouse(x,y,,b)=0 then
    x=x/32:y=y/32
    If b=1 Then
      RoadMatrix(x+1,y  )=RoadMatrix(x+1,y  ) Or 16
      RoadMatrix(x-1,y  )=RoadMatrix(x-1,y  ) Or 8
      RoadMatrix(x  ,y+1)=RoadMatrix(x  ,y+1) Or 4
      RoadMatrix(x  ,y-1)=RoadMatrix(x  ,y-1) Or 2
      RoadMatrix(x  ,y  )=RoadMatrix(x  ,y  ) Or 1
      
      DrawTile x,y+1,RoadMatrix(x,y+1)
      DrawTile x,y-1,RoadMatrix(x,y-1)
      DrawTile x-1,y,RoadMatrix(x-1,y)
      DrawTile x+1,y,RoadMatrix(x+1,y)

      DrawTile x,y,RoadMatrix(x,y)

    Elseif b=2 Then
      RoadMatrix(x+1,y  )=RoadMatrix(x+1,y  ) And Not 16
      RoadMatrix(x-1,y  )=RoadMatrix(x-1,y  ) And Not 8
      RoadMatrix(x  ,y+1)=RoadMatrix(x  ,y+1) And Not 4
      RoadMatrix(x  ,y-1)=RoadMatrix(x  ,y-1) And Not 2
      RoadMatrix(x  ,y  )=RoadMatrix(x  ,y  ) And Not 1
      Line (x*32-31,y*32+1)-(x*32+63,y*32+31),0,bf
      Line (x*32+1,y*32-31)-(x*32+31,y*32+63),0,bf
      DrawTile x,y+1,RoadMatrix(x,y+1)
      DrawTile x,y-1,RoadMatrix(x,y-1)
      DrawTile x-1,y,RoadMatrix(x-1,y)
      DrawTile x+1,y,RoadMatrix(x+1,y)
      DrawTile x,y,RoadMatrix(x,y)
    else
      sleep(100)
    End If
  else
   sleep(100)
  end if
Loop Until Inkey=Chr(27)
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Road drawing system, similar to SimCity

Post by BasicCoder2 »

angros47 wrote:This simple program allows to draw road tiles, in a way similar to SimCity roads: draw with your mouse (left button draws, right button erases).

The "map" is stored into RoadMatrix.
I changed,

screenres 800,600

to,

screenres 800,640,32


Also I found the pointer was in the wrong position and changed the lines,

x=x/32:y=y/32

to an integer divide,

x=x\32:y=y\32

followed by this to provide a grid guide,

for j as integer = 0 to 19
for i as integer = 0 to 24
line(i*32+1,j*32+1)-(i*32+30,j*32+30),rgb(64,64,64),b
next i
next j

John
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

Interesting.

Does have some bugs though:

Mostly it's to do with the fact that a road can be adjacent to, but not connect with, another road... and you don't account for that.
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Post by angros47 »

Mostly it's to do with the fact that a road can be adjacent to, but not connect with, another road... and you don't account for that.
That's true.... :-( But SimCity, too, had the same bug!
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

But besides that you have some sort of weird line flashing bug when a road is next to others like this:

oo
xo
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Post by BasicCoder2 »

This is my version which I find easier to use ...

Code: Select all


'select button to draw, menu button to erase

screenres 640,480,32

dim shared as integer mx,my,mb,px,py,dx,dy,ox,oy

dim shared as integer matrix(25,15)

sub displayMatrix()
    'draw grid
    for j as integer = 0 to 14
        for i as integer = 0 to 19
            line(i*32,j*32)-(i*32+30,j*32+30),rgb(64,64,64),b
        next i
    next j
    'display matrix
    for j as integer = 0 to 14
        for i as integer = 0 to 19
            '  clear old image
            line (i*32+1,j*32+1)-(i*32+31,j*32+31),rgb(0,0,0),bf
            'generate new image from value in matrix
SELECT CASE AS CONST matrix(i,j)
    case 1
        line (i*32,j*32+5)-(i*32+31,j*32+5)
        line (i*32,j*32+15)-(i*32+31,j*32+15),rgb(255,0,0),,&H00FF00FF
        line (i*32,j*32+25)-(i*32+31,j*32+25)
    case 2
        line (i*32+5,j*32)-(i*32+5,j*32+31)
        line (i*32+15,j*32)-(i*32+15,j*32+31),rgb(255,0,0),,&H00FF00FF
        line (i*32+25,j*32)-(i*32+25,j*32+31)
    case 3
        Circle (i*32,j*32+31),5,,0 / 180 * 3.14159,90 / 180 * 3.14159
        circle (i*32,j*32+31),15,rgb(255,0,0),0 / 180 * 3.14159,90 / 180 * 3.14159
        Circle (i*32,j*32+31),25,,0 / 180 * 3.14159,90 / 180 * 3.14159
    case 4
        line (i*32,j*32+5)-(i*32+31,j*32+5)
        line (i*32,j*32+15)-(i*32+31,j*32+15),rgb(255,0,0),,&H00FF00FF
        line (i*32,j*32+25)-(i*32+31,j*32+25)
    case 5
        line (i*32,j*32+5)-(i*32+31,j*32+5)
        line (i*32,j*32+15)-(i*32+31,j*32+15),rgb(255,0,0),,&H00FF00FF
        line (i*32,j*32+25)-(i*32+31,j*32+25)
    case 6
        Circle (i*32+31,j*32+31),5,,90 / 180 * 3.14159,180 / 180 * 3.14159
        circle (i*32+31,j*32+31),15,rgb(255,0,0),90 / 180 * 3.14159,180 / 180 * 3.14159
        Circle (i*32+31,j*32+31),25,,90 / 180 * 3.14159,180 / 180 * 3.14159
    case 7
        line (i*32,j*32+5)-(i*32+31,j*32+5)
        line (i*32,j*32+25)-(i*32+5,j*32+25)
        line (i*32+5,j*32+25)-(i*32+5,j*32+31)
        line (i*32+25,j*32+25)-(i*32+31,j*32+25)
        line (i*32+25,j*32+25)-(i*32+25,j*32+31)
    case 8
        line (i*32+5,j*32)-(i*32+5,j*32+31)
        line (i*32+15,j*32)-(i*32+15,j*32+31),rgb(255,0,0),,&H00FF00FF
        line (i*32+25,j*32)-(i*32+25,j*32+31)

    case 9
        Circle (i*32,j*32),5,,270 / 180 * 3.14159,360 / 180 * 3.14159
        circle (i*32,j*32),15,rgb(255,0,0),270 / 180 * 3.14159,360 / 180 * 3.14159
        Circle (i*32,j*32),25,,270 / 180 * 3.14159,360 / 180 * 3.14159
    case 11
        line (i*32+25,j*32)-(i*32+25,j*32+31)
        line (i*32+5,j*32)-(i*32+5,j*32+5)
        line (i*32+5,j*32+5)-(i*32,j*32+5)
        line (i*32+5,j*32+25)-(i*32,j*32+25)
        line (i*32+5,j*32+25)-(i*32+5,j*32+31)
    case 10
        line (i*32+5,j*32)-(i*32+5,j*32+31)
        line (i*32+15,j*32)-(i*32+15,j*32+31),rgb(255,0,0),,&H00FF00FF
        line (i*32+25,j*32)-(i*32+25,j*32+31)        
    case 12
        Circle (i*32+31,j*32),5,,180 / 180 * 3.14159,270 / 180 * 3.14159
        circle (i*32+31,j*32),15,rgb(255,0,0),180 / 180 * 3.14159,270 / 180 * 3.14159
        Circle (i*32+31,j*32),25,,180 / 180 * 3.14159,270 / 180 * 3.14159
    case 13
        line (i*32,j*32+25)-(i*32+31,j*32+25)
        line (i*32,j*32+5)-(i*32+5,j*32+5)
        line (i*32+5,j*32+5)-(i*32+5,j*32)
        line (i*32+25,j*32)-(i*32+25,j*32+5)
        line (i*32+25,j*32+5)-(i*32+31,j*32+5)
    case 14
        line (i*32+5, j*32)-(i*32+5,j*32+31)
        line (i*32+25,j*32)-(i*32+25,j*32+5)
        line (i*32+25,j*32+5) -(i*32+31,j*32+5)
        line (i*32+25,j*32+25)-(i*32+31,j*32+25)
        line (i*32+25,j*32+25)-(i*32+25,j*32+31)
    case 15
        line (i*32+5,j*32)-(i*32+5,j*32+5)
        line (i*32,j*32+5)-(i*32+5,j*32+5)
    
        line (i*32+25,j*32)-(i*32+25,j*32+5)
        line (i*32+25,j*32+5)-(i*32+31,j*32+5)
    
        line (i*32,j*32+25)-(i*32+5,j*32+25)
        line (i*32+5,j*32+25)-(i*32+5,j*32+31)
    
        line (i*32+25,j*32+25)-(i*32+31,j*32+25)
        line (i*32+25,j*32+25)-(i*32+25,j*32+31)
    END SELECT       
next i
next j

end sub

displayMatrix()

do
    displayMatrix()
    'wait for keypress
    getmouse mx,my,,mb
    while mb = 0
        getmouse mx,my,,mb
    wend

    ox = mx/32    'get start
    oy = my/32

    if mb = 2 then
        matrix(mx\32,my\32) = 0
        matrix(mx\32,my\32-1)=matrix(mx\32,my\32-1) and 13
        matrix(mx\32+1,my\32)=matrix(mx\32+1,my\32) and 14
        matrix(mx\32-1,my\32)=matrix(mx\32-1,my\32) and 11
        matrix(mx\32,my\32+1)=matrix(mx\32,my\32+1) and  7
        displayMatrix()
    else

        while mb = 1
            getmouse mx,my,,mb
            if ox<>mx\32 or oy<>my\32 then
                'mouse has moved
                px = mx\32
                py = my\32
                
                dx = px - ox
                dy = py - oy
    
                if dx=1 then
                    matrix(ox,oy)=matrix(ox,oy) or 4
                    matrix(px,py)=matrix(px,py) or 1
                end if
                if dx= -1 then
                    matrix(ox,oy)=matrix(ox,oy) or 1
                    matrix(px,py)=matrix(px,py) or 4
                end if
                if dy=1 then
                    matrix(ox,oy)=matrix(ox,oy) or 2
                    matrix(px,py)=matrix(px,py) or 8
                end if
                if dy= -1 then
                    matrix(ox,oy)=matrix(ox,oy) or 8
                    matrix(px,py)=matrix(px,py) or 2
                end if
    
                ox = px
                oy = py
                
                displayMatrix()

            end if
        wend
        
    end if

loop until multikey(&H01)


sleep
end

Post Reply