FreeBASIC マニュアルのトップに戻る

FreeBASIC ウイルス感染シミュレーション

目次→フォーラム→FreeBASIC→補足Corona virus simulator←オリジナル・サイト

ウイルス感染シミュレーション 左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

←リンク元に戻る プログラム開発関連に戻る

ウイルス感染状況  これは、ウイルスが国境を越えて感染拡大していく状況をシミュレーションするコード例です。
 プログラムの作者は、オランダの badidea さんです。

 ShawnLG さんが作成した、一国内で、旅行者により感染が拡大する過程のシミュレーションもあります。
https://www.freebasic.net/forum/viewtopic.php?f=3&t=28414#p270032

注:FreeBASIC 1.08〜 で、SetEnviron を追加しなくても、日本語環境で描画画面が表示されるように改善されました。
'Corona virus simulator
'by badidea ≫ Apr 01, 2020 22:23 
'https://www.freebasic.net/forum/viewtopic.php?f=3&t=28414&start=30#p270296
'Simulation of virus containment failure:
'国境を越えてウイルスが拡散するシミュレーション

#Include "fbgfx.bi"
#Include "string.bi"

' Sets the graphics method GDI
' 描画方法を GDI に設定
SetEnviron("fbgfx=GDI")

Type int2d
   As Integer x, y
   Declare Constructor
   Declare Constructor(x As Integer, y As Integer)
   Declare Operator Cast () As String
End Type

Constructor int2d
End Constructor

Constructor int2d(x As Integer, y As Integer)
   This.x = x : This.y = y
End Constructor

' "x, y"
Operator int2d.cast () As String
  Return Str(x) & "," & Str(y)
End Operator

Operator = (a As int2d, b As int2d) As boolean
   If a.x <> b.x Then Return FALSE
   If a.y <> b.y Then Return FALSE
   Return TRUE
End Operator

Operator <> (a As int2d, b As int2d) As boolean
   If a.x = b.x And a.y = b.y Then Return FALSE
   Return TRUE
End Operator

' a + b 
Operator + (a As int2d, b As int2d) As int2d
   Return Type(a.x + b.x, a.y + b.y)
End Operator

' a - b
Operator - (a As int2d, b As int2d) As int2d
   Return Type(a.x - b.x, a.y - b.y)
End Operator

' -a
Operator - (a As int2d) As int2d
   Return Type(-a.x, -a.y)
End Operator

' a * b
Operator * (a As int2d, b As int2d) As int2d
   Return Type(a.x * b.x, a.y * b.y)
End Operator

' a * mul
Operator * (a As int2d, mul As Integer) As int2d
   Return Type(a.x * mul, a.y * mul)
End Operator

' a \ b
Operator \ (a As int2d, b As int2d) As int2d
   Return Type(a.x \ b.x, a.y \ b.y)
End Operator

' a \ div
Operator \ (a As int2d, divider As Integer) As int2d
   Return Type(a.x \ divider, a.y \ divider)
End Operator

'===============================================================================

Type sgl2d
   As Single x, y
   Declare Constructor
   Declare Constructor(x As Single, y As Single)
   Declare Operator Cast() As String
   Declare Function cross(b As sgl2d) As Single
   Declare Function lengthSqrd() As Single
   Declare Function dist(b As sgl2d) As Single
   Declare Function distSqrd(b As sgl2d) As Single
   Declare Function normalise() As sgl2d
End Type

Constructor sgl2d
End Constructor

Constructor sgl2d(x As Single, y As Single)
   This.x = x : This.y = y
End Constructor

Function sgl2d.cross(b As sgl2d) As Single
   Return This.x * b.y - This.y * b.x
End Function

Function sgl2d.lengthSqrd() As Single
   Return (This.x * This.x) + (This.y * This.y) 
End Function

Function sgl2d.dist(b As sgl2d) As Single
   Dim As Single dx = This.x - b.x
   Dim As Single dy = This.y - b.y
   Return Sqr((dx * dx) + (dy * dy)) 
End Function

Function sgl2d.distSqrd(b As sgl2d) As Single
   Dim As Single dx = This.x - b.x
   Dim As Single dy = This.y - b.y
   Return (dx * dx) + (dy * dy) 
End Function

