Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 512
» Latest member: zaidativanovoz1699
» Forum threads: 2,909
» Forum posts: 27,041

Full Statistics

Latest Threads
Roll The Dice InputBox$ a...
Forum: Programs
Last Post: bplus
41 minutes ago
» Replies: 14
» Views: 169
Hardware Acceleration and...
Forum: General Discussion
Last Post: a740g
4 hours ago
» Replies: 2
» Views: 37
Memory Usage Monitor
Forum: Utilities
Last Post: Steffan-68
4 hours ago
» Replies: 4
» Views: 93
'BandInte' - Bandwidth & ...
Forum: Utilities
Last Post: Sanmayce
Today, 08:59 AM
» Replies: 5
» Views: 506
Dialog Tools
Forum: bplus
Last Post: bplus
Today, 12:18 AM
» Replies: 4
» Views: 246
PCX file format
Forum: Petr
Last Post: a740g
Yesterday, 10:05 PM
» Replies: 9
» Views: 113
BMP File format
Forum: Petr
Last Post: Petr
Yesterday, 09:39 PM
» Replies: 0
» Views: 29
QB64 and QB64PE together?
Forum: General Discussion
Last Post: Mad Axeman
Yesterday, 08:48 PM
» Replies: 7
» Views: 127
Updating my mouse and key...
Forum: Works in Progress
Last Post: Pete
Yesterday, 08:39 PM
» Replies: 28
» Views: 719
Word-list creator
Forum: Utilities
Last Post: PhilOfPerth
Yesterday, 07:18 AM
» Replies: 2
» Views: 83

 
  Asteroids Clone
Posted by: SierraKen - 02-01-2025, 10:36 PM - Forum: Games - Replies (10)

Well, it's not exactly like the original Asteroids. The rocks don't break into smaller ones. I did try to make it that way, but it's a bit too advanced for my learning. Plus I don't want to make it look almost exactly like the arcade version because of copyright infringement. I know there's been a million other versions already made, but ya never know. lol

The rocks change their looks randomly for each level. 

Tell me what you think, I've been working on this for maybe 3 or 4 days. It might still have some flukes, like possibly more than 1 asteroids being gone after shooting one for a different angle. I'm not exactly sure why that happened but I might have fixed it, or at least almost all of it. 

Disclaimer: This game is not intended to replace any other game in existence. It is a labor of love and given out for free like usual. 
Thank you guys for your inspiration. My Mouse Tank game really helped a lot on this code. Plus I got more math code from ChatGPT. Feel free to take as much as you want, as usual. Smile 
Here is a picture, the code is below it.

@bplus
@Pete


[Image: Asteroids-Clone-by-Sierra-Ken.jpg]

Code: (Select All)


'Asteroids Clone by, SierraKen
'February 1, 2025
'Thank you QB64pe Forum for your inspiration!
'Thank you also ChatGPT for a lot of the math.
'This game is not intended to replace any other game already in existence.
'It is a labor of love and given out for free.


_Title "Asteroids Clone - by SierraKen"

Screen _NewImage(800, 600, 32)

Randomize Timer

Dim oldx(100), oldy(100)
Dim llx(300), lly(300)
Dim lx(300), ly(300), ldir(300)
Dim x1 As Single, y1 As Single

Const numPoints = 30
Dim x2(100, 35), y2(100, 35)
Dim xRot(100, 35), yRot(100, 35)
Dim cx2(200), cy2(200), angle2(200)
Dim dx(100), dy(100)
Dim nox(200)

start:

numAsteroids = 8
radius2 = 45 'Asteroids
level = 1
score = 0
health = 50
healthp = 100
rot = -90

Cls
_AutoDisplay

Locate 3, 25: Print "A s t e r o i d s  C l o n e"
Locate 5, 25: Print "By SierraKen"
Locate 10, 25: Print "Move your ship around with the arrow keys."
Locate 11, 25: Print "Turn your ship with the left and right arrow keys."
Locate 12, 25: Print "Go forward with the up arrow key."
Locate 12, 25: Print "Press Space Bar to fire at asteroids."
Locate 13, 25: Print "To pause and un-pause, press Esc."
Locate 14, 25: Print "Press Q anytime to quit."
Locate 16, 25: Print "This game is not intended to replace any other game."
Locate 17, 25: Print "It is a labor of love and given out for free."
Locate 20, 25: Input "Press Enter to Begin.", a$

start2:
Cls

_Title "Score: " + Str$(score) + "    Health: " + Str$(healthp) + "%    Level: " + Str$(level)

numAsteroids = numAsteroids + 2
If numAsteroids > 40 Then numAsteroids = 40
num = numAsteroids
rock = 0
hits = 0
speed2 = 0
laser = 0
ll = 0
numpoints2 = Int(Rnd * numPoints) + 5

For ll3 = 1 To 200
    lx(ll3) = 0
    ly(ll3) = 0
    ldir(ll3) = 0
Next ll3

sx = 400
sy = 300
oldx = 400
oldy = 300
det = 0

r1 = 3 'bullets
r3 = 25 'Your ship
loops = 0

Play "MB"

' Initialize asteroids
For a = 0 To num - 1
    more:
    cx2(a) = Int(Rnd * 680) + 55 ' Random start X
    cy2(a) = Int(Rnd * 480) + 55 ' Random start Y
    If cx2(a) > 250 And cx2(a) < 550 And cy2(a) > 150 And cy2(a) < 450 Then GoTo more:
    angle2(a) = Rnd * 360 ' Random starting rotation
    dx(a) = (Rnd - 0.5) * 2 ' Random speed X (-1 to 1)
    dy(a) = (Rnd - 0.5) * 2 ' Random speed Y (-1 to 1)

    ' Generate random asteroid shape
    For i = 0 To numpoints2
        ang = i * (360 / numpoints2)
        rOffset = radius2 + Int(Rnd * 15 - 7) ' Vary radius randomly
        x2(a, i) = Cos(ang * _Pi / 180) * rOffset
        y2(a, i) = Sin(ang * _Pi / 180) * rOffset
    Next
    rock = rock + 1
Next

