4
\$\begingroup\$

I am trying to programm the Abelian sandpile model in VisualBasic. Also, here is a youtube video made by Numberphile about the very same topic.

Here is a picture (\$2^{20}\$ grains of sand) I made with my programm:

1048576 grains of and dropped.

The current version workes fine - for now.

However, with large amounts of sand the calculation takes a very long time, and I wonder: Is there a possibility of speeding the code up?

To be fair, I am mostly self-taught in VB, so my code is likely to be ugly.

I'd be happy if you could take a look at my code and tell me, where I can make improvements. Thanks!

Variables - Deklaration

Dim WDTH As Integer = 1000
Dim HGHT As Integer = 1000
Dim Array1(WDTH, HGHT) As Integer
Dim Done As Boolean
Dim Temp1 As Integer = 0
Dim Temp2 As Integer = 0

Calculation

The first thing I do is resetting the array to 0.

For y As Integer = 0 To HGHT
    For x As Integer = 0 To WDTH
        Array1(x, y) = 0
    Next
Next

The sand is placed on the grid:

Array1(500, 500) = 2 ^ 20

Then the calculation happens:

    Done = False
    Do
        Done = True
        For y As Integer = 0 To HGHT
            For x As Integer = 0 To WDTH
                If Array1(x, y) >= 4 Then
                    Done = False
                    Temp1 = Array1(x, y) Mod 4
                    Temp2 = (Array1(x, y) - Temp1) / 4
                    Array1(x, y) = Temp1
                    Array1(x + 1, y) += Temp2
                    Array1(x - 1, y) += Temp2
                    Array1(x, y + 1) += Temp2
                    Array1(x, y - 1) += Temp2
                End If
            Next
        Next
    Loop Until Done = True

This describes the toppling of the sand. I go through the entire array, check if a sandpile needs to topple, I do that if needed, and go on. Once I have run through the entire array and nothing has happend, I know I am done.

However, this is very time consuming as I am checking a lot of cells that don't even have sand on them, and going through an 1000x1000 array 95175 times (this is the time it takes to topple \$2^{20}\$ sand grains) takes a lot of time.

This is actually already an improved version, I tried a recursive one too, but that didn't work.

So, the complete code is:

Dim WDTH As Integer = 1000
Dim HGHT As Integer = 1000
Dim Array1(WDTH, HGHT) As Integer
Dim Done As Boolean
Dim Temp1 As Integer = 0
Dim Temp2 As Integer = 0
Dim BGW As New System.ComponentModel.BackgroundWorker

Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
    If Not BGW.IsBusy Then            
        BGW.RunWorkerAsync()
        Button1.Enabled = False
    End If
End Sub