Function sgl2d.normalise() As sgl2d
   Dim As Single length = Sqr((This.x * This.x) + (This.y * This.y))
   Return sgl2d(This.x / length, This.y / length)
End Function

' "x, y"
Operator sgl2d.cast() As String
   Return Str(x) & "," & Str(y)
End Operator

'---- operators ---

' distance / lenth
Operator Len (a As sgl2d) As Single
   Return Sqr(a.x * a.x + a.y * a.y)
End Operator

' a = b ?
Operator = (a As sgl2d, b As sgl2d) As boolean
   If a.x <> b.x Then Return FALSE
   If a.y <> b.y Then Return FALSE
   Return TRUE
End Operator

' a != b ?
Operator <> (a As sgl2d, b As sgl2d) As boolean
   If a.x = b.x And a.y = b.y Then Return FALSE
   Return TRUE
End Operator

' a + b 
Operator + (a As sgl2d, b As sgl2d) As sgl2d
   Return Type(a.x + b.x, a.y + b.y)
End Operator

' a - b
Operator - (a As sgl2d, b As sgl2d) As sgl2d
   Return Type(a.x - b.x, a.y - b.y)
End Operator

' -a
Operator - (a As sgl2d) As sgl2d
   Return Type(-a.x, -a.y)
End Operator

' a * b
Operator * (a As sgl2d, b As sgl2d) As sgl2d
   Return Type(a.x * b.x, a.y * b.y)
End Operator

' a * mul
Operator * (a As sgl2d, mul As Single) As sgl2d
   Return Type(a.x * mul, a.y * mul)
End Operator

' a / div
Operator / (a As sgl2d, div As Single) As sgl2d
   Return Type(a.x / div, a.y / div)
End Operator

'===============================================================================

'list can grow, but never shrink, for performance, non-sorted
'パフォーマンスのため、ソートされていません。
'リストは縮小せず、大きくなります。
Type grow_list
   Dim As Integer index(Any)
   Private:
   Dim As Integer numItems
   Public:
   Declare Constructor(startSize As Integer)
   Declare Constructor()
   Declare Destructor()
   Declare Sub Add(newIndex As Integer)
   Declare Sub empty()
   Declare Function numAlloc() As Integer
   Declare Function numInUse() As Integer
   Declare Sub show()
   'non-list methods
End Type

Constructor grow_list(startSize As Integer)
   If startSize > 0 Then
      ReDim index(startSize - 1)
   End If
End Constructor

Constructor grow_list()
   This.constructor(0)
End Constructor

Destructor grow_list()
   Erase(index)
End Destructor

Sub grow_list.add(newIndex As Integer)
   Dim As Integer ub = UBound(index)
   'if list is full, increase list size by 1
   'リストがいっぱいになると、リストのサイズを1増やします
   If numItems = ub + 1 Then
      ReDim Preserve index(numItems)
   End If
   index(numItems) = newIndex
   numItems += 1
End Sub

Sub grow_list.empty()
   numItems = 0
End Sub

Function grow_list.numAlloc() As Integer
   Return UBound(index) + 1
End Function

Function grow_list.numInUse() As Integer
   Return numItems
End Function

'for debugging
Sub grow_list.show()
   Print "--- " & numInUse() & " / " & numAlloc() & " ---"
   For i As Integer = 0 To numItems - 1
      Print i, index(i)
   Next
End Sub

'===============================================================================

#Define MOUSE_IDLE 0
#Define MOUSE_POS_CHANGED 1
#Define MOUSE_LB_PRESSED 2
#Define MOUSE_LB_RELEASED 3
#Define MOUSE_RB_PRESSED 4
#Define MOUSE_RB_RELEASED 5
#Define MOUSE_MB_PRESSED 6
#Define MOUSE_MB_RELEASED 7
#Define MOUSE_WHEEL_UP 8
#Define MOUSE_WHEEL_DOWN 9

Type mouse_type
   Pos As int2d
   posChange As int2d
   wheel As Integer
   buttons As Integer
   lb As Integer 'left button
   rb As Integer 'right button
   mb As Integer 'middle button
End Type

