error doing image collision detection with _MemGet

[madscijr]

Trying to do collision detection. Version 1 function ShapesOverlap% works.
I asked google for help with speeding it up with _MEM functions, 
and it spat out ShapesOverlapMem%, but when I try running it, 
I'm getting a "Memory region out of range" error.
I'm not really a _MEM expert, I don't even play one on TV.
If anyone would look at this and give me a clue that would be much appreciated...

Code: (Select All)

' *****************************************************************************
' *****************************************************************************
' Function ShapesOverlapMem% FAILS WITH Memory region out of range ERROR at
' Line 323: _MemGet mem1, offset1, color1
'
' Function ShapesOverlap% works.
' *****************************************************************************
' *****************************************************************************

' Q:
' How might we leverage _MEM, _MEMIMAGE and similar functions to speed up the
' image overlap test?

' A:
' That's an excellent question. Leveraging direct memory access with _MEM and
' _MEMIMAGE is a classic and powerful optimization technique in QB64, especially
' for pixel-level operations.
'
' The current ShapesOverlap% function is slowed down by the repeated calls to
' Point(x, y). Each call has a certain amount of overhead. By accessing the image
' data directly in memory, we can bypass this overhead and read the pixel data
' much faster.
'
' The Strategy: From Point to Pointers
' Get Memory Access: For each of the two shape images, we'll use _MEMIMAGE to
' create a _MEM block. This block acts as a direct pointer to the raw pixel data
' of the image.
'
' Calculate Offsets: Instead of asking for the color at coordinate (x, y), we'll
' calculate the exact memory address (or offset) of that pixel's data within the
' _MEM block. For a 32-bit image, each pixel takes 4 bytes, so the offset for a
' pixel at (px, py) in an image of width is (py * width + px) * 4.
'
' Read Data Directly: We'll use _MEMGET to read the 4-byte color value directly
' from that calculated offset.
'
' Release Memory: After we're done, we must use _MEMFREE to release the _MEM
' blocks to prevent memory leaks.
'
' This approach significantly reduces the function call overhead inside the
' loops, resulting in a much faster overlap test, especially for larger shapes or
' more complex scenes.
'
' I have updated the ShapesOverlap% function in your file as ShapesOverlapMem%
' to use this memory-based approach. The core logic of finding the intersection
' area remains the same, but the pixel checking part is now much more efficient.
'
' Here is the updated file:

_Title "Alpha Overlap Demo"

Type ShapeType
    height As Long
    width As Long
    color As _Unsigned Long
    image As Long ' image handle (image handles are long not _Unsigned Long)
    x As Long
    y As Long
End Type ' ShapeType

Dim MyScreen As Long
Dim arrImg(1 To 4) As ShapeType
Dim i1 As Integer
Dim i2 As Integer
Dim bOverlaps As Integer
Dim RowNum As Integer
Dim bCompareBothWays As Integer
Dim bUseMemFunctions As Integer
Dim in$