Do
    _Limit 100

    k = _KeyHit

    If k = 32 Then
        laser = 1
        ll = ll + 1
        If ll > 100 Then ll = 1
        lx(ll) = x1
        ly(ll) = y1
        ldir(ll) = angle
    End If

    If k = 19200 Then dir = 1 ' Left Arrow (rotate counterclockwise)
    If k = 19712 Then dir = 2 ' Right Arrow (rotate clockwise)
    If k = 18432 Then dir = 3 ' Up Arrow (thrust forward)
    If k = 20480 Then dir = 4 ' Down Arrow (thrust backward)

    If dir = 1 Then
        angle = angle - 1
        If right = 1 Then
            right = 0
            dir = 0
            GoTo nex2
        End If
        left = 1
        right = 0
    End If
    If dir = 2 Then
        angle = angle + 1
        If left = 1 Then
            left = 0
            dir = 0
            GoTo nex2
        End If
        right = 1
        left = 0
    End If
    If dir = 3 Then
        forward = 1
        backward = 0
        speed2 = speed2 + .5
        If speed2 > 3 Then speed2 = 3
        ' Move in the direction of the angle
        sx = sx + speed2 * Cos(angle * _Pi / 180)
        sy = sy + speed2 * Sin(angle * _Pi / 180)
    End If
    If dir = 4 Then
        If forward = 1 Then
            dir = 0
            speed2 = 0
            GoTo nex2:
        End If
    End If
    nex2:
    If sx > 800 Then sx = 0
    If sx < 0 Then sx = 800
    If sy > 600 Then sy = 0
    If sy < 0 Then sy = 600

    If k = 27 Then
        Do: c = _KeyHit
        Loop Until c = 27
    End If

    If k = 81 Or k = 113 Then End

    ' Update and draw each asteroid
    For a = 0 To num - 1
        If nox(a) = 1 Then GoTo skip
        angle2(a) = angle2(a) + 1 ' Rotate
        If angle2(a) >= 360 Then angle2(a) = 0

        ' Rotate asteroid points
        rad = angle2(a) * _Pi / 180
        For i = 0 To numpoints2
            xRot(a, i) = cx2(a) + (x2(a, i) * Cos(rad) - y2(a, i) * Sin(rad))
            yRot(a, i) = cy2(a) + (x2(a, i) * Sin(rad) + y2(a, i) * Cos(rad))
        Next

        ' Draw asteroid
        For i = 0 To numpoints2 - 1
            j = (i + 1) Mod numpoints2
            Line (xRot(a, i), yRot(a, i))-(xRot(a, j), yRot(a, j)), _RGB32(255, 255, 255)
        Next

        ' Move asteroid
        cx2(a) = cx2(a) + dx(a)
        cy2(a) = cy2(a) + dy(a)

        ' Wrap around screen edges
        If cx2(a) < 0 Then cx2(a) = 800
        If cx2(a) > 800 Then cx2(a) = 0
        If cy2(a) < 0 Then cy2(a) = 600
        If cy2(a) > 600 Then cy2(a) = 0
    Next

    skip:

    If laser = 1 Then
        For lz = 0 To ll - 1 Step 10
            lx2 = Cos(ldir(lz) * _Pi / 180) * 10
            ly2 = Sin(ldir(lz) * _Pi / 180) * 10
            lx(lz) = lx2 + lx(lz)
            ly(lz) = ly2 + ly(lz)
            If lx(lz) > 850 Then lx(lz) = 850
            If lx(lz) < -50 Then lx(lz) = -50
            If ly(lz) > 650 Then ly(lz) = 650
            If ly(lz) < -50 Then ly(lz) = -50
            fillCircle lx(lz), ly(lz), r1, _RGB32(255, 0, 5)
            For chk = 0 To num - 1
                distance = Sqr((lx(lz) - cx2(chk)) ^ 2 + (ly(lz) - cy2(chk)) ^ 2)
                If distance <= r1 + radius2 Then
                    DetectCollision = -1 ' True (collision detected)
                Else
                    DetectCollision = 0 ' False (no collision)
                End If

                If DetectCollision = -1 Then
                    For explosion = 1 To 50
                        Circle (lx(lz), ly(lz)), explosion, _RGB32(255, 0, 0)
                        llx(explosion) = lx(lz)
                        lly(explosion) = ly(lz)
                    Next explosion
                    'SOUND frequency!, duration![, volume!][, panPosition!][, waveform&][, waveformParameters!][, voice&]]
                    Sound 800, .4, , , 5
                    Sound 200, .75, , , 6
                    Sound 100, .75, , , 7
                    nox(rock) = 1
                    rock = rock - 1
                    num = num - 1
                    cx2(chk) = -500: cy2(chk) = 1200
                    lx(lz) = -150: ly(lz) = -150: ldir(lz) = 0
                    score = score + 10
                    _Title "Score: " + Str$(score) + "    Health: " + Str$(healthp) + "%    Level: " + Str$(level)
                    hits = hits + 1
                    laser = 0
                End If
            Next chk
            'Detect Level Change
            If hits > numAsteroids - 1 Then
                Cls
                level = level + 1
                For n = 1 To 200
                    nox(n) = 0
                Next n
                For n = 0 To 100
                    cx2(n) = -400: cy2(n) = -400
                    dx(n) = 0: dy(n) = 0
                    angle2(n) = 0
                Next n
                GoTo start2
            End If
        Next lz
    End If

    'Draw ship,
    DrawTriangle sx, sy, 20, angle, x1, y1

    For chk = 0 To numAsteroids - 1
        distance = Sqr((sx - cx2(chk)) ^ 2 + (sy - cy2(chk)) ^ 2)
        If distance <= r3 + radius2 Then
            DetectCollision = -1 ' True (collision detected)
        Else
            DetectCollision = 0 ' False (no collision)
        End If
        If DetectCollision = -1 And nox(chk) <> 1 Then
            det = 1
            health = health - .2
            healthp = Int((health / 50) * 100)
            _Title "Score: " + Str$(score) + "    Health: " + Str$(healthp) + "%    Level: " + Str$(level)
            If health < .01 Then
                health = 0
                For explosion = 1 To 200
                    Circle (sx, sy + 25), explosion, _RGB32(255, 0, 0)
                Next explosion
                For nn = 1 To 200
                    nox(nn) = 0
                Next nn
                Sound 500, 4, , , 8
                Sound 500, 8, , , 5
                Sound 100, 4, , , 7
                Locate 20, 30: Print "G A M E    O V E R"
                Locate 25, 30: Input "Again (Y/N)"; ag$
                ag2$ = LTrim$(RTrim$(ag$))
                If Left$(ag2$, 1) = "y" Or Left$(ag2$, 1) = "Y" Then GoTo start
                End
            End If
        End If
    Next chk
    skip3:
    If det > 0 Then
        det = det + 1
        Paint (sx, sy), _RGB32(255, 0, 0), _RGB32(255, 255, 255)
        If det > 200 Then det = 0
    End If

    If loops < 1000 Then
        loops = loops + 1
    End If
    _Display
    Cls
Loop


'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

Sub DrawTriangle (cx As Integer, cy As Integer, size As Integer, angle As Single, x1, y1)
    Dim x2 As Single, y2 As Single
    Dim x3 As Single, y3 As Single
    Dim a1 As Single, a2 As Single, a3 As Single

    ' Define angles of triangle vertices
    a1 = angle
    a2 = angle + 120
    a3 = angle + 240

    ' Convert polar to Cartesian coordinates
    x1 = cx + size * Cos(a1 * _Pi / 180)
    y1 = cy + size * Sin(a1 * _Pi / 180)

    x2 = cx + size * Cos(a2 * _Pi / 180)
    y2 = cy + size * Sin(a2 * _Pi / 180)

    x3 = cx + size * Cos(a3 * _Pi / 180)
    y3 = cy + size * Sin(a3 * _Pi / 180)

    ' Draw triangle
    Line (x1, y1)-(x2, y2), _RGB32(255, 255, 255)
    Line (x2, y2)-(x3, y3), _RGB32(255, 255, 255)
    Line (x3, y3)-(x1, y1), _RGB32(255, 255, 255)

    'Draw Gun
    gx = x1 + Cos(angle * _Pi / 180) * 5
    gy = y1 + Sin(angle * _Pi / 180) * 5
    Line (x1, y1)-(gx, gy), _RGB32(255, 255, 255)
End Sub


Print this item

  My discord account
Posted by: AtomicSlaughter - 01-31-2025, 01:26 PM - Forum: General Discussion - Replies (2)

Hey guys,

Sorry about all the spam messages. 

My discord got hacked. 

Could one the admins post an apology for my ass my discord jas been limited. 

Thanks and sorry again folks

Print this item

  Another _Mem function program
Posted by: eoredson - 01-30-2025, 05:30 AM - Forum: Programs - Replies (1)

Here is my first stab at yet another _Mem function set program:

This is my first lame attempt of using _Mem functions.. Wink 

Let me know if anything needs to be added or is incorrect..

-ejo

Code: (Select All)

Rem example using _mem functions. v1.0a 01/30/2025 QB64 PD 2025.
Rem  written by Erik Jon Oredson at eoredson@gmail.com
Rem new version 2.0a adds display function.
$Checking:Off
_ScreenMove _Middle
Width 80, 25
Dim m As _MEM
Dim n As _MEM
Dim p As _Offset
Color 15
Print "Mem sample program v2.0a"
Print "Mem value(10-32767)";
Input t
If t >= 10 And t <= 32767 Then
Else
  End
