Results 1 to 22 of 22

Thread: Roulette Wheel Animation

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Roulette Wheel Animation

    Hello,

    I thought I had all the math right in my Roulette Wheel code,
    but when I attempted to position the wheel in the center of the form,
    the path of my spinning ball becomes erratic.

    To see the problem,
    Change
    WheelOffsetX = 10
    to
    WheelOffsetX = (Form1.ScaleWidth - WidthWheelImage) / 2

    Any ideas?

    ps
    How do I change my Roulette Ball to have a transparent background?
    I use MS Paint, and I am trying to use "Transparent selection", but nothing I try works.
    Attached Files Attached Files

  2. #2
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    10,266

    Re: Roulette Wheel Animation

    Oh man, I'm having visions of a physics engine. I'm not sure if I've seen a physics engine used by any VB6 program.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  3. #3
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    10,266

    Re: Roulette Wheel Animation

    Ohhh, apparently reexre developed a 2D physics engine for VB6, and apparently Schmidt integrated the Chipmunk physics engine into his RC# library.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  4. #4
    Addicted Member Mongoose_MHS's Avatar
    Join Date
    May 2024
    Posts
    178

    Re: Roulette Wheel Animation

    Quote Originally Posted by mms_ View Post
    ps
    How do I change my Roulette Ball to have a transparent background?
    I use MS Paint, and I am trying to use "Transparent selection", but nothing I try works.
    I thought this was pretty neat! However, I adjusted the ball image for you. I hope you don't mind. I wasn't sure what size you would like because your original image is 14x15. So I rounded it off.

    14x14 or 15x15


    1.) Use paint and the circle tool evenly in the image
    2.) Fill the outside of the circle pink
    3.) Save image as .PNG
    4.) Open image with Jasc Paint Shop Pro - (or something similar), and then go to colors / transparency and select the pink color and make it transparent and save as the new .PNG

    However, I saved you the time.
    Attached Images Attached Images   
    Last edited by Mongoose_MHS; May 14th, 2024 at 04:40 PM. Reason: forgot to mention something
    Monroe High School.. GO HORNETS!

    If I've help you, please add to my reputation level! Each reply has a "STAR" icon followed by: "Rate this post".. click that

  5. #5

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Re: Roulette Wheel Animation

    15x15 then.

    you have a transparent png you could upload?

    nevermind... you did
    Last edited by mms_; May 14th, 2024 at 04:13 PM.

  6. #6
    Addicted Member Mongoose_MHS's Avatar
    Join Date
    May 2024
    Posts
    178

    Re: Roulette Wheel Animation

    Already did in my last post. Just right click on 1 of them and save the image.
    Monroe High School.. GO HORNETS!

    If I've help you, please add to my reputation level! Each reply has a "STAR" icon followed by: "Rate this post".. click that

  7. #7

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Re: Roulette Wheel Animation

    Thank you!

    So not able to do in MS Paint alone?

  8. #8
    Addicted Member Mongoose_MHS's Avatar
    Join Date
    May 2024
    Posts
    178

    Re: Roulette Wheel Animation

    Quote Originally Posted by mms_ View Post
    Thank you!

    So not able to do in MS Paint alone?
    Yer welcome! Unfortunately not, as it doesn't have the ability to make colors transparent - (atleast not my copy of it which is "XP", I don't like the other versions of MS Paint).. Sorry

    Simple images I'm pretty good at - vb coding not so much sadly. So, if you need something simple feel free to PM me
    Last edited by Mongoose_MHS; May 14th, 2024 at 04:43 PM.
    Monroe High School.. GO HORNETS!

    If I've help you, please add to my reputation level! Each reply has a "STAR" icon followed by: "Rate this post".. click that

  9. #9
    Addicted Member Mongoose_MHS's Avatar
    Join Date
    May 2024
    Posts
    178

    Re: Roulette Wheel Animation

    I got rid of the black outline on the ball if you want this one instead:
    Attached Images Attached Images  
    Monroe High School.. GO HORNETS!

    If I've help you, please add to my reputation level! Each reply has a "STAR" icon followed by: "Rate this post".. click that

  10. #10
    Addicted Member Mongoose_MHS's Avatar
    Join Date
    May 2024
    Posts
    178

    Re: Roulette Wheel Animation

    Just curious, are you just making an animation app OR are you trying to make an actual game with this app? If it's for a game, the wheel is way too big and then you have it take over and expand the form so to add other elements would be daunting.
    Last edited by Mongoose_MHS; May 15th, 2024 at 09:33 PM.
    Monroe High School.. GO HORNETS!

    If I've help you, please add to my reputation level! Each reply has a "STAR" icon followed by: "Rate this post".. click that

  11. #11
    Fanatic Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    686

    Re: Roulette Wheel Animation

    Physics is one of my great passions. This challenge was fun.
    The result I obtained is not yet perfect but in my opinion it could be sufficient.
    I used vbRichClient RC6 for rendering (add reference to RC6.Dll), the rest is my own work.

    The RouletteWheel.png image from the previous ZIP must be in your project folder

    Create a Form called fMain.frm with the Code:
    Code:
    Option Explicit
    
    Private Sub Form_Activate()
        SETUP
    End Sub
    
    Private Sub Form_Load()
        ScaleMode = vbPixels
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        End
    End Sub
    Place a MultiLine TextBox called TEXT1 in this fMain Form.

    And a Module with the Code:
    Code:
    Option Explicit
    
    Private SRF       As cCairoSurface
    Private WheelSRF  As cCairoSurface
    
    Private CC        As cCairoContext
    
    Private CX        As Double
    Private CY        As Double
    
    Private WheelImageRadius As Double
    
    Private ANG       As Double
    Private AngSpeed  As Double
    
    Private CurrTICK  As Long
    Private TickAnim  As Long
    Private TickDRAW  As Long
    
    Private BallX     As Double
    Private BallY     As Double
    Private BallVX    As Double
    Private BallVY    As Double
    Private Const R   As Double = 7    'BallRadius
    
    Private OuterRadius As Double
    Private Const InnerRadius As Double = 159
    
    Private Const PI2 As Double = 6.28318530717959
    Private Const PI  As Double = 3.14159265358979
    Private Const PIh As Double = 1.5707963267949
    
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    
    Private SLOTn(0 To 37) As Long
    
    Public Sub SETUP()
        Randomize Timer
    
        Set WheelSRF = Cairo.ImageList.AddImage("WHEEL", App.Path & "\RouletteWheel.png")
        WheelImageRadius = WheelSRF.Width * 0.5
        CX = WheelImageRadius + 10
        CY = WheelImageRadius + 10
    
        OuterRadius = WheelImageRadius - 14    '24
    
        fMain.Text1.Left = CX * 2 + 5
    
    
        Set SRF = Cairo.CreateSurface(WheelImageRadius * 2 + 20, WheelImageRadius * 2 + 20, ImageSurface)
        Set CC = SRF.CreateContext
        CC.SetLineWidth 1
    
        SLOTn(0) = 33: SLOTn(1) = 7: SLOTn(2) = 17: SLOTn(3) = 5: SLOTn(4) = 22: SLOTn(5) = 34: SLOTn(6) = 15: SLOTn(7) = 3
        SLOTn(8) = 24: SLOTn(9) = 36: SLOTn(10) = 13: SLOTn(11) = 1: SLOTn(12) = -1: SLOTn(13) = 27: SLOTn(14) = 10: SLOTn(15) = 25
        SLOTn(16) = 29: SLOTn(17) = 12: SLOTn(18) = 8: SLOTn(19) = 19: SLOTn(20) = 31: SLOTn(21) = 18: SLOTn(22) = 6: SLOTn(23) = 21
        SLOTn(24) = 26: SLOTn(25) = 16: SLOTn(26) = 4: SLOTn(27) = 23: SLOTn(28) = 35: SLOTn(29) = 14: SLOTn(30) = 2: SLOTn(31) = 0
        SLOTn(32) = 20: SLOTn(33) = 9: SLOTn(34) = 28: SLOTn(35) = 32: SLOTn(36) = 11: SLOTn(37) = 30
    
        LAUNCH
    
    End Sub
    
    
    Public Sub LAUNCH()
    
        AngSpeed = 0.25 + (Rnd * 2 - 1) * 0.05
    
        BallX = -0
        BallY = -(OuterRadius - R) + 4
        BallVX = Rnd * 2
        BallVY = 0
    
        While ANG > PI2: ANG = ANG - PI2: Wend
    
        WHEELLOOP
    
    End Sub
    
    Private Sub ShowResult()
        Dim N         As Long
        Dim Result    As Long
        Dim S         As String
    
        N = (-ANG + Atan2(BallX, BallY)) / PI2 * 38
        While N < 0: N = N + 38: Wend
        N = N Mod 38
    
        Result = SLOTn(N)
    
        If Result < 0 Then S = "00" Else: S = CStr(Result)
        If Len(S) = 1 Then S = " " & S
        If Result > 0 Then
            S = S & IIf((N Mod 2), " Red", " Black")
        End If
        fMain.Text1 = S & vbCrLf & fMain.Text1
    
        ' Test Text Length
        If Len(fMain.Text1) > 1000 Then fMain.Text1 = Left$(fMain.Text1, 1000)
    
        LAUNCH
    
    End Sub
    
    
    Public Sub WHEELLOOP()
        TickAnim = GetTickCount
        TickDRAW = GetTickCount
        Do
            CurrTICK = GetTickCount
    
            If CurrTICK - TickAnim >= 8 Then    ' 1000 / 8 = 125 FPS    Computed
                SIMULATE
                TickAnim = GetTickCount
                If AngSpeed < 0 Then
                    ShowResult
                    Exit Do
                End If
            End If
            If CurrTICK - TickDRAW >= 20 Then    ' 1000 / 20 = 50 FPS    Draw
                TickDRAW = GetTickCount
                DRAWALL
                DoEvents
    
            End If
    
        Loop While True
    End Sub
    
    Public Sub DRAWALL()
    
        CC.SetSourceColor vbWhite: CC.Paint
        CC.Save
        CC.TranslateDrawings CX, CY
        CC.RotateDrawings ANG
        CC.RenderSurfaceContent WheelSRF, -WheelImageRadius, -WheelImageRadius
    
        'DEBUG .............
        '    Dim A#, CA#, SA#
        '    Const STP     As Double = 0.165346981767884
        '    For A = -0.07 To PI2 Step STP
        '        CA = Cos(A)
        '        SA = Sin(A)
        '        CC.DrawLine CA * 175, SA * 175, CA * 150, SA * 150, , 4, vbRed
        '    Next
        '    ' ...............
    
        CC.Restore
    
        CC.Arc BallX + CX, BallY + CY, R + 1
        CC.Fill True, Cairo.CreateSolidPatternLng(vbWhite)
        CC.SetSourceColor 0
        CC.Stroke
    
        fMain.Picture = SRF.Picture
    
    End Sub
    
    'Private Sub Reflect(X#, Y#, ByVal WallX#, ByVal WallY#)
    '    Dim D#
    '    D = X * WallX + Y * WallY
    '    X = X - WallX * D * 2
    '    Y = Y - WallY * D * 2
    'End Sub
    Private Sub Project(X#, Y#, ByVal v2X#, ByVal v2Y#)
        Dim D         As Double
        D = X * v2X + Y * v2Y
        X = v2X * D
        Y = v2Y * D
    End Sub
    
    
    Public Function Atan2(ByVal DX As Double, ByVal DY As Double) As Double
        If DX Then Atan2 = Atn(DY / DX) + PI * (DX < 0#) Else Atan2 = -PIh - (DY > 0#) * PI
    End Function
    
    
    Private Sub CalcDistFromLineAndNormal(ByVal PX#, ByVal PY#, ByVal AX#, ByVal AY#, ByVal BallX#, ByVal BallY#, ByVal InvABlen2#, rDIST#, rNX#, rNY#)    ', rPosX#, rPosY#)
        Dim PAX#, PAY#, H#
        Dim bAX#, bAY#
        Dim DX#, DY#
    
        PAX = PX - AX
        PAY = PY - AY
        bAX = BallX - AX
        bAY = BallY - AY
    
        H = (PAX * bAX + PAY * bAY) * InvABlen2
        If H > 1# Then H = 1#
        If H < 0# Then H = 0#
    
        DX = PAX - bAX * H
        DY = PAY - bAY * H
    
        rDIST = Sqr(DX * DX + DY * DY)
    
        rNX = DX / rDIST
        rNY = DY / rDIST
        '    rPosX = AX + bAX * H
        '    rPosY = AY + bAY * H
    
    End Sub
    
    
    Public Sub SIMULATE()
    
        Dim DistFromCenter#
        Dim DX#, DY#
    
        Const WallSPEEDK As Double = 0.002
    
        ANG = ANG + AngSpeed
    
        AngSpeed = AngSpeed * 0.997 - 0.00002
    
        DistFromCenter = Sqr(BallX * BallX + BallY * BallY)
    
        DX = BallX / DistFromCenter
        DY = BallY / DistFromCenter
    
    
        If DistFromCenter < 183 Then   ' CHECK CHELL SLOT
            CheckCOLLISIONwihtSLOTS DistFromCenter
        End If
    
    
        If DistFromCenter > (OuterRadius - R) Then    'Beyond OUTER Radius --->  Reflect Velocity
            COLLISIONResponse BallVX, BallVY, -DY * DistFromCenter * WallSPEEDK * AngSpeed, DX * DistFromCenter * WallSPEEDK * AngSpeed, DX, DY
            DistFromCenter = (OuterRadius - R)
            BallX = DX * DistFromCenter
            BallY = DY * DistFromCenter
        End If
    
        If DistFromCenter < InnerRadius Then    'Beyond INNER Radius --->  Reflect Velocity
            COLLISIONResponse BallVX, BallVY, -DY * DistFromCenter * WallSPEEDK * AngSpeed, DX * DistFromCenter * WallSPEEDK * AngSpeed, -DX, -DY
            DistFromCenter = InnerRadius
            BallX = DX * DistFromCenter
            BallY = DY * DistFromCenter
        End If
    
    
        '
        BallVX = BallVX - DY * DistFromCenter * 0.003 * AngSpeed    ' Force induced by spinning wheel
        BallVY = BallVY + DX * DistFromCenter * 0.003 * AngSpeed
    
        BallVX = BallVX - DX * 0.25    'Toward Center (Like CONE)
        BallVY = BallVY - DY * 0.25
    
        BallVX = BallVX * 0.995        'GLOABAL Friction
        BallVY = BallVY * 0.995
    
        BallX = BallX + BallVX         'Update Position
        BallY = BallY + BallVY
    
    End Sub
    
    
    
    Private Sub CheckCOLLISIONwihtSLOTS(DFC#)
        Dim A         As Double
        Dim CA#, SA#
        Const InvLineLengthSquared As Double = 0.0016    '1 / (25 * 25)  '175-150
        Const AngSTEP As Double = 0.165346981767884    ' 2 PI / 38
    
        Dim rDIST#, rNX#, rNY#
        '    Dim rLX#, rLY#
        Dim DX#, DY#
        Dim wVX#, wVY#
    
        For A = -0.07 To PI2 Step AngSTEP
            CA = Cos(A + ANG)
            SA = Sin(A + ANG)
    
            CalcDistFromLineAndNormal BallX + BallVX, BallY + BallVY, CA * 150, SA * 150, CA * 175, SA * 175, InvLineLengthSquared, rDIST, rNX, rNY    ', rLX, rLY
    
            If rDIST < R + 4 Then
    
                DFC = Sqr(BallX * BallX + BallY * BallY)
                DX = BallX / DFC
                DY = BallY / DFC
    
                wVX = -SA * DFC * AngSpeed * 1.37
                wVY = CA * DFC * AngSpeed * 1.37
    
                '            If BallVX * wVX + BallVY * wVY > 0 Then
                COLLISIONResponse BallVX, BallVY, _
                                  wVX, _
                                  wVY, rNX, rNY
                '1 Step forward
                BallX = BallX + BallVX
                BallY = BallY + BallVY
                Exit For
                '            End If
            End If
        Next
    
    End Sub
    
    
    Private Sub COLLISIONResponse(VX1, VY1, VX2, VY2, nDX, nDY)
    
        Const Elasticity As Double = 0.7
        Const Friction As Double = 0.9
    
        Const MassI   As Double = 1
        Const MassJ   As Double = 99
        Const InvMassSum As Double = 0.01
        Const MassDiff As Double = -98
    
        Dim parIx#, parIy#             'Parallel VEL for V1
        Dim perpIx#, perpIy#           'Perpendicular VEL for V1
        Dim parJx#, parJy#             'Parallel VEL for V2
        Dim perpJx#, perpJy#           'Perpendicular VEL for V2
    
        parIx = VX1: parIy = VY1
        parJx = VX2: parJy = VY2
    
        '    'decompose velocities along collision direction (Parallel and Perpendicular)
        Project parIx, parIy, nDX, nDY
        Project parJx, parJy, nDX, nDY
        perpIx = VX1 - parIx
        perpIy = VY1 - parIy
        perpJx = VX2 - parJx
        perpJy = VY2 - parJy
        '-------------------------------
    
        VX1 = (parIx * MassDiff + parJx * 2 * MassJ) * InvMassSum
        VY1 = (parIy * MassDiff + parJy * 2 * MassJ) * InvMassSum
        VX2 = (parJx * -MassDiff + parIx * 2 * MassI) * InvMassSum
        VY2 = (parJy * -MassDiff + parIy * 2 * MassI) * InvMassSum
    
        'Apply Elasticity and friction
        VX1 = VX1 * Elasticity + perpIx * Friction
        VY1 = VY1 * Elasticity + perpIy * Friction
        VX2 = VX2 * Elasticity + perpJx * Friction
        VY2 = VY2 * Elasticity + perpJy * Friction
    
    End Sub

    PS: I will edit this post instead of creating another one if there are improvements or changes. (if they are not too big)


    EDIT 1 : Now it Displays Result Number

    EDIT2 : Ignore all and download latest Version HERE

  12. #12

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Re: Roulette Wheel Animation

    Very exited to see your implementation reexre, and thanks for doing that.
    I too had fun in doing as much as I did.

    Unfortunately for me I do not have RC6 (for no other reason than I am too old to learn new things)

    Just so I could see what you had done, I downloaded RC6.dll, placed in same folder as roulette app, referenced it,
    and tried to run, but get a Class not registered error.

    I will see if I can change all Cairo calls to GDI+ but this could take some time.

    Anyways, thanks again for doing this

  13. #13
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,615

    Talking Re: Roulette Wheel Animation

    Quote Originally Posted by mms_ View Post
    (for no other reason than I am too old to learn new things)
    No such thing!

    As far as I've gathered from other threads around here, RC6 should come with a ready-made script that should register everything for you so just double-click it!

  14. #14
    Fanatic Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    686

    Re: Roulette Wheel Animation

    Yes RC6 come with a ready-made script RegisterRC6inPlace.vbs. To register RC6.DLL Just Run it.

    (It's not needed to put it in the same folder.)

    I updated the code above: now, after spinning, it Textouts the reslut numbers. (Just add in the fMain Form a MultiLine TextBox called Text1)

  15. #15

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Re: Roulette Wheel Animation

    I'm sure RC6 and Cairo are both excellent platforms,
    but honestly my poor old brain hurts too much when it is forced to learn new concepts.

    I've successfully ported the RC6/Cairo code to GDI+ (verbatim for the most part)
    Well maybe not perfectly, because ShowResult reports the wrong result.

    I modified ShowResult slightly so it doesn't automatically restart the wheel
    so that I could examine which pocket the ball was in, and the reported result.
    (It was re-starting before I could compare the results)

    Also I am trying to reverse the direction of the wheel,
    as ball and wheel direction are always opposite in my experience.

    reexre some pretty amazing work!!!
    I especially like how the ball "hops" sometimes pocket to pocket!
    Once again, thank you!

    GDI+ code below (need form name fMain, PictureBox, CommandButton, TextBox (Multiline set to True)

    fMain
    Code:
    Option Explicit
    
    Private Sub Form_Activate()
        SETUP
    End Sub
    
    Private Sub Form_Load()
        ScaleMode = vbPixels
        
        '-------------------------------------------------------------------------------
        Me.Caption = "GDI+ Roulette"
        Me.Width = Screen.TwipsPerPixelX * 1000
        Me.Height = Screen.TwipsPerPixelY * 750
        Me.BackColor = &H8000000F
        
        Picture1.Appearance = 0
        Picture1.Left = 16
        Picture1.Top = 16
        Picture1.Height = fMain.ScaleHeight - (16 * 1) - (10 * 2 + 25)
        Picture1.Width = fMain.ScaleWidth - (16 * 2)
        'Picture1.Font = "Consolas"
        Picture1.AutoRedraw = True
        Picture1.ScaleMode = vbPixels
        
        Command1.Width = Picture1.Width
        Command1.Height = 25
        Command1.Left = Picture1.Left
        Command1.Top = Picture1.Top + Picture1.Height + 10
        Command1.Caption = "Stop/Restart"
        
        'Text1.MultiLine = True      'must be done @ design-time
        Text1.Appearance = 0
        Text1.Width = 50
        Text1.Height = 15
        Text1.Text = ""
        
        ' Load the GDI+ Dll
        GpInput.GdiplusVersion = 1
        If GdiplusStartup(gdiplusToken, GpInput) <> Ok Then
            MsgBox "Error loading GDI+!", vbCritical
            'Unload Me
            Call GdiplusShutdown(gdiplusToken)
        End If
        '-------------------------------------------------------------------------------
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    
        '-------------------------------------------------------------------------------
        ' Cleanup
        stat = GdipDeletePen(whitePen)
        stat = GdipDeleteBrush(whiteBrush)
        stat = GdipDisposeImage(image1)
        stat = GdipDeleteGraphics(graphics)
    
        ' Unload the GDI+ Dll
        Call GdiplusShutdown(gdiplusToken)
        '-------------------------------------------------------------------------------
        
        End
    End Sub
    
    Private Sub Command1_Click()
    
        ' Toggle stop and restart
        If bExit = False Then
            bExit = True
        Else
            bExit = False
            SETUP
        End If
        
    End Sub
    Module1
    Code:
    Option Explicit
    
    'Private SRF       As cCairoSurface
    'Private WheelSRF  As cCairoSurface
    
    'Private CC        As cCairoContext
    
    Private CX        As Double
    Private CY        As Double
    
    Private WheelImageRadius As Double
    
    Private ANG       As Double
    Private AngSpeed  As Double
    
    Private CurrTICK  As Long
    Private TickAnim  As Long
    Private TickDRAW  As Long
    
    Private BallX     As Double
    Private BallY     As Double
    Private BallVX    As Double
    Private BallVY    As Double
    Private Const R   As Double = 7    'BallRadius
    
    Private OuterRadius As Double
    Private Const InnerRadius As Double = 159
    
    Private Const PI2 As Double = 6.28318530717959
    Private Const PI  As Double = 3.14159265358979
    Private Const PIh As Double = 1.5707963267949
    
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    
    Private SLOTn(0 To 37) As Long
    
    Public Sub SETUP()
        Randomize Timer
        
        'Set WheelSRF = Cairo.ImageList.AddImage("WHEEL", App.Path & "\RouletteWheel.png")
        stat = GdipLoadImageFromFile(StrConv(App.Path & "\RouletteWheel.png", vbUnicode), image1)
        
        'WheelImageRadius = WheelSRF.Width * 0.5
        stat = GdipGetImageWidth(image1, WidthWheelImage)
        WheelImageRadius = WidthWheelImage * 0.5
        
        CX = WheelImageRadius + 10
        CY = WheelImageRadius + 10
    
        OuterRadius = WheelImageRadius - 14    '24
        
        fMain.Text1.Left = CX * 2 + 5
    
    
        'Set SRF = Cairo.CreateSurface(WheelImageRadius * 2 + 20, WheelImageRadius * 2 + 20, ImageSurface)
        'Set CC = SRF.CreateContext
        'CC.SetLineWidth 1
        stat = GdipCreateFromHDC(fMain.Picture1.hdc, graphics)
            
        SLOTn(0) = 33: SLOTn(1) = 7: SLOTn(2) = 17: SLOTn(3) = 5: SLOTn(4) = 22: SLOTn(5) = 34: SLOTn(6) = 15: SLOTn(7) = 3
        SLOTn(8) = 24: SLOTn(9) = 36: SLOTn(10) = 13: SLOTn(11) = 1: SLOTn(12) = -1: SLOTn(13) = 27: SLOTn(14) = 10: SLOTn(15) = 25
        SLOTn(16) = 29: SLOTn(17) = 12: SLOTn(18) = 8: SLOTn(19) = 19: SLOTn(20) = 31: SLOTn(21) = 18: SLOTn(22) = 6: SLOTn(23) = 21
        SLOTn(24) = 26: SLOTn(25) = 16: SLOTn(26) = 4: SLOTn(27) = 23: SLOTn(28) = 35: SLOTn(29) = 14: SLOTn(30) = 2: SLOTn(31) = 0
        SLOTn(32) = 20: SLOTn(33) = 9: SLOTn(34) = 28: SLOTn(35) = 32: SLOTn(36) = 11: SLOTn(37) = 30
    
        LAUNCH
    
    End Sub
    
    
    Public Sub LAUNCH()
    
        AngSpeed = 0.25 + (Rnd * 2 - 1) * 0.05
    
        BallX = -0
        BallY = -(OuterRadius - R) + 4
        BallVX = Rnd * 2
        BallVY = 0
    
        While ANG > PI2: ANG = ANG - PI2: Wend
    
        WHEELLOOP
    
    End Sub
    
    Private Sub ShowResult()
        Dim N         As Long
        Dim Result    As Long
        Dim S         As String
    
        N = (-ANG + Atan2(BallX, BallY)) / PI2 * 38
        While N < 0: N = N + 38: Wend
        N = N Mod 38
    
        Result = SLOTn(N)
    
        If Result < 0 Then S = "00" Else: S = CStr(Result)
        If Len(S) = 1 Then S = " " & S
        If Result > 0 Then
            S = S & IIf((N Mod 2), " Red", " Black")
        End If
        fMain.Text1 = S & vbCrLf & fMain.Text1
    
        ' Test Text Length
        If Len(fMain.Text1) > 1000 Then fMain.Text1 = Left$(fMain.Text1, 1000)
        
        ' changed by mms
        bExit = True
        'LAUNCH
        
    End Sub
    
    
    Public Sub WHEELLOOP()
        TickAnim = GetTickCount
        TickDRAW = GetTickCount
        Do
            CurrTICK = GetTickCount
    
            If CurrTICK - TickAnim >= 8 Then    ' 1000 / 8 = 125 FPS    Computed
                SIMULATE
                TickAnim = GetTickCount
                If AngSpeed < 0 Then
                    ShowResult
                    Exit Do
                End If
            End If
            If CurrTICK - TickDRAW >= 20 Then    ' 1000 / 20 = 50 FPS    Draw
                TickDRAW = GetTickCount
                DRAWALL
                DoEvents
    
            End If
            
            If bExit = True Then Exit Do
    
        Loop While True
    End Sub
    
    Public Sub DRAWALL()
    
        'CC.SetSourceColor vbWhite: CC.Paint
        'CC.Save
        stat = GdipCreatePen1(&HFFFFFFFF, 1, UnitPixel, whitePen)
        stat = GdipCreateSolidFill(&HFFFFFFFF, whiteBrush)
    
        'CC.TranslateDrawings CX, CY
        'CC.RotateDrawings ANG
        'CC.RenderSurfaceContent WheelSRF, -WheelImageRadius, -WheelImageRadius
        stat = GdipTranslateWorldTransform(graphics, CX, CY, MatrixOrderPrepend)
        stat = GdipRotateWorldTransform(graphics, ANG, MatrixOrderPrepend)
        stat = GdipDrawImage(graphics, image1, -WheelImageRadius, -WheelImageRadius)
    
        'DEBUG .............
        '    Dim A#, CA#, SA#
        '    Const STP     As Double = 0.165346981767884
        '    For A = -0.07 To PI2 Step STP
        '        CA = Cos(A)
        '        SA = Sin(A)
        '        CC.DrawLine CA * 175, SA * 175, CA * 150, SA * 150, , 4, vbRed
        '    Next
        '    ' ...............
        
        'CC.Restore
        stat = GdipResetWorldTransform(graphics)
        
        'CC.Arc BallX + CX, BallY + CY, R + 1
        'CC.Fill True, Cairo.CreateSolidPatternLng(vbWhite)
        'CC.SetSourceColor 0
        'CC.Stroke
        stat = GdipDrawEllipse(graphics, whitePen, BallX + CX, BallY + CY, R + 1, R + 1)
        stat = GdipFillEllipse(graphics, whiteBrush, BallX + CX, BallY + CY, R + 1, R + 1)
        
        fMain.Picture1.Refresh
        
    End Sub
    
    'Private Sub Reflect(X#, Y#, ByVal WallX#, ByVal WallY#)
    '    Dim D#
    '    D = X * WallX + Y * WallY
    '    X = X - WallX * D * 2
    '    Y = Y - WallY * D * 2
    'End Sub
    Private Sub Project(X#, Y#, ByVal v2X#, ByVal v2Y#)
        Dim D         As Double
        D = X * v2X + Y * v2Y
        X = v2X * D
        Y = v2Y * D
    End Sub
    
    
    Public Function Atan2(ByVal DX As Double, ByVal DY As Double) As Double
        If DX Then Atan2 = Atn(DY / DX) + PI * (DX < 0#) Else Atan2 = -PIh - (DY > 0#) * PI
    End Function
    
    
    Private Sub CalcDistFromLineAndNormal(ByVal PX#, ByVal PY#, ByVal AX#, ByVal AY#, ByVal BallX#, ByVal BallY#, ByVal InvABlen2#, rDIST#, rNX#, rNY#)    ', rPosX#, rPosY#)
        Dim PAX#, PAY#, H#
        Dim bAX#, bAY#
        Dim DX#, DY#
    
        PAX = PX - AX
        PAY = PY - AY
        bAX = BallX - AX
        bAY = BallY - AY
    
        H = (PAX * bAX + PAY * bAY) * InvABlen2
        If H > 1# Then H = 1#
        If H < 0# Then H = 0#
    
        DX = PAX - bAX * H
        DY = PAY - bAY * H
    
        rDIST = Sqr(DX * DX + DY * DY)
    
        rNX = DX / rDIST
        rNY = DY / rDIST
        '    rPosX = AX + bAX * H
        '    rPosY = AY + bAY * H
    
    End Sub
    
    
    Public Sub SIMULATE()
    
        Dim DistFromCenter#
        Dim DX#, DY#
    
        Const WallSPEEDK As Double = 0.002
    
        ANG = ANG + AngSpeed
    
        AngSpeed = AngSpeed * 0.997 - 0.00002
    
        DistFromCenter = Sqr(BallX * BallX + BallY * BallY)
    
        DX = BallX / DistFromCenter
        DY = BallY / DistFromCenter
    
    
        If DistFromCenter < 183 Then   ' CHECK CHELL SLOT
            CheckCOLLISIONwihtSLOTS DistFromCenter
        End If
    
    
        If DistFromCenter > (OuterRadius - R) Then    'Beyond OUTER Radius --->  Reflect Velocity
            COLLISIONResponse BallVX, BallVY, -DY * DistFromCenter * WallSPEEDK * AngSpeed, DX * DistFromCenter * WallSPEEDK * AngSpeed, DX, DY
            DistFromCenter = (OuterRadius - R)
            BallX = DX * DistFromCenter
            BallY = DY * DistFromCenter
        End If
    
        If DistFromCenter < InnerRadius Then    'Beyond INNER Radius --->  Reflect Velocity
            COLLISIONResponse BallVX, BallVY, -DY * DistFromCenter * WallSPEEDK * AngSpeed, DX * DistFromCenter * WallSPEEDK * AngSpeed, -DX, -DY
            DistFromCenter = InnerRadius
            BallX = DX * DistFromCenter
            BallY = DY * DistFromCenter
        End If
    
    
        '
        BallVX = BallVX - DY * DistFromCenter * 0.003 * AngSpeed    ' Force induced by spinning wheel
        BallVY = BallVY + DX * DistFromCenter * 0.003 * AngSpeed
    
        BallVX = BallVX - DX * 0.25    'Toward Center (Like CONE)
        BallVY = BallVY - DY * 0.25
    
        BallVX = BallVX * 0.995        'GLOABAL Friction
        BallVY = BallVY * 0.995
    
        BallX = BallX + BallVX         'Update Position
        BallY = BallY + BallVY
    
    End Sub
    
    
    
    Private Sub CheckCOLLISIONwihtSLOTS(DFC#)
        Dim A         As Double
        Dim CA#, SA#
        Const InvLineLengthSquared As Double = 0.0016    '1 / (25 * 25)  '175-150
        Const AngSTEP As Double = 0.165346981767884    ' 2 PI / 38
    
        Dim rDIST#, rNX#, rNY#
        '    Dim rLX#, rLY#
        Dim DX#, DY#
        Dim wVX#, wVY#
    
        For A = -0.07 To PI2 Step AngSTEP
            CA = Cos(A + ANG)
            SA = Sin(A + ANG)
    
            CalcDistFromLineAndNormal BallX + BallVX, BallY + BallVY, CA * 150, SA * 150, CA * 175, SA * 175, InvLineLengthSquared, rDIST, rNX, rNY    ', rLX, rLY
    
            If rDIST < R + 4 Then
    
                DFC = Sqr(BallX * BallX + BallY * BallY)
                DX = BallX / DFC
                DY = BallY / DFC
    
                wVX = -SA * DFC * AngSpeed * 1.37
                wVY = CA * DFC * AngSpeed * 1.37
    
                '            If BallVX * wVX + BallVY * wVY > 0 Then
                COLLISIONResponse BallVX, BallVY, _
                                  wVX, _
                                  wVY, rNX, rNY
                '1 Step forward
                BallX = BallX + BallVX
                BallY = BallY + BallVY
                Exit For
                '            End If
            End If
        Next
    
    End Sub
    
    
    Private Sub COLLISIONResponse(VX1, VY1, VX2, VY2, nDX, nDY)
    
        Const Elasticity As Double = 0.7
        Const Friction As Double = 0.9
    
        Const MassI   As Double = 1
        Const MassJ   As Double = 99
        Const InvMassSum As Double = 0.01
        Const MassDiff As Double = -98
    
        Dim parIx#, parIy#             'Parallel VEL for V1
        Dim perpIx#, perpIy#           'Perpendicular VEL for V1
        Dim parJx#, parJy#             'Parallel VEL for V2
        Dim perpJx#, perpJy#           'Perpendicular VEL for V2
    
        parIx = VX1: parIy = VY1
        parJx = VX2: parJy = VY2
    
        '    'decompose velocities along collision direction (Parallel and Perpendicular)
        Project parIx, parIy, nDX, nDY
        Project parJx, parJy, nDX, nDY
        perpIx = VX1 - parIx
        perpIy = VY1 - parIy
        perpJx = VX2 - parJx
        perpJy = VY2 - parJy
        '-------------------------------
    
        VX1 = (parIx * MassDiff + parJx * 2 * MassJ) * InvMassSum
        VY1 = (parIy * MassDiff + parJy * 2 * MassJ) * InvMassSum
        VX2 = (parJx * -MassDiff + parIx * 2 * MassI) * InvMassSum
        VY2 = (parJy * -MassDiff + parIy * 2 * MassI) * InvMassSum
    
        'Apply Elasticity and friction
        VX1 = VX1 * Elasticity + perpIx * Friction
        VY1 = VY1 * Elasticity + perpIy * Friction
        VX2 = VX2 * Elasticity + perpJx * Friction
        VY2 = VY2 * Elasticity + perpJy * Friction
    
    End Sub
    Module2
    Code:
    Option Explicit
    
    Public Enum GpStatus    ' aka Status
       Ok = 0
       GenericError = 1
       InvalidParameter = 2
       OutOfMemory = 3
       ObjectBusy = 4
       InsufficientBuffer = 5
       NotImplemented = 6
       Win32Error = 7
       WrongState = 8
       Aborted = 9
       FileNotFound = 10
       ValueOverflow = 11
       AccessDenied = 12
       UnknownImageFormat = 13
       FontFamilyNotFound = 14
       FontStyleNotFound = 15
       NotTrueTypeFont = 16
       UnsupportedGdiplusVersion = 17
       GdiplusNotInitialized = 18
       PropertyNotFound = 19
       PropertyNotSupported = 20
    End Enum
    
    Public Enum GpUnit      ' aka Unit
       UnitWorld
       UnitDisplay
       UnitPixel
       UnitPoint
       UnitInch
       UnitDocument
       UnitMillimeter
    End Enum
    
    Public Enum MatrixOrder
       MatrixOrderPrepend = 0
       MatrixOrderAppend = 1
    End Enum
    
    Public Type GdiplusStartupInput
       GdiplusVersion As Long
       DebugEventCallback As Long
       SuppressBackgroundThread As Long
       SuppressExternalCodecs As Long
    End Type
    
    
    Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
    Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
    
    Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
    Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
    
    Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus
    Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus
    Public Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus
    Public Declare Function GdipDrawImage Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal X As Single, ByVal Y As Single) As GpStatus
    Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
    
    Public Declare Function GdipTranslateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal DX As Single, ByVal DY As Single, ByVal order As MatrixOrder) As GpStatus
    Public Declare Function GdipRotateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal angle As Single, ByVal order As MatrixOrder) As GpStatus
    Public Declare Function GdipResetWorldTransform Lib "gdiplus" (ByVal graphics As Long) As GpStatus
    
    Public Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As GpUnit, pen As Long) As GpStatus
    Public Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal pen As Long, ByVal Width As Single) As GpStatus
    Public Declare Function GdipDeletePen Lib "gdiplus" (ByVal pen As Long) As GpStatus
    
    Public Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, brush As Long) As GpStatus
    Public Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal brush As Long) As GpStatus
    
    Public Declare Function GdipDrawEllipse Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
    Public Declare Function GdipFillEllipse Lib "gdiplus" (ByVal graphics As Long, ByVal brush As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
    Module3
    Code:
    Option Explicit
    
    Public stat As Long
    
    Public gdiplusToken As Long             ' Needed to close GDI+
    Public GpInput As GdiplusStartupInput
    
    Public graphics As Long
    
    Public image1 As Long                   'Roulette Wheel
    
    Public WidthWheelImage As Long
    Public HeightWheelImage As Long
    
    Public whitePen As Long
    Public whiteBrush As Long
    
    
    Public bExit As Boolean
    Last edited by mms_; May 17th, 2024 at 08:51 AM.

  16. #16

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Re: Roulette Wheel Animation

    A couple of questions.

    Where is direction of wheel spin set?

    Where is direction of ball spin set?

    Where is initial wheel speed set?

    Where is initial ball speed set?

    Where is the "make bounce" code when ball is very near the green pockets?
    Maybe I could add sound at each "bounce".

    Can wheel spin start where wheel is at rest (after successive spins) instead of always starting from same place?

  17. #17
    Fanatic Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    686

    Re: Roulette Wheel Animation

    Code:
    CalcDistFromLineAndNormal
    Has a bug (Argument Variables) caused by string Replacement BAX->BALLX BAY-BALLY
    I'll investigate later

  18. #18

  19. #19
    Addicted Member Mongoose_MHS's Avatar
    Join Date
    May 2024
    Posts
    178

    Re: Roulette Wheel Animation

    ball image?


    *It won't work for me rc thing missing..
    Last edited by Mongoose_MHS; May 20th, 2024 at 04:11 PM.
    Monroe High School.. GO HORNETS!

    If I've help you, please add to my reputation level! Each reply has a "STAR" icon followed by: "Rate this post".. click that

  20. #20

  21. #21

  22. #22

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    659

    Re: Roulette Wheel Animation

    Just back from a weeks holiday and...

    Wow!

    Going to take some time to try to absorb all of these new concepts, but hope I can learn from them.

    Thanks again for taking the time to share!!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width