Meteorite shooter

[badidea]

Continuation form topic Simple dynamic non-shrinking list.
I wanted to make a corona-virus shooter, but this may be inappropriate. So a Meteorite shooter it is.

Code: Select all

#Include Once "fbgfx.bi"

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

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 screen_type ' pretty dumb graphics class
   Private:
      'dim as fb.Image ptr pFbImg
      Dim As Integer wPage, vPage 'work page, visible page
   Public:
      'dim as long w, h 'size
      Dim As int2d size
      Dim As int2d cntr 'center
      Dim As int2d edge
      Dim As Long gfxFlags
      Declare Constructor(w As Long, h As Long, flags As Long)
      Declare Sub activate()
      Declare Sub flipPage()
      Declare Sub clearScreen(colour As ULong)
End Type

Constructor screen_type(w As Long, h As Long, flags As Long)
   size = int2d(w, h)
   cntr = int2d(w \ 2, h \ 2)
   edge = int2d(w - 1, h - 1)
   gfxFlags = flags
End Constructor

Sub screen_type.activate()
   ScreenRes size.x, size.y, 32, 2, gfxFlags
   Width size.x \ 8, size.y \ 16 'bigger font
   'pFbImg = ImageCreate(w, h)
   wPage = 0
   vPage = 0
   ScreenSet wPage, vPage
   wPage = 1
End Sub

Sub screen_type.flipPage()
   ScreenSet wPage, vPage
   wPage Xor= 1
   vPage Xor= 1
End Sub

Sub screen_type.clearScreen(colour As ULong)
   Line(0, 0)-(size.x - 1, size.y - 1), colour, bf
End Sub

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

'TODO:
' use bit-field
' union of pos & x,y
' add clip
' make real class

#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 mouseType
   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 mouseType) As Integer
   Static previous As mouseType
   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
      If previous.pos <> mouse.pos 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
      mouse.posChange = mouse.pos - previous.pos
      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

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

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

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

Declare Function toInt2d Overload (v As sgl2d) As int2d

Function toInt2d(v As sgl2d) As int2d
   Return int2d(Int(v.x), Int(v.y))
End Function

Declare Function toCint2d Overload (v As sgl2d) As int2d

Function toCint2d(v As sgl2d) As int2d
   Return int2d(CInt(v.x), CInt(v.y))
End Function

Function toSgl2d(v As int2d) As sgl2d
   Return sgl2d(v.x, v.y)
End Function

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

'simple event timer

Type timer_type
   Private:
   Dim As Double tEnd
   Dim As Double tStart
   Dim As Double tSpan
   Dim As boolean active = false
   Public:
   Declare Sub start(duration As Double)
   Declare Sub stop_()
   Declare Function isActive() As boolean
   Declare Function ended() As boolean
   Declare Function timeLeft() As Double
   '~ declare sub restart()
End Type

Sub timer_type.start(duration As Double)
   tStart = Timer()
   tSpan = duration
   tEnd = tStart + tSpan
   active = true
End Sub

Sub timer_type.stop_()
   active = false
End Sub

'does NOT update the timer status
Function timer_type.isActive() As boolean
   Return active
End Function

'check only once in loop! Inactive after ended.
Function timer_type.ended() As boolean
   If active = false Then Return false
   If Timer() >= tEnd Then
      active = false
      Return true
   Else
      Return false
   End If
End Function

Function timer_type.timeLeft() As Double
   Dim As Double tLeft = tEnd - Timer
   Return IIf(tLeft < 0, 0, tLeft)
End Function

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

Type loop_timer_type
   Private:
   Dim As Double tStart
   Dim As Double tNow
   Dim As Double tPrev
   Dim As Double dt
   'dim as double dtAvg
   Dim As Integer pauseFlag = 0
   Public:
   Declare Sub init()
   Declare Sub update()
   Declare Sub togglePause()
   Declare Function isPaused() As Integer
   Declare Function getDt() As Double
   Declare Function getRunTime() As Double
End Type

Sub loop_timer_type.init()
   tStart = Timer
   tNow = tStart
   tPrev = tNow
   dt = 0.0
   pauseFlag = 0
   'dtAvg = 0.0
End Sub

Sub loop_timer_type.update()
   tPrev = tNow
   tNow = Timer
   dt = tNow - tPrev
   If pauseFlag = 1 Then dt = 0
   'dtAvg = 0.95 * dtAvg + 0.05 * dt
End Sub

Sub loop_timer_type.togglePause()
   pauseFlag Xor= 1
End Sub

Function loop_timer_type.isPaused() As Integer
   Return pauseFlag
End Function

Function loop_timer_type.getDt() As Double
   Return dt
End Function

Function loop_timer_type.getRunTime() As Double
   Return Timer - tStart
End Function

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

Const As Single V_BULLET = 400 'pixels/s

Type bullet_type
   Dim As sgl2d pos_
   Dim As sgl2d vel
   Dim As Single dist 'travel distance
End Type

'list can grow, but never shrink, for performance, non-sorted
Type bullet_list
   Private:
   Dim As Integer numItems
   Dim As bullet_type item(Any)
   Public:
   Dim As Single radius = 5
   Declare Constructor(startSize As Integer)
   Declare Constructor()
   Declare Destructor()
   Declare Sub Add(pos_ As sgl2d, dir_ As sgl2d)
   Declare Sub del(index As Integer)
   'not essential methods
   Declare Function numAlloc() As Integer
   Declare Function numInUse() As Integer
   Declare Function getPos(index As Integer) As sgl2d
   Declare Sub show()
   'non-list methods
   Declare Sub draw_()
   Declare Sub update(dt As Double, maxDist As Single)