End If
l$ = LTrim$(Str$(t))
l = Len(l$) ' length of mem value

' define length of memory buffer
m = _MemNew(t * l + l)
n = _MemNew(t * l + l)
p = m.TYPE

' perform the memory functions
GoSub PutMem
GoSub CopyMem
GoSub GetMem
GoSub FreeMem

' take apart the memory buffer
Color 14
Print "Display memory buffer."
Print " Memtype:"; p ' ; "("; _Bin$(p); ")"
For q = 1 To t
  z = Int(Val(Mid$(b$, (q - 1) * l + 1, l)))
  Print z;
Next
Print
x = More
Color 7
End

' store the memory buffer
PutMem:
Color 14
For q = 1 To t
  x$ = String$(l, "0")
  s$ = s$ + Right$(x$ + LTrim$(Str$(q)), l)
Next
Print "Store memory buffer."
x = Display(s$)
_MemPut m, m.OFFSET, s$
Return

' copy the memory buffer
CopyMem:
Color 14
s$ = Space$(t * l)
_MemGet m, m.OFFSET, s$
Print "Copy memory buffer."
x = Display(s$)
_MemCopy m, m.OFFSET, m.SIZE To n, n.OFFSET
Return

' read the memory buffer
GetMem:
Color 14
b$ = Space$(t * l)
_MemGet n, n.OFFSET, b$
Print "Read memory buffer."
x = Display(b$)
Return

' always clear the memory when done
FreeMem:
Color 14
Print "Free memory buffer."
_MemFree m: _MemFree n
x = More
Return

' prompt for next display
Function More
  Color 15
  Print "-more-";
  Do
      _Limit 50
      x$ = InKey$
      If Len(x$) Then
        Print
        Exit Do
      End If
  Loop
  More = -1
End Function

' prompt for next display
Function MoreX
  Color 15
  Print "-next-";
  Do
      _Limit 50
      x$ = InKey$
      If Len(x$) Then
        Print
        Exit Do
      End If
  Loop
  MoreX = -1
End Function

Function Display (o$)
  c = -1
  For d = 1 To Len(o$)
      c = c + 1
      If c >= 22 * 80 Then
        c = 0
        Print
        x = MoreX
      End If
      Color 14
      Print Mid$(o$, d, 1);
  Next
  Print
  x = More
  Display = -1
End Function


[Image: memory.png]



Attached Files
.zip   MEMORY.ZIP (Size: 1.03 KB / Downloads: 27)
Print this item

  QB64PE, Aria, and... STUFF
Posted by: TempodiBasic - 01-29-2025, 04:14 AM - Forum: General Discussion - Replies (9)

Print this item

  testing a number's quare root is an integer and casting to a value?
Posted by: madscijr - 01-27-2025, 07:44 PM - Forum: Help Me! - Replies (22)

I need to test whether a number's square root is an integer (nothing after the decimal, test code below). 
My first try was to use MOD and see if 1 divides into it evenly, but MOD is integer only. 
I thought maybe I could cast the square root to an integer, and subtracting that from the square root value yields 0, we know there is a fractional portion left over, so it's not just an integer. 
Did I hear something about a "cast" command being added at some point? 
Even if that's not the best way to test the square root, that would be good to know about. 
Any guidance would be appreciated... 

Code: (Select All)
Dim iLoop%
For iLoop% = 1 To 16
    TestSquareRoot iLoop%
Next iLoop%

Sub TestSquareRoot (MyNumber%)
    Dim MySquareRoot!
    MySquareRoot! = Sqr(MyNumber%)
    Print "For value " + _Trim$(Str$(MyNumber%)) + ", " + _
        "square root is " + _trim$(str$(MySquareRoot!)) + ", " + _
        _IIf((MySquareRoot! Mod 1 = 0), "even", "different")
End Sub

Print this item

Smile Problem replacing legacy code with modern QB64 code
Posted by: HuggbardCeline - 01-27-2025, 11:58 AM - Forum: Help Me! - Replies (10)

Dear Sirs,

first of all many thanks for this great forum. This forum is the reason why i'm learning QB64 [Image: smile.png].

I read the tutorial from here https://www.qb64tutorial.com
which was really excellent. Some smaller tutorials followd and i learned a lot.

For learning purposes i'm now trying to translate an older QBasic code to modern QB64 Code. It is an old Demo from Phatcode called "digital reality" by plasma. For me the most interesting part ist the Vector_Balls part.

My problem is I can't figure out how to do the page flipping in a correct way in modern QB64.
I also sent the DIGIREAL.BIN fily, simply rename .bmp to .BIN.

This is the reduced working code:

Code: (Select All)


'digital reality by plasma
'.........................
'
'[11-01-2004] updated final release
'[07-16-2002] final release
'[11-01-2001] contest release
'
'created for Toshi's Fall 2001 "Pure QB" demo competition
'placed 3rd out of 6 entries
'
'www.phatcode.net


'Dim ScreenImage& ' the main graphics screen
'Dim ActivePage% '  page being written to
'Dim ViewPage% '    page being viewed

'ScreenImage& = _NewImage(640, 640, 32) '              create main graphics screen'Screen ScreenImage&, , 1, 0 '                        page 1 active and viewing page 0
'Screen ScreenImage&, , 0, 0 '                        active and view page set to 0




DefInt A-Z
'$Static

Const NONE = 0
Const ADLIB = 1
Const MPU401 = 2
Const FALSE = 0
Const TRUE = Not FALSE

Const Compiled = TRUE 'change this to FALSE to run in the QB IDE
'change this to TRUE when compiling for extra speed

DECLARE SUB Do.End ()

DECLARE SUB Do.VectorBalls ()

DECLARE SUB Gfx.Pal.GetAttr (pal.seg, pal.off, Reg, r, g, b)
DECLARE SUB Gfx.Pal.Load (Filename$, pal.seg, pal.off)
DECLARE SUB Gfx.Pal.Set (pal.seg, pal.off)
DECLARE SUB Gfx.Put (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off)
DECLARE SUB Gfx.Put.Mask (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off, clip.color)

DECLARE SUB Lookup.GenTables ()

DECLARE SUB Pack.BLoad (PakFile, Filename$, segment, offset)
DECLARE FUNCTION Pack.Offset& (PakFile, Filename$)

Dim Shared Pack
Dim Shared PackFile$

PackFile$ = "DIGIREAL.BIN"
Pack = FreeFile
Open "DIGIREAL.BIN" For Binary As #Pack
If LOF(Pack) = 0 Then
    Close #Pack
    Kill PackFile$
    Print "Cannot find " + PackFile$
    End
End If

Dim Shared Gfx.OldSkool
Dim Shared Gfx.WaitSync

Dim Shared Pal.FadeBuffer(767)

'$Dynamic
'$Static

Dim Shared Lookup.Cosine(360) As Single
Dim Shared Lookup.Sine(360) As Single
Dim Shared Lookup.Sine160(0 To 360) As Single
Dim Shared Lookup.Cosine160(0 To 360) As Single

Randomize 357

Do.Startup
Lookup.GenTables
'Screen _NewImage(1024, 768, 32)

Screen 13

Do.VectorBalls


Sub Do.Startup

    Dim Choose(2)

    DetectVSync = TRUE
    Choose(1) = 3

    Gfx.WaitSync = Choose(1)

    Cls

End Sub