Private Sub BGW_DoWork(ByVal sender As Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles BGW.DoWork
    For y As Integer = 0 To HGHT
        For x As Integer = 0 To WDTH
            Array1(x, y) = 0
        Next
    Next

    Array1(CInt(WDTH / 2), CInt(HGHTY / 2)) = 2 ^ 20

    Done = False
    Dim Iterationen As Integer = 0

    Do
        Done = True
        Iterationen += 1
        For y As Integer = 0 To HGHT
            For x As Integer = 0 To WDTH
                If Array1(x, y) >= 4 Then
                    Done = False
                    Temp1 = Array1(x, y) Mod 4
                    Temp2 = (Array1(x, y) - Temp1) / 4
                    Array1(x, y) = Temp1
                    Array1(x + 1, y) += Temp2
                    Array1(x - 1, y) += Temp2
                    Array1(x, y + 1) += Temp2
                    Array1(x, y - 1) += Temp2
                End If
            Next
        Next

        If BGW.CancellationPending Then
            e.Cancel = True
            Exit Sub
        End If

    Loop Until Done = True


    Dim BMP As New Bitmap(WDTH, HGHT)

    For y As Integer = 0 To HGHT - 1
        For x As Integer = 0 To WDTH - 1
            Select Case Array1(x, y)
                Case 0 : BMP.SetPixel(x, y, Color.White)
                Case 1 : BMP.SetPixel(x, y, Color.Green)
                Case 2 : BMP.SetPixel(x, y, Color.Red)
                Case 3 : BMP.SetPixel(x, y, Color.Blue)
            End Select
        Next
    Next

    PictureBox1.BackgroundImage = BMP

    Beep()
End Sub

Private Sub BGW_RunWorkerCompleted(ByVal sender As Object, ByVal e As System.ComponentModel.RunWorkerCompletedEventArgs) Handles BGW.RunWorkerCompleted
    Button1.Enabled = True
End Sub

Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
    PictureBox1.Width = WDTH
    PictureBox1.Height = HGHT
End Sub

I tried reducing this as much as possible. The GUI contains a button named "Button1" and a picture box named "PictureBox1".


This section contains a failed try. Please ignore it.

If you like to know, here is the recursive one:

Calling the recursive function

ToppleSand(500, 500)

The function itself

 Private Sub ToppleSand(ByVal x As Integer, ByVal y As Integer)
    If Array1(x, y) >= 4 Then
        Temp1 = Array1(x, y)
        Array1(x, y) = Temp1 Mod 4
        Temp1 = (Temp1 - (Temp1 Mod 4)) / 4
        Array1(x + 1, y) += Temp1
        Array1(x - 1, y) += Temp1
        Array1(x, y + 1) += Temp1
        Array1(x, y - 1) += Temp1
        ToppleSand(x + 1, y)
        ToppleSand(x - 1, y)
        ToppleSand(x, y + 1)
        ToppleSand(x, y - 1)
    End If
End Sub

This got me a stackoverflow exeption, so I discarded this try.

\$\endgroup\$
3
  • \$\begingroup\$ "Can you show the whole method you are using ?" - So, you mean the entire programm? With graphics and GUI and everything? \$\endgroup\$
    – G. Ünther
    Commented Jun 20, 2017 at 11:37
  • \$\begingroup\$ Don't be confused by the ´ToppleSand()´ method. That was a failed try. I'll edit it to make it more clear. \$\endgroup\$
    – G. Ünther
    Commented Jun 20, 2017 at 11:46
  • 1
    \$\begingroup\$ Will review it tomorrow if no one reviewed it. \$\endgroup\$
    – Heslacher
    Commented Jun 20, 2017 at 12:21

1 Answer 1

2
\$\begingroup\$

Option Strict

Not setting Option Strict to On can lead to problems because it enables you to code without strictly typing. See: https://docs.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/option-strict-statement

It can e.g lead to loss in precision or to a runtime exception.


Naming and scope of variables

Dim Array1(WDTH, HGHT) As Integer
Dim Done As Boolean
Dim Temp1 As Integer = 0
Dim Temp2 As Integer = 0

These variables should be declared inside the BGW_DoWork() method. As a rule of thumb, one should declare variables as near to their usage as possible and should be scoped as thightly as possible.

While we are at the variables let's talk about naming.
Neither methods, nor parameters, variables, fields should be named using abbreviations. It makes your code harder to read if you first need to figure out in your head what e.g HGHT means. Writing code should be done in a way that enables the reader to grasp at first glance what the code is doing.

Based on the .NET Naming Guidelines variables/fields should be named using camelCase casing. Although VB isn't case sensitive you will do yourself a favour if you stick to the naming guidelines for each language you learn.

If a variable isn't meant to be changed by code you should make it a const, e.g your WDTH and HGHT.


Performance

  • By declaring Array1 inside BGW_DoWork() you won't need to set the array items to 0.

  • Instead of SetPixel() you could use Bitmap.LockBits() like shown here but this will only save 1 second for a 1000x1000 bitmap.

  • The calculation of the values when Array1(x, y) >= 4 can be simplified by using integer division like so

    Done = False
    Temp2 = Array1(x, y) \ 4
    Array1(x, y) = Array1(x, y) Mod 4
    Array1(x + 1, y) += Temp2
    Array1(x - 1, y) += Temp2
    Array1(x, y + 1) += Temp2
    Array1(x, y - 1) += Temp2
    

    This saves around 20% of execution time which results in 984 seconds for 1000x1000.

  • By using a 1d array the performace can be improved some more. Please note that the created image by the provided code looks good for 1000x1000 but not for a 100x100 (couldn't sort it out, will be glad if someone can point the problem).

    Private Function StabilizeGrains(piles() As Integer, gridWidth As Integer, gridHeight As Integer) As Boolean
    
        Dim allPilesAreStable As Boolean = True
        Dim width As Integer = 0
        For y As Integer = 0 To gridHeight - 1
            For x As Integer = 0 To gridWidth - 1
    
                Dim index As Integer = x + width
                Dim currentvalue As Integer = piles(index)
    
                If currentvalue > 3 Then
    
                    allPilesAreStable = False
                    Dim quarter As Integer = currentvalue \ 4
    
                    piles(index) = currentvalue Mod 4
                    If (x < gridWidth) Then
                        piles(index + 1) += quarter
                    End If
                    If (x > 0) Then
                        piles(index - 1) += quarter
                    End If
                    If (y < gridHeight - 1) Then
                        piles(index + gridWidth) += quarter
                    End If
                    If (y > 0) Then
                        piles(index - gridWidth) += quarter
                    End If
    
                End If
    
            Next
            width += WDTH
        Next
        Return allPilesAreStable
    End Function 
    

    This method is called in the BGW_DoWork() method which looks like so

    Private Sub BGW_DoWork(ByVal sender As Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles BGW.DoWork
    
        Dim piles(WDTH * HGHT) As Integer
    
        Dim sandPlacingIndex As Integer = (WDTH * HGHT + WDTH) \ 2
    
        piles(sandPlacingIndex) = CInt(2 ^ 20)
    
        Dim Iterationen As Integer = 0
    
        Do
            Iterationen += 1
    
            If BGW.CancellationPending Then
                e.Cancel = True
                Exit Sub
            End If
    
        Loop Until StabilizeGrains(piles, WDTH, HGHT)
    
        PictureBox1.BackgroundImage = CreateBitmap(piles, WDTH, HGHT)
    
    End Sub
    

    The creation of the resulting image is extracted to its own method like so

    Private Function CreateBitmap(piles() As Integer, gridWidth As Integer, gridHeight As Integer) As Bitmap
        Dim bmp As New Bitmap(WDTH, HGHT)
    
        Dim width As Integer = 0
        For y As Integer = 0 To gridHeight - 1
    
            For x As Integer = 0 To gridWidth - 1
                Select Case piles(x + width)
                    Case 0 : bmp.SetPixel(x, y, Color.White)
                    Case 1 : bmp.SetPixel(x, y, Color.Green)
                    Case 2 : bmp.SetPixel(x, y, Color.Red)
                    Case 3 : bmp.SetPixel(x, y, Color.Blue)
                End Select
            Next
            width += gridWidth
        Next
        Return bmp
    End Function
    

    These changes will lead to a processing time of 229 seconds.

    Please note that measureing the times where done using poor man benchmarking aka StopWatch. So don't take them granted


Small Bug

If e.g WDTH = 100 and HGHT = 100 your code will throw an IndexOutOfRangeException. If you want to prevent this you should add some if statements to check the values of x and y. This doesn't seem to be a problem with WDTH = 1000 and HGHT = 1000.

\$\endgroup\$
8
  • 2
    \$\begingroup\$ According to the pattern the variable name Done is wrong, it should be Dn :-) \$\endgroup\$
    – t3chb0t
    Commented Jun 21, 2017 at 16:00
  • \$\begingroup\$ This might be the reason why the picture doesn't look good if the array is 100x100. You wrote: Dim sandPlacingIndex As Integer = (WDTH * HGHT + WDTH) \ 2 but this doesn't quite center the sand pile. I guess this should be Dim sandPlacingIndex As Integer = (WDTH * HGHT) \ 2. Another idea: By letting the x and y range not from 0 but from 1 up to gridHeight - 1 or gridWidth - 1, this should remove the out of range exeption and does not requiere the additional If-statements. Those were some ideas I had. But now I want to thank you for your very detailed answer! :D \$\endgroup\$
    – G. Ünther
    Commented Jun 22, 2017 at 11:21
  • \$\begingroup\$ Brain failed. The correct formula should beDim sandPlacingIndex As Integer = WDTH * (HGHT \ 2) + WDTH \ 2 \$\endgroup\$
    – G. Ünther
    Commented Jun 22, 2017 at 11:56
  • \$\begingroup\$ Thats exactly the same as I have written :-( \$\endgroup\$
    – Heslacher
    Commented Jun 22, 2017 at 12:00
  • \$\begingroup\$ Weird. Hmmm... Do you mean by "doesn't look good" the fact that the picture is quite different from a cropped version of the 1000x1000 picture? If so: This normal and expected for an array too small. \$\endgroup\$
    – G. Ünther
    Commented Jun 22, 2017 at 12:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.