Task: Forest fire








VB: Public Class ForestFire
    Private _forest(,) As ForestState
    Private _isBuilding As Boolean
    Private _bm As Bitmap
    Private _gen As Integer
    Private _sw As Stopwatch

    Private Const _treeStart As Double = 0.5
    Private Const _f As Double = 0.00001
    Private Const _p As Double = 0.001

    Private Const _winWidth As Integer = 300
    Private Const _winHeight As Integer = 300

    Private Enum ForestState
        Empty
        Burning
        Tree
    End Enum

    Private Sub ForestFire_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.ClientSize = New Size(_winWidth, _winHeight)
        ReDim _forest(_winWidth, _winHeight)

        Dim rnd As New Random()
        For i As Integer = 0 To _winHeight - 1
            For j As Integer = 0 To _winWidth - 1
                _forest(j, i) = IIf(rnd.NextDouble <= _treeStart, ForestState.Tree, ForestState.Empty)
            Next
        Next

        _sw = New Stopwatch
        _sw.Start()
        DrawForest()
        Timer1.Start()
    End Sub

    Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        If _isBuilding Then Exit Sub

        _isBuilding = True
        GetNextGeneration()

        DrawForest()
        _isBuilding = False
    End Sub

    Private Sub GetNextGeneration()
        Dim forestCache(_winWidth, _winHeight) As ForestState
        Dim rnd As New Random()

        For i As Integer = 0 To _winHeight - 1
            For j As Integer = 0 To _winWidth - 1
                Select Case _forest(j, i)
                    Case ForestState.Tree
                        If forestCache(j, i) <> ForestState.Burning Then
                            forestCache(j, i) = IIf(rnd.NextDouble <= _f, ForestState.Burning, ForestState.Tree)
                        End If

                    Case ForestState.Burning
                        For i2 As Integer = i - 1 To i + 1
                            If i2 = -1 OrElse i2 >= _winHeight Then Continue For
                            For j2 As Integer = j - 1 To j + 1
                                If j2 = -1 OrElse i2 >= _winWidth Then Continue For
                                If _forest(j2, i2) = ForestState.Tree Then forestCache(j2, i2) = ForestState.Burning
                            Next
                        Next
                        forestCache(j, i) = ForestState.Empty

                    Case Else
                        forestCache(j, i) = IIf(rnd.NextDouble <= _p, ForestState.Tree, ForestState.Empty)
                End Select
            Next
        Next

        _forest = forestCache
        _gen += 1
    End Sub

    Private Sub DrawForest()
        Dim bmCache As New Bitmap(_winWidth, _winHeight)

        For i As Integer = 0 To _winHeight - 1
            For j As Integer = 0 To _winWidth - 1
                Select Case _forest(j, i)
                    Case ForestState.Tree
                        bmCache.SetPixel(j, i, Color.Green)

                    Case ForestState.Burning
                        bmCache.SetPixel(j, i, Color.Red)
                End Select
            Next
        Next

        _bm = bmCache
        Me.Refresh()
    End Sub

    Private Sub ForestFire_Paint(ByVal sender As System.Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles MyBase.Paint
        e.Graphics.DrawImage(_bm, 0, 0)

        Me.Text = "Gen " & _gen.ToString() & " @ " & (_gen / (_sw.ElapsedMilliseconds / 1000)).ToString("F02") & " FPS: Forest Fire"
    End Sub
End Class



Fortran: module ForestFireModel
  implicit none

  type :: forestfire
     integer, dimension(:,:,:), allocatable :: field
     integer :: width, height
     integer :: swapu
     real :: prob_tree, prob_f, prob_p
  end type forestfire

  integer, parameter :: &
       empty = 0, &
       tree = 1, &
       burning = 2

  private :: bcheck, set, oget, burning_neighbor 

contains

  
  function forestfire_new(w, h, pt, pf, pp) result(res)
    type(forestfire) :: res
    integer, intent(in) :: w, h
    real, intent(in), optional :: pt, pf, pp

    integer :: i, j
    real :: r

    allocate(res%field(2,w,h)) 
    res%prob_tree = 0.5
    res%prob_f = 0.00001
    res%prob_p = 0.001
    if ( present(pt) ) res%prob_tree = pt
    if ( present(pf) ) res%prob_f = pf
    if ( present(pp) ) res%prob_p = pp

    res%width = w
    res%height = h
    res%swapu = 0

    res%field = empty

    do i = 1,w
       do j = 1,h
          call random_number(r)
          if ( r <= res%prob_tree ) call cset(res, i, j, tree)
       end do
    end do
    
  end function forestfire_new
  
  
  subroutine forestfire_destroy(f)
    type(forestfire), intent(inout) :: f

    if ( allocated(f%field) ) deallocate(f%field)
    
  end subroutine forestfire_destroy

  
  subroutine forestfire_evolve(f)
    type(forestfire), intent(inout) :: f

    integer :: i, j
    real :: r

    do i = 1, f%width
       do j = 1, f%height
          select case ( get(f, i, j) )
          case (burning)
             call set(f, i, j, empty)
          case (empty)
             call random_number(r)
             if ( r > f%prob_p ) then
                call set(f, i, j, empty)
             else
                call set(f, i, j, tree)
             end if
          case (tree)
             if ( burning_neighbor(f, i, j) ) then
                call set(f, i, j, burning)
             else
                call random_number(r)
                if ( r > f%prob_f ) then
                   call set(f, i, j, tree)
                else
                   call set(f, i, j, burning)
                end if
             end if
          end select
       end do
    end do
    f%swapu = ieor(f%swapu, 1)
  end subroutine forestfire_evolve

  
  subroutine set(f, i, j, t)
    type(forestfire), intent(inout) :: f
    integer, intent(in) :: i, j, t

    if ( bcheck(f, i, j) ) then
       f%field(ieor(f%swapu,1), i, j) = t
    end if
  end subroutine set

  subroutine cset(f, i, j, t)
    type(forestfire), intent(inout) :: f
    integer, intent(in) :: i, j, t

    if ( bcheck(f, i, j) ) then
       f%field(f%swapu, i, j) = t
    end if
  end subroutine cset

  function bcheck(f, i, j)
    logical :: bcheck
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
    
    bcheck = .false.
    if ( (i >= 1) .and. (i <= f%width) .and. &
         (j >= 1) .and. (j <= f%height) ) bcheck = .true.
 
  end function bcheck
    

  function get(f, i, j) result(r)
    integer :: r
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
    
    if ( .not. bcheck(f, i, j) ) then
       r = empty
    else
       r = f%field(f%swapu, i, j)
    end if
  end function get

  function oget(f, i, j) result(r)
    integer :: r
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
    
    if ( .not. bcheck(f, i, j) ) then
       r = empty
    else
       r = f%field(ieor(f%swapu,1), i, j)
    end if
  end function oget

  function burning_neighbor(f, i, j) result(r)
    logical :: r
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j

    integer, dimension(3,3) :: s
    
    s = f%field(f%swapu, i-1:i+1, j-1:j+1)
    s(2,2) = empty
    r = any(s == burning)
  end function burning_neighbor

  subroutine forestfire_print(f)
    type(forestfire), intent(in) :: f

    integer :: i, j

    do j = 1, f%height
       do i = 1, f%width
          select case(get(f, i, j))
          case (empty) 
             write(*,'(A)', advance='no') '.'
          case (tree)
             write(*,'(A)', advance='no') 'Y'
          case (burning) 
             write(*,'(A)', advance='no') '*'
          end select
       end do
       write(*,*)
    end do
  end subroutine forestfire_print

end module ForestFireModel