Sub Do.VectorBalls

    Seek #Pack, Pack.Offset&(Pack, "VECTORS.DAT")

    Get #Pack, , NumShapes
    Get #Pack, , NumBalls

    Dim Vector(NumShapes, NumBalls - 1, 2)
    Dim Temp(NumBalls - 1, 2)
    Distance = 256

    Dim Morph(NumShapes, NumBalls - 1, 2)

    For i = 1 To NumShapes
        For j = 0 To NumBalls - 1
            Get #Pack, , x
            Get #Pack, , y
            Get #Pack, , z
            Vector(i, j, 0) = x
            Vector(i, j, 1) = y
            Vector(i, j, 2) = z
        Next
    Next



    '-----------------------------------------------------------------------------------------------------------------------

    'ViewPage% = 0 '                                            set view page
    'PCopy ViewPage% + 1, 0 '                                copy page 1 or 2 to page 0
    'ViewPage% = 1 - ViewPage% '                            flip view page
    '_Display '


    Dim Screen.Buffer(32001)
    Screen.Buffer(0) = 2560
    Screen.Buffer(1) = 200

    '-----------------------------------------------------------------------------------------------------------------------


    For i = 1 To NumShapes - 1
        For j = 0 To NumBalls - 1
            startX = Vector(i, j, 0)
            startY = Vector(i, j, 1)
            startZ = Vector(i, j, 2)
            endX = Vector(i + 1, j, 0)
            endY = Vector(i + 1, j, 1)
            endZ = Vector(i + 1, j, 2)
            Morph(i, j, 0) = endX - startX
            Morph(i, j, 1) = endY - startY
            Morph(i, j, 2) = endZ - startZ
        Next
    Next

    For i = 0 To NumBalls - 1
        Vector(0, i, 0) = Vector(1, i, 0)
        Vector(0, i, 1) = Vector(1, i, 1)
        Vector(0, i, 2) = Vector(1, i, 2)
    Next

    Dim Ball(191) As Integer
    Dim BallPal(2, 383) As Integer

    Gfx.Pal.Load "BALL.PAL", VarSeg(BallPal(0, 0)), VarPtr(BallPal(0, 0))

    Dim pal(383)

    For i = 3 To 383
        pal(i) = 10 + 256 * 10
    Next

    For i = 0 To 255
        Gfx.Pal.sFade 255, i, VarSeg(pal(0)), VarPtr(pal(0)), VarSeg(BallPal(0, 0)), VarPtr(BallPal(0, 0))

        If Gfx.WaitSync > 0 Then
            Wait &H3DA, 8, 8
            Wait &H3DA, 8
        End If
        Gfx.Pal.Set VarSeg(pal(0)), VarPtr(pal(0))
    Next

    Pack.BLoad Pack, "BALL.GFX", VarSeg(Ball(0)), VarPtr(Ball(0))

    Def Seg = VarSeg(Screen.Buffer(0))

    steps = 0
    shape = 1
    Do
        'PCopy 1, 0 '                                            clear screen with page 3 image

        If steps < 128 Then
            For i = 0 To NumBalls - 1
                Vector(0, i, 0) = Vector(shape, i, 0) + (Morph(shape, i, 0) / 128) * steps
                Vector(0, i, 1) = Vector(shape, i, 1) + (Morph(shape, i, 1) / 128) * steps
                Vector(0, i, 2) = Vector(shape, i, 2) + (Morph(shape, i, 2) / 128) * steps
            Next
            steps = steps + 1
        ElseIf steps < 512 Then
            steps = steps + 1
        ElseIf steps = 512 And shape < NumShapes - 1 Then
            steps = 0
            shape = shape + 1
        End If

        If shape = NumShapes - 1 And steps > 128 And AngleX >= 0 And AngleX <= 5 And AngleY >= 0 And AngleY <= 0 And AngleZ >= 0 And AngleZ <= 5 Then
            AngleX = 0
            AngleY = 0
            AngleZ = 0
            Distance = Distance - 1
            If Distance = 0 Then Exit Do
        Else
            AngleX = AngleX + 1
            If AngleX >= 360 Then AngleX = 0
            AngleY = AngleY + 1
            If AngleY >= 360 Then AngleY = 0
            AngleZ = AngleZ - 1
            If AngleZ < 0 Then AngleZ = 359
        End If


        For i = 0 To NumBalls - 1

            TempX = Vector(0, i, 0)
            TempY = Vector(0, i, 1)
            TempZ = Vector(0, i, 2)

            'rotate around the x-axis
            NewY = TempY * Lookup.Cosine(AngleX) - TempZ * Lookup.Sine(AngleX)
            NewZ = TempY * Lookup.Sine(AngleX) + TempZ * Lookup.Cosine(AngleX)
            NewX = TempX
            TempX = NewX
            TempY = NewY
            TempZ = NewZ

            'rotate around the y-axis
            NewX = TempX * Lookup.Cosine(AngleY) + TempZ * Lookup.Sine(AngleY)
            NewZ = -TempX * Lookup.Sine(AngleY) + TempZ * Lookup.Cosine(AngleY)
            TempX = NewX
            TempZ = NewZ

            'rotate around the z-axis
            NewX = TempX * Lookup.Cosine(AngleZ) - TempY * Lookup.Sine(AngleZ)
            NewY = TempX * Lookup.Sine(AngleZ) + TempY * Lookup.Cosine(AngleZ)
            TempX = NewX
            TempY = NewY

            'push the z coordinates into the view area
            TempZ = TempZ - Distance

            Temp(i, 0) = TempX * 256 \ TempZ + 160
            Temp(i, 1) = TempY * 256 \ TempZ + 100
            Temp(i, 2) = TempZ

        Next

        For j = 0 To NumBalls - 2
            For k = j + 1 To NumBalls - 1
                a = Temp(j, 2)
                b = Temp(k, 2)
                If a >= b Then
                    Swap Temp(j, 0), Temp(k, 0)
                    Swap Temp(j, 1), Temp(k, 1)
                    Swap Temp(j, 2), Temp(k, 2)
                End If
            Next
        Next

        For i = 0 To NumBalls - 1
            Gfx.Put Temp(i, 0) - 10, Temp(i, 1) - 8, VarSeg(Ball(0)), VarPtr(Ball(0)), VarSeg(Screen.Buffer(0)), 4
        Next


        If Gfx.WaitSync > 1 Then
            Wait &H3DA, 8, 8
            Wait &H3DA, 8
        End If

        '-----------------------------------------------------------------------------------------------------------------------

        'ActivePage% = 1 - ActivePage% '                  flip active page


        Put (0, 0), Screen.Buffer(0), PSet
        ReDim Screen.Buffer(32001)
        Screen.Buffer(0) = 2560
        Screen.Buffer(1) = 200
        '-----------------------------------------------------------------------------------------------------------------------
        '_Display

    Loop


End Sub

Sub Gfx.Pal.Load (Filename$, pal.seg, pal.off)

    Seek #Pack, Pack.Offset&(Pack, Filename$)
    Byte$ = " "

    Def Seg = pal.seg
    For x = 0 To 767
        Get #Pack, , Byte$
        Poke pal.off + x, Asc(Byte$)
    Next

End Sub

Sub Gfx.Pal.Set (pal.seg, pal.off)

    Def Seg = pal.seg
    Out &H3C8, 0

    For x = 0 To 255
        red = Peek(pal.off + x * 3)
        green = Peek(pal.off + x * 3 + 1)
        blue = Peek(pal.off + x * 3 + 2)
        If Gfx.OldSkool Then
            gray = (red * 30 + green * 59 + blue * 11) \ 100
            Out &H3C9, gray
            Out &H3C9, gray
            Out &H3C9, gray
        Else
            Out &H3C9, red
            Out &H3C9, green
            Out &H3C9, blue
        End If
    Next

End Sub

Sub Gfx.Pal.SetAttr (pal.seg, pal.off, Reg, r, g, b)

    Def Seg = pal.seg
    Poke pal.off + Reg * 3, r
    Poke pal.off + Reg * 3 + 1, g
    Poke pal.off + Reg * 3 + 2, b

End Sub