' MAIN LOOP
Do
    Screen 0
    Cls
    Print "Collision detection"
    Print "-------------------"
    Print

    ' Prompt user for preferences
    Do
        Print "ELIMINATE DUPLICATES?"
        Print " y = to compare both A:B and B:A"
        Print " n = to eliminate duplicates"
        Print " q = quit"
        Input "Compare both ways (y/n/q)"; in$
        in$ = LCase$(_Trim$(in$))
        If in$ = "y" Then
            bCompareBothWays = _TRUE: Exit Do
        ElseIf in$ = "n" Then
            bCompareBothWays = _FALSE: Exit Do
        ElseIf in$ = "q" Then
            GoTo CleanupAndExit
        Else
            Print "Please type y or n."
        End If
        _KeyClear: _Delay .5 ' CLEAR KEYBOARD BUFFER
    Loop
    Print
    Do
        Print "TRY FAST _MEM METHOD?"
        Print " y = _MEM method (experimental)"
        Print " n = proven but slower method"
        Print " q = quit"
        Input "Use fast _MEM method (y/n/q)"; in$
        in$ = LCase$(_Trim$(in$))
        If in$ = "y" Then
            bUseMemFunctions = _TRUE: Exit Do
        ElseIf in$ = "n" Then
            bUseMemFunctions = _FALSE: Exit Do
        ElseIf in$ = "q" Then
            GoTo CleanupAndExit
        Else
            Print "Please type y or n."
        End If
        _KeyClear: _Delay .5 ' CLEAR KEYBOARD BUFFER
    Loop

    ' Init screen
    MyScreen = _NewImage(640, 480, 32): Screen MyScreen: Cls , _RGB32(0, 0, 0)

    ' Create 4 images in memory

    ' Create a red square with some transparency
    arrImg(1).height = 60
    arrImg(1).width = 60
    arrImg(1).color = _RGBA32(255, 0, 0, 150)
    arrImg(1).image = _NewImage(arrImg(1).width, arrImg(1).height, 32)
    _Dest arrImg(1).image: Cls , arrImg(1).color
    arrImg(1).x = 10
    arrImg(1).y = 10

    ' Create a green rectangle with some transparency
    arrImg(2).height = 30
    arrImg(2).width = 90
    arrImg(2).color = _RGBA32(0, 255, 0, 150)
    arrImg(2).image = _NewImage(arrImg(2).width, arrImg(2).height, 32)
    _Dest arrImg(2).image: Cls , arrImg(2).color
    arrImg(2).x = 80
    arrImg(2).y = 40

    ' Create a blue ellipse with some transparency
    arrImg(3).height = 20
    arrImg(3).width = 30
    arrImg(3).color = _RGBA32(0, 0, 255, 150)
    arrImg(3).image = _NewImage(arrImg(3).width, arrImg(3).height, 32)
    _Dest arrImg(3).image: Cls , _RGBA32(0, 0, 0, 0)
    EllipseFill arrImg(3).width \ 2, arrImg(3).height \ 2, arrImg(3).width \ 2, arrImg(3).height \ 2, arrImg(3).color
    arrImg(3).x = 60
    arrImg(3).y = 60

    ' Create a yellow circle with no transparency
    arrImg(4).height = 45
    arrImg(4).width = 45
    arrImg(4).color = _RGB32(255, 255, 0)
    arrImg(4).image = _NewImage(arrImg(4).width, arrImg(4).height, 32)
    _Dest arrImg(4).image: Cls , _RGBA32(0, 0, 0, 0)
    CircleFill arrImg(4).width \ 2, arrImg(4).height \ 2, arrImg(4).width \ 2, arrImg(4).color
    arrImg(4).x = 80
    arrImg(4).y = 10

    ' Display the images on the screen
    _Dest MyScreen ' Set destination back to the main screen
    For i1 = LBound(arrImg) To UBound(arrImg)
        _PutImage (arrImg(i1).x, arrImg(i1).y), arrImg(i1).image
    Next i1

    ' -----------------------------------------------------------------------------
    ' Check for overlap
    ' -----------------------------------------------------------------------------
    If bCompareBothWays Then
        ' VERSION #1 LETS US TEST BOTH COMPARE(A,B) AND COMPARE(B,A)
        RowNum = 10
        For i1 = LBound(arrImg) To UBound(arrImg)
            For i2 = LBound(arrImg) To UBound(arrImg)
                If i2 <> i1 Then
                    ' USE MEM VERSION OR REGULAR VERSION?
                    If bUseMemFunctions Then
                        bOverlaps = ShapesOverlapMem%(arrImg(i1), arrImg(i2))
                    Else
                        bOverlaps = ShapesOverlap%(arrImg(i1), arrImg(i2))
                    End If

                    ' Print next result
                    _Dest MyScreen
                    RowNum = RowNum + 1: Locate RowNum, 1
                    If bOverlaps = _TRUE Then
                        Color _RGB32(255, 0, 0), _RGB32(0, 0, 0): Print "* ";
                        Color _RGB32(0, 0, 0), arrImg(i1).color: Print "Shape #" + _ToStr$(i1);
                        Color _RGB32(255, 0, 0), _RGB32(0, 0, 0): Print " and ";
                        Color _RGB32(0, 0, 0), arrImg(i2).color: Print "Shape #" + _ToStr$(i2);
                        Color _RGB32(255, 0, 0), _RGB32(0, 0, 0): Print " overlap.";
                    Else
                        Color _RGB32(0, 255, 255), _RGB32(0, 0, 0): Print "  ";
                        Color _RGB32(0, 0, 0), arrImg(i1).color: Print "Shape #" + _ToStr$(i1);
                        Color _RGB32(0, 255, 255), _RGB32(0, 0, 0): Print " and ";
                        Color _RGB32(0, 0, 0), arrImg(i2).color: Print "Shape #" + _ToStr$(i2);
                        Color _RGB32(0, 255, 255), _RGB32(0, 0, 0): Print " do not overlap."
                    End If
                End If
            Next i2
        Next i1
    Else
        ' VERSION #2 TOTALLY ELIMINATES DUPLICATES
        RowNum = 10
        For i1 = LBound(arrImg) To UBound(arrImg)
            For i2 = i1 + 1 To UBound(arrImg) ' Check each pair only once
                ' USE MEM VERSION OR REGULAR VERSION?
                If bUseMemFunctions Then
                    bOverlaps = ShapesOverlapMem%(arrImg(i1), arrImg(i2))
                Else
                    bOverlaps = ShapesOverlap%(arrImg(i1), arrImg(i2))
                End If

                ' Print next result for (i1, i2)
                _Dest MyScreen
                RowNum = RowNum + 1: Locate RowNum, 1
                If bOverlaps Then
                    Color _RGB32(255, 0, 0), _RGB32(0, 0, 0): Print "* ";
                    Color _RGB32(0, 0, 0), arrImg(i1).color: Print "Shape #" + _ToStr$(i1);
                    Color _RGB32(255, 0, 0), _RGB32(0, 0, 0): Print " and ";
                    Color _RGB32(0, 0, 0), arrImg(i2).color: Print "Shape #" + _ToStr$(i2);
                    Color _RGB32(255, 0, 0), _RGB32(0, 0, 0): Print " overlap.";
                Else
                    Color _RGB32(0, 255, 255), _RGB32(0, 0, 0): Print "  ";
                    Color _RGB32(0, 0, 0), arrImg(i1).color: Print "Shape #" + _ToStr$(i1);
                    Color _RGB32(0, 255, 255), _RGB32(0, 0, 0): Print " and ";
                    Color _RGB32(0, 0, 0), arrImg(i2).color: Print "Shape #" + _ToStr$(i2);
                    Color _RGB32(0, 255, 255), _RGB32(0, 0, 0): Print " do not overlap."
                End If
            Next i2
        Next i1
    End If

    ' DONE
    RowNum = RowNum + 2: Locate RowNum, 1
    Color _RGB32(160, 160, 160): Print "Press any key to continue"
    _Delay .5: Sleep: _KeyClear: _Delay .5 ' CLEAR KEYBOARD BUFFER

    Screen 0
    For i1 = LBound(arrImg) To UBound(arrImg): FreeImage arrImg(i1).image: Next i1
    FreeImage MyScreen
Loop

CleanupAndExit:
Screen 0
For i1 = LBound(arrImg) To UBound(arrImg): FreeImage arrImg(i1).image: Next i1
FreeImage MyScreen

