Option _Explicit
_Title "Pinball Molly v 1-1: left ctrl for left flipper, right ctrl for right" 'b+ 2024-11-16
' Thanks to Rod Bird at JB Forum for inspiring this Pinball Game with his from which
' I used sound effects.
' 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 numbers tweaked a bit
' 2024-11-26 add kickers now, tweak add bonus rounds I name it Molly v1.0
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 ' finish flipper setup
FLen = 250: BaseR = 30: TipR = 12
Dim Shared LFC(FLen) As CircleType, RFC(FLen) As CircleType
SetFlipperRadii
Dim bx, by, br, bs, ba, bdx, bdy ' ball stuff
Dim lffirstI, lflastI, rffirsti, rflasti ' ball collision flipper stuff
Dim As Long i, score, bell, fall, balls, bonus, f
Dim k$, s$
Dim Shared As CircleType plus(7)
For i = 0 To 7
plus(i).x = ScR + (ScR - 50) * Cos(i * _Pi(1 / 6) + _Pi(11 / 12))
plus(i).y = ScR + (ScR - 50) * Sin(i * _Pi(1 / 6) + _Pi(11 / 12))
plus(i).r = 20
Next
Screen _NewImage(XMax, YMax, 32): _ScreenMove 320, 0
bell = _SndOpen("bell.wav")
fall = _SndOpen("fall.wav")
bonus = _SndOpen("digit.wav")
f = _LoadFont("arial.ttf", 24)
_Font f
br = 25 ' ball radius
restart:
bx = ScR: by = br: bs = 10 ' ball loacation and speed
' shoot ball out towards one of the flippers randomly
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
If bs > 30 Then bs = 30
Cls
FC3 ScR, ScR, ScR + 3, &HFFBB0000
FC3 ScR, ScR, ScR, &HFF888888
If _KeyDown(100306) Then leftFlip.TargetUpTF = -1 ' left side ctrl
If _KeyDown(100305) Then rightFlip.TargetUpTF = -1 ' right side ctrl
drawBall bx, by, br, _RGB32(250)
DrawFlipper leftFlip
DrawFlipper rightFlip
For i = 0 To 2
DrawKicker i
Next
For i = 0 To 7
DrawBonus i
Next
s$ = _Trim$(Str$(score))
Color &HFFFFFFFF, &HFFFF0000
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 150), s$
Color &HFFFFFFFF, &HFF220044
'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 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 ' handle left flipper collisions
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 - 3 * 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
ElseIf rffirsti >= 0 Then ' handle right flipper collisions
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 - 3 * 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
End If
' collision Kickers
For i = 0 To 2
If _Hypot(by - k(i).y, bx - k(i).x) <= k(i).r + br Then ' left kick
FC3 k(i).x, k(i).y, k(i).r + 15, &HFFFFFFFF
_SndPlay bell
score = score + 100
ba = _Atan2(by - k(i).y, bx - k(i).x) + Rnd - .5 ' avoid infinite loops
bx = k(i).x + (br + k(i).r) * Cos(ba)
by = k(i).y + (br + k(i).r) * Sin(ba)
bs = bs * 1.3
bdx = bs * Cos(ba): bdy = bs * Sin(ba)
End If
Next
' ball over Bonus round
For i = 0 To 7
If _Hypot(by - plus(i).y, bx - plus(i).x) <= plus(i).r Then ' bonus
FC3 plus(i).x, plus(i).y, plus(i).r, &HFFFFFFFF
_SndPlay bonus
score = score + 50
End If
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
If _KeyDown(27) = 0 Then
_SndPlay fall
balls = balls + 1
Color &HFFFFFFFF, &HFFFF0000
If balls >= 5 Then
s$ = "5 balls played, Game Over!"
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 127), s$
_Display
k$ = "" ' for some reason sleep is not working right after first time it doesn't
While k$ = ""
k$ = InKey$
_Limit 30
Wend
End
Else
s$ = "Press any for ball:" + Str$(balls + 1)
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 127), s$
Color &HFFFFFFFF, &HFF220044
_Display
k$ = "" ' for some reason sleep is not working right after first time it doesn't
While k$ = ""
k$ = InKey$
_Limit 30
Wend
GoTo restart
End If
End If
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 DrawKicker (kNum)
FC3 k(kNum).x, k(kNum).y, k(kNum).r + 20, &HFFFF0000
FC3 k(kNum).x, k(kNum).y, k(kNum).r + 18, &HFFFFFFFF
star k(kNum).x, k(kNum).y, k(kNum).r, k(kNum).r + 15, 24, 0, &HFFFF0000
End Sub
Sub DrawBonus (Num)
FC3 plus(Num).x, plus(Num).y, plus(Num).r, &HFFFF0000
FC3 plus(Num).x, plus(Num).y, plus(Num).r - 2, &HFFFFFFFF
star plus(Num).x, plus(Num).y, 5, plus(Num).r - 5, 7, 0, &HFFFF0000
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
Sub star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
Dim pAngle, radAngleOffset, x1, y1, x2, y2, x3, y3, i As Long
pAngle = _D2R(360 / nPoints): radAngleOffset = _D2R(angleOffset)
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
ftri x1, y1, x2, y2, x3, y3, K
'triangles leaked
Line (x1, y1)-(x2, y2), K
Line (x2, y2)-(x3, y3), K
Line (x3, y3)-(x1, y1), K
x1 = x3: y1 = y3
Next
Paint (x, y), K, K
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
11-27-2024, 08:51 PM (This post was last modified: 11-27-2024, 08:59 PM by bplus.)
Wow! Thanks Pete! (that's Pete factorial BTW )
I just tried a _FullScreen mod THAT ignores that pesky Taskbar. (NOT Full Screen, just fits on my screen which I thought was small!)
Now you can look at Molly 2 ways:
1. She's gained so much weight that her face is oval OR
2. She's now tilted back and you are looking at a circlular face at a slant like Pinball would show.
Ohhh just got an idea to add to that 3D slant thing
11-27-2024, 10:16 PM (This post was last modified: 11-27-2024, 10:35 PM by bplus.)
Towards 3D Molly v1-2
Code: (Select All)
Option _Explicit
_Title "Pinball Molly v1-2: left ctrl for left flipper, right ctrl for right" 'b+ 2024-11-16
' Thanks to Rod Bird at JB Forum for inspiring this Pinball Game with his from which
' I used sound effects.
' 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 numbers tweaked a bit
' 2024-11-26 add kickers now, tweak add bonus rounds I name it Molly v1.0
' 2024-11-27 mouth score v1.1
' 2024-11-27 v1-2 FullScreen add some 3d effects
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 ' finish flipper setup
FLen = 250: BaseR = 30: TipR = 12
Dim Shared LFC(FLen) As CircleType, RFC(FLen) As CircleType
SetFlipperRadii
Dim Shared br ' for making image
Dim ball, bx, by, bs, ba, bdx, bdy ' ball stuff
Dim lffirstI, lflastI, rffirsti, rflasti ' ball collision flipper stuff
Dim As Long i, score, bell, fall, balls, bonus, f
Dim k$, s$
Dim Shared As CircleType plus(7)
For i = 0 To 7
plus(i).x = ScR + (ScR - 50) * Cos(i * _Pi(1 / 6) + _Pi(11 / 12))
plus(i).y = ScR + (ScR - 50) * Sin(i * _Pi(1 / 6) + _Pi(11 / 12))
plus(i).r = 20
Next
Screen _NewImage(XMax, YMax, 32) ': _ScreenMove 320, 0
_FullScreen
bell = _SndOpen("bell.wav")
fall = _SndOpen("fall.wav")
bonus = _SndOpen("digit.wav")
f = _LoadFont("arial.ttf", 24)
_Font f
br = 25 ' ball radius
ball = makeSkinnyBall& ' after br !!!
restart:
bx = ScR: by = br: bs = 10 ' ball loacation and speed
' shoot ball out towards one of the flippers randomly
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
If bs > 30 Then bs = 30
Cls
FC3 ScR, ScR, ScR + 3, &HFFBB8800 'back circle
FC3 ScR, ScR, ScR, &HFF888888
If _KeyDown(100306) Then leftFlip.TargetUpTF = -1 ' left side ctrl
If _KeyDown(100305) Then rightFlip.TargetUpTF = -1 ' right side ctrl
For i = 0 To 7 ' draw under the ball stuff
DrawBonus i
Next
For i = 0 To 2
DrawKickerBottom i
Next
' here's the ball image
_PutImage (bx - br * 1.7786 - 1, by - br * 1.7786 - 1), ball, 0
DrawFlipper leftFlip
DrawFlipper rightFlip
For i = 0 To 2 ' Kicker tops over the ball
DrawKicker i
Next
s$ = _Trim$(Str$(score))
Color &HFFFFFFFF, &HFFFF0000
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 150), s$
Color &HFFFFFFFF, &HFF220044
'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 by > YMax - 1.25 * br Then 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 ' handle left flipper collisions
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 - 3 * 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
ElseIf rffirsti >= 0 Then ' handle right flipper collisions
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 - 3 * 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
End If
' collision Kickers
For i = 0 To 2
If _Hypot(by - k(i).y, bx - k(i).x) <= k(i).r + br Then ' left kick
FC3 k(i).x, k(i).y, k(i).r + 15, &HFFFFFFFF
_SndPlay bell
score = score + 100
ba = _Atan2(by - k(i).y, bx - k(i).x) + Rnd - .5 ' avoid infinite loops
bx = k(i).x + (br + k(i).r) * Cos(ba)
by = k(i).y + (br + k(i).r) * Sin(ba)
bs = bs * 1.3
bdx = bs * Cos(ba): bdy = bs * Sin(ba)
End If
Next
' ball over Bonus round
For i = 0 To 7
If _Hypot(by - plus(i).y, bx - plus(i).x) <= plus(i).r Then ' bonus
FC3 plus(i).x, plus(i).y, plus(i).r, &HFFFFFFFF
_SndPlay bonus
score = score + 50
End If
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
If _KeyDown(27) = 0 Then
_SndPlay fall
balls = balls + 1
Color &HFFFFFFFF, &HFFFF0000
If balls >= 5 Then
s$ = "5 balls played, Game Over!"
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 127), s$
_Display
k$ = "" ' for some reason sleep is not working right after first time it doesn't
While k$ = ""
k$ = InKey$
_Limit 30
Wend
End
Else
s$ = "Press any for ball:" + Str$(balls + 1)
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 127), s$
Color &HFFFFFFFF, &HFF220044
_Display
k$ = "" ' for some reason sleep is not working right after first time it doesn't
While k$ = ""
k$ = InKey$
_Limit 30
Wend
GoTo restart
End If
End If
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 + 10, 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 + 10, 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, &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, &HFFFFFFFF
End If
Next
End Sub
Sub DrawKickerBottom (kNum)
FC3 k(kNum).x, k(kNum).y + 40, k(kNum).r + 20, &HFF990000
FC3 k(kNum).x, k(kNum).y + 40, k(kNum).r + 18, &HFF555555
End Sub
Sub DrawKicker (kNum)
FC3 k(kNum).x, k(kNum).y, k(kNum).r + 20, &HFFFF0000
FC3 k(kNum).x, k(kNum).y, k(kNum).r + 18, &HFFFFFFFF
star k(kNum).x, k(kNum).y, k(kNum).r, k(kNum).r + 15, 24, 0, &HFFFF0000
End Sub
Sub DrawBonus (Num)
FC3 plus(Num).x, plus(Num).y, plus(Num).r, &HFFFF0000
FC3 plus(Num).x, plus(Num).y, plus(Num).r - 2, &HFFFFFFFF
star plus(Num).x, plus(Num).y, 5, plus(Num).r - 5, 7, 0, &HFFFF0000
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 star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
Dim pAngle, radAngleOffset, x1, y1, x2, y2, x3, y3, i As Long
pAngle = _D2R(360 / nPoints): radAngleOffset = _D2R(angleOffset)
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
ftri x1, y1, x2, y2, x3, y3, K
'triangles leaked
Line (x1, y1)-(x2, y2), K
Line (x2, y2)-(x3, y3), K
Line (x3, y3)-(x1, y1), K
x1 = x3: y1 = y3
Next
Paint (x, y), K, K
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
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
Function makeSkinnyBall& ' for this game
Dim As Long im, g, rr
Dim f
g = 200
im = _NewImage(2 * br * 1.7786 + 2, 2 * br * 1.7786 + 2, 32)
_Dest im
For rr = br To 0 Step -1
f = 1 - Sin(rr / (br + 5)) ' thank OldMoses for Sin ;-))
FEllipse br * 1.7786 + 1, br * 1.7786 + 1, rr, rr * 1.7786, _RGB32(g * f)
Next
_Dest 0
makeSkinnyBall& = im
End Function
Sub FEllipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
Well the round ball will probabably only work on my screen but here's what it looks like for me:
EDIT: 3D Flippers a little bit too!
OK I think I can make it look like this on anyones screen, stay tuned... (The roundness of ball is what I fear will be off.)
11-27-2024, 11:42 PM (This post was last modified: 11-28-2024, 09:22 AM by bplus.)
Heh, heh
OK this should make the ball round on anyone's screen. I am using the _deskTopWidth/_deskTopHeight ratio as ScrF, SO when the ball is drawn with FilledEllipsii it will appear round _FullScreen Mode:
Code: (Select All)
Option _Explicit
_Title "Pinball Molly v1-2: left ctrl for left flipper, right ctrl for right" 'b+ 2024-11-16
' Thanks to Rod Bird at JB Forum for inspiring this Pinball Game with his from which
' I used sound effects.
' 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 numbers tweaked a bit
' 2024-11-26 add kickers now, tweak add bonus rounds I name it Molly v1.0
' 2024-11-27 mouth score v1.1
' 2024-11-27 v1-2 FullScreen add some 3d effects
' 2024-11-27 v1-2 make ball look round in any screen
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 ' finish flipper setup
FLen = 250: BaseR = 30: TipR = 12
Dim Shared LFC(FLen) As CircleType, RFC(FLen) As CircleType
SetFlipperRadii
Dim Shared br, ScrF ' for making image
ScrF = _DesktopWidth / _DesktopHeight
Dim ball, bx, by, bs, ba, bdx, bdy ' ball stuff
Dim lffirstI, lflastI, rffirsti, rflasti ' ball collision flipper stuff
Dim As Long i, score, bell, fall, balls, bonus, f
Dim k$, s$
Dim Shared As CircleType plus(7)
For i = 0 To 7
plus(i).x = ScR + (ScR - 50) * Cos(i * _Pi(1 / 6) + _Pi(11 / 12))
plus(i).y = ScR + (ScR - 50) * Sin(i * _Pi(1 / 6) + _Pi(11 / 12))
plus(i).r = 20
Next
Screen _NewImage(XMax, YMax, 32) ': _ScreenMove 320, 0
_FullScreen
bell = _SndOpen("bell.wav")
fall = _SndOpen("fall.wav")
bonus = _SndOpen("digit.wav")
f = _LoadFont("arial.ttf", 24)
_Font f
br = 25 ' ball radius
ball = makeSkinnyBall& ' after br !!!
restart:
bx = ScR: by = br: bs = 10 ' ball loacation and speed
' shoot ball out towards one of the flippers randomly
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
If bs > 30 Then bs = 30
Cls
FC3 ScR, ScR, ScR + 3, &HFFBB8800 'back circle
FC3 ScR, ScR, ScR, &HFF888888
If _KeyDown(100306) Then leftFlip.TargetUpTF = -1 ' left side ctrl
If _KeyDown(100305) Then rightFlip.TargetUpTF = -1 ' right side ctrl
For i = 0 To 7 ' draw under the ball stuff
DrawBonus i
Next
For i = 0 To 2
DrawKickerBottom i
Next
' here's the ball image
_PutImage (bx - br * ScrF - 1, by - br * ScrF - 1), ball, 0
DrawFlipper leftFlip
DrawFlipper rightFlip
For i = 0 To 2 ' Kicker tops over the ball
DrawKicker i
Next
s$ = _Trim$(Str$(score))
Color &HFFFFFFFF, &HFFFF0000
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 150), s$
Color &HFFFFFFFF, &HFF220044
'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 by > YMax - 1.25 * br Then 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 ' handle left flipper collisions
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 - 3 * 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
ElseIf rffirsti >= 0 Then ' handle right flipper collisions
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 - 3 * 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
End If
' collision Kickers
For i = 0 To 2
If _Hypot(by - k(i).y, bx - k(i).x) <= k(i).r + br Then ' left kick
FC3 k(i).x, k(i).y, k(i).r + 15, &HFFFFFFFF
_SndPlay bell
score = score + 100
ba = _Atan2(by - k(i).y, bx - k(i).x) + Rnd - .5 ' avoid infinite loops
bx = k(i).x + (br + k(i).r) * Cos(ba)
by = k(i).y + (br + k(i).r) * Sin(ba)
bs = bs * 1.3
bdx = bs * Cos(ba): bdy = bs * Sin(ba)
End If
Next
' ball over Bonus round
For i = 0 To 7
If _Hypot(by - plus(i).y, bx - plus(i).x) <= plus(i).r Then ' bonus
FC3 plus(i).x, plus(i).y, plus(i).r, &HFFFFFFFF
_SndPlay bonus
score = score + 50
End If
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
If _KeyDown(27) = 0 Then
_SndPlay fall
balls = balls + 1
Color &HFFFFFFFF, &HFFFF0000
If balls >= 5 Then
s$ = "5 balls played, Game Over!"
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 127), s$
_Display
k$ = "" ' for some reason sleep is not working right after first time it doesn't
While k$ = ""
k$ = InKey$
_Limit 30
Wend
End
Else
s$ = "Press any for ball:" + Str$(balls + 1)
_PrintString ((XMax - _PrintWidth(s$)) / 2, ScR + 127), s$
Color &HFFFFFFFF, &HFF220044
_Display
k$ = "" ' for some reason sleep is not working right after first time it doesn't
While k$ = ""
k$ = InKey$
_Limit 30
Wend
GoTo restart
End If
End If
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 + 10, 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 + 10, 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, &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, &HFFFFFFFF
End If
Next
End Sub
Sub DrawKickerBottom (kNum)
FC3 k(kNum).x, k(kNum).y + 40, k(kNum).r + 20, &HFF990000
FC3 k(kNum).x, k(kNum).y + 40, k(kNum).r + 18, &HFF555555
End Sub
Sub DrawKicker (kNum)
FC3 k(kNum).x, k(kNum).y, k(kNum).r + 20, &HFFFF0000
FC3 k(kNum).x, k(kNum).y, k(kNum).r + 18, &HFFFFFFFF
star k(kNum).x, k(kNum).y, k(kNum).r, k(kNum).r + 15, 24, 0, &HFFFF0000
End Sub
Sub DrawBonus (Num)
FC3 plus(Num).x, plus(Num).y, plus(Num).r, &HFFFF0000
FC3 plus(Num).x, plus(Num).y, plus(Num).r - 2, &HFFFFFFFF
star plus(Num).x, plus(Num).y, 5, plus(Num).r - 5, 7, 0, &HFFFF0000
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 star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
Dim pAngle, radAngleOffset, x1, y1, x2, y2, x3, y3, i As Long
pAngle = _D2R(360 / nPoints): radAngleOffset = _D2R(angleOffset)
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
ftri x1, y1, x2, y2, x3, y3, K
'triangles leaked
Line (x1, y1)-(x2, y2), K
Line (x2, y2)-(x3, y3), K
Line (x3, y3)-(x1, y1), K
x1 = x3: y1 = y3
Next
Paint (x, y), K, K
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
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
Function makeSkinnyBall& ' for this game
Dim As Long im, g, rr
Dim f
g = 200
im = _NewImage(2 * br * ScrF + 2, 2 * br * ScrF + 2, 32)
_Dest im
For rr = br To 0 Step -1
f = 1 - Sin(rr / (br + 5)) ' thank OldMoses for Sin ;-))
FEllipse br * ScrF + 1, br * ScrF + 1, rr, rr * ScrF, _RGB32(g * f)
Next
_Dest 0
makeSkinnyBall& = im
End Function
Sub FEllipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
If this doesn't work for someone, do you have something not Windows? Can you give a screen shot?
Again, the .wav files for sound effects are in then zip of First post of this thread.