Sub Gfx.Pal.sFade (steps, frame, pal.seg, pal.off, topal.seg, topal.off)

    For x = 0 To 767
        Def Seg = topal.seg
        target = Peek(topal.off + x)
        Def Seg = pal.seg
        current = Peek(pal.off + x)
        If frame = 0 Then
            Pal.FadeBuffer(x) = current
            original = current
        Else
            original = Pal.FadeBuffer(x)
        End If

        If current < target Then
            current = original + ((target - original) / steps) * frame
        ElseIf current > target Then
            current = target + ((original - target) / steps) * (steps - frame)
        End If

        Poke pal.off + x, current

    Next

End Sub

Sub Gfx.Put (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off)

    Def Seg = src.seg
    xsize = (Peek(src.off) + Peek(src.off + 1) * 256) / 8
    ysize = Peek(src.off + 2)

    If Compiled Then

        For y = 0 To ysize - 1
            For x = 0 To xsize - 1
                Def Seg = src.seg
                Byte = Peek(src.off + 4 + y * xsize + x)
                If Byte <> 0 Then
                    If y.pos + y > 0 And y.pos + y < 200 And x.pos + x > 0 And x.pos + x < 320 Then
                        Def Seg = dest.seg
                        Poke dest.off + (y.pos + y) * 320 + x.pos + x, Byte
                    End If
                End If
            Next
        Next

    Else

        For y = 0 To ysize - 1
            For x = 0 To xsize - 1
                Def Seg = src.seg
                Byte = Peek(src.off + 4 + y * xsize + x)
                If Byte <> 0 Then
                    If y.pos + y > 0 And y.pos + y < 200 And x.pos + x > 0 And x.pos + x < 320 Then
                        Def Seg = dest.seg
                        Poke dest.off + (y.pos + y) * 320& + x.pos + x, Byte
                    End If
                End If
            Next
        Next

    End If

End Sub

Sub Gfx.Put.Mask (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off, clip.color)

    Def Seg = src.seg
    xsize = Peek(src.off) / 8
    ysize = Peek(src.off + 2)

    If Compiled Then

        For y = 0 To ysize - 1
            For x = 0 To xsize - 1
                Def Seg = src.seg
                Byte = Peek(src.off + 4 + y * xsize + x)
                Def Seg = dest.seg
                If y.pos + y > 0 And y.pos + y < 320 And x.pos + x > 0 And x.pos + x < 320 Then
                    If Peek(dest.off + (y.pos + y) * 320 + x.pos + x) <> clip.color Then
                        Poke dest.off + (y.pos + y) * 320 + x.pos + x, Byte
                    End If
                End If
            Next
        Next

    Else

        For y = 0 To ysize - 1
            For x = 0 To xsize - 1
                Def Seg = src.seg
                Byte = Peek(src.off + 4 + y * xsize + x)
                Def Seg = dest.seg
                If y.pos + y > 0 And y.pos + y < 320 And x.pos + x > 0 And x.pos + x < 320 Then
                    If Peek(dest.off + (y.pos + y) * 320& + x.pos + x) <> clip.color Then
                        Poke dest.off + (y.pos + y) * 320& + x.pos + x, Byte
                    End If
                End If
            Next
        Next

    End If

End Sub