Function handleMouse(ByRef mouse As mouse_type) As Integer
   Static previous As mouse_type
   Dim As Integer change = MOUSE_IDLE
   GetMouse mouse.pos.x, mouse.pos.y, mouse.wheel, mouse.buttons
   If (mouse.buttons = -1) Then
      mouse.lb = 0
      mouse.rb = 0
      mouse.mb = 0
      mouse.posChange.x = 0
      mouse.posChange.y = 0
   Else
      mouse.lb = (mouse.buttons And 1)
      mouse.rb = (mouse.buttons Shr 1) And 1
      mouse.mb = (mouse.buttons Shr 2) And 1
      If (previous.pos.x <> mouse.pos.x Or previous.pos.y <> mouse.pos.y) Then
         change = MOUSE_POS_CHANGED
      End If
      mouse.posChange.x = mouse.pos.x - previous.pos.x
      mouse.posChange.y = mouse.pos.y - previous.pos.y
      If (previous.buttons <> mouse.buttons) Then
         If (previous.lb = 0 And mouse.lb = 1) Then change = MOUSE_LB_PRESSED
         If (previous.lb = 1 And mouse.lb = 0) Then change = MOUSE_LB_RELEASED
         If (previous.rb = 0 And mouse.rb = 1) Then change = MOUSE_RB_PRESSED
         If (previous.rb = 1 And mouse.rb = 0) Then change = MOUSE_RB_RELEASED
         If (previous.mb = 0 And mouse.mb = 1) Then change = MOUSE_MB_PRESSED
         If (previous.mb = 1 And mouse.mb = 0) Then change = MOUSE_MB_RELEASED
      End If
      If (mouse.wheel > previous.wheel) Then change = MOUSE_WHEEl_UP
      If (mouse.wheel < previous.wheel) Then change = MOUSE_WHEEl_DOWN
      previous = mouse
   End If
   Return change
End Function

'===============================================================================

'Note: y+ = up, x+ = right, (0,0) = center
Type scaled_graphics_type
   Dim As Single scale = 1 ' = 1 / pixel_size 'pixels / meter
   'dim as int2d offset' = (scrn_w \ 2, h \ 2) 'offset in pixels
   Dim As sgl2d offset
   Dim As Integer w = -1, h = -1
   Dim As Integer wc = -1, hc = -1 'center x,y
   Declare Sub setScreen(w As Integer, h As Integer)
   Declare Sub setScaling(scale As Single, offset As sgl2d)
   Declare Sub clearScreen(c As ULong)
   Declare Function pos2screen(p As sgl2d) As int2d
   Declare Sub drawPixel(p As sgl2d, c As ULong)
   Declare Sub drawCircle(p As sgl2d, r As Single, c As ULong)
   'declare sub drawCircleFilled(p as sgl2d, r as single, c as ulong, cFill as ulong)
   Declare Sub drawCircleFilled(p As sgl2d, r As Single, c As ULong)
   Declare Sub drawElipse(p As sgl2d, r As Single, aspect As Single, c As ULong)
   Declare Sub drawLine(p1 As sgl2d, p2 As sgl2d, c As ULong)
   Declare Sub drawRect(p1 As sgl2d, p2 As sgl2d, c As ULong)
   Declare Sub drawRectFilled(p1 As sgl2d, p2 As sgl2d, c As ULong)
End Type

Sub scaled_graphics_type.setScreen(w As Integer, h As Integer)
   This.w = w 'width
   This.h = h 'height
   wc = w \ 2
   hc = h \ 2
   ScreenRes w, h, 32
   Width w \ 8, h \ 16 'bigger font
End Sub

Sub scaled_graphics_type.setScaling(scale As Single, offset As sgl2d)
   This.scale = scale
   This.offset = offset
End Sub

Sub scaled_graphics_type.clearScreen(c As ULong)
   Line(0, 0)-(w - 1, h - 1), c, bf
End Sub

Function scaled_graphics_type.pos2screen(p As sgl2d) As int2d
   Return int2d(Int(wc + (p.x - offset.x) * scale), h - Int(hc + (p.y - offset.y) * scale))
End Function

Sub scaled_graphics_type.drawPixel(p As sgl2d, c As ULong)
   Dim As int2d posScrn = pos2screen(p)
   PSet(posScrn.x, posScrn.y), c
End Sub

Sub scaled_graphics_type.drawCircle(p As sgl2d, r As Single, c As ULong)
   Dim As int2d posScrn = pos2screen(p)
   Circle(posScrn.x, posScrn.y), r * scale, c