System

' /////////////////////////////////////////////////////////////////////////////
' FUNCTION: ShapesOverlapMem%
'
' Compares two shapes to determine if any of their non-transparent pixels overlap.
' This version uses _MEMIMAGE for fast, direct memory access to pixel data.
'
' PARAMETERS:
'   shape1: The first shape to compare.
'   shape2: The second shape to compare.
'
' RETURNS:
'   _TRUE if an alpha overlap is found, _FALSE otherwise.

Function ShapesOverlapMem% (shape1 As ShapeType, shape2 As ShapeType)
    Dim bHasOverlap As Integer
    Dim x As Long, y As Long ' Loop iterators for absolute screen coordinates
    Dim x1 As Long, y1 As Long ' Relative coordinates for shape1's image
    Dim x2 As Long, y2 As Long ' Relative coordinates for shape2's image
    Dim color1 As _Unsigned Long
    Dim color2 As _Unsigned Long

    Dim overlapX1 As Long, overlapY1 As Long
    Dim overlapX2 As Long, overlapY2 As Long

    ' === New variables for memory access ===
    Dim mem1 As _MEM, mem2 As _MEM
    Dim offset1 As _Offset, offset2 As _Offset

    ' Initialize
    bHasOverlap = _FALSE

    ' Define bounding boxes for each shape based on their screen position and dimensions
    Dim box1X1 As Long: box1X1 = shape1.x
    Dim box1Y1 As Long: box1Y1 = shape1.y
    Dim box1X2 As Long: box1X2 = shape1.x + shape1.width - 1
    Dim box1Y2 As Long: box1Y2 = shape1.y + shape1.height - 1

    Dim box2X1 As Long: box2X1 = shape2.x
    Dim box2Y1 As Long: box2Y1 = shape2.y
    Dim box2X2 As Long: box2X2 = shape2.x + shape2.width - 1
    Dim box2Y2 As Long: box2Y2 = shape2.y + shape2.height - 1

    ' Find the intersection of the two bounding boxes.
    If box1X1 > box2X1 Then overlapX1 = box1X1 Else overlapX1 = box2X1
    If box1Y1 > box2Y1 Then overlapY1 = box1Y1 Else overlapY1 = box2Y1
    If box1X2 < box2X2 Then overlapX2 = box1X2 Else overlapX2 = box2X2
    If box1Y2 < box2Y2 Then overlapY2 = box1Y2 Else overlapY2 = box2Y2

    ' If the intersection area is valid, check each pixel within it.
    If overlapX1 <= overlapX2 And overlapY1 <= overlapY2 Then
        ' === Get direct memory access to the images ===
        mem1 = _MemImage(shape1.image)
        mem2 = _MemImage(shape2.image)

        For y = overlapY1 To overlapY2
            For x = overlapX1 To overlapX2
                ' Calculate coordinates relative to each shape's own image canvas
                x1 = x - shape1.x
                y1 = y - shape1.y
                x2 = x - shape2.x
                y2 = y - shape2.y

                ' === Read pixel data directly from memory ===
                ' Calculate byte offset: (y * width + x) * 4 bytes per pixel
                offset1 = (y1 * shape1.width + x1) * 4
                offset2 = (y2 * shape2.width + x2) * 4
       
                ' *****************************************************************************
                ' *****************************************************************************
                ' PROGRAM CRASHES AT _MemGet WITH Memory region out of range ERROR
                ' *****************************************************************************
                ' *****************************************************************************
                _MemGet mem1, offset1, color1
                _MemGet mem2, offset2, color2

                ' Check if both pixels are non-transparent (alpha > 0)
                If _Alpha(color1) > 0 And _Alpha(color2) > 0 Then
                    bHasOverlap = _TRUE
                    Exit For
                End If
            Next x
            If bHasOverlap = _TRUE Then Exit For
        Next y

        ' === IMPORTANT: Free the memory blocks when done ===
        _MemFree mem1
        _MemFree mem2
    End If

    ' Return the result
    ShapesOverlapMem% = bHasOverlap
End Function ' ShapesOverlapMem%

' /////////////////////////////////////////////////////////////////////////////
' FUNCTION: ShapesOverlap%
'
' Compares two shapes to determine if any of their non-transparent pixels overlap.
'
' PARAMETERS:
'   shape1: The first shape to compare.
'   shape2: The second shape to compare.
'
' RETURNS:
'   _TRUE if an alpha overlap is found, _FALSE otherwise.