End Type

Constructor bullet_list(startSize As Integer)
   If startSize > 0 Then
      ReDim item(startSize - 1)
   End If
End Constructor

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

Destructor bullet_list()
   Erase(item)
End Destructor

Sub bullet_list.add(pos_ As sgl2d, dir_ As sgl2d)
   Dim As Integer ub = UBound(item)
   'if list is full, increase list size by 1
   If numItems = ub + 1 Then
      ReDim Preserve item(numItems)
   End If
   item(numItems).pos_ = pos_
   item(numItems).vel = dir_ * V_BULLET
   item(numItems).dist = 0
   numItems += 1
End Sub

Sub bullet_list.del(index As Integer)
   'check valid index
   'if index >= 0 andalso index < numItems then
      'move last to del pos
      item(index) = item(numItems - 1)
      numItems -= 1
   'end if
End Sub

Function bullet_list.numAlloc() As Integer
   Return UBound(item) + 1
End Function

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

Function bullet_list.getPos(index As Integer) As sgl2d
   Return item(index).pos_
End Function

'for debugging
Sub bullet_list.show()
   Print "--- " & numInUse() & " / " & numAlloc() & " ---"
   For i As Integer = 0 To numItems - 1
      Print i, item(i).pos_.x, item(i).pos_.y
   Next
End Sub

Sub bullet_list.draw_()
   For i As Integer = 0 To numItems - 1
      With item(i)
         Circle(.pos_.x, .pos_.y), radius, RGB(200,200,0),,,,f
      End With
   Next
End Sub

'update positions, remove to too far
Sub bullet_list.update(dt As Double, maxDist As Single)
   For i As Integer = 0 To numItems - 1
      With item(i)
         .dist += V_BULLET * dt
         If .dist > maxDist Then
            del(i)
         Else
            .pos_ += .vel * dt
         End If
      End With
   Next
End Sub

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

Const As Single V_ENEMY_MAX = 200 'pixels/s
Const As Single V_ENEMY_MIN = 50 'pixels/s

Type enemy_type
   Dim As sgl2d pos_
   Dim As sgl2d vel 'velocity vector
End Type

'list can grow, but never shrink, for performance, non-sorted
Type enemy_list
   Private:
   Dim As Integer numItems
   Dim As enemy_type item(Any)
   Public:
   Dim As Single radius = 10
   Declare Constructor(startSize As Integer)
   Declare Constructor()
   Declare Destructor()
   Declare Sub Add(pos_ As sgl2d, dir_ As sgl2d)
   Declare Sub del(index As Integer)
   'not essential methods
   Declare Function numAlloc() As Integer
   Declare Function numInUse() As Integer
   Declare Function getPos(index As Integer) As sgl2d
   Declare Sub show()
   'non-list methods
   Declare Sub draw_()
   Declare Function update(dt As Double, targetPos As sgl2d, targetRadius As Single) As Integer
End Type

Constructor enemy_list(startSize As Integer)
   If startSize > 0 Then
      ReDim item(startSize - 1)
   End If
End Constructor

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

Destructor enemy_list()
   Erase(item)
End Destructor

Sub enemy_list.add(pos_ As sgl2d, dir_ As sgl2d)
   Dim As Integer ub = UBound(item)
   'if list is full, increase list size by 1
   If numItems = ub + 1 Then
      ReDim Preserve item(numItems)
   End If
   Dim As Single speed =  V_ENEMY_MIN + Rnd * (V_ENEMY_MAX - V_ENEMY_MIN)
   item(numItems).pos_ = pos_
   item(numItems).vel = dir_ * speed
   numItems += 1
End Sub

Sub enemy_list.del(index As Integer)
   'check valid index
   'if index >= 0 andalso index < numItems then
      'move last to del pos
      item(index) = item(numItems - 1)
      numItems -= 1
   'end if
End Sub

Function enemy_list.numAlloc() As Integer
   Return UBound(item) + 1
End Function

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

Function enemy_list.getPos(index As Integer) As sgl2d
   Return item(index).pos_
End Function

'for debugging
Sub enemy_list.show()
   Print "--- " & numInUse() & " / " & numAlloc() & " ---"
   For i As Integer = 0 To numItems - 1
      Print i, item(i).pos_.x, item(i).pos_.y
   Next
End Sub

Sub enemy_list.draw_()
   For i As Integer = 0 To numItems - 1
      With item(i)
         Circle(.pos_.x, .pos_.y), radius, RGB(200,100,0),,,,f
      End With
   Next
End Sub

'update positions, remove to too far
Function enemy_list.update(dt As Double, targetPos As sgl2d, targetRadius As Single) As Integer
   Dim As Integer hitCount = 0
   For i As Integer = 0 To numItems - 1
      With item(i)
         .pos_ += .vel * dt
         Dim As Single dist = .pos_.dist(targetPos)
         If dist < (radius + targetRadius) Then
            del(i)
            hitCount += 1
         End If
      End With
   Next
   Return hitCount
End Function

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

Const As String KEY_ESC = Chr(27)
Const SW = 800, SH = 600
Const MAX_DIST = Sqr((SW / 2) ^ 2 + (SH / 2) ^ 2)
Const SPAWN_DIST = MAX_DIST * 1.2
Const PI = Atn(1) * 4
Dim Shared As screen_type scr = screen_type(SW, SH, fb.GFX_ALPHA_PRIMITIVES) '1024, 768

Declare Function main() As String

scr.activate() 'set screen

Randomize Timer