End Sub

Sub scaled_graphics_type.drawCircleFilled(p As sgl2d, r As Single, c As ULong)
   Dim As int2d posScrn = pos2screen(p)
   Circle(posScrn.x, posScrn.y), r * scale, c,,,,f
End Sub

Sub scaled_graphics_type.drawElipse(p As sgl2d, r As Single, aspect As Single, c As ULong)
   Dim As int2d posScrn = pos2screen(p)
   Circle(posScrn.x, posScrn.y), r * scale, c, , , aspect
End Sub

Sub scaled_graphics_type.drawLine(p1 As sgl2d, p2 As sgl2d, c As ULong)
   Dim As int2d posScrn1 = pos2screen(p1)
   Dim As int2d posScrn2 = pos2screen(p2)
   Line(posScrn1.x, posScrn1.y)-(posScrn2.x, posScrn2.y), c
End Sub

Sub scaled_graphics_type.drawRect(p1 As sgl2d, p2 As sgl2d, c As ULong)
   Dim As int2d posScrn1 = pos2screen(p1)
   Dim As int2d posScrn2 = pos2screen(p2)
   Line(posScrn1.x, posScrn1.y)-(posScrn2.x, posScrn2.y), c, b
End Sub

Sub scaled_graphics_type.drawRectFilled(p1 As sgl2d, p2 As sgl2d, c As ULong)
   Dim As int2d posScrn1 = pos2screen(p1)
   Dim As int2d posScrn2 = pos2screen(p2)
   Line(posScrn1.x, posScrn1.y)-(posScrn2.x, posScrn2.y), c, bf
End Sub

'===============================================================================

Const As Single INFEC_DIST = 0.05 'm
Const As Single INFEC_DIST_SQRD = INFEC_DIST ^ 2
Const As Single SICK_DAYS_MIN = 7, SICK_DAYS_MAX = 21
Const As Single MORTALITY = 3 / 100
'const as single SICK_SPEED_FACTOR = 0.25 'disable due to some bug

Const SEC_PER_DAY = 24 * 60 * 60
Const As Single DAY_PER_SEC = 1 / SEC_PER_DAY 

Const PERSONS = 5000
Const As Single V_MAX = 0.1 / 3600 '1 m/hr
Const As Single MAP_X_MAX = +50, MAP_X_MIN = -MAP_X_MAX
Const As Single MAP_Y_MAX = +35, MAP_Y_MIN = -MAP_Y_MAX
Const As Single MAP_W = MAP_X_MAX - MAP_X_MIN
Const As Single MAP_H = MAP_Y_MAX - MAP_Y_MIN

Const DRAW_INTERVAL = 10 '1 to 10 
Const FOLLOW_PATIENT_0 = FALSE

Const NUM_SECT_X = 16 * 3, NUM_SECT_Y = 12 * 3
Dim As grow_list sector(NUM_SECT_X - 1, NUM_SECT_Y -1)

'screen stuff
Const As Single PPM = 6.0 'pixels per meter (set zoom level)
Const SCRN_W = 1050, SCRN_H = 750
Dim Shared As scaled_graphics_type sg
sg.setScreen(SCRN_W, SCRN_H)
sg.setScaling(PPM, sgl2d(0, 0))

Enum HEALTH_STATE
   ST_INIT '0
   ST_INFEC '1
   ST_RECOV '2
   ST_DEAD '3
   ST_LAST 'number of states
End Enum

Dim As Integer statCounters(ST_LAST - 1)
Dim As ULong stateColor(ST_LAST - 1) = _
   {RGB(0, 150, 0), RGB(150, 0, 0), RGB(150, 150, 0), RGB(0, 0, 0)}
Dim As Single statPercentage(ST_LAST - 1)

Const As ULong WHITE = RGB(250, 250, 250)
Const As ULong BLACK = RGB(0, 0, 0)

Type person_type
   p As sgl2d 'position [m]
   pPrev As sgl2d 'position [m]
   v As sgl2d 'velocity [m/s]
   r As Single 'radius [m]
   sickEndTime As Single 'not double!
   state As Integer 'health
End Type

Function drawUpdate(interval As Integer) As boolean
   Static As Integer counter = 0
   counter += 1
   If counter >= interval Then
      counter = 0
      Return TRUE
   Else
      Return FALSE
   End If