Function ShapesOverlap% (shape1 As ShapeType, shape2 As ShapeType)
    Dim bHasOverlap As Integer
    Dim x As Long, y As Long ' Loop iterators for absolute screen coordinates
    Dim x1 As Long, y1 As Long ' Relative coordinates for shape1's image
    Dim x2 As Long, y2 As Long ' Relative coordinates for shape2's image
    Dim color1 As _Unsigned Long
    Dim color2 As _Unsigned Long

    Dim overlapX1 As Long, overlapY1 As Long
    Dim overlapX2 As Long, overlapY2 As Long

    ' Initialize
    bHasOverlap = _FALSE

    ' Define bounding boxes for each shape based on their screen position and dimensions
    Dim box1X1 As Long: box1X1 = shape1.x
    Dim box1Y1 As Long: box1Y1 = shape1.y
    Dim box1X2 As Long: box1X2 = shape1.x + shape1.width - 1
    Dim box1Y2 As Long: box1Y2 = shape1.y + shape1.height - 1

    Dim box2X1 As Long: box2X1 = shape2.x
    Dim box2Y1 As Long: box2Y1 = shape2.y
    Dim box2X2 As Long: box2X2 = shape2.x + shape2.width - 1
    Dim box2Y2 As Long: box2Y2 = shape2.y + shape2.height - 1

    ' Find the intersection of the two bounding boxes.
    ' This is the only area where pixels could possibly overlap.
    If box1X1 > box2X1 Then overlapX1 = box1X1 Else overlapX1 = box2X1
    If box1Y1 > box2Y1 Then overlapY1 = box1Y1 Else overlapY1 = box2Y1
    If box1X2 < box2X2 Then overlapX2 = box1X2 Else overlapX2 = box2X2
    If box1Y2 < box2Y2 Then overlapY2 = box1Y2 Else overlapY2 = box2Y2

    ' If the intersection area is valid, check each pixel within it.
    If overlapX1 <= overlapX2 And overlapY1 <= overlapY2 Then
        For y = overlapY1 To overlapY2
            For x = overlapX1 To overlapX2
                ' Calculate coordinates relative to each shape's own image canvas
                x1 = x - shape1.x
                y1 = y - shape1.y
                x2 = x - shape2.x
                y2 = y - shape2.y

                ' Get the color of the pixel from each source image
                _Source shape1.image: color1 = Point(x1, y1)
                _Source shape2.image: color2 = Point(x2, y2)

                ' Check if both pixels are non-transparent (alpha > 0)
                If _Alpha(color1) > 0 And _Alpha(color2) > 0 Then
                    ' Found an overlap, set flag and exit loops immediately
                    bHasOverlap = _TRUE
                    Exit For
                End If
            Next x
            If bHasOverlap = _TRUE Then Exit For
        Next y
    End If

    ' Return the result
    ShapesOverlap% = bHasOverlap
End Function ' ShapesOverlap%

' /////////////////////////////////////////////////////////////////////////////

Sub FreeImage (ThisImage&)
    If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage

' /////////////////////////////////////////////////////////////////////////////

Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    ' CX = center x coordinate
    ' CY = center y coordinate
    '  R = radius
    '  C = fill color
    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 ' CircleFill

' /////////////////////////////////////////////////////////////////////////////

Sub EllipseFill (CX As Integer, CY As Integer, a As Integer, b As Integer, C As _Unsigned Long)
    ' CX = center x coordinate
    ' CY = center y coordinate
    '  a = semimajor axis
    '  b = semiminor axis
    '  C = fill color
    If a = 0 Or b = 0 Then Exit Sub
    Dim h2 As _Integer64
    Dim w2 As _Integer64
    Dim h2w2 As _Integer64
    Dim x As Integer
    Dim y As Integer
    w2 = a * a
    h2 = b * b
    h2w2 = h2 * w2
    Line (CX - a, CY)-(CX + a, CY), C, BF
    Do While y < b
        y = y + 1
        x = Sqr((h2w2 - y * y * w2) \ h2)
        Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
        Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
    Loop
End Sub ' EllipseFill

' /////////////////////////////////////////////////////////////////////////////
'DrawRectSolid x%, y%, width%, height%, fgColor~&

Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
    Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid

[Unseen Machine]

Dont use MEM, itll not work as you need to have actual variables to reference....a UDT for your rect with a singular rotation point is first...then based on rotation you calculate the corners, then use rectangle collision....my suggestion would be to define a UDT wtih rect dimensions and the offset for center and then ask a AI to make you a SAT function...

Unseen

[madscijr]

Thanks for your reply, I don't follow what you're saying, very much over my head. Why do I need to calculate corners and do rotation? What even is a SAT function? I just want to find out if any pixels in image1 overlap any pixels in image2. I read through a bunch of posts on collision detection and tried to follow bplus's charming spider infestation program, couldn't make any sense of it. All I'm trying to accomplish is to determine whether pixels in irregularly shaped image A at point x1,y1 on the screen intersect one or more pixels in irregularly shaped image B located at x2,y2, as quickly as possible. I think a built-in command for this would be very useful.
Anyway, thanks again, forgive my frustration, math was never my strong point!

[Unseen Machine]

Im very much a person who thinks learning is best done by resaerch and trial and error....if you havent sorted it in 3 days ill help! Untill then , SAT is Seperated axis theorom, but, here...i aint tested it though and ai made it...should get you started!

Code: (Select All)

Code: (Select All)
' A pixel-perfect collision demo using bitmasks in QB64

' This program requires two PNG files: "player.png" and "target.png"

' The transparent background of the PNGs is crucial for this to work.



' === Setup constants and types ===

CONST SCREEN_WIDTH = 800

CONST SCREEN_HEIGHT = 600

CONST BORDER_COLOR = _RGB32(255, 255, 255)

CONST COLLISION_COLOR = _RGB32(255, 0, 0)

CONST NO_COLLISION_COLOR = _RGB32(0, 255, 0)

CONST PLAYER_SPEED = 2



TYPE Sprite

    image AS LONG

    mask AS _BIT

    width AS INTEGER

    height AS INTEGER

    x AS INTEGER

    y AS INTEGER

END TYPE



' === Function to check for pixel collision ===

FUNCTION IsPixelCollision (a AS Sprite, b AS Sprite) AS _BIT

    ' Step 1: Bounding box check (broad phase)

    IF a.x + a.width <= b.x OR a.x >= b.x + b.width THEN IsPixelCollision = 0: EXIT FUNCTION

    IF a.y + a.height <= b.y OR a.y >= b.y + b.height THEN IsPixelCollision = 0: EXIT FUNCTION



    ' Step 2: Pixel-perfect check (narrow phase)

    ' Determine the overlapping rectangle

    startx = _MAX(a.x, b.x)

    starty = _MAX(a.y, b.y)

    endx = _MIN(a.x + a.width, b.x + b.width)

    endy = _MIN(a.y + a.height, b.y + b.height)



    ' Iterate through the overlapping area

    FOR y = starty TO endy

        FOR x = startx TO endx

            ' Get the corresponding pixel coordinates in each sprite's mask

            mask_a_x = x - a.x

            mask_a_y = y - a.y

            mask_b_x = x - b.x

            mask_b_y = y - b.y



            ' Check if both masks have a solid pixel at this position

            IF _BITGET(a.mask, mask_a_x, mask_a_y) AND _BITGET(b.mask, mask_b_x, mask_b_y) THEN

                IsPixelCollision = -1

                EXIT FUNCTION

            END IF

        NEXT x

    NEXT y



    IsPixelCollision = 0