Dim As String quitStr
SetMouse( , , 0) 'hide cursor
quitStr = main()
SetMouse( , , 1) 'restore cursor
Print "End: " & quitStr
Sleep 5000
End

Function main() As String
   Dim As mouseType mouse
   Dim As Integer mouseEvent
   Dim As sgl2d aimPos, deltaPosNorm, barrelPos
   Dim As sgl2d gunPos = toSgl2d(scr.size) / 2 'centre
   Dim As Single gunRadius = 15
   Dim As timer_type trigTmr
   Dim As bullet_list bulletList
   Dim As timer_type spawnTmr
   Dim As enemy_list enemyList
   Dim As timer_type hitTmr
   Dim As loop_timer_type loopTimer
   Dim As Integer bulletCount, enemyCount, hitCount, damage, health = 10
   Dim As ULong gunColor = RGB(80, 80, 80)
   Dim As ULong barrelColor = RGB(160, 160, 160)
   Dim As ULong aimColor = RGB(80, 160, 80)
   Dim As Double spawnTime = 2.0
   Dim As String quitStr = ""
   'main loop
   spawnTmr.start(spawnTime)
   loopTimer.init()
   While quitStr = ""
      If InKey = KEY_ESC Then quitStr = "Quit, user abort request"
      mouseEvent = handleMouse(mouse)
      If mouse.buttons <> -1 Then aimPos = toSgl2d(mouse.pos)

      deltaPosNorm = (aimPos - gunPos).normalise()
      barrelPos = gunPos + deltaPosNorm * 24
      
      If mouse.lb = 1 Then
         If trigTmr.isActive = false Then
            trigTmr.start(0.2)
            bulletList.add(barrelPos, deltaPosNorm)
            bulletCount += 1
         End If
      End If
      If spawnTmr.ended() Then
         spawnTmr.start(spawnTime)
         enemyCount += 1
         If enemyCount Mod 10 = 0 Then spawnTime *= 0.9
         Dim As Single angle = Rnd * 2 * PI
         Dim As sgl2d relPos = sgl2d(Cos(angle) * SPAWN_DIST, Sin(angle) * SPAWN_DIST)
         enemyList.add(relPos + gunPos, -relPos.normalise())
      End If
      If hitTmr.ended() Then
         gunColor = RGB(80, 80, 80)
         barrelColor = RGB(160, 160, 160)
      End If
      trigTmr.ended() 'update timer
      bulletList.update(loopTimer.getdt(), MAX_DIST)
      damage = enemyList.update(loopTimer.getdt(), gunPos, gunRadius)
      health -= damage
      If damage > 0 Then
         gunColor = RGB(160, 80, 80)
         barrelColor = RGB(240, 160, 160)
         hitTmr.start(0.2)
      End If

      'check bullet <-> enemy collisions
      Dim As Integer iBullet = 0
      While iBullet < bulletList.numInUse()
         Dim As Integer iEnemy = 0
         While iEnemy < enemyList.numInUse()
            Dim As sgl2d bulletPos = bulletList.getPos(iBullet)
            Dim As Single dist = bulletPos.dist(enemyList.getPos(iEnemy))
            If dist < (bulletList.radius + enemyList.radius) Then
               bulletList.del(iBullet)
               enemyList.del(iEnemy)
               'list changed start over
               'iBullet = 0
               'iEnemy = 0
               'list changed recheck these indices, is this right?
               If iBullet > 0 Then iBullet -= 1
               If iEnemy > 0 Then iEnemy -= 1
               hitCount += 1
            End If
            iEnemy += 1
         Wend
         iBullet += 1
      Wend
      
      ScreenLock
      
      scr.clearScreen(RGBA(0, 0, 0, 255))
      'draw gun
      Circle(gunPos.x, gunPos.y), gunRadius, gunColor,,,,f
      'draw target aim
      Circle(aimPos.x, aimPos.y), 10, aimColor,,,0.1,f
      Circle(aimPos.x, aimPos.y), 10, aimColor,,,10.0,f
      'draw gun barrel
      barrelPos = gunPos
      For i As Integer = 0 To 4
         Circle(barrelPos.x, barrelPos.y), 5, barrelColor,,,,f
         barrelPos += (deltaPosNorm * 6)
      Next
      'draw all existing bullets & enemies
      bulletList.draw_()
      enemyList.draw_()
      Locate 1,1: Print "Press left mouse button to fire"
      Locate 2,1: Print "Bullet list: " & bulletList.numInUse() & " / " & bulletList.numAlloc()
      Locate 3,1: Print "Enemy list: " & enemyList.numInUse() & " / " & enemyList.numAlloc()
      Locate 4,1: Print "Health: " & health
      Locate 5,1: Print "Hits: " & hitCount
   
      ScreenUnLock

      Sleep 1
      loopTimer.update()
      If health <= 0 Then quitStr = "Game over!"
   Wend
   Return quitStr
End Function


It gets more difficult after time. My best score so far: 123

[Dr_D]

Nice. It reminds me of a little game I made for fun a long time ago. These things are so fun to program. Good job. :)

By the way... In my opinion, I don't think a coronavirus inspired game is inappropriate. We're all facing it. Everyone handles it differently, but we all have to face it.

[ShawnLG]

I wanted to make a corona-virus shooter, but this may be inappropriate.

Are you kidding me! I fixed it.

Code: Select all

#Include Once "fbgfx.bi"

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

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 screen_type ' pretty dumb graphics class
   Private:
      'dim as fb.Image ptr pFbImg
      Dim As Integer wPage, vPage 'work page, visible page
   Public:
      'dim as long w, h 'size
      Dim As int2d size
      Dim As int2d cntr 'center
      Dim As int2d edge
      Dim As Long gfxFlags
      Declare Constructor(w As Long, h As Long, flags As Long)
      Declare Sub activate()
      Declare Sub flipPage()
      Declare Sub clearScreen(colour As ULong)
