Road drawing system, similar to SimCity

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

Road drawing system, similar to SimCity

Postby angros47 » Apr 29, 2010 20:06

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:

Postby duke4e » Apr 29, 2010 21:07

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

Postby D.J.Peters » Apr 30, 2010 5:04

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: 3571
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Road drawing system, similar to SimCity

Postby BasicCoder2 » Apr 30, 2010 23:59

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

Postby agamemnus » May 01, 2010 18:14

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: 1670
Joined: Jun 21, 2005 19:04

Postby angros47 » May 01, 2010 18:48

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

Postby agamemnus » May 02, 2010 3:04

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: 3571
Joined: Jan 01, 2009 7:03
Location: Australia

Postby BasicCoder2 » May 02, 2010 3:21

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


Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 0 guests