END FUNCTION



' === Function to generate a bitmask from an image handle ===

FUNCTION CreateBitmask (image_handle AS LONG) AS _BIT

    mask = _BITNEW(_WIDTH(image_handle), _HEIGHT(image_handle))

    _DEST mask



    _SOURCE image_handle

    FOR y = 0 TO _HEIGHT(image_handle) - 1

        FOR x = 0 TO _WIDTH(image_handle) - 1

            ' Check if pixel is not transparent (assuming _CLEARCOLOR is used for transparency)

            IF _POINT(x, y) <> _CLEARCOLOR THEN

                _BITSET mask, x, y, -1 ' Set the bit

            END IF

        NEXT x

    NEXT y

    _SOURCE 0

    _DEST 0

    CreateBitmask = mask

END FUNCTION



' === Main program starts here ===

DIM player AS Sprite

DIM target AS Sprite



SCREEN _NEWIMAGE(SCREEN_WIDTH, SCREEN_HEIGHT, 32)

_TITLE "QB64 Bitmask Collision Demo"

_CLEARCOLOR _RGB32(0, 0, 0) ' The transparent color for the PNGs

_FULLSCREEN _KEEP ' Prevents the screen from being resized



' Load images and create sprites

player.image = _LOADIMAGE("player.png")

IF player.image = -1 THEN PRINT "Error loading player.png": SYSTEM

player.width = _WIDTH(player.image)

player.height = _HEIGHT(player.image)

player.mask = CreateBitmask(player.image)

player.x = 100

player.y = 100



target.image = _LOADIMAGE("target.png")

IF target.image = -1 THEN PRINT "Error loading target.png": SYSTEM

target.width = _WIDTH(target.image)

target.height = _HEIGHT(target.image)

target.mask = CreateBitmask(target.image)

target.x = 400

target.y = 250



' Main game loop

DO

    ' Handle input for player movement

    IF _KEYHIT(57416) THEN player.y = player.y - PLAYER_SPEED ' Up arrow

    IF _KEYHIT(57424) THEN player.y = player.y + PLAYER_SPEED ' Down arrow

    IF _KEYHIT(57419) THEN player.x = player.x - PLAYER_SPEED ' Left arrow

    IF _KEYHIT(57421) THEN player.x = player.x + PLAYER_SPEED ' Right arrow



    ' Check for collision and update border color

    IF IsPixelCollision(player, target) THEN

        border_color = COLLISION_COLOR

    ELSE

        border_color = NO_COLLISION_COLOR

    END IF



    ' Double buffering for smooth animation

    _LIMIT 60

    _NEWIMAGE SCREEN_WIDTH, SCREEN_HEIGHT, 32 ' Create a new blank buffer

    _DISPLAY ' Swap buffers



    ' Draw the sprites

    _PUTIMAGE (player.x, player.y), player.image

    _PUTIMAGE (target.x, target.y), target.image



    ' Draw a bounding box and collision status

    LINE (player.x, player.y)-(player.x + player.width, player.y + player.height), border_color, B

    LINE (target.x, target.y)-(target.x + target.width, target.y + target.height), NO_COLLISION_COLOR, B



    _DISPLAY ' Show the new frame

LOOP UNTIL _KEYHIT(1) ' Loop until the escape key is pressed



SYSTEM

Also, from my experience, pixel perfect is to slow, use 80% rectangles (kinda industry standard) or as i said SAT or another method if you need advanced polygons or something, in GL youll want to use a mesh checking method...(thats over my head though so dont go there)

Have Fun

Unseen

[madscijr]

OK I'll check it out - thanks so much!

[bplus]

+1 Thankyou @madscijr of reminding me of this delightful little piece of code. As I recall @TerryRitchie got us started on this topic of collision with irregular objects. Thankyou Terry, where the heck are you anyway?

To save people from having to dig this up, here it is AGAIN!

Code: (Select All)

Option _Explicit
_Title "Spiders with Box and Pixel Collisions Experiment 3" 'b+ 2023-01-30/31
' 2023-02-08 Another experiment in handling Spider collisions,
' At collision, explosion!
' Tweaked number of spiders, speeds, colors and sizes and sound if collide

' !!!!!!!!!!!!!!!!!!!          Escape to Quit         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'                 !!! Speaker volume around 20 maybe! !!!

Randomize Timer
Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight
Const nSpinners = 40
Type SpinnerType
    As Single x, y, dx, dy, sz
    c As _Unsigned Long
End Type
Dim Shared s(1 To nSpinners) As SpinnerType

Type boxType ' for PixelCollison&
    As Long img, x, y, w, h
    c As _Unsigned Long
End Type

Type particle 'setup for explosions =======================================
    As Long life, death
    As Single x, y, dx, dy, r
    As _Unsigned Long c
End Type

Dim Shared nDots
nDots = 2000
ReDim Shared dots(nDots) As particle '=====================================


Dim As Long i, j, iImg, jImg, lc, i2, sc, intx, inty
Dim As boxType sIo, sJo

sc = _ScreenImage
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 0, 0
_FullScreen
For i = 1 To nSpinners
    newSpinner i