End Type

Constructor screen_type(w As Long, h As Long, flags As Long)
   size = int2d(w, h)
   cntr = int2d(w \ 2, h \ 2)
   edge = int2d(w - 1, h - 1)
   gfxFlags = flags
End Constructor

Sub screen_type.activate()
   ScreenRes size.x, size.y, 32, 2, gfxFlags
   Width size.x \ 8, size.y \ 16 'bigger font
   'pFbImg = ImageCreate(w, h)
   wPage = 0
   vPage = 0
   ScreenSet wPage, vPage
   wPage = 1
End Sub

Sub screen_type.flipPage()
   ScreenSet wPage, vPage
   wPage Xor= 1
   vPage Xor= 1
End Sub

Sub screen_type.clearScreen(colour As ULong)
   Line(0, 0)-(size.x - 1, size.y - 1), colour, bf
End Sub

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

'TODO:
' use bit-field
' union of pos & x,y
' add clip
' make real class

#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 mouseType
   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 mouseType) As Integer
   Static previous As mouseType
   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
      If previous.pos <> mouse.pos 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
      mouse.posChange = mouse.pos - previous.pos
      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

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

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

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

Declare Function toInt2d Overload (v As sgl2d) As int2d

Function toInt2d(v As sgl2d) As int2d
   Return int2d(Int(v.x), Int(v.y))
End Function

Declare Function toCint2d Overload (v As sgl2d) As int2d

Function toCint2d(v As sgl2d) As int2d
   Return int2d(CInt(v.x), CInt(v.y))
End Function

Function toSgl2d(v As int2d) As sgl2d
   Return sgl2d(v.x, v.y)
End Function

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

'simple event timer

Type timer_type
   Private:
   Dim As Double tEnd
   Dim As Double tStart
   Dim As Double tSpan
   Dim As boolean active = false
   Public:
   Declare Sub start(duration As Double)
   Declare Sub stop_()
   Declare Function isActive() As boolean
   Declare Function ended() As boolean
   Declare Function timeLeft() As Double
   '~ declare sub restart()
End Type

Sub timer_type.start(duration As Double)
   tStart = Timer()
   tSpan = duration
   tEnd = tStart + tSpan
   active = true
End Sub

Sub timer_type.stop_()
   active = false
End Sub

'does NOT update the timer status
Function timer_type.isActive() As boolean
   Return active
End Function

'check only once in loop! Inactive after ended.
Function timer_type.ended() As boolean
   If active = false Then Return false
   If Timer() >= tEnd Then
      active = false
      Return true
   Else
      Return false
   End If
End Function

Function timer_type.timeLeft() As Double
   Dim As Double tLeft = tEnd - Timer
   Return IIf(tLeft < 0, 0, tLeft)
End Function

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

Type loop_timer_type
   Private:
   Dim As Double tStart
   Dim As Double tNow
   Dim As Double tPrev
   Dim As Double dt
   'dim as double dtAvg
   Dim As Integer pauseFlag = 0
   Public:
   Declare Sub init()
   Declare Sub update()
   Declare Sub togglePause()
   Declare Function isPaused() As Integer
   Declare Function getDt() As Double
   Declare Function getRunTime() As Double
End Type

Sub loop_timer_type.init()
   tStart = Timer
   tNow = tStart
   tPrev = tNow
   dt = 0.0
   pauseFlag = 0
   'dtAvg = 0.0
End Sub

Sub loop_timer_type.update()
   tPrev = tNow
   tNow = Timer
   dt = tNow - tPrev
   If pauseFlag = 1 Then dt = 0
   'dtAvg = 0.95 * dtAvg + 0.05 * dt
End Sub

Sub loop_timer_type.togglePause()
   pauseFlag Xor= 1
End Sub

Function loop_timer_type.isPaused() As Integer
   Return pauseFlag
End Function

Function loop_timer_type.getDt() As Double
   Return dt
End Function

Function loop_timer_type.getRunTime() As Double
   Return Timer - tStart
End Function

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

Const As Single V_BULLET = 400 'pixels/s

Type bullet_type
   Dim As sgl2d pos_
   Dim As sgl2d vel
   Dim As Single dist 'travel distance
End Type

'list can grow, but never shrink, for performance, non-sorted
Type bullet_list
   Private:
   Dim As Integer numItems
   Dim As bullet_type item(Any)
   Public:
   Dim As Single radius = 5
   Declare Constructor(startSize As Integer)
   Declare Constructor()
   Declare Destructor()
   Declare Sub Add(pos_ As sgl2d, dir_ As sgl2d)
   Declare Sub del(index As Integer)
   'not essential methods
   Declare Function numAlloc() As Integer
   Declare Function numInUse() As Integer
   Declare Function getPos(index As Integer) As sgl2d
   Declare Sub show()
   'non-list methods
   Declare Sub draw_()
   Declare Sub update(dt As Double, maxDist As Single)
End Type

Constructor bullet_list(startSize As Integer)
   If startSize > 0 Then
      ReDim item(startSize - 1)
   End If
End Constructor

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

Destructor bullet_list()
   Erase(item)
End Destructor

Sub bullet_list.add(pos_ As sgl2d, dir_ As sgl2d)
   Dim As Integer ub = UBound(item)
   'if list is full, increase list size by 1
   If numItems = ub + 1 Then
      ReDim Preserve item(numItems)
   End If
   item(numItems).pos_ = pos_
   item(numItems).vel = dir_ * V_BULLET
   item(numItems).dist = 0
   numItems += 1