Sub Lookup.GenTables

    For x = 0 To 359
        Lookup.Cosine(x) = Cos(x * 3.14159265# / 180)
        Lookup.Sine(x) = Sin(x * 3.14159265# / 180)
        Lookup.Sine160(x) = Lookup.Sine(x) / 160
        Lookup.Cosine160(x) = Lookup.Cosine(x) / 160
    Next

End Sub


Sub Pack.BLoad (PakFile, Filename$, segment, offset)

    buffer = 8000

    Seek #PakFile, 6
    Get #PakFile, , NumFiles

    For x = 1 To NumFiles

        Name$ = Space$(8)
        Get #PakFile, , Name$

        Ext$ = Space$(3)
        Get #PakFile, , Ext$

        If Filename$ = LTrim$(RTrim$(Name$)) + "." + LTrim$(RTrim$(Ext$)) Then
            FileNum = x
            Exit For
        End If

    Next

    If x = 0 Then
        Close #PakFile
        Exit Sub
    End If

    Seek #PakFile, 11 + NumFiles * 11 + (FileNum - 1) * 8
    Get #PakFile, , FileLoc&
    Get #PakFile, , FileLen&

    FileLoc& = FileLoc& + 7
    FileLen& = FileLen& - 7
    Seek #PakFile, FileLoc& + 1

    offset& = offset - 1
    Block = buffer
    Do
        If Loc(PakFile) = FileLoc& + FileLen& + 1 Then Exit Do
        If Loc(PakFile) + Block > FileLoc& + FileLen& + 1 Then
            Block = (FileLoc& + FileLen& + 1) - Loc(PakFile)
        End If

        buffer$ = Input$(Block, # PakFile)

        Def Seg = segment
        For x = 1 To Len(buffer$)
            Poke offset& + x, Asc(Mid$(buffer$, x, 1))
        Next
        offset& = offset& + Len(buffer$)
    Loop Until EOF(PakFile)
    buffer$ = ""

End Sub

Function Pack.Offset& (PakFile, Filename$)

    Seek #PakFile, 6
    Get #PakFile, , NumFiles

    For x = 1 To NumFiles

        Name$ = Space$(8)
        Get #PakFile, , Name$

        Ext$ = Space$(3)
        Get #PakFile, , Ext$

        If Filename$ = LTrim$(RTrim$(Name$)) + "." + LTrim$(RTrim$(Ext$)) Then
            FileNum = x
            Exit For
        End If

    Next

    If x = 0 Then Exit Function

    Seek #PakFile, 11 + NumFiles * 11 + (FileNum - 1) * 8
    Get #PakFile, , FileLoc&
    Get #PakFile, , FileLen&

    Pack.Offset& = FileLoc& + 1

End Function


I'm also a little bit confused about the waitsync part.

Im trying it now for 1 week but I'm totally stuck [Image: sad.png].

Thank you fot your help and work in advance.

Best regards,
Huggy


Admin Edit:

Removed the DIGIREAL.BMP as it was wanting to try and load as an image and couldn't (as it's a BIN file instead), so it just errored out and was inaccessible. You can now grab the file in the 7z archive and extract it without issue for testing and experimentation with the code above.



Attached Files
.7z   DIGIREAL_.7z (Size: 6.55 KB / Downloads: 31)
Print this item

  X-box Gamepad Routines
Posted by: SMcNeill - 01-26-2025, 11:28 PM - Forum: SMcNeill - No Replies

Code: (Select All)
'The type and ReDim statements should go at the top of your code
'Or go in a BI file
Type Axis_Type
Active As _Byte
X As Integer
Y As Integer
Vert As Single
Hort As Single
Angle As Single
End Type
ReDim Shared As Axis_Type JoyStick(0)
ReDim Shared As Long Button(0)

Do
Cls
ReadJoyStick 'Use this command to read your joystick

'The code here is what we use to check the results of our joystick input
For i = 1 To UBound(JoyStick) 'this checks for each axis of our joystick
'joystick(1) should be the left paddle
'joystick(2) should be the right paddle
'joystick(3) should be the d-pad
If JoyStick(i).Active Then 'check to see if any of the joysticks are active
Print Using "STICK # ACTIVE:"; i
Print "Hort:", JoyStick(i).Hort, "Vert:", JoyStick(i).Vert 'if one is, you can get the direction it's pressed in
Print "X:", JoyStick(i).X, "Y:", JoyStick(i).Y 'simply by referencing these global variables
Print "Angle:", JoyStick(i).Angle 'and this gives you the angle of the joystick
End If
Next
For b = 1 To UBound(Button)
'button(1) is the A button
'button(2) is the B button
'button(3) is the X button
'button(4) is the Y button
'button(5) is the top-left button on the front of the game pad
'button(6) is the top-right button on the front of the game pad
'button(7) is the select button (top of game pad, beside the d-pad
'button(8) is the start button (top of game pad, right of button(7)
'button(9) is the left paddle being pushed in as a button
'button(10) is the right paddle being pushed in as a button
'button(11) is the bottom-left button on the front of the game pad (Z-Axis)
'button(12) is the bottom-right button on the front of the game pad (Z-Axis)
If Button(b) Then Print Using "Button ## down (of ##)"; b, UBound(Button) 'if the button is down, process it
Next
_Limit 30
_Display
Loop


'This sub needs to go at the end of your code, or in a BM file
Sub ReadJoyStick
Static As Long d, LA, LB 'Last Axis, Last Button
If d = 0 Then d = _Devices
If d < 3 Then Exit Sub '3 is joystick. Without one, then there's no reason to waste effort doing anything else.
If LA = 0 Then LA = _LastAxis(3): ReDim JoyStick(1 To 3) As Axis_Type
If LA = 0 Then Exit Sub 'if there's no axis on your joystick, I don't know how to read it!
If LB = 0 Then LB = _LastButton(3): ReDim Button(1 To LB + 2) As Long
If LB = 0 Then Exit Sub 'if there's no buttons on your joystick, then it's not a proper controller. Go buy one!

Dim axis(LA) As Single
Do
di = _DeviceInput
Select Case di
Case 3 'We have joystick input
For a = 1 To LA: axis(a) = Int(100 * _Axis(a)) / 100: Next 'read the input on each axis
JoyStick(1).Hort = axis(1): JoyStick(1).Vert = axis(2) 'left pad is axis 1 and 2
'axis 3 is the botton left/right buttons on the front of my joystick
JoyStick(2).Hort = axis(5): JoyStick(2).Vert = axis(4) 'right pad is axis 5 and 4
JoyStick(3).Hort = axis(6): JoyStick(3).Vert = axis(7) 'd-pad is axis 6 and 7
'right-pad seems to be mapped backwards to the other axis??!!
For i = 1 To LB
Button(i) = _Button(i)
Next
Button(LB + 1) = _FALSE: Button(LB + 2) = _FALSE
Select Case _Axis(3) 'this is an odd axis which reads off the left/right buttons on the front of the gamepad
Case Is > 0.4: Button(LB + 1) = _TRUE
Case Is < -0.4: Button(LB + 2) = _TRUE
End Select
End Select
Loop Until di = 0
For j = 1 To 3
If Abs(JoyStick(j).Vert) <= .01 Then JoyStick(j).Vert = 0 'remove some natural drift from the keypad
If Abs(JoyStick(j).Hort) <= .01 Then JoyStick(j).Hort = 0 'my joystick seldom resets back to perfect 0
' the code below here gives me a simple X/Y value for left/right, up/down of _TRUE/_FALSE
'I personally find it easier for my 2-d style games to process than having to use frational results.
'Feel free to change the threshold as necessary for your own uses. 0.4 works fine for cardinal directions and diagionals for my use.
If Abs(JoyStick(j).Vert) > 0.4 Then JoyStick(j).Y = Sgn(JoyStick(j).Vert) Else JoyStick(j).Y = 0
If Abs(JoyStick(j).Hort) > 0.4 Then JoyStick(j).X = Sgn(JoyStick(j).Hort) Else JoyStick(j).X = 0
'the angle here is just like the one we learned in school with 0/360 to the right, 90 up, 180 left, and 270 down
'Tweak this as needed so it fits the coordinate system of your own stuff as desired.
JoyStick(j).Angle = _Atan2(JoyStick(j).Hort, JoyStick(j).Vert)
JoyStick(j).Angle = (_R2D(JoyStick(j).Angle) + 270) Mod 360
'And below here is what determines if a joystick was active or not
If JoyStick(j).Vert = 0 And JoyStick(j).Hort = 0 Then JoyStick(j).Active = _FALSE Else JoyStick(j).Active = _TRUE
Next
End Sub

All the mappings here work for my gamepad, though some buttons just fail to report. Even checking the Windows controller test routine, they fail to read, so this appears to be a Windows issue and not a QB64PE issue.

As it is, 16 of my 21 buttons are now mapped and reading properly, with 5 of them just lost.

Keep in mind though, that 4 of the buttons that work are double-mapped to the same input.

My left-paddle can be pressed down to generate a button event. On the bottom of my controller is another button that generates that exact same event. The controller was made like this, just for ease of producing that event.
Same with the right-paddle and pressing it down to generate a button event. On the bottom of the controller is another button that mimics that same press. It's just the way it's designed.

My Z-Axis (the left and right bottom buttons on the front) for some reason are separated into two distinct buttons. Perhaps an ergonomics thing? Either way, both of them generate the same button response as the button beside them.

I don't know if other's controllers are configured the same, but I would hope so. Hopefully several folks will test this out and report back for us, and let us know if everything maps to the same buttons for them.

I commented the crapola out of this code, so it should be easy to read, understand, and maintain in the future. There's a few parts which people might want to tweak for their own personal preferences, so be certain to take a moment to look at those. (The angle we return is one which I'd think various programs might need to tweak for their own usage.)

Try it out. Report back. I hope it works just as well for everyone else as it does on my personal game pad. Smile

Print this item

  Joystick WIP
Posted by: SMcNeill - 01-26-2025, 10:03 AM - Forum: Works in Progress - Replies (3)

For testing purposes only, give this a try with your favorite joystick and see how this maps out/behaves.

Code: (Select All)
Type Axis_Type
Active As _Byte
Vert As Single
Hort As Single
Angle As Single
End Type
ReDim Shared As Axis_Type JoyStick(0)

Do
Cls
ReadJoyStick
For i = 1 To UBound(JoyStick)
If JoyStick(i).Active Then
Print Using "STICK # ACTIVE:"; i
Print JoyStick(i).Hort, JoyStick(i).Vert, JoyStick(i).Angle
End If
Next
_Limit 30
_Display
Loop

Sub ReadJoyStick
Static d, LA
If d = 0 Then d = _Devices
If d < 3 Then Exit Sub '3 is joystick. Without one, then there's no reason to waste effort doing anything else.
If LA = 0 Then LA = _LastAxis(3): ReDim JoyStick(1 To LA \ 2) As Axis_Type
If LA = 0 Then Exit Sub 'if there's no axis on your joystick, I don't know how to read it!
Dim axis(LA) As Single
Do
di = _DeviceInput
Select Case di
Case 3
For a = 1 To LA: axis(a) = _Axis(a): Next
For j = 1 To LA \ 2
If j = 1 Then
'left pad is axis 1 and 2
JoyStick(j).Hort = axis(j * 2 - 1): JoyStick(j).Vert = axis(j * 2)
Else
'axis 3 is the botton left/right buttons on the front of my joystick
'so the right pad is axis 4 and 5
'and the d-pad is axis 6 and 7
JoyStick(j).Hort = axis(j * 2 + 1): JoyStick(j).Vert = axis(j * 2)
'd-pad seems to be mapped backwards to the other axis??!!
If j = 3 Then Swap JoyStick(j).hort, JoyStick(j).vert
End If
Next
End Select
Loop Until di = 0
For j = 1 To LA \ 2
If Abs(JoyStick(j).Vert) <= .01 Then JoyStick(j).Vert = 0
If Abs(JoyStick(j).Hort) <= .01 Then JoyStick(j).Hort = 0
JoyStick(j).Angle = _Atan2(JoyStick(j).Hort, JoyStick(j).Vert)
JoyStick(j).Angle = (_R2D(JoyStick(j).Angle) + 270) Mod 360
If JoyStick(j).Vert = 0 And JoyStick(j).Hort = 0 Then JoyStick(j).Active = _FALSE Else JoyStick(j).Active = _TRUE
Next
End Sub


I've tested this on my Xbox-style joystick and... these mappings seem odd as BLEEP to me!

Left paddle is axis 1 and 2
Right paddle is axis 4 and 5
D-pad is axis 7 and 6

Axis 3 is the button left/right buttons on the front of the joystick
Note that the D-pad is REVERSED in order compared to the paddles.

Who the crap configures these things? Who thought this type of set up would be nice and normal and easy to configure for??

/sigh

Anywho... Test this out with your own joysticks and see if it responds as expected for you. So far, this just tests for the stick movement (it doesn't even try and tell you about those button-sticks!), but it *should* have x and y both mapped for all 3 axis.

Let me know if it works for you, or if it gives some odd readings, or whatnot. I have no idea how the heck this might work on various controllers. It's just... weird the mapping on this thing.



As for the angle, I've fixed it so it should map to the same coordinates as what we learned in school. 0 is to right, 90 is to the top, 180 is left and 270 is bottom. It should be the quickest way to tell if something is completely off with the left/right paddles.

Print this item

  Pinball
Posted by: SierraKen - 01-26-2025, 12:21 AM - Forum: Works in Progress - Replies (6)

I worked over 8 hours on this game so far, but I can't figure out how to make the oval flippers collide with the ball efficiently. So far, they work around 50% of the time. Much of this code is from when B+ helped me with hocky puck colliders awhile back and another big part of this code is math from ChatGPT, such as making the ovals turn on the axis at the end of the oval, for the flippers. 

You can still play this game if you keep pressing the 2 CTRL keys to move the flippers many times to hit the ball. But it would be nice if I could fix this, thanks. You can probably tell a lot of it has been made experimenting with numbers, etc. Smile I'm just zomped out. lol 

Code: (Select All)

'Pinball by SierraKen
'1-25-25

'Much of this code is from help by B+ with collisions awhile back.
'Thank you B+ and QB64pe Forum!
'Another large chunk of this math is from ChatGPT.

'The paddles only work about 50 percent of the time and I'm not sure how to fix that.
'OItherwise if you keep pressing the paddles they will work.

'The Left Paddle is the Left CTRL key and the Right Paddle is the Right CTRL key.

_Title "Pinball - by SierraKen - Press the Left and Right CTRL keys to move Paddles."


Randomize Timer
Screen _NewImage(800, 800, 32)

num = 12

ball = 10


Dim circx(num), circy(num), size(num), red(num), green(num), blue(num)

Dim X As Single, Y As Single
Dim Xc As Single, Yc As Single
Dim a As Single, b As Single
Dim theta As Single, t As Single
Dim thickness As Integer

Dim X2 As Single, Y2 As Single
Dim Xc2 As Single, Yc2 As Single
Dim a2 As Single, b2 As Single
Dim theta2 As Single, t2 As Single
Dim thickness2 As Integer

Xc = 500 ' Center of the screen
Yc = 700
a = 75 ' Semi-major axis
b = 25 ' Semi-minor axis
theta = 45 * _Pi / 180 ' Rotate 45 degrees in radians
thickness = 10 ' Thickness of the ellipse

Xc2 = 300 ' Center of the screen
Yc2 = 700
a2 = 75 ' Semi-major axis
b2 = 25 ' Semi-minor axis
theta2 = 45 * _Pi / -180 ' Rotate 45 degrees in radians
thickness2 = 10 ' Thickness of the ellipse

begin:

slotx = 280
sloty = 690
dir = 1

For cir = 1 To num
    If cir = 1 Then
        circx(cir) = 775
        circy(cir) = 25
        size(cir) = 50
    End If
    If cir = 2 Then
        circx(cir) = 25
        circy(cir) = 25
        size(cir) = 50
    End If
    If cir = 4 Then
        circx(cir) = 635
        circy(cir) = 200
        size(cir) = 40
    End If
    If cir = 5 Then
        circx(cir) = 175
        circy(cir) = 200
        size(cir) = 40
    End If
    If cir = 6 Then
        circx(cir) = 535
        circy(cir) = 350
        size(cir) = 30
    End If
    If cir = 7 Then
        circx(cir) = 275
        circy(cir) = 350
        size(cir) = 30
    End If
    If cir = 8 Then
        circx(cir) = 460
        circy(cir) = 500
        size(cir) = 20
    End If
    If cir = 9 Then
        circx(cir) = 355
        circy(cir) = 500
        size(cir) = 20
    End If
    If cir = 10 Then
        circx(cir) = 400
        circy(cir) = 550
        size(cir) = 15
    End If
    If cir = 11 Then
        circx(cir) = 800
        circy(cir) = 680
        size(cir) = 50
    End If
    If cir = 12 Then
        circx(cir) = 0
        circy(cir) = 680
        size(cir) = 165
    End If
    red(cir) = Rnd * 255
    green(cir) = Rnd * 255
    blue(cir) = Rnd * 255
Next cir


pr = 7 'Radius of ball
pc = _RGB32(0, 255, 0) 'Color of ball
'
speedx = 30 '
speedy = 30
gravity = 0.5 ' Gravitational acceleration (adjust this to simulate stronger/weaker gravity)
floorHeight = 680 ' Floor height, where the ball will stop when it hits


start:
px = (Rnd * 550) + 60: py = 60
_Delay 1
Cls

pa = _Pi(1) * Rnd


Play "MB"

Do

    _Limit 800
    Line (10, 10)-(790, 690), _RGB32(255, 255, 255), B

    For cir = 1 To num
        _Limit 800

        'Bumpers
        fillCircle circx(cir), circy(cir), size(cir), _RGB32(red(cir), green(cir), blue(cir))
        fillCircle circx(cir), circy(cir), size(cir) / 2, _RGB32(255, 255, 127)
        a$ = InKey$
        If a$ = " " Then GoTo start:
        If a$ = Chr$(27) Then End

        'Flippers
        If _KeyDown(100305) Then 'Right Side
            If theta > .85 Then GoTo skip1
            theta = theta + .05
        Else
            If theta < -.25 Then GoTo skip1
            theta = theta - .05
        End If
        skip1:
        If _KeyDown(100306) Then 'Left Side
            If theta2 < -.85 Then GoTo skip2
            theta2 = theta2 - .05
        Else
            If theta2 > .25 Then GoTo skip2
            theta2 = theta2 + .05
        End If
        skip2:
        For offset = 0 To thickness - 1 Step 0.5 ' Add layers for thickness
            For t2 = 0 To 2 * _Pi Step 0.01
                ' Calculate initial x and y for the oval before rotation
                X_initial = (a + offset) * Cos(t2)
                Y_initial = (b + offset) * Sin(t2)

                ' Translate so the end of the oval becomes the origin
                X_translated = X_initial - (a + offset)
                Y_translated = Y_initial

                ' Rotate around the new origin using theta
                X_rotated = X_translated * Cos(theta) - Y_translated * Sin(theta)
                Y_rotated = X_translated * Sin(theta) + Y_translated * Cos(theta)

                ' Translate back to the original position
                X2 = Xc + X_rotated + (a + offset)
                Y2 = Yc + Y_rotated

                ' Draw the point
                PSet (X2, Y2), _RGB32(255, 255, 255)
            Next
        Next

        For offset = 0 To thickness - 1 Step 0.5 ' Add layers for thickness
            For t = 0 To 2 * _Pi Step 0.01
                ' Calculate initial x and y for the second flipper
                X_initial = (a + offset) * Cos(t)
                Y_initial = (b + offset) * Sin(t)

                ' Translate so the opposite end of the oval becomes the origin
                X_translated = X_initial + (a + offset) ' Notice the + instead of -
                Y_translated = Y_initial

                ' Rotate around the new origin using theta for Flipper 2
                X_rotated = X_translated * Cos(theta2) - Y_translated * Sin(theta2)
                Y_rotated = X_translated * Sin(theta2) + Y_translated * Cos(theta2)

                ' Translate back to the original position for Flipper 2
                X = Xc2 + X_rotated - (a + offset) ' Translate back from the opposite end
                Y = Yc2 + Y_rotated

                ' Draw Flipper 2
                PSet (X, Y), _RGB32(255, 255, 255) ' Use a different color for Flipper 2
            Next
        Next

        'Check flippers
        For chk = -10 To 10 Step 1
            If Sqr((X + chk - px) ^ 2 + (Y + chk - py) ^ 2) < (pr + 35) Then
                pa = _Atan2(py - Y, px - X)
                collision px, py, pa, speedx, speedy
                px = px + speedx * Cos(pa)
                py = py + speedy * Sin(pa)
            End If
            If Sqr((X2 + chk - px) ^ 2 + (Y2 + chk - py) ^ 2) < (pr + 35) Then
                pa = _Atan2(py - Y2, px - Y2)
                collision px, py, pa, speedx, speedy
                px = px + speedx * Cos(pa)
                py = py + speedy * Sin(pa)
            End If
        Next chk

        'Check bumpers
        If Sqr((circx(cir) - px) ^ 2 + (circy(cir) - py) ^ 2) < (pr + size(cir)) Then
            pa = _Atan2(py - circy(cir), px - circx(cir))
            pa = pa + Rnd
            px = px + speedx * Cos(pa)
            py = py + speedy * Sin(pa)
            fillCircle circx(cir), circy(cir), size(cir), _RGB32(255, 0, 0)
            fillCircle circx(cir), circy(cir), size(cir) / 1.33, _RGB32(255, 255, 127)
            score = Int(score + 10000 / size(cir))
            Sound 350, .5, , , 2
            Sound 400, .5, , , 3
            Sound 350, .5, , , 4
            Sound 300, .5, , , 5
            _Title "Score: " + Str$(score) + "    Ball: " + Str$(ball) + "    Level: " + Str$(level)
            oldlevel = level
            level = Int(score \ 50000 + 1)
            If oldlevel <> level And level <> 1 Then GoTo begin:
        End If
        If speedx < 5 Then speedx = 5
        If speedy < 5 Then speedy = 5
        If speedx > 30 Then speedx = 30
        If speedy > 30 Then speedy = 30
    Next cir

    'Border reflection.
    If px > 790 - pr Then pa = _Pi - pa * Rnd + 1: px = 790 - pr
    If px < 10 + pr Then pa = _Pi - pa * Rnd + 1: px = 10 + pr
    If py > 790 - pr And floorHeight = 680 Then pa = -pa * Rnd + 1: py = 790 - pr
    If py < 10 + pr Then pa = -pa * Rnd + 1: py = 10 + pr

    If px > slotx + 30 And px < slotx + 170 And py > sloty - 70 Then
        floorHeight = floorHeight + 8
        If px > slotx + 60 And px < slotx + 200 And floorHeight > 760 Then
            ball = ball - 1
            _Title "Score: " + Str$(score) + "    Ball: " + Str$(ball) + "    Level: " + Str$(level)
            px = (Rnd * 550) + 60: py = 60
            down = 0
            floorHeight = 680
            _Delay 1
            If ball = 0 Then End
        End If
    Else
        floorHeight = 680
    End If

    ' Update velocities
    speedy = speedy + gravity ' Apply gravity to vertical speed

    ' Simulate ball bouncing off the floor
    If py + pr >= floorHeight And hit <> 1 Then
        py = floorHeight - pr ' Position ball on the floor
        speedy = -speedy * 0.9 ' Reverse direction and apply damping
    End If

    ' Simulate ball moving with some friction
    If Abs(speedx) > 0.1 Then
        speedx = speedx * 0.99 ' Friction effect on horizontal velocity
    Else
        speedx = 0 ' Stop ball when velocity is too low
    End If
    If speedx < 5 Then speedx = 5
    If speedy < 5 Then speedy = 5
    If speedx > 30 Then speedx = 30
    If speedy > 30 Then speedy = 30

    'Speed
    px = px + speedx * Cos(pa)
    py = py + speedy * Sin(pa)

    fillCircle px, py, pr, pc

    Line (slotx, sloty)-(slotx + 300, sloty), _RGB32(0, 0, 0)
    _Display
    Cls
Loop Until InKey$ = Chr$(27)

End

'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

Sub collision (px, py, pa, speedx, speedy)
    speedx = speedx + 5
    speedy = -speedy
    px = px + speedx * Cos(pa)
    py = py + speedy * Sin(pa)
End Sub

Print this item

  Color Picker TSR
Posted by: SMcNeill - 01-24-2025, 08:55 AM - Forum: SMcNeill - Replies (5)

Code: (Select All)
Dim WinMse As POINTAPI
Type POINTAPI: As Long X_Pos, Y_Pos: End Type

Declare Dynamic Library "User32"
Function GetWindowLongA& (ByVal hwnd As Long, ByVal nIndex As Long)
Function SetWindowLongA& (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)
Function GetAsyncKeyState% (ByVal vkey As Long)
Function GetCursorPos (lpPoint As POINTAPI)
End Declare
Width 12, 1 'large enough to hold our color value in hex
GWL_STYLE = -16
ws_border = &H800000
WS_VISIBLE = &H10000000
_Title "Color Picker"
hwnd& = _WindowHandle
winstyle& = GetWindowLongA&(hwnd&, GWL_STYLE)
_Delay .2
a& = SetWindowLongA&(hwnd&, GWL_STYLE, winstyle& And WS_VISIBLE)

Color 15
show = -1

swaptimer# = Timer(0.001) + 1

Do
If Timer(0.001) > swaptimer# Then
If GetAsyncKeyState(&H11) _Andalso GetAsyncKeyState(&H12) _Andalso GetAsyncKeyState(&H4B) Then
show = Not show
swaptimer# = (Timer(0.001) + 1) Mod 86400
If show Then _ScreenShow Else _ScreenHide
End If
End If
_Limit 30
z = GetCursorPos(WinMse)
_ScreenMove WinMse.X_Pos + 1, WinMse.Y_Pos + 1
tempimage = _ScreenImage
Cls , 0
_Source tempimage: Print Hex$(Point(WinMse.X_Pos, WinMse.Y_Pos));: _Source 0
_FreeImage tempimage
_Display
Loop

I don't know if TSR is the proper term for this type of program nowadays, but back in the yesteryears of the past these type of tools were called Terminate and Stay Resident programs.

Not that without a title bar and without any easy exit commands, this little program doesn't terminate and quit very easily on you now. You'll probably need to go into task manager to manually stop it, so keep that in mind. If you're not comfortable with manual program stopping then... why the heck are you into programming? Tongue

This works just like before except I've made some important changes here.

1)To start with, this loads and runs and behaves exactly as the other version...
2)..until you hit CTRL-ALT-K (for Kolor Picker), where it will then hide itself and disappear completely off your computer...
3)..until you hit CTRL-ALT-K once again, where the tool will instantly reappear at command and be usable once more.

Configure this to run in your windows startup and from now on, you'll always have a handle little CTRL-ALT-K color picker available for use on your machine!



So why is this here instead of in the other topic?

Basically so folks will take the time to read the fact that this doesn't ever terminate on its own. Start it up and it'll stay in your task list and do its thing forever more unless you manually close it yourself.

For me, this is a system tool which I can make use of to always be able to grab the color code from whatever I see on my monitor. My personal plan is just to pop this into windows startup and then it'll just always be an extended system tool for me. I thought others might like the same (or at least to see how to do the same so they could write similar little programs for themselves.)

For anyone who isn't familiar with how to make a program startup in windows, see the quick write up here: https://www.howtogeek.com/208224/how-to-...in-windows

Any questions, just ask. Wink

Print this item