Pinball

[bplus]

Well if you get figety I am testing a circular board here:

Code: (Select All)

Option _Explicit
_Title "Test flippers with Circle BG: left ctrl for left flipper, right ctrl for right" 'b+ 2024-11-16
' instead of a light beam reflecting off surface angle in = angle out

' here we try angle out is perpendicular to flipper
' result: not a hell of allot of difference flipper goes righjt over the ball near tip
' and ball falls right through or trips and dribbles???????
' 2024-11-23 moved Weird Filpper code into here and dumped previous  code I had.

' 2024-11-24 dont let bs go below zero better yet below gravity.
' Moved baseX of flippers closer to walls so ball isn't stuck in the corner.
' Increased power down line of flipper contact from i/200 to i/50 because
' gravity was increased to roll ball down flipper faster from dead stop.
' More deadening of bs when hitting walls or flippers not moving.

' 2024-11-25 now add a Circle Board BackGround = BG
Const XMax = 740, YMax = 740
Const ScR = 370, Gravity = .5

Type FlipperType
    As Single baseX, baseY ' DrawFlipper needs these
    As Single tipX, tipY ' need to track collisions on ends of flipper
    As Single UpA, DownA, CurA
    As Long LeftFlipTF, TargetUpTF ' true false boolean
End Type

Type CircleType
    As Single x, y, r
End Type

Dim As FlipperType leftFlip, rightFlip
' some parts of Type are constant declare now
leftFlip.LeftFlipTF = -1
leftFlip.baseX = ScR - 300
leftFlip.baseY = YMax - 140
leftFlip.UpA = -_Pi(1 / 6) ' 315 degrees NE
leftFlip.DownA = _Pi(1 / 6)
leftFlip.TargetUpTF = 0 ' test a key press OK
leftFlip.CurA = leftFlip.DownA ' flipper at rest in down position

rightFlip.LeftFlipTF = 0
rightFlip.baseX = ScR + 300
rightFlip.baseY = YMax - 140
rightFlip.UpA = _Pi(7 / 6) ' 180 + 45 = 225 degrees NE
rightFlip.DownA = _Pi(5 / 6)
rightFlip.TargetUpTF = 0 ' flipper at rest in down position
rightFlip.CurA = rightFlip.DownA

Dim Shared FLen, BaseR, TipR
FLen = 250: BaseR = 30: TipR = 12
Dim Shared LFC(FLen) As CircleType, RFC(FLen) As CircleType
SetFlipperRadii
Dim ftime, rtime
Dim bx, by, br, bs, ba, bdx, bdy, i, lffirstI, lflastI, rffirsti, rflasti

Screen _NewImage(XMax, YMax, 32): _ScreenMove 320, 0
br = 25

restart:
bx = ScR: by = br: bs = 10
If Rnd < .5 Then ba = _Pi((8 + 2 * Rnd) / 12) Else ba = _Pi((4 - 2 * Rnd) / 12)
bdx = bs * Cos(ba): bdy = bs * Sin(ba)
Color , &HFF220044
Do
    Cls: Print "ba bs"; _R2D(ba); bs
    'Sleep
    FC3 ScR, ScR, ScR + 3, &HFFBB0000
    FC3 ScR, ScR, ScR, &HFF888888
    If _KeyDown(100306) And Timer(.001) > ftime + .1 Then leftFlip.TargetUpTF = -1 ' left side ctrl
    If _KeyDown(100305) And Timer(.001) > rtime + .1 Then rightFlip.TargetUpTF = -1 ' right side ctrl
    drawBall bx, by, br, _RGB32(250)
    DrawFlipper leftFlip
    DrawFlipper rightFlip

    'update ball
    bdy = bdy + Gravity
    ba = _Atan2(bdy, bdx)
    bx = bx + bdx
    by = by + bdy
    If bs < Gravity Then bs = Gravity ' limit lowest speed
    'If bs > 20 Then bs = 20
    If by > YMax - 1.25 * br Then drawBall bx, by, br, _RGB32(250): _Display: Exit Do ' drain
    'keep ball inside board radius
    If _Hypot(by - ScR, bx - ScR) + br > ScR Then ' move back ball
        ba = _Atan2(by - ScR, bx - ScR) ' angle ball to center
        bx = ScR + (ScR - br) * Cos(ba): by = ScR + (ScR - br) * Sin(ba)
        ba = ba - _Pi
        bs = bs - 5 * Gravity
        If bs < Gravity Then bs = Gravity
        bdx = bs * Cos(ba): bdy = bs * Sin(ba)
        bx = bx + bdx: by = by + bdy
    End If

    'update flippers
    lffirstI = -1: rffirsti = -1: lflastI = -1: rflasti = -1
    For i = 0 To FLen
        If _Hypot(by - LFC(i).y, bx - LFC(i).x) < br + LFC(i).r Then ' collision
            If lffirstI < 0 Then lffirstI = i Else lflastI = i
        End If
        If _Hypot(by - RFC(i).y, bx - RFC(i).x) < br + RFC(i).r Then ' collision
            If rffirsti < 0 Then rffirsti = i Else rflasti = i
        End If
    Next
    If lffirstI >= 0 Then
        If lflastI > 0 Then
            i = (lffirstI + lflastI) / 2
        Else
            i = lffirstI
        End If

        If leftFlip.TargetUpTF And leftFlip.CurA <> leftFlip.UpA Then
            bs = bs + i / 25
        Else
            bs = bs - 5 * Gravity
            If bs < Gravity Then bs = Gravity
        End If
        ba = _Atan2(by - LFC(i).y, bx - LFC(i).x)
        bx = LFC(i).x + (br + LFC(i).r) * Cos(ba): by = LFC(i).y + (br + LFC(i).r) * Sin(ba) ' move ball back above flipper
        bdx = bs * Cos(ba): bdy = bs * Sin(ba)
        bx = bx + bdx: by = by + bdy
        'If leftFlip.TargetUpTF Then leftFlip.TargetUpTF = 0: ftime = Timer(.001)
    ElseIf rffirsti >= 0 Then
        If rflasti > 0 Then
            i = (rffirsti + rflasti) / 2
        Else
            i = rffirsti
        End If
        If rightFlip.TargetUpTF And rightFlip.CurA <> rightFlip.UpA Then
            bs = bs + i / 25
        Else
            bs = bs - 5 * Gravity
            If bs < Gravity Then bs = Gravity
        End If
        ba = _Atan2(by - RFC(i).y, bx - RFC(i).x)
        bx = RFC(i).x + (br + RFC(i).r) * Cos(ba): by = RFC(i).y + (br + RFC(i).r) * Sin(ba) ' move ball back above flipper
        bdx = bs * Cos(ba): bdy = bs * Sin(ba)
        bx = bx + bdx: by = by + bdy
        'If rightFlip.TargetUpTF Then rightFlip.TargetUpTF = 0: rtime = Timer(.001)
    End If

    _Display
    _Limit 60