Next
i2 = 1
While InKey$ <> Chr$(27)
    '_Title Str$(i2) + " spiders"     ' when testing spider speeds
    _PutImage , sc, 0
    lc = lc + 1
    If lc Mod 50 = 49 Then
        lc = 0
        If i2 < nSpinners Then i2 = i2 + 1
    End If
    For i = 1 To i2

        'ready for collision check

        ' max sz = .75 which needs 140 x 140 image square  +++++++++++++++++++++++++
        iImg = _NewImage(140, 140, 32)
        _Dest iImg
        drawSpinner iImg, 70, 70, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
        _Dest 0
        sIo.x = s(i).x - 70
        sIo.y = s(i).y - 70
        sIo.w = 140
        sIo.h = 140 ' this meets requirements for collision obj1
        sIo.img = iImg ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++

        For j = i + 1 To i2
            ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++
            jImg = _NewImage(140, 140, 32)
            _Dest jImg
            drawSpinner jImg, 70, 70, s(j).sz, _Atan2(s(j).dy, s(j).dx), s(j).c
            _Dest 0
            sJo.x = s(j).x - 70
            sJo.y = s(j).y - 70
            sJo.w = 140
            sJo.h = 140 ' this meets requirements for collision obj1
            sJo.img = jImg
            If PixelCollision&(sIo, sJo, intx, inty) Then '+++++++++++++++++++++++++++++++++++++++
                Sound Rnd * 7000 + 400, .05
                explode s(i).x, s(i).y, 150 * s(i).sz, 200, 200, 200
                newSpinner i
                's(i).x = s(i).x + s(i).dx + rndCW(0, 3.5)
                's(i).y = s(i).y + s(i).dy + rndCW(0, 3.5)
                's(j).x = s(j).x + s(j).dx + rndCW(0, 3.5)
                's(j).y = s(j).y + s(j).dy + rndCW(0, 3.5)
                Exit For
            End If
            _FreeImage jImg
        Next
        s(i).x = s(i).x + s(i).dx + rndCW(0, 3.5)
        s(i).y = s(i).y + s(i).dy + rndCW(0, 3.5)
        If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i
        _PutImage (s(i).x - 70, s(i).y - 70), iImg, 0
        _FreeImage iImg
    Next
    drawDots
    _Display
    _Limit 30
Wend

Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color?
    Dim r
    s(i).sz = rndCW(.5, .25) ' * .55 + .2
    If Rnd < .5 Then r = -1 Else r = 1
    s(i).dx = (s(i).sz * Rnd * 8 + 1) * r * 2: s(i).dy = (s(i).sz * Rnd * 8 + 1) * r * 2
    r = Int(Rnd * 4)
    Select Case r
        Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy
        Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy
        Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx
        Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx
    End Select
    r = Rnd * 80 + 40
    s(i).c = _RGB32(r, 20 + rndCW(.5 * r, 15), 10 + rndCW(.25 * r, 10))
End Sub

Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
    Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
    Static switch As Integer
    switch = switch + 2
    switch = switch Mod 16 + 1
    red = _Red32(c): green = _Green32(c): blue = _Blue32(c)
    r = 10 * scale
    x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
    r = 2 * r 'lg lengths
    For lg = 1 To 8
        If lg < 5 Then
            a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
        Else
            a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
        End If
        x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
        drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
        If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
        a1 = a + d * _Pi(1 / 12)
        x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
        drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
        rd = Int(Rnd * 8) + 1
        a2 = a1 + d * _Pi(1 / 8) * rd / 8
        x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
        drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
    Next
    r = r * .5
    fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
    x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    r = r * 2
    x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
    TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub

Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
    Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
    a = _Atan2(y2 - y1, x2 - x1)
    a1 = a + _Pi(1 / 2)
    a2 = a - _Pi(1 / 2)
    x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
    x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
    x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
    x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
    fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c
    fcirc x1, y1, r1, c
    fcirc x2, y2, r2, c
End Sub

'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
    ftri idest&, x1, y1, x2, y2, x4, y4, c
    ftri idest&, x3, y3, x4, y4, x1, y1, c
End Sub

Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim a&
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest idest&
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