End Function

Function rndRangeSgl(min As Single, max As Single) As Single
   Return Rnd() * (max - min) + min
End Function

Sub limitInt(ByRef value As Integer, min As Integer, max As Integer)
   If value < min Then value = min
   If value > max Then value = max
End Sub

Dim As Integer mouseEvent, mouseDrag
Dim As mouse_type mouse
Dim As person_type person(0 To PERSONS-1)

Randomize 1234
'initialise persons
For i As Integer = 0 To UBound(person)
   person(i).p.x = rndRangeSgl(MAP_X_MIN, MAP_X_MAX) 'm
   person(i).p.y = rndRangeSgl(MAP_Y_MIN, MAP_Y_MAX) 'm
   person(i).pPrev = person(i).p
   person(i).v.x = rndRangeSgl(-V_MAX, +V_MAX) 'm/s
   person(i).v.y = rndRangeSgl(-V_MAX, +V_MAX) 'm/s
   person(i).r = 0.35
   'person(i).state = int(rndRangeSgl(0, csng(ST_LAST)))
   person(i).state = ST_INIT
Next

'time step such that a max speed, position change = 20 % of infection distance
'位置変化 = 感染距離の 20% となる最大速度の時間ステップ
Dim As Single timeStep = (INFEC_DIST * 0.2) / V_MAX 'sec
Dim As Single simulDays, simulTime = 0
Dim As Integer numInit, numDead, numRecov
Dim As boolean sectioning = TRUE

'move view
sg.offset.x = -35
sg.offset.y = -25
Dim As Double tNow(0 To 9), tAcc(0 To 9)
Dim As Integer trigger = 1