Loop Until _KeyDown(27)
If _KeyDown(27) = 0 Then _Delay 2: GoTo restart

Function FlipAngle (f As FlipperType)
    Dim da
    da = _Pi(1 / 48)
    If f.LeftFlipTF Then ' left flipper
        If f.TargetUpTF Then ' move CCW subtract
            If f.CurA - da < f.UpA Then
                f.CurA = f.UpA
                f.TargetUpTF = 0 'target hit
            Else
                f.CurA = f.CurA - da
            End If
        Else ' move CW
            If f.CurA + da > f.DownA Then f.CurA = f.DownA Else f.CurA = f.CurA + da
        End If
    Else ' right flip
        If f.TargetUpTF Then ' move CW
            If f.CurA + da > f.UpA Then
                f.CurA = f.UpA
                f.TargetUpTF = 0
            Else
                f.CurA = f.CurA + da
            End If
        Else ' move CCW
            If f.CurA - da < f.DownA Then f.CurA = f.DownA Else f.CurA = f.CurA - da
        End If
    End If
    FlipAngle = f.CurA
End Function

Sub SetFlipperRadii
    Dim i, f
    f = (BaseR - TipR) / FLen
    For i = 0 To FLen
        LFC(i).r = BaseR - i * f
        RFC(i).r = LFC(i).r
    Next
End Sub

Sub DrawFlipper (f As FlipperType)
    ' setup to drawLink
    Dim ang, i
    ang = FlipAngle(f)
    For i = 0 To FLen
        If f.LeftFlipTF Then
            LFC(i).x = f.baseX + i * Cos(ang)
            LFC(i).y = f.baseY + i * Sin(ang)
            FC3 LFC(i).x, LFC(i).y, LFC(i).r, &HFFFF4400
        Else
            RFC(i).x = f.baseX + i * Cos(ang)
            RFC(i).y = f.baseY + i * Sin(ang)
            FC3 RFC(i).x, RFC(i).y, RFC(i).r, &HFFFF4400
        End If
    Next
    For i = 0 To FLen
        If f.LeftFlipTF Then
            LFC(i).x = f.baseX + i * Cos(ang)
            LFC(i).y = f.baseY + i * Sin(ang)
            FC3 LFC(i).x, LFC(i).y, LFC(i).r - 5, &HFFFFFFFF
        Else
            RFC(i).x = f.baseX + i * Cos(ang)
            RFC(i).y = f.baseY + i * Sin(ang)
            FC3 RFC(i).x, RFC(i).y, RFC(i).r - 5, &HFFFFFFFF
        End If
    Next
End Sub

Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' no suffix punctuation use the Global Default Type as Long or Single or Double
    Dim As Long r2, x, y ' for Option _Explicit
    If r < 1 Then Exit Sub
    Line (cx - r, cy)-(cx + r, cy), clr~&, BF
    r2 = r * r
    Do
        y = y + 1
        x = Sqr(r2 - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
    Loop Until y = r
End Sub

Sub drawBall (x, y, r, c As _Unsigned Long)
    Dim rred As Long, grn As Long, blu As Long, rr As Long, f
    rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
    For rr = r To 0 Step -1
        f = 1 - Sin(rr / r) ' thank OldMoses for Sin ;-))
        FC3 x, y, rr, _RGB32(rred * f, grn * f, blu * f)
    Next
End Sub