Sub fcirc (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 TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
    Dim TEmax As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
    Dim prc As _Unsigned Long, tef As Long
    prc = _RGB32(255, 255, 255, 255)
    If a > b Then TEmax = a + 1 Else TEmax = b + 1
    mx2 = TEmax + TEmax
    tef = _NewImage(mx2, mx2)
    _Dest tef
    _Source tef 'point wont read without this!
    For k = 0 To 6.2832 + .05 Step .1
        i = TEmax + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
        j = TEmax + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
        If k <> 0 Then
            Line (lasti, lastj)-(i, j), prc
        Else
            PSet (i, j), prc
        End If
        lasti = i: lastj = j
    Next
    Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
    For y = 0 To mx2
        x = 0
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        xleft(y) = x
        While Point(x, y) = prc And x < mx2
            x = x + 1
        Wend
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
    Next
    _Dest destHandle&
    For y = 0 To mx2
        If xleft(y) <> mx2 Then Line (xleft(y) + x0 - TEmax, y + y0 - TEmax)-(xright(y) + x0 - TEmax, y + y0 - TEmax), c, BF
    Next
    _FreeImage tef
End Sub

Function BoxCollision% (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h)
    ' x, y represent the box left most x and top most y
    ' w, h represent the box width and height which is the usual way sprites / tiles / images are described
    ' such that boxbottom = by + bh
    '        and boxright = bx + bw

    If (b1y + b1h < b2y) Or (b1y > b2y + b2h) Or (b1x > b2x + b2w) Or (b1x + b1w < b2x) Then
        BoxCollision% = 0
    Else
        BoxCollision% = -1
    End If
End Function

' this needs max, min functions as well as BoxCollision%
Sub Intersect2Boxes (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h, bix As Long, biy As Long, biw As Long, bih As Long)
    If b2x >= b1x And b2x <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'top left corner in 2nd box
        bix = b2x: biy = b2y
        If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
        If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
    ElseIf b2x >= b1x And b2x <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'bottom left corner of 2nd box in first
        bix = b2x
        If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
        If b2y <= b1y Then biy = b1y: bih = b2y + b2h - b1y Else biy = b2y: bih = b2h
    ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'right top corner 2nd box in first
        If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
        biy = b2y
        If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
    ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'left bottom corners in first box
        If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
        If b2y >= b1y Then biy = b2y: bih = b2h Else biy = b1y: bih = b2y + b2h - b1y
    ElseIf BoxCollision%(b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h) Then
        bix = max(b1x, b2x): biy = max(b1y, b2y)
        biw = min(b1x + b1w, b2x + b2w) - bix: bih = min(b1y + b1h, b2y + b2h) - biy
    Else 'no intersect
        bix = -1: biy = -1: biw = 0: bih = 0
    End If
End Sub

Function max (a, b)
    If a > b Then max = a Else max = b
End Function

Function min (a, b)
    If a < b Then min = a Else min = b
End Function

' this sub needs Intersect2Boxes which uses  max, min, and BoxCollision Functions
Function PixelCollision& (img1 As boxType, img2 As boxType, intx As Long, inty As Long)
    ' boxType here needs at least an x, y, w, h and img
    Dim As Long x, y, ix, iy, iw, ih
    Dim As _Unsigned Long p1, p2
    intx = -1: inty = -1 ' no collision set
    Intersect2Boxes img1.x, img1.y, img1.w, img1.h, img2.x, img2.y, img2.w, img2.h, ix, iy, iw, ih
    If ix <> -1 Then ' the boxes intersect
        y = iy: x = ix
        Do
            _Source img1.img
            p1 = Point(x - img1.x, y - img1.y) ' point minus img x, y location = location in image I hope
            _Source img2.img
            p2 = Point(x - img2.x, y - img2.y)
            If (p1 <> 0) And (p2 <> 0) Then
                PixelCollision& = -1: intx = x: inty = y: Exit Function
            End If
            If (x + 1) > (ix + iw - 1) Then ' get rid of 2 slow For Loops
                x = ix: y = y + 1
                If y >= (iy + ih - 1) Then
                    _Source 0: Exit Function
                Else
                    y = y + 1
                End If
            Else
                x = x + 1
            End If
        Loop
    End If
End Function

Function rndCW (C As Single, range As Single) 'center +/-range weights to center
    rndCW = C + Rnd * range - Rnd * range
End Function

' explode sets up old dead particles for display for a life
' This sub sets up Dots to display with DrawDots
Sub explode (x, y, spread, cr, cg, cb)
    ' x, y explosion origin
    ' spread is diameter of area to cover from it number of dots, number of frames and speed are calculated

    ' setup
    'Type particle
    '    As Long life, death
    '    As Single x, y, dx, dy, r
    '    As _Unsigned Long c
    'End Type

    'Dim Shared nDots
    'nDots = 2000
    'ReDim Shared dots(nDots) As particle

    Dim As Long i, dotCount, newDots
    Dim angle, speed, rd, rAve, frames
    newDots = spread / 2 ' quota
    frames = spread / 5
    speed = spread / frames ' 0 to spread in frames
    rAve = .5 * spread / Sqr(newDots)
    For i = 1 To nDots ' find next available dot
        If dots(i).life = 0 Then
            dots(i).life = 1 ' turn on display
            dots(i).death = frames
            angle = _Pi(2 * Rnd)
            dots(i).x = x: dots(i).y = y ' origin
            rd = Rnd
            dots(i).dx = rd * speed * Cos(angle) ' moving
            dots(i).dy = rd * speed * Sin(angle)
            dots(i).r = rndCW(rAve, rAve) ' radius
            dots(i).c = _RGB32(cr + Rnd * 40 - 20, cg + Rnd * 40 - 20, cb + Rnd * 40 - 20) 'color
            dotCount = dotCount + 1
            If dotCount >= newDots Then Exit Sub
        End If
    Next
End Sub

Sub drawDots ' this sub needs fcirc to Fill Circles and Sub Explode sets up the Dots to draw.
    ' setup in main
    'Type particle
    '    As Long life, death
    '    As Single x, y, dx, dy, r
    '    As _Unsigned Long c
    'End Type

    'Dim Shared nDots
    'nDots = 2000
    'ReDim Shared dots(nDots) As particle

    Dim As Long i
    For i = 1 To nDots ' display of living particles
        If dots(i).life Then
            fcirc dots(i).x, dots(i).y, dots(i).r, dots(i).c
            ' update dot
            If dots(i).life + 1 >= dots(i).death Then
                dots(i).life = 0
            Else
                dots(i).life = dots(i).life + 1
                ' might want air resistence or gravity added to dx or dy
                dots(i).x = dots(i).x + dots(i).dx
                dots(i).y = dots(i).y + dots(i).dy
                If dots(i).x < 0 Or dots(i).x > xmax Then dots(i).life = 0
                If dots(i).y < 0 Or dots(i).y > ymax Then dots(i).life = 0
                dots(i).r = dots(i).r * 1 - (dots(i).life / dots(i).death) ' puff!
                If dots(i).r <= 0 Then dots(i).life = 0
            End If
        End If
    Next
End Sub

I don't know PixelCollision& looks pretty straight forward. Why get _Mem stuff involved? For speed of course but the above code does work pretty darn good in real time!

+1 @Unseen Machine has an interesting idea how to approach this problem worth investigating, if you can draw a line between two objects without touching either then no collision. But you can draw infinite amounts of lines between 2 objects, not sure how you can narrow it down? Needs study.

[Pete]

Maybe Terry got deployed to D.C., making it the safest city in the country. Anyway, I wish he wasn't MIA as much around here, too.

I'm surprised Steve hasn't responded yet, because I think he's just about the only person I can recall who actually works with _Mem. If I worked with graphics, I know I'd be using it, because it seems to me collision detection should be a simple as detecting any overlying pixel, which should be pretty straight forward with screen mapping.

Pete

[madscijr]

I think I found a way to do pixel-perfect collision detection fast, using memory compare. 
It works, so I posted the proof of concept code under "works in progress": 
a way to do fast pixel-perfect collision?

[SMcNeill]

Let me showcase a very simple collision detection routine that will work with all shapes and sizes of images:

Code: (Select All)

Dim As _Unsigned Long BSC, BJC, SJC, BSJC, CP 'bob+ sam collision, bob + joe collision, ect

$Console



Randomize Timer



Display = _NewImage(800, 600, 32)

Screen Display

_Console On

Bob = _NewImage(64, 64, 32)

Sam = _NewImage(64, 64, 32)

Joe = _NewImage(64, 64, 32)

Cls , _RGBA(255, 0, 0, 128), Bob

Cls , _RGBA(0, 255, 0, 128), Sam

Cls , _RGBA(0, 0, 255, 128), Joe



CollisionScreen = _NewImage(64, 64, 32)

_Source CollisionScreen 'to read the blended colors on that screen

_Dest CollisionScreen

_PutImage , Bob 'put bob on the screen

_PutImage , Sam 'put sam on the screen

BSC = Point(0, 0) 'we now know the blended color for a bob + sam collision

_PutImage , Joe 'put joe on the screen

BSJC = Point(0, 0) 'we now know the blended color for a bob + sam + joe collision

Cls , 0 'clear the screen we use for blending

_PutImage , Bob 'bob back on the screen

_PutImage , Joe 'joe on the screen

BJC = Point(0, 0) 'and now we know the blended color for bob + joe collison

Cls , 0 'clear the screen one last time

_PutImage , Sam 'put Sam on the screen

_PutImage , Joe 'put Joe on the screen

SJC = Point(0, 0) 'and now we know the blended color for a sam + joe collision

_Source Display 'restore the source to original screen

_Dest Display

_FreeImage CollisionScreen 'free that screen as we're done getting our blended colors



Dim As Long x(2), y(2)

For i = 0 To 2

    x(i) = Rnd * 700: y(i) = Rnd * 500 'random staring point of a character on the screen

Next

For i = 0 To 2

    Do Until xmove(i) <> 0: xmove(i) = Rnd * 10 - 5: Loop

    Do Until ymove(i) <> 0: ymove(i) = Rnd * 10 - 5: Loop

Next



Do

    Cls , 0 'clear the screen

    For i = 0 To 2 'generate movement

        If x(i) + xmove(i) >= 800 - 64 Then xmove(i) = -xmove(i)

        If x(i) + xmove(i) <= 0 Then xmove(i) = -xmove(i)

        If y(i) + ymove(i) >= 600 - 64 Then ymove(i) = -ymove(i)

        If y(i) + ymove(i) <= 0 Then ymove(i) = -ymove(i)

        x(i) = x(i) + xmove(i)

        y(i) = y(i) + ymove(i)

    Next

    _PutImage (x(0), y(0)), Bob

    _PutImage (x(1), y(1)), Sam

    _PutImage (x(2), y(2)), Joe



    'now do a quick collision detection check

    BSCE = 0: BSJCE = 0: SJCE = 0: BJCE = 0

    For x = 0 To 799: For y = 0 To 679 'detect collisions

            Select Case Point(x, y)

                Case BSC: BSCE = -1

                Case BSJC: BSJCE = -1

                Case SJC: SJCE = -1

                Case BJC: BJCE = -1

            End Select

    Next y, x

    If BSCE Then _Echo "Bob and Sam Collided!" 'report collisions

    If BSJCE Then _Echo "All three collided!"

    If SJCE Then _Echo "Sam and Joe Collided!"

    If BJCE Then _Echo "Bob and Joe Collided!"



    _Limit 120

    _Display

Loop Until _KeyHit

System

Now notice that I'm being lazy here and just making my "images" to be plain squares of 64x64 pixels (like a lot of sprites used in sprite sheets). This ***DOES NOT*** do square detection or rectangle detection or any real math at all. Like I mentioned on a different post about this, this is simply tossing paint at the wall and looking for colors that blend together.

Yellow + Blue = Green type logic.

Even using POINT, as you can see, this has no problems running and maintaining a nice fast animation speed for us. If you truly need, you can easily swap in a _MEM check here to speed it up even faster, but the overall process is really quite simple and efficient. Toss your images on a background screen (I'm doing all this on the main screen so you can watch it in real time as it happens), read that screen once and look for the existence of any collision colors.

Simple. Direct. Efficient. What's not to love about it, and no math is involved whatsoever!

[bplus]

' Steve's code appears to search whole screen pixel by pixel plus some??? 679?

For x = 0 To 799: For y = 0 To 679 'detect collisions

Hmm...looks to me like you are going the whole screen pixel by pixel for collisions and why, BTW, 679? typo?

I think checking for a box collision of images contained by rectangles before going pixel by pixel would save scads of time.  Box collisions are pretty easy to test and save you from searching the whole screen, brute force.
ie, if no box collision then no need to test a single pixel!!!