End Sub

Sub bullet_list.del(index As Integer)
   'check valid index
   'if index >= 0 andalso index < numItems then
      'move last to del pos
      item(index) = item(numItems - 1)
      numItems -= 1
   'end if
End Sub

Function bullet_list.numAlloc() As Integer
   Return UBound(item) + 1
End Function

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

Function bullet_list.getPos(index As Integer) As sgl2d
   Return item(index).pos_
End Function

'for debugging
Sub bullet_list.show()
   Print "--- " & numInUse() & " / " & numAlloc() & " ---"
   For i As Integer = 0 To numItems - 1
      Print i, item(i).pos_.x, item(i).pos_.y
   Next
End Sub

Sub bullet_list.draw_()
   For i As Integer = 0 To numItems - 1
      With item(i)
         Circle(.pos_.x, .pos_.y), radius, RGB(200,200,0),,,,f
      End With
   Next
End Sub

'update positions, remove to too far
Sub bullet_list.update(dt As Double, maxDist As Single)
   For i As Integer = 0 To numItems - 1
      With item(i)
         .dist += V_BULLET * dt
         If .dist > maxDist Then
            del(i)
         Else
            .pos_ += .vel * dt
         End If
      End With
   Next
End Sub

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

Const As Single V_ENEMY_MAX = 200 'pixels/s
Const As Single V_ENEMY_MIN = 50 'pixels/s

Type enemy_type
   Dim As sgl2d pos_
   Dim As sgl2d vel 'velocity vector
End Type

'list can grow, but never shrink, for performance, non-sorted
Type enemy_list
   Private:
   Dim As Integer numItems
   Dim As enemy_type item(Any)
   Public:
   Dim As Single radius = 10
   Declare Constructor(startSize As Integer)
   Declare Constructor()
   Declare Destructor()
   Declare Sub Add(pos_ As sgl2d, dir_ As sgl2d)
   Declare Sub del(index As Integer)
   'not essential methods
   Declare Function numAlloc() As Integer
   Declare Function numInUse() As Integer
   Declare Function getPos(index As Integer) As sgl2d
   Declare Sub show()
   'non-list methods
   Declare Sub draw_()
   Declare Function update(dt As Double, targetPos As sgl2d, targetRadius As Single) As Integer
End Type

Constructor enemy_list(startSize As Integer)
   If startSize > 0 Then
      ReDim item(startSize - 1)
   End If
End Constructor

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

Destructor enemy_list()
   Erase(item)
End Destructor

Sub enemy_list.add(pos_ As sgl2d, dir_ As sgl2d)
   Dim As Integer ub = UBound(item)
   'if list is full, increase list size by 1
   If numItems = ub + 1 Then
      ReDim Preserve item(numItems)
   End If
   Dim As Single speed =  V_ENEMY_MIN + Rnd * (V_ENEMY_MAX - V_ENEMY_MIN)
   item(numItems).pos_ = pos_
   item(numItems).vel = dir_ * speed
   numItems += 1
End Sub

Sub enemy_list.del(index As Integer)
   'check valid index
   'if index >= 0 andalso index < numItems then
      'move last to del pos
      item(index) = item(numItems - 1)
      numItems -= 1
   'end if
End Sub

Function enemy_list.numAlloc() As Integer
   Return UBound(item) + 1
End Function

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

Function enemy_list.getPos(index As Integer) As sgl2d
   Return item(index).pos_
End Function

'for debugging
Sub enemy_list.show()
   Print "--- " & numInUse() & " / " & numAlloc() & " ---"
   For i As Integer = 0 To numItems - 1
      Print i, item(i).pos_.x, item(i).pos_.y
   Next
End Sub

Sub enemy_list.draw_()
   For i As Integer = 0 To numItems - 1
      With item(i)
        dim as single dpi = 6.28318530718
        dim as integer x = .pos_.x, y = .pos_.y, r = radius
        Circle(x, y), r, RGB(230,130,130),,,,f
        for rad as integer = 0 to 6
            circle(x+sin(dpi*rad/6)*r,y+cos(dpi*rad/6)*r), r*.25, rgb(152,80,80),,,,f
        next rad
        circle(x+r*.25,y+r*.25), r*.20, rgb(152,90,90),,,,f
        circle(x-r*.10,y-r*.35), r*.20, rgb(152,90,90),,,,f
        circle(x-r*.40,y+r*.10), r*.20, rgb(152,90,90),,,,f
      End With
   Next
End Sub

'update positions, remove to too far
Function enemy_list.update(dt As Double, targetPos As sgl2d, targetRadius As Single) As Integer
   Dim As Integer hitCount = 0
   For i As Integer = 0 To numItems - 1
      With item(i)
         .pos_ += .vel * dt
         Dim As Single dist = .pos_.dist(targetPos)
         If dist < (radius + targetRadius) Then
            del(i)
            hitCount += 1
         End If
      End With
   Next
   Return hitCount
End Function

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

Const As String KEY_ESC = Chr(27)
Const SW = 800, SH = 600
Const MAX_DIST = Sqr((SW / 2) ^ 2 + (SH / 2) ^ 2)
Const SPAWN_DIST = MAX_DIST * 1.2
Const PI = Atn(1) * 4
Dim Shared As screen_type scr = screen_type(SW, SH, fb.GFX_ALPHA_PRIMITIVES) '1024, 768

Declare Function main() As String

scr.activate() 'set screen

Randomize Timer

Dim As String quitStr
SetMouse( , , 0) 'hide cursor
quitStr = main()
SetMouse( , , 1) 'restore cursor
Print "End: " & quitStr
Sleep 5000
End

Function main() As String
   Dim As mouseType mouse
   Dim As Integer mouseEvent
   Dim As sgl2d aimPos, deltaPosNorm, barrelPos
   Dim As sgl2d gunPos = toSgl2d(scr.size) / 2 'centre
   Dim As Single gunRadius = 15
   Dim As timer_type trigTmr
   Dim As bullet_list bulletList
   Dim As timer_type spawnTmr
   Dim As enemy_list enemyList
   Dim As timer_type hitTmr
   Dim As loop_timer_type loopTimer
   Dim As Integer bulletCount, enemyCount, hitCount, damage, health = 10
   Dim As ULong gunColor = RGB(80, 80, 80)
   Dim As ULong barrelColor = RGB(160, 160, 160)
   Dim As ULong aimColor = RGB(80, 160, 80)
   Dim As Double spawnTime = 2.0
   Dim As String quitStr = ""
   'main loop
   spawnTmr.start(spawnTime)
   loopTimer.init()
   While quitStr = ""
      If InKey = KEY_ESC Then quitStr = "Quit, user abort request"
      mouseEvent = handleMouse(mouse)
      If mouse.buttons <> -1 Then aimPos = toSgl2d(mouse.pos)

      deltaPosNorm = (aimPos - gunPos).normalise()
      barrelPos = gunPos + deltaPosNorm * 24
     
      If mouse.lb = 1 Then
         If trigTmr.isActive = false Then
            trigTmr.start(0.2)
            bulletList.add(barrelPos, deltaPosNorm)
            bulletCount += 1
         End If
      End If
      If spawnTmr.ended() Then
         spawnTmr.start(spawnTime)
         enemyCount += 1
         If enemyCount Mod 10 = 0 Then spawnTime *= 0.9
         Dim As Single angle = Rnd * 2 * PI
         Dim As sgl2d relPos = sgl2d(Cos(angle) * SPAWN_DIST, Sin(angle) * SPAWN_DIST)
         enemyList.add(relPos + gunPos, -relPos.normalise())
      End If
      If hitTmr.ended() Then
         gunColor = RGB(80, 80, 80)
         barrelColor = RGB(160, 160, 160)
      End If
      trigTmr.ended() 'update timer
      bulletList.update(loopTimer.getdt(), MAX_DIST)
      damage = enemyList.update(loopTimer.getdt(), gunPos, gunRadius)
      health -= damage
      If damage > 0 Then
         gunColor = RGB(160, 80, 80)
         barrelColor = RGB(240, 160, 160)
         hitTmr.start(0.2)
      End If

      'check bullet <-> enemy collisions
      Dim As Integer iBullet = 0
      While iBullet < bulletList.numInUse()
         Dim As Integer iEnemy = 0
         While iEnemy < enemyList.numInUse()
            Dim As sgl2d bulletPos = bulletList.getPos(iBullet)
            Dim As Single dist = bulletPos.dist(enemyList.getPos(iEnemy))
            If dist < (bulletList.radius + enemyList.radius) Then
               bulletList.del(iBullet)
               enemyList.del(iEnemy)
               'list changed start over
               'iBullet = 0
               'iEnemy = 0
               'list changed recheck these indices, is this right?
               If iBullet > 0 Then iBullet -= 1
               If iEnemy > 0 Then iEnemy -= 1
               hitCount += 1
            End If
            iEnemy += 1
         Wend
         iBullet += 1
      Wend
     
      ScreenLock
     
      scr.clearScreen(RGBA(0, 0, 0, 255))
      'draw gun
      Circle(gunPos.x, gunPos.y), gunRadius, gunColor,,,,f
      'draw target aim
      Circle(aimPos.x, aimPos.y), 10, aimColor,,,0.1,f
      Circle(aimPos.x, aimPos.y), 10, aimColor,,,10.0,f
      'draw gun barrel
      barrelPos = gunPos
      For i As Integer = 0 To 4
         Circle(barrelPos.x, barrelPos.y), 5, barrelColor,,,,f
         barrelPos += (deltaPosNorm * 6)
      Next
      'draw all existing bullets & enemies
      bulletList.draw_()
      enemyList.draw_()
      Locate 1,1: Print "Press left mouse button to fire             Corona Blaster 2000!"
      Locate 2,1: Print "Bullet list: " & bulletList.numInUse() & " / " & bulletList.numAlloc()
      Locate 3,1: Print "Corona list: " & enemyList.numInUse() & " / " & enemyList.numAlloc()
      Locate 4,1: Print "Health: " & health
      Locate 5,1: Print "Hits: " & hitCount
   
      ScreenUnLock

      Sleep 1
      loopTimer.update()
      If health <= 0 Then quitStr = "You died from COVID 19!"
   Wend
   Return quitStr
End Function


My high score was 183. Is there a way to win?

[badidea]

Are you kidding me! I fixed it.

Looks good.

My high score was 183. Is there a way to win?

No, infection is unavoidable :-)

[dodicat]

Shooting click area outside the shape.
You must annihilate all green pixels before they leave the shape.
A single pixel might get out but you must finish it off anyway.

Code: Select all


Type Point
    As Single x,y
    As Single dx,dy
End Type

const num=3   ''' dificulty
dim shared as long maxbullet=400*num
Const ball=Rgb(0,110,0)
Const cp=Rgb(50,50,50)
Dim Shared As Ulong clr

 #define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius

 Const pi=4*Atn(1)
Sub rotateimage(im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255))
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
   If runflag=0 Then Screeninfo xres,yres,,,pitchS:runflag=1
    Dim As Any Ptr rowS=Screenptr
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx
                 If x+shiftx >=0 Then 'on the screen
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then 'on the image
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
    Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
   If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
End If:End If:End If:End If
End If:End If:End If:End If
        Next x
    Next y
End Sub

Function spline(p() As Point,t As Single) As Point
    #macro set(n)
    0.5 *(     (2 * P(2).n) +_
   (-1*P(1).n + P(3).n) * t +_
    (2*P(1).n - 5*P(2).n + 4*P(3).n - P(4).n) * t*t +_
    (-1*P(1).n + 3*P(2).n- 3*P(3).n + P(4).n) * t*t*t)
    #endmacro
    Return Type<Point>(set(x),set(y))',set(z))
End Function

Sub GetCatmull(v() As Point,outarray() As Point,arraysize As Integer=500)
    Dim As Point p(1 To 4)
    Redim outarray(0)
    Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
    If stepsize>1 Then stepsize=1
    For n As Integer=2 To Ubound(v)-2
        p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
        For t As Single=0 To 1 Step stepsize
            Redim Preserve outarray(1 To Ubound(outarray)+1)
            outarray(Ubound(outarray))=spline(p(),t)'temp
        Next t
    Next n
End Sub

Sub DrawCurve(a() As Point,col As Ulong)
    Pset(a(Lbound(a)).x,a(Lbound(a)).y),col
    For z As Integer=Lbound(a) To Ubound(a)
        Line-(a(z).x,a(z).y),col
    Next z
End Sub

Sub DrawSetPoints(a() As Point,col As Ulong)
    For n As Long=Lbound(a) To Ubound(a)
        Circle(a(n).x,a(n).y),4,col,,,,f
        Draw String(a(n).x,a(n).y),Str(n),Rgb(100,100,100)
    Next n
End Sub

Sub thickline(x1 As Long,y1 As Long,x2 As Long,y2 As Long,thickness As Double,p As Ulong,im As Any Ptr=0)
        Dim As Double h=Sqr((x2-x1)^2+(y2-y1)^2):If h=0 Then h=1e-6
        Dim As Double s= (y1-y2)/h ,c=(x2-x1)/h
            Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),p
            Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
            Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),p
            Line im,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
            Paint im,((x1+x2)/2, (y1+y2)/2), p, p
End Sub

Sub lineto(x1 As Long,y1 As Long,x2 As Long,y2 As Long,d As Double,th As Double,col As Ulong)
    Var L=Sqr((x1-x2)^2 + (y1-y2)^2),dx=x2-x1,dy=y2-y1
    thickline(x1,y1,x1+d*dx/L,y1+d*dy/L,th,col)
End Sub

Function pathto(x1 As Long,y1 As Long,x2 As Long,y2 As Long,d As Single,L As Single) As Point
    Var dx=x2-x1,dy=y2-y1
    Return Type(x1+d*dx/L,y1+d*dy/L)
End Function

Sub cannon(pt As Point,mx As Long,my As Long)
   Circle(pt.x,pt.y),7,Rgb(200,200,201),,,,f
    lineto(pt.x,pt.y,mx,my,10,15,Rgb(200,200,200))
    lineto(pt.x,pt.y,mx,my,30,5,Rgb(0,100,200))
End Sub

Function inpolygon(p1() As point,Byval p2 As point) As Integer 'is a point in a polygon?
    #define Winder(L1,L2,p) ((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y))
    Dim As Integer index,nextindex,k=Ubound(p1)+1,wn
    For n As Integer=1 To Ubound(p1)
        index=n Mod k:nextindex=(n+1) Mod k
        If nextindex=0 Then nextindex=1
        If p1(index).y<=p2.y Then
            If p1(nextindex).y>p2.y Andalso  Winder(p1(index),p1(nextindex),p2)>0 Then wn+=1
        Else
            If p1(nextindex).y<=p2.y Andalso Winder(p1(index),p1(nextindex),p2)<0 Then wn-=1
        End If
    Next n
    Return wn
End Function

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Sub createzone(p() As Point,c As Point, rad As Long,cmul() As Point)
    Dim As Long ctr,radius
    For z As Single=0 To 2*pi Step 2*pi/24
        ctr+=1
        If ctr Mod 2=0 Then radius=rad Else radius=.95*rad
        Redim Preserve p(1 To ctr)
        p(ctr).x=c.x+1.2*radius*Cos(z)
        p(ctr).y=c.y+radius*Sin(z)
    Next z
    Redim Preserve p(1 To Ubound(p)+2)
    p(Ubound(p)-1)=p(2)
    p(Ubound(p))=p(3)
    GetCatmull(p(),cmul())
End Sub

Sub advance(pts() As Point)
    For m As Long=Lbound(pts) To Ubound(pts)
         pts(m).x+=pts(m).dx
         pts(m).y+=pts(m).dy
         if pts(m).x<40 or pts(m).x >1024-40 then pts(m).dx=-pts(m).dx
         if pts(m).y<40 or pts(m).y >768-40 then pts(m).dy=-pts(m).dy
         Next
End Sub
   
    Sub drawballs(b() As Point,im() As Any Ptr)
        For m As Long=1 To Ubound(b)
         Put(b(m).x-40,b(m).y-40),im(m),trans
         Next m
    End Sub
       
    Function check(c() As Point,x As Long) As Long
    For n As Long=1 To Ubound(c)
        If Point(c(n).x,c(n).y)=clr Then circle(c(n).x,c(n).y),10,rgb(200,0,0): Return 1
    Next n
    Return 0
    End Function
           
    Function whatsleft(p() As Any Ptr) As Long
    For n As Long=1 To Ubound(p)
        For x As Long=0 To 80
            For y As Long=0 To 80
            If Point(x,y,p(n))=ball Then Return 1
            Next y
        Next x
    Next n
        Return 0
    End Function
   
    #macro SHOOT
    If mb=1 And burst < 7 and inpolygon(p(),type(mx,my)) =0 Then
        burst+=1
        counter+=1
        Var l=Sqr((c(n).x-mx)*(c(n).x-mx)+(c(n).y-my)*(c(n).y-my))
        Var idx=0
        For m As Single =35 To L
        Var p=pathto(c(n).x,c(n).y,mx,my,m,l)
        If Point(p.x,p.y)=clr Then
            For k As Long=1 To Ubound(b)
                If incircle(b(k).x,b(k).y,36,p.x,p.y) Then idx=k:Exit For
            Next
       If idx Then
           Var x=p.x-(b(idx).x-40)
           Var y=p.y-(b(idx).y-40)
        Circle im(idx),(x,y),4,Rgb(255,0,255),,,,f: Exit For
       End If
        End If
        Pset(p.x,p.y),Rgb(200,200,200)
        Next m
    End If
    #endmacro
   
function mainfb() as long
Redim As Point p(),c()
createzone p(),Type(1024\2,768\2),350,c()

Screen 20,32
Dim As String arrow = _
"C4278241280BM25,0M+-49,22M+8,8M+37,-15M+-6,58M+10,-21"_
&"M+8,18M+-4,-54M+38,10M+6,-10M+-48,-15"_
&"BM+-1,7P4294904320,4278241280"
Dim As Any Ptr i=Imagecreate(50,50)
Draw i,arrow

randomize
Dim As Point b(1 To num)
Dim As Any Ptr im(1 To Ubound(b))
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
Dim As Single a
For n As Long=1 To ubound(b)
    Select Case n
    Case 1:a=1
    Case 2:a=1.25
    Case 3:a=.75
    case else:a=1
    End Select
    im(n)=Imagecreate(40*2,40*2)
    Circle im(n),(20*2,20*2),18*2,ball,,,a,f
    b(n)=Type(Range(300,700),Range(300,500),(Rnd-Rnd)/3,(Rnd-Rnd)/3)
Next

Cls
Put(300,300),im(1),trans
 clr=Point(320,320) 'get the correct green

Dim As Long fps,counter
Dim As Long mx,my,mb,burst
setmouse ,,,1
Do

For n As Long=Lbound(c) To Ubound(c)-1
    Getmouse mx,my,,mb
    Var a=Atan2(-(c(n+1).y-c(n).y),(c(n+1).x-c(n).x))'slope of curve
    Screenlock
    Cls
    Draw String(20,20),"FPS "&fps,Rgb(200,200,200)
    advance(b())
    drawballs(b(),im())
    SHOOT
    rotateimage(i,a+pi/2+pi,c(n).x-25,c(n).y-25)
    cannon(c(n),mx,my)
 
   If check(c(),n) or counter>maxbullet Then
        Draw String(40,150),"YOU LOST",Rgb(0,100,255)
        Screenunlock: Exit Do
   End If
   
   If whatsleft(im())=0 Then
        Draw String(40,150),"YOU WON",Rgb(0,100,255)
   Screenunlock: Exit Do
  Else
      Draw String(10,130),"Bullets: "&counter &"  of " & maxbullet,Rgb(0,100,255)
   End If
    drawcurve(c(),cp)
    Screenunlock
Sleep regulate(30,fps),1
If Inkey =Chr(27) Then Exit Do
If mb=0 Then burst=mb
Next n
Loop
Draw String(10,170),"Bullets: "&counter &"  of " & maxbullet,Rgb(0,100,255)
drawcurve(c(),cp)
Sleep
imagedestroy i
for n as long=1 to ubound(im)
    imagedestroy im(n)
    next n
return 0
end function

mainfb
 
 

[Dr_D]

Shooting click area outside the shape.
You must annihilate all green pixels before they leave the shape.
A single pixel might get out but you must finish it off anyway.

Ok... That thing is pretty cool man. :)
It took me a minute to figure out that you have to click outside the "cell" to shoo the ray though. Have you considered making it where you can just shoot towards the cursor at any position?

By the way, I got 1051 out of 1200...

[badidea]

Shooting click area outside the shape.
You must annihilate all green pixels before they leave the shape.
A single pixel might get out but you must finish it off anyway.

You are a clever coder, but making games is not your best skill :-)
Or I am just too stupid. I don't understand how to play it.

Edit: I figured it out. Just point at the opposite side, outside the cell. But it is not easy to win.

[BasicCoder2]

Thanks badidea. At first I thought you meant the opposite side of the green blobs but it is the opposite side of the screen!!

[dodicat]

You can remove
and inpolygon(p(),type(mx,my)) =0 in line 191 so the mouse is active anywhere, but I found that too easy.
You can make the burst bigger (30 = a gatling gun).
Anyway thanks for testing, the actual Meteorite shooter is more fun to play.

[Dr_D]

You can remove
and inpolygon(p(),type(mx,my)) =0 in line 191 so the mouse is active anywhere, but I found that too easy.
You can make the burst bigger (30 = a gatling gun).
Anyway thanks for testing, the actual Meteorite shooter is more fun to play.

Yep... the Meteorite Shooter is very fun to play. This whole thread is fun. :)