sg.clearScreen(WHITE)
While Not MultiKey(FB.SC_ESCAPE)
   tNow(0) = Timer

   'trigger outbreak
   If MultiKey(FB.SC_SPACE) Then trigger = 1
   If trigger = 1 Then
      trigger = 0
      person(0).state = ST_INFEC
      person(0).sickEndTime = simulTime _
         + rndRangeSgl(SICK_DAYS_MIN, SICK_DAYS_MAX) * SEC_PER_DAY
   End If
   'zoom / drag view by mouse
   mouseEvent = handleMouse(mouse)
      If (mouse.buttons <> -1) Then
      If (mouseEvent = MOUSE_LB_PRESSED) Then mouseDrag = 1
      If (mouseEvent = MOUSE_LB_RELEASED) Then mouseDrag = 0
      If (mouseEvent = MOUSE_WHEEl_UP) Then sg.scale *= 1.1
      If (mouseEvent = MOUSE_WHEEl_DOWN) Then sg.scale /= 1.1
   End If
   If (mouseDrag) Then
      sg.offset.x -= (mouse.posChange.x / PPM)
      sg.offset.y += (mouse.posChange.y / PPM)
   End If
   'patient 0 perpective
   If FOLLOW_PATIENT_0 = TRUE Then
      sg.offset.x = (person(0).p.x)
      sg.offset.y = (person(0).p.y)
   End If

   tNow(1) = Timer

   'update positions
   For i As Integer = 0 To UBound(person)
      person(i).p += person(i).v * timeStep
   Next
   'random direction change
   For i As Integer = 1 To 1
      Dim As Integer iPerson = Int(rndRangeSgl(0, PERSONS))
      If Rnd() > 0.5 Then
         person(iPerson).v.x = -person(iPerson).v.x
      Else
         person(iPerson).v.y = -person(iPerson).v.y
      End If
   Next

   tNow(2) = Timer

   'check wall collisions
   '壁との衝突を確認
   For i As Integer = 0 To UBound(person)
      With person(i)
         If .p.x < MAP_X_MIN Then .v.x = +Abs(.v.x)
         If .p.x > MAP_X_MAX Then .v.x = -Abs(.v.x)
         If .p.y < MAP_Y_MIN Then .v.y = +Abs(.v.y)
         If .p.y > MAP_Y_MAX Then .v.y = -Abs(.v.y)
         If .pPrev.x > 0 And .p.x < 0 Then .v.x = +Abs(.v.x)
         If .pPrev.x < 0 And .p.x > 0 Then .v.x = -Abs(.v.x)
         If .pPrev.y > 0 And .p.y < 0 Then .v.y = +Abs(.v.y)
         If .pPrev.y < 0 And .p.y > 0 Then .v.y = -Abs(.v.y)
      End With
   Next

   tNow(3) = Timer

   'check end of sickness
   '病気の終了を確認
   For i As Integer = 0 To UBound(person)
      If person(i).state = ST_INFEC Then
         If simulTime > person(i).sickEndTime Then
            If Rnd() < MORTALITY Then
               person(i).state = ST_DEAD
               person(i).v = sgl2d(0, 0)
            Else
               person(i).state = ST_RECOV
               'person(i).v /= SICK_SPEED_FACTOR 'somthing wrong with this
               'person(i).v.x = rndRangeSgl(-V_MAX, +V_MAX) 'm/s
               'person(i).v.y = rndRangeSgl(-V_MAX, +V_MAX) 'm/s
            End If
         End If
      End If
   Next
   
   tNow(4) = Timer

   'clear sectors
   For xi As Integer = 0 To NUM_SECT_X - 1
      For yi As Integer = 0 To NUM_SECT_Y - 1
         sector(xi, yi).empty()
      Next
   Next
   
   tNow(5) = Timer

   'assign persons to sectors
   'セクターに人を割り当て
   For i As Integer = 0 To UBound(person)
      Dim As Integer xi = Int((person(i).p.x - MAP_X_MIN) / (MAP_W / NUM_SECT_X))
      Dim As Integer yi = Int((person(i).p.y - MAP_Y_MIN) / (MAP_H / NUM_SECT_Y))
      limitInt(xi, 0, NUM_SECT_X - 1)
      limitInt(yi, 0, NUM_SECT_Y - 1)
      sector(xi, yi).add(i)
   Next

   tNow(6) = Timer

   'spread the virus
   'ウイルスが拡散
   If sectioning = TRUE Then
      For xi As Integer = 0 To NUM_SECT_X - 1
         For yi As Integer = 0 To NUM_SECT_Y - 1
            'loop source in 1 sector
            For iiSrc As Integer = 0 To sector(xi, yi).numInUse - 1
               Dim As Integer iSrc = sector(xi, yi).index(iiSrc)
               If person(iSrc).state = ST_INFEC Then
                  'check against targets in near sectors, including this sector
                  'このセクターを含む近くのセクターの目標をチェック
                  For xdi As Integer = -1 To +1
                     If xi + xdi < 0 Then Continue For
                     If xi + xdi >= NUM_SECT_X Then Continue For
                     For ydi As Integer = -1 To +1
                        If yi + ydi < 0 Then Continue For
                        If yi + ydi >= NUM_SECT_Y Then Continue For
                        'loop targets with 1 (near) sector
                        For iiTar As Integer = 0 To sector(xi + xdi, yi + ydi).numInUse - 1
                           Dim As Integer iTar = sector(xi + xdi, yi + ydi).index(iiTar)
                           If person(iTar).state = ST_INIT Then
                              If person(iSrc).p.distSqrd(person(iTar).p) < INFEC_DIST_SQRD Then
                                 person(iTar).state = ST_INFEC
                                 person(iTar).sickEndTime = simulTime _
                                    + rndRangeSgl(SICK_DAYS_MIN, SICK_DAYS_MAX) * SEC_PER_DAY
                                 'person(iTar).v *= SICK_SPEED_FACTOR
                              End If
                           End If
                        Next
                     Next
                  Next
               End If
            Next
         Next
      Next
   Else
      'case: sectioning = FALSE
      'check for disease transmission (iSrc = source, iTar = target)
      '病気の伝染をチェック (iSrc = source, iTar = target)
      For iSrc As Integer = 0 To UBound(person)
         If person(iSrc).state = ST_INFEC Then
            For iTar As Integer = 0 To UBound(person)
               If person(iTar).state = ST_INIT Then
                  If person(iSrc).p.distSqrd(person(iTar).p) < INFEC_DIST_SQRD Then
                     person(iTar).state = ST_INFEC
                     person(iTar).sickEndTime = simulTime _
                        + rndRangeSgl(SICK_DAYS_MIN, SICK_DAYS_MAX) * SEC_PER_DAY
                     'person(iTar).v *= SICK_SPEED_FACTOR
                  End If
               End If
            Next
         End If
      Next
   End If

   tNow(7) = Timer

   'clear stats
   For i As Integer = 0 To UBound(statCounters)
      statCounters(i) = 0
   Next
   'update stats
   For i As Integer = 0 To UBound(person)
      statCounters(person(i).state) += 1
   Next
   
   tNow(8) = Timer

   'draw world
   If (drawUpdate(DRAW_INTERVAL) = TRUE) Then
      ScreenLock
      'sg.clearScreen(WHITE)
      'clear part of screen
      sg.drawRectFilled(sgl2d(MAP_X_MIN - 2, MAP_Y_MIN - 2), _
         sgl2d(MAP_X_MAX + 2, MAP_Y_MAX + 2), WHITE)
      sg.drawLine(sgl2d(MAP_X_MIN, 0), sgl2d(MAP_X_MAX, 0), BLACK)
      sg.drawLine(sgl2d(0, MAP_Y_MIN), sgl2d(0, MAP_Y_MAX), BLACK)
      For xi As Integer = 0 To NUM_SECT_X - 1
         For yi As Integer = 0 To NUM_SECT_Y - 1
            Dim As Single x1 = MAP_W * (xi / NUM_SECT_X) + MAP_X_MIN
            Dim As Single y1 = MAP_H * (yi / NUM_SECT_Y) + MAP_Y_MIN
            Dim As Single x2 = MAP_W * ((xi + 1) / NUM_SECT_X) + MAP_X_MIN
            Dim As Single y2 = MAP_H * ((yi + 1) / NUM_SECT_Y) + MAP_Y_MIN
            'sg.drawRect(sgl2d(x1, y1), sgl2d(x2, y2), BLACK) 'grid
            'dim as int2d scrnPos = sg.pos2screen(sgl2d(x1, y1))
            'draw string (scrnPos.x + 2, scrnPos.y - 16), str(sector(xi, yi).numInUse), 0
            'draw string (scrnPos.x + 2, scrnPos.y - 32), str(sector(xi, yi).numAlloc), 0
         Next
      Next
      sg.drawCircle(person(0).p, person(0).r * 3, stateColor(person(0).state))
      For i As Integer = 0 To UBound(person)
         Dim As ULong c = stateColor(person(i).state)
         sg.drawCircleFilled(person(i).p, person(i).r, c)
      Next
      Line(0, 0)-(150, 100), WHITE, bf
      Draw String (10, 10 + 00), "Day: " & Format(simulDays, "0.#0"), BLACK
      Draw String (10, 10 + 16), "Initial: " & statCounters(ST_INIT), stateColor(ST_INIT)
      Draw String (10, 10 + 32), "Infected: " & statCounters(ST_INFEC), stateColor(ST_INFEC)
      Draw String (10, 10 + 48), "Recovered: " & statCounters(ST_RECOV), stateColor(ST_RECOV)
      Draw String (10, 10 + 64), "Dead: " & statCounters(ST_DEAD), stateColor(ST_DEAD)
      '~ for i as integer = 1 to 9
         '~ draw string (10, 90 + i * 16), "Step: " & i & " = " &  format(tAcc(i), "0.#0"), BLACK
      '~ next
      For i As Integer = 0 To ST_LAST - 1
         statPercentage(i) = 100 * (statCounters(i) / PERSONS)
         Circle(10 + 4 * simulDays, (SCRN_H - 10) - 3 * statPercentage(i)), 1, stateColor(i),,,,f
      Next
      ScreenUnLock
      Sleep 1,1 'don't sleep every loop
   End If
   simulTime += timeStep
   simulDays = simulTime * DAY_PER_SEC
   tAcc(9) = 0 'sum other timers
   For i As Integer = 1 To 8
      tAcc(i) += (tNow(i) - tNow(i - 1))
      tAcc(9) += tAcc(i) 'sum
   Next
   If statCounters(ST_INFEC) = 0 Then Exit While
Wend
Draw String (10, SCRN_W - 26), "End of simulation", BLACK
While InKey = "" : Sleep 1 : Wend
End
 
補足 に戻る
←リンク元に戻る プログラム開発関連に戻る
ページ歴史:2020-10-03 00:00
日本語翻訳:WATANABE Makoto、原文著作者:badidea

ホームページのトップに戻る

表示-非営利-継承