' This program demonstrates the application of a collision detection algorithm in 3 steps:

'

' Step 1. Inspecting areas to identify where at least 2 shapes are in.

' Step 2. For each area, checking the distance between the present shapes to determine 

'        if they could potentially be in contact.

' Step 3. Testing for overlap in each area where the shapes are potentially in contact

'        using semi-transparent shape masks.



type point_type



    x as double

    y as double

end type



type shape_type

    index as integer                ' shape id

    radius as integer              ' half size of the shape

    firstPointIndex as integer      ' first pointer to the points array for vertices

    lastPointIndex as integer      ' lasr pointer for vertices 

    x as double                    ' shape position 

    y as double

    rgbaColor as long              ' base color

    speed as double                ' movement speed

    direction as double            ' direction speed

    rotation as double              ' angular speed (radians)

    orientation as double          ' angular orientation (radians)

    drawString as string            ' draw description

    area as integer                ' area where the center of the shape is located

    areaX as integer                ' 

    areaY as integer                '

    imageHandle as long            ' stock shape drawing

    maskHandle as long              ' stock mask drawing

    maskComputed as integer        ' mask indicator (-1 = computed / 0 = not computed)

    collid as integer              ' collision indicator (-1 = collision detected)

end type



const SHAPES_COUNT = 128            ' number of shapes

const MIN_SHAPE_RADIUS = 5          ' minimum radius of the circle containing a shape

const MAX_SHAPE_RADIUS = 30        ' maximum radius of the circle containing a shape

const MIN_SHAPE_VERTICES = 5        ' minimum number of vertices of a shape

const MAX_SHAPE_VERTICES = 15      ' maximum number of vertices of a shape

const MIN_SHAPE_SPEED = 0.5        ' minimum speed of a shape

const MAX_SHAPE_SPEED = 1.1        ' maximum speed of a shape



const PIXELS_PRECISION = 2          ' collision pixels precision



type area_type

    shapeLocator as string * SHAPES_COUNT  ' Character array to memorize shapes in area

    column as integer              ' area colum

    row as integer                  ' area row

    x as integer                    ' top-left position of the area on the screen

    y as integer                    

    center as point_type            ' center position of the area onthe screen

end type



const DRAW_MODE = 1                ' 0 = use DRAW instruction / 1 = use LINE instruction



const STEP_MODE_KEY = "S"          ' toggle stepmode

step_mode_activated% = 0            ' -1 = step by step / 0 = don't



const SHOW_DETECTION_KEY = "D"      ' toggle drawing proximity detection areas

show_detection_activated% = 0      ' -1 = show proximity detections areas / 0 = don't



const SHOW_GRID_KEY = "G"          ' toggle drawing grid to show area delimitations

show_grid_activated% = 0            ' -1 = show grid of areas / 0 = dont't



const SHOW_COLLISIONS_KEY = "C"    ' toogle drawing areas with potential collisions

show_collisions_activated% = 0      ' -1 = show areas where collisions are potentials / 0 = dont't



const EXPECTED_FPS = 60            ' Expected Frames Per Second



const VIEWPORT_WIDTH = 440          ' viewport width

const VIEWPORT_HEIGHT = 440        ' viewport height



dim shared TAU as single            ' 2 * PI

TAU = 8 * atn(1)



redim shapes(-1) as shape_type      ' array containing the shapes description

redim points(0) as point_type      ' array containing coordinates of the vertices of the shapes



' definition of the page dimension in which the shapes are drawn



const X_DECAY = _ceil(2.5 * MAX_SHAPE_RADIUS)      ' offset between canvas and viewport

const Y_DECAY = _ceil(2.5 * MAX_SHAPE_RADIUS)

const CANVAS_WIDTH = VIEWPORT_WIDTH + 2 * X_DECAY  ' canvas size

const CANVAS_HEIGHT = VIEWPORT_HEIGHT + 2 * Y_DECAY



' areas definitions



const AREAS_WIDTH = _ceil(CANVAS_WIDTH / MAX_SHAPE_RADIUS)      ' number of areas in a row

const AREAS_HEIGHT = _ceil(CANVAS_HEIGHT / MAX_SHAPE_RADIUS)    ' number of areas in a colum

const AREAS_COUNT = AREAS_WIDTH * AREAS_HEIGHT                  ' total number of areas (size of areas array)

const WIDTH_OF_AREA = 2 * MAX_SHAPE_RADIUS                      ' size of an area

const HEIGHT_OF_AREA = 2 * MAX_SHAPE_RADIUS



' areas array initialisation



redim areas(0 to AREAS_COUNT) as area_type



for i%=lbound(areas) to ubound(areas)

    areas(i%).column = i% mod AREAS_WIDTH

    areas(i%).row = i% \ AREAS_WIDTH + 1

    areas(i%).x = areas(i%).column * MAX_SHAPE_RADIUS

    areas(i%).y = areas(i%).row * MAX_SHAPE_RADIUS 

    areas(i%).center.x = areas(i%).x + MAX_SHAPE_RADIUS

    areas(i%).center.y = areas(i%).y + MAX_SHAPE_RADIUS

next i%



' set random draw



randomize timer



' home screen



screen 0

cls

color _rgb(63,160,0)

locate 4,1

? "    ========================"

? "    Collision Detection Demo"

? "    ========================"

?

? "    What this program does:"

? "    - Generates moving and rotating irregular polygonal shapes."

? "    - Uses spatial partitioning (areas) to find near neighbours."

? "    - Performs circle-circle and pixel-level mask collision tests."

? "    - Show collisions by changing the color of the affected shapes."

?

? "    Keyboard shortcuts:"

? "    S  - Toggle step mode (when active, press any key to advance a frame)"

? "    D  - Toggle drawing of proximity detection areas"

? "    G  - Toggle grid of areas"

? "    C  - Toggle highlighting of areas with potential collisions"

? "    Esc - Quit"

?

? "    Press any key to start..."

do : k$ = inkey$ : loop while k$ = ""



' generate all shapes



for i% = 1 to SHAPES_COUNT

    generateShape _

        shapes(), points(), _

        MIN_SHAPE_RADIUS, MAX_SHAPE_RADIUS, _

        MIN_SHAPE_VERTICES, MAX_SHAPE_VERTICES, _

        MIN_SHAPE_SPEED, MAX_SHAPE_SPEED

next i%



' prepare screen rendering



viewport& = _newimage(VIEWPORT_WIDTH,VIEWPORT_HEIGHT,32)

canvas& = _newimage(CANVAS_WIDTH,CANVAS_HEIGHT,32)

textview& = _newimage(CANVAS_WIDTH,64,32)

screen viewport&



' timer to compute frames per second



t = timer(.001)



' main loop



do

    _limit EXPECTED_FPS



    _dest canvas&

    cls



    ' draw shapes



    for i%=lbound(shapes) to ubound(shapes)

        drawShape shapes(i%), points()

        shapes(i%).collid = 0

    next i%



    ' draw grid



    if show_grid_activated% then

        for x% = 0 to AREAS_WIDTH

            xx%= (x% + 0.5) * MAX_SHAPE_RADIUS

            line (xx%,0)-(xx%,CANVAS_HEIGHT),_rgba(255,255,255,63)

        next x%

        for y% = 0 to AREAS_HEIGHT

            yy% = (y% + 0.5) * MAX_SHAPE_RADIUS

            line (0,yy%)-(CANVAS_WIDTH,yy%),_rgba(255,255,255,63)

        next y%

    end if



    ' init areas for collision detection



    for i% = lbound(areas) to ubound(areas)

        areas(i%).shapeLocator = space$(SHAPES_COUNT)

    next i%



    ' move shapes



    for i%=lbound(shapes) to ubound(shapes)

        moveShape shapes(i%), points()

    next i%



    ' compute proximity detections areas

    ' and draw on demand

    

    for i%=lbound(shapes) to ubound(shapes)

        redim targets(-1) as integer

        evaluateShapeSector shapes(i%), areas(), targets()

        if show_detection_activated% then

            if shapes(i%).area>=0 then

                for j% = 0 to ubound(targets)

                    x% = targets(j%) mod AREAS_WIDTH

                    y% = targets(j%) \ AREAS_WIDTH + 1

                    circle ( _

                        x% * MAX_SHAPE_RADIUS, _

                        y% * MAX_SHAPE_RADIUS _

                        ), MAX_SHAPE_RADIUS\2, _rgba(255,255,255,127)

                next j%        

            end if

        end if

    next i%



    ' detect collisions

    ' and draw ondemand



    for i% = lbound(areas) to ubound(areas)

        if instr(areas(i%).shapeLocator,"*") <> _instrrev(areas(i%).shapeLocator,"*") then

            collid% = collision(shapes(),areas(i%))

            ' draw potentials collisions areas

            if show_collisions_activated% then

                if collid% then

                    c~& = _rgb(255,0,0)

                else

                    c~& = _rgba(255,255,0,127)

                end if

                circle ( _

                    areas(i%).x, _

                    areas(i%).y _

                    ), MAX_SHAPE_RADIUS\2, c~&

            end if

        end if

    next i%



    color &HFFFFFFFF

    _printstring (100,100), "fps:"+str$(fps%)



    frames% = frames% + 1 

    if timer(.001)>=t+1 then

        fps% = frames%

        frames% = 0

        t = timer(.001)

    end if



    ' display result



    _putimage (- X_DECAY,- Y_DECAY), canvas&, viewport&



    ' keyboard interaction



    do

        key$ = inkey$

        if key$ = chr$(27) then

            system

        end if

        select case ucase$(key$)

            case STEP_MODE_KEY

                step_mode_activated% = - step_mode_activated% - 1

            case SHOW_DETECTION_KEY

                show_detection_activated% = - show_detection_activated% - 1

            case SHOW_GRID_KEY

                show_grid_activated% = - show_grid_activated% - 1

            case SHOW_COLLISIONS_KEY

                show_collisions_activated% = - show_collisions_activated% - 1

        end select

        if step_mode_activated% then

            if key$ <> "" then exit do

        else

            exit do

        end if

    loop



loop



' generate a polygonal shape

' with movement attributes



sub generateShape ( _

        shapes() as shape_type, _

        points() as point_type, _

        minRadius as integer, maxRadius as integer, _

        minPoints as integer, maxPoints as integer,_

        minSpeed as double, maxSpeed as double _

    )



    dim shape as shape_type

    dim pointsCounter as integer



    shape.radius = int(rnd * (maxRadius - minRadius)) + minRadius

    pointsCounter = int(rnd * (maxPoints - minPoints)) + minPoints

    shape.firstPointIndex = ubound(points) + 1

    shape.lastPointIndex = ubound(points) + pointsCounter

    shape.rgbaColor = _rgb32(int(rnd*127)+128,int(rnd*127)+128,int(rnd*127)+128)

    shape.x = int(rnd*CANVAS_WIDTH)

    shape.y = int(rnd*CANVAS_HEIGHT)

    shape.speed = rnd*(maxSpeed - minSpeed) + minSpeed

    shape.direction = rnd*TAU

    shape.rotation = (rnd*TAU - TAU/2)/100

    shape.orientation = 0

    shape.imageHandle = _newimage(2*MAX_SHAPE_RADIUS,2*MAX_SHAPE_RADIUS,32)

    shape.maskHandle = _newimage(2*MAX_SHAPE_RADIUS\PIXELS_PRECISION,2*MAX_SHAPE_RADIUS\PIXELS_PRECISION,32)



    redim _preserve points(1 to shape.lastPointIndex) as point_type



    delta! = TAU / pointsCounter

    angle! = 0



    for i% = shape.firstPointIndex to shape.lastPointIndex

        radius% = int(rnd * (shape.radius - minRadius)) + minRadius

        points(i%).x = int(cos(angle!) * radius%)

        points(i%).y = int(sin(angle!) * radius%)

        angle! = angle! + delta!

    next i%



    convertShapeToDrawString shape, points()



    redim _preserve shapes(1 to ubound(shapes) + 1) as shape_type



    shape.index = ubound(shapes)



    shapes(ubound(shapes)) = shape



end sub



' compute a shape movement and rotation



sub moveShape ( shape as shape_type, points() as point_type )

    shape.x = shape.x + cos(shape.direction) * shape.speed

    shape.y = shape.y + sin(shape.direction) * shape.speed

    if shape.x<0 then 

        shape.x = CANVAS_WIDTH - shape.x

    elseif shape.x>CANVAS_WIDTH then 

        shape.x = - (shape.x - CANVAS_WIDTH)

    end if

    if shape.y<0 then 

        shape.y = CANVAS_HEIGHT - shape.y

    elseif shape.y > CANVAS_HEIGHT then 

        shape.y = - (shape.y - CANVAS_HEIGHT)

    end if

    shape.orientation = shape.orientation + shape.rotation

    if shape.orientation < 0 then 

        shape.orientation = TAU + shape.orientation

    elseif shape.orientation > TAU then

        shape.orientation = shape.orientation - TAU

    end if

    for i%=shape.firstPointIndex to shape.lastPointIndex

        x! = points(i%).x

        y! = points(i%).y

        rotation x!, y!, shape.rotation

        points(i%).x = x!

        points(i%).y = y!

    next i%

    convertShapeToDrawString shape, points()

    ' shape change the mask is not valid

    shape.maskComputed = 0

end sub



' helper to angular rotation



sub rotation (x!, y!, a!)

    xr! = x! * cos(a!) - y! * sin(a!)

    yr! = x! * sin(a!) + y! * cos(a!)

    x! = xr!

    y! = yr!

end sub



' convert a points array to DRAW string sequence



sub convertShapeToDrawString (shape as shape_type, points() as point_type)

    shape.drawString = ""

    n% = 0

    for i% = shape.firstPointIndex to shape.lastPointIndex

        x% = int(points(i%).x + shape.x)

        y% = int(points(i%).y + shape.y)

        if x%<0 or y%<0 then n% = -1

        rx$ = _tostr$(x%)

        ry$ = _tostr$(y%)

        shape.drawString = shape.drawString + "M " + rx$ + ", " + ry$

    next i%

    x% = int(points(shape.firstPointIndex).x + shape.x)

    y% = int(points(shape.firstPointIndex).y + shape.y)

    rx$ = _tostr$(x%)

    ry$ = _tostr$(y%)

    shape.drawString = shape.drawString + "M " + rx$ + ", " + ry$

    if n% then shape.drawString = ""

end sub



' draw shape

' CAUTION : the DRAW mode is not efficient, prefer then LINE mode



sub drawShape ( shape as shape_type, points() as point_type )



    h& = _dest

    _dest shape.imageHandle

    cls , &H00FFFFFF



    dim rgbaColor as _unsigned long

    rgbaColor = shape.rgbaColor

    if shape.collid then rgbaColor = _rgba(255,255,0,255) 



    select case DRAW_MODE

        case 0

            if shape.drawString<>"" then

                draw "C"+str$(shape.rgbaColor)

                draw "B"+shape.drawString

                paint (MAX_SHAPE_RADIUS,MAX_SHAPE_RADIUS),rgbaColor and &H7FFFFFFF ,rgbaColor

            end if

        case 1

            pset (points(shape.firstPointIndex).x + MAX_SHAPE_RADIUS, points(shape.firstPointIndex).y + MAX_SHAPE_RADIUS), rgbaColor

            for i%=shape.firstPointIndex to shape.lastPointIndex

                line - (points(i%).x + MAX_SHAPE_RADIUS, points(i%).y + MAX_SHAPE_RADIUS), rgbaColor

            next i%

            line - (points(shape.firstPointIndex).x + MAX_SHAPE_RADIUS, points(shape.firstPointIndex).y + MAX_SHAPE_RADIUS), rgbaColor

            paint (MAX_SHAPE_RADIUS,MAX_SHAPE_RADIUS),rgbaColor and &H7FFFFFFF ,rgbaColor

    end select



    _putimage (shape.x - MAX_SHAPE_RADIUS, shape.y - MAX_SHAPE_RADIUS), shape.imageHandle, h& 

    _dest h&

end sub



' generates a semi-transparent mask image



sub computeMask ( shape as shape_type )

    h& = _dest

    _source shape.imageHandle

    _dest shape.maskHandle

    cls , &H00000000

    m% = 2 * MAX_SHAPE_RADIUS - 1

    for x% = 0 to m% step PIXELS_PRECISION

        for y% = 0 to m% step PIXELS_PRECISION

            if point(x%,y%) <> &H00FFFFFF then 

                pset(x%\PIXELS_PRECISION,y%\PIXELS_PRECISION), &H7FFFFFFF

            end if

        next y%

    next x%

    ' the mask is now valid

    shape.maskComputed = -1

    _dest h&

end sub



' calculation of the areas affected by the shape



sub evaluateShapeSector ( shape as shape_type, areas() as area_type, targets() as integer )

    x% = shape.x

    y% = shape.y



    ' shape outside the canvas, so not in an area



    if x% < 0 or x% > CANVAS_WIDTH or y% < 0 or y% > CANVAS_HEIGHT then

        shape.area = -1

        exit sub

    end if



    ' computes area



    shape.areaX = _round(x% / MAX_SHAPE_RADIUS)

    shape.areaY = _round(y% / MAX_SHAPE_RADIUS)

    shape.area = (shape.areaY - 1) * AREAS_WIDTH + shape.areaX



    ' search other potential areas around



    if shape.area>=0 then 



        redim targets(-1) as integer



        x0! = shape.x - shape.radius

        y0! = shape.y - shape.radius

        sx0% = _round(x0! / MAX_SHAPE_RADIUS)

        sy0% = _round(y0! / MAX_SHAPE_RADIUS)



        x2! = shape.x + shape.radius

        y2! = shape.y + shape.radius

        sx2% = _round(x2! / MAX_SHAPE_RADIUS)

        sy2% = _round(y2! / MAX_SHAPE_RADIUS)



        s0% = (sy0% - 1) * AREAS_WIDTH + sx0%

        s1% = (sy0% - 1) * AREAS_WIDTH + shape.areaX

        s2% = (sy0% - 1) * AREAS_WIDTH + sx2%

        s3% = (shape.areaY - 1) * AREAS_WIDTH + sx0%

        s4% = (shape.areaY - 1) * AREAS_WIDTH + shape.areaX

        s5% = (shape.areaY - 1) * AREAS_WIDTH + sx2%

        s6% = (sy2% - 1) * AREAS_WIDTH + sx0%

        s7% = (sy2% - 1) * AREAS_WIDTH + shape.areaX

        s8% = (sy2% - 1) * AREAS_WIDTH + sx2%



        addUniqueInteger targets(), s0%

        addUniqueInteger targets(), s1%

        addUniqueInteger targets(), s2%

        addUniqueInteger targets(), s3%

        addUniqueInteger targets(), s4%

        addUniqueInteger targets(), s5%

        addUniqueInteger targets(), s6%

        addUniqueInteger targets(), s7%

        addUniqueInteger targets(), s8%



        ' remembers the presence of the shape in the area in the character array



        for i% = 0 to ubound(targets)

            if targets(i%)>=0 and targets(i%)<=AREAS_COUNT then mid$(areas(targets(i%)).shapeLocator,shape.index,1) = "*"

        next i%



    end if

end sub



' helper to keep only unique values



sub addUniqueInteger ( t() as integer, v as integer )

    for i%=lbound(t) to ubound(t)

        if t(i%)=v then exit sub

    next i%

    redim _preserve t(ubound(t)+1) as integer

    t(ubound(t)) = v

end sub



' detects collisions between shapes



function collision% ( shapes() as shape_type, area as area_type )

    res% = 0

    redim obj(-1) as integer



    ' collect unique shape indices from the area string (positions of '*')



    p0% = instr(area.shapeLocator,"*")

    do until p0% = 0

        s0% = p0%

        found% = 0

        for i%=lbound(obj) to ubound(obj)

            if obj(i%) = s0% then

                found% = -1

                exit for

            end if

        next i%

        if not found% then

            redim _preserve obj(ubound(obj)+1) as integer

            obj(ubound(obj)) = s0%

        end if

        p0% = instr(p0%+1,area.shapeLocator,"*")

    loop



    ' pairwise collision test (circle-circle) then test pixel-perfect 

    ' when the distance is short enough to have a possible collision



    for i%=lbound(obj) to ubound(obj)

        for j%=i%+1 to ubound(obj)

            if shapes(obj(i%)).collid and shapes(obj(j%)).collid then exit for

            h% = _hypot(shapes(obj(i%)).x-shapes(obj(j%)).x,shapes(obj(i%)).y-shapes(obj(j%)).y)

            r% = shapes(obj(i%)).radius + shapes(obj(j%)).radius

            if h% <= r% then

                res% = fusion%(shapes(obj(i%)),shapes(obj(j%)),area)

                if res% then

                    shapes(obj(i%)).collid = -1

                    shapes(obj(j%)).collid = -1

                end if

            end if

        next j%

    next i%



    collision% = res%

end function



' detects the overlapping of shapes

'

' each shape mask is semi-transparent ;

' copies each shape mask to its actual position in the area ;

' if we find at least one point that is no longer transparent

' then there is overlap and therefore collision detection



function fusion% ( shapeA as shape_type, shapeB as shape_type, area as area_type )

    if not shapeA.maskComputed then

        computeMask shapeA

    end if

    if not shapeB.maskComputed then

        computeMask shapeB

    end if

    res% = 0

    m% = 2 * MAX_SHAPE_RADIUS \ PIXELS_PRECISION - 1

    buffer& = _newimage(WIDTH_OF_AREA\PIXELS_PRECISION,HEIGHT_OF_AREA\PIXELS_PRECISION,32)

    _putimage ( (shapeA.x - area.center.x)\PIXELS_PRECISION, (shapeA.y - area.center.y)\PIXELS_PRECISION ), shapeA.maskHandle, buffer&

    _putimage ( (shapeB.x - area.center.x)\PIXELS_PRECISION, (shapeB.y - area.center.y)\PIXELS_PRECISION ), shapeB.maskHandle, buffer&

    _source buffer&

    for x% = 0 to m%

        for y% = 0 to m%

            if _alpha32(point(x%,y%)) > &H7F then 

                res% = -1

                exit for

            end if

        next y%

    next x%

    _freeimage buffer&

    fusion% = res%

end function

(09-15-2025, 06:12 PM)Herve Wrote: For sprites that are wider than they are long, this should work, but I suppose the limit is six times the maximum radius for the length, because I set a limit to test only nine areas for each sprite (the one where its center is located + the eight surrounding areas).

Hey, I might just test that!

(09-15-2025, 07:06 PM)Herve Wrote:

(09-15-2025, 06:12 PM)Herve Wrote: For sprites that are wider than they are long, this should work, but I suppose the limit is six times the maximum radius for the length, because I set a limit to test only nine areas for each sprite (the one where its center is located + the eight surrounding areas).

Hey, I might just test that!

Well, no, it doesn't work with sprites larger than 2 * MAX_SHAPE_RADIUS!!! And if you increase MAX_SHAPE_RADIUS too much, performance drops very quickly. But hey, it was mostly for fun; pixel-perfect is a luxury that isn't necessary in most applications.

type point_type

    x as double

    y as double

end type



type shape_type

    index as integer

    verticescounter as integer

    firstpointindex as integer

    lastpointindex as integer

    center as point_type

    min as point_type

    max as point_type

    coord as point_type

    rgbacolor as _unsigned long

    speed as double

    direction as double

    rotation as double

    orientation as double

    imageHandle as long

    touchdownHandle as long

    width as long

    height as long

    radius as long

    area as integer                ' area where the center of the shape is located

    areaX as integer                ' 

    areaY as integer                '

    collid as integer

end type



type context_type

    step_mode_activated as integer              ' -1 = step by step / 0 = don't

    show_grid_activated as integer              ' -1 = show grid of areas / 0 = dont't

    show_detection_activated as integer        ' -1 = show proximity detections areas / 0 = don't

    show_collisions_activated as integer        ' -1 = show areas where collisions are potentials / 0 = dont't

    show_radius_activated as integer

    show_index_activated as integer

    fullscreen_activated as integer

    show_help_activated as integer

    textHandle as long

    extra_shape_activated as integer

end type



const STEP_MODE_KEY = "S"          ' toggle stepmode

const SHOW_DETECTION_KEY = "P"      ' toggle drawing proximity detection areas

const SHOW_GRID_KEY = "G"          ' toggle drawing grid to show area delimitations

const SHOW_COLLISIONS_KEY = "C"    ' toogle drawing areas with potential collisions

const SHOW_RADIUS_KEY = "R"

const SHOW_INDEX_KEY = "I"

const SWAP_FULLSCREEN = "F"

const HIDE_HELP = "H"

const EXTRA_SHAPE_KEY = "E"

const UP_KEY = chr$(0) + chr$(72)

const RIGHT_KEY = chr$(0) + chr$(77)

const DOWN_KEY = chr$(0) + chr$(80)

const LEFT_KEY = chr$(0) + chr$(75)



dim context as context_type



const SHAPES_COUNTER = 64

const MIN_SHAPE_VERTICES = 3

const MAX_SHAPE_VERTICES = 12

const MIN_SHAPE_WIDTH = 30

const MAX_SHAPE_WIDTH = 60

const MIN_SHAPE_HEIGHT = 10

const MAX_SHAPE_HEIGHT = 20

const MIN_SHAPE_SPEED = 0.5        ' minimum speed of a shape

const MAX_SHAPE_SPEED = 1.1        ' maximum speed of a shape



const EXPECTED_FPS = 60            ' expected frames per second



const VIEWPORT_WIDTH = 640        ' viewport width

const VIEWPORT_HEIGHT = 480        ' viewport height



const FULLSCREEN = 0                ' -1 = fullscreen / 0 = don't



dim shared tau as single            ' 2 * pi

tau = 8 * atn(1)



CONST EPS = 0 '1E-9



randomize timer



' areas initialization



type area_type

    shapeLocator as string * SHAPES_COUNTER  ' Character array to memorize shapes in area

    column as integer              ' area colum

    row as integer                  ' area row

    x as integer                    ' top-left position of the area on the screen

    y as integer                    

    center as point_type            ' center position of the area onthe screen

end type



dim shared AREA_SIDE_WIDTH as integer 

dim shared AREAS_ROWS_COUNT as integer 

dim shared AREAS_COLUMNS_COUNT as integer 

dim shared AREAS_COUNT as integer 



AREA_SIDE_WIDTH = _max(MAX_SHAPE_WIDTH,MAX_SHAPE_HEIGHT)



' definition of the page dimension in which the shapes are drawn



const X_DECAY = 120 '_ceil(2.5 * MAX_SHAPE_WIDTH) ' offset between canvas and viewport

const Y_DECAY = 120 'X_DECAY

const CANVAS_WIDTH = VIEWPORT_WIDTH + 2 * X_DECAY  ' canvas size

const CANVAS_HEIGHT = VIEWPORT_HEIGHT + 2 * Y_DECAY



AREAS_COLUMNS_COUNT = _ceil(CANVAS_WIDTH / AREA_SIDE_WIDTH)

AREAS_ROWS_COUNT = _ceil(CANVAS_HEIGHT / AREA_SIDE_WIDTH)

AREAS_COUNT = AREAS_COLUMNS_COUNT * AREAS_ROWS_COUNT



areas_max = AREAS_COUNT

redim areas(0 to areas_max-1) as area_type

redim infos(-1) as string

dim i as integer



$console

_dest _console



for i=lbound(areas) to ubound(areas)

    areas(i).column = i mod AREAS_COLUMNS_COUNT

    areas(i).row = i \ AREAS_COLUMNS_COUNT

    areas(i).x = areas(i).column * area_side_width

    areas(i).y = areas(i).row * area_side_width

    areas(i).center.x = areas(i).x + area_side_width / 2

    areas(i).center.y = areas(i).y + area_side_width / 2

next i



' shapes initialization



redim shapes(-1) as shape_type

redim points(0) as point_type



for i=1 to SHAPES_COUNTER

    generateshape shapes(), points()

next i



' prepare screen rendering





viewport& = _newimage(VIEWPORT_WIDTH,VIEWPORT_HEIGHT,32)

_printmode _keepbackground, viewport&



canvas& = _newimage(CANVAS_WIDTH,CANVAS_HEIGHT,32)

textDest& = _newimage(CANVAS_WIDTH,CANVAS_HEIGHT,32)

context.textHandle = textDest&



screen viewport&

if FULLSCREEN then _fullscreen , _smooth



' timer to compute frames per second



t = timer(.001)

fps% = 0

frames% = 0



color &HFFFFFFFF, &H00000000



' main loop



do

    _limit EXPECTED_FPS



    for i=lbound(shapes) to ubound(shapes)

        moveShape shapes(i), points()

        shapes(i).collid = 0

    next i



    ' reset areas



    for i = lbound(areas) to ubound(areas)

        areas(i).shapeLocator = ""

    next i



    ' compute shapes' areas

    for i=lbound(shapes) to ubound(shapes)

        redim targets(-1) as integer

        evaluateShapeSector shapes(i), areas(), targets()

    next i



    _dest canvas&

    cls



    ' draw grid



    if context.show_grid_activated then

        for x% = 0 to AREAS_COLUMNS_COUNT

            xx%= x% * AREA_SIDE_WIDTH

            line (xx%,0)-(xx%,CANVAS_HEIGHT),_rgba(255,255,255,63)

        next x%

        for y% = 0 to AREAS_ROWS_COUNT

            yy% = y% * AREA_SIDE_WIDTH

            line (0,yy%)-(CANVAS_WIDTH,yy%),_rgba(255,255,255,63)

        next y%

    end if



    areasNotEmpty% = 0

    areasWithPossibleCollisions% = 0

    areasWithCollisions% = 0

    shapesInCollision% = 0



    for i = lbound(areas) to ubound(areas)

        showme% = 0

        if instr(areas(i).shapeLocator,"*") > 0 then

            showme% = 1

            areasNotEmpty% = areasNotEmpty% + 1

        end if

        if instr(areas(i).shapeLocator,"*") <> _instrrev(areas(i).shapeLocator,"*") then

            showme% = 2

            areasWithPossibleCollisions% = areasWithPossibleCollisions% + 1

            status% = collision(shapes(), points(), areas(i))

            if status% then areasWithCollisions% = areasWithCollisions% + 1

        end if

        if showme% > 0 then

            if context.show_detection_activated or context.show_collisions_activated then

                if context.show_detection_activated and not context.show_collisions_activated then

                    showme% = 1

                end if

                showcolor! = _iif(showme%=1,&H7FFFFF00,&HFFFF0000)

                if context.show_detection_activated or (context.show_collisions_activated and showme% = 2) then

                    pset (areas(i).x,areas(i).y)

                    line -step (area_side_width,0), showcolor!

                    line -step (0,area_side_width), showcolor!

                    line -step (-area_side_width,0), showcolor!

                    line -step (0,-area_side_width), showcolor!

                    if context.show_index_activated then

                        color &HFFFFFFFF '', &H00000000

                        _printstring (x%,y%), _tostr$(i), context.textHandle

                    end if

                end if

            end if

        end if

    next i



    _dest textDest&

    cls , _rgba(0,0,0,0)



    for i=lbound(shapes) to ubound(shapes)

        if shapes(i).collid then shapesInCollision% = shapesInCollision% + 1

        drawShape context,shapes(i), points(), 0

    next i



    ' fps



    frames% = frames% + 1 

    if timer(.001)>=t+1 then

        fps% = frames%

        frames% = 0

        t = timer(.001)

    end if



    ' display result



    _dest textDest&

    color &HFFFFFFFF, &HE0A0A0FF

    if context.show_help_activated then

        resetInfo infos()

        addinfo infos(), "                                                                fps: "+right$("000"+_tostr$(fps%),3)

        addInfo infos(), "  *** Pixel Perfect Collision Detection Demonstrator ***"

        addinfo infos(), ""

        addInfo infos(), "SHAPES"

        addinfo infos(), "======"

        addInfo infos(), " - total: "+right$("000"+_tostr$(SHAPES_COUNTER),3)

        addInfo infos(), " - in collision: "+right$("000"+_tostr$(shapesInCollision%),3)

        addinfo infos(), ""

        addInfo infos(), "AREAS"

        addinfo infos(), "======"

        addinfo infos(), " - not empty: "+right$("000"+_tostr$(areasNotEmpty%),3)

        addinfo infos(), " - with possible collisions: "+right$("000"+_tostr$(areasWithPossibleCollisions%),3)

        addinfo infos(), " - with detected collisions: "+right$("000"+_tostr$(areasWithCollisions%),3)

        addinfo infos(), ""

        addinfo infos(), "ACTION KEYS"

        addinfo infos(), "==========="

        addinfo infos(), " - H) hide/show this screen (hiding it will increase the performance)"

        addInfo infos(), " - S) swicth step mode (then SPACE to move forward step by step): "+_iif(context.step_mode_activated,"ON","OFF")

        addinfo infos(), " - G) show areas grid (number,coordinates,1st overlaid shape): "+_iif(context.show_grid_activated,"ON","OFF")

        addinfo infos(), " - P) show proximity detection areas: "+_iif(context.show_detection_activated,"ON","OFF")

        addInfo infos(), " - C) show probable collision areas: "+_iif(context.show_collisions_activated,"ON","OFF")

        addinfo infos(), " - R) show shapes radius: "+_iif(context.show_radius_activated,"ON","OFF")

        addinfo infos(), " - I) show shapes index (+ coordinates + area number): "+_iif(context.show_index_activated,"ON","OFF")

        addInfo infos(), " - E) swicth control of a shape (use arrows key to move): "+_iif(context.extra_shape_activated,"ON","OFF")

        addinfo infos(), " - F) swicth fullscreen" 

        addinfo infos(), " - ESC) stop and quit this program"

        addinfo infos(), ""

        showInfo infos()

    else

        color &HE0FFFFFF, &H00000000

        _printstring (1 + X_DECAY,1+Y_DECAY), "fps:"+right$("000"+_tostr$(fps%),3)

        _printstring (1 + X_DECAY,1+VIEWPORT_HEIGHT+Y_DECAY-16), "H)elp S)tep G)rid P)roximity C)ollision R)adius I)ndex E)xtra F)ullscr ESC)quit" 

    end if



    if context.show_grid_activated then

        color &HA0FFFFFF, &H00000000

        for i = lbound(areas) to ubound(areas)

            _printstring (areas(i).x,areas(i).y), _tostr$(i)

            _printstring (areas(i).x,areas(i).y+12), _tostr$(areas(i).x)

            _printstring (areas(i).x,areas(i).y+24), _tostr$(areas(i).y)

            _printstring (areas(i).x,areas(i).y+36), _tostr$(instr(areas(i).shapeLocator,"*")-1)

        next i

    end if

    

    _putimage (0,0), textDest&, canvas&

    _putimage (- X_DECAY,- Y_DECAY), canvas&, viewport&



    ' keyboard interaction



    do

        key$ = inkey$

        if key$ = chr$(27) then system

        select case ucase$(key$)

            case STEP_MODE_KEY

                switch context.step_mode_activated

            case SHOW_DETECTION_KEY

                switch context.show_detection_activated

            case SHOW_GRID_KEY

                switch context.show_grid_activated

            case SHOW_COLLISIONS_KEY

                switch context.show_collisions_activated

            case SHOW_RADIUS_KEY

                switch context.show_radius_activated

            case SHOW_INDEX_KEY

                switch context.show_index_activated

            case HIDE_HELP

                switch context.show_help_activated

            case SWAP_FULLSCREEN

                switch context.fullscreen_activated

                if context.fullscreen_activated then

                    _fullscreen _squarepixels, _smooth

                else

                    _fullscreen _off

                end if

            case EXTRA_SHAPE_KEY

                switch context.extra_shape_activated

                if context.extra_shape_activated then

                    extraShape shapes(lbound(shapes)), points()

                else

                    disextraShape shapes(lbound(shapes)), points()

                end if

            case UP_KEY

                if context.extra_shape_activated then shapes(lbound(shapes)).coord.y = shapes(lbound(shapes)).coord.y - 5

            case DOWN_KEY

                if context.extra_shape_activated then shapes(lbound(shapes)).coord.y = shapes(lbound(shapes)).coord.y + 5

            case RIGHT_KEY

                if context.extra_shape_activated then shapes(lbound(shapes)).coord.x = shapes(lbound(shapes)).coord.x + 5

            case LEFT_KEY

                if context.extra_shape_activated then shapes(lbound(shapes)).coord.x = shapes(lbound(shapes)).coord.x - 5

        end select

        if context.step_mode_activated then

            if key$ <> "" then exit do

        else

            exit do

        end if

    loop



loop



sub switch (boolean as integer)

    boolean = not boolean

end sub



' draw a shape



sub drawShape (context as context_type, shape as shape_type, points() as point_type, mask as integer)



        x0 = shape.coord.x '- X_DECAY '- shape.width\2

        y0 = shape.coord.y '+ Y_DECAY '- shape.height\2



        if shape.collid then

            RotoZoom3 x0, y0, shape.touchdownHandle, 1, 1, shape.orientation

            circle (x0,y0), shape.radius/4, &HFFFF0000

        else

            RotoZoom3 x0, y0, shape.imageHandle, 1, 1, shape.orientation

        end if



        if context.show_radius_activated then

          circle (x0,y0), shape.radius, shape.rgbaColor

        end if



        if context.extra_shape_activated and shape.index = 0  then

          circle (x0,y0), shape.radius/4, &HFFFF0000

          paint (x0,y0), &HFFFF0000, &HFFFF0000

        end if



        if context.show_index_activated then

            color &HFFFFFFFF, &H00000000

            '_printstring (shape.center.x - 6,shape.center.y - 6), _tostr$(shape.index), shape.imageHandle

            _printstring (x0 - 6,y0 - 6), _tostr$(shape.index)+"("+_tostr$(int(shape.coord.x))+","+_tostr$(int(shape.coord.y))+")"+"["+_tostr$(shape.area)+"]", context.textHandle

        end if



end sub



' prepare the sprite image



sub prepareSpriteImage (shape as shape_type, points() as point_type)

    h& = _dest

    _dest shape.imageHandle

    cls , &H00FFFFFF



    borderColor& = shape.rgbacolor

    fillColor& = shape.rgbacolor AND &H80FFFFFF



    x0 = points(shape.firstpointindex).x + shape.center.x

    y0 = points(shape.firstpointindex).y + shape.center.y



    pset (x0,y0), borderColor&



    for p = shape.firstpointindex to shape.lastpointindex

        x1 = points(p).x + shape.center.x

        y1 = points(p).y + shape.center.y



        line -(x1, y1), borderColor&

    next p



    line -(x0, y0), borderColor&



    paint (shape.center.x,shape.center.y), borderColor&, borderColor&



    pset (shape.center.x,shape.center.y), borderColor&



    _dest h&

end sub



' prepare the touchdown image



sub prepareTouchdownImage (shape as shape_type, points() as point_type)

    colorizeImage shape.imageHandle, shape.touchdownHandle, &HA0FFFF00

end sub



sub colorizeImage (imageSource as long, imageDest as long, colorDest as _unsigned long)

    h& = _dest

    _dest imageDest

    cls , &H00FFFFFF

    _source imageSource

    for x% = 0 to _width(imageSource) - 1

        for y% = 0 to _height(imageSource) - 1

            if _alpha32(point(x%,y%))>0 then pset (x%,y%), colorDest

        next y%

    next x%

    _dest h&

end sub



' generate a shape



sub generateshape (shapes() as shape_type, points() as point_type)



    ' nombre de sommets

    n = int(rnd * (MAX_SHAPE_VERTICES - MIN_SHAPE_VERTICES)) + MIN_SHAPE_VERTICES + 1

    ' largeur

    w = int(rnd * (MAX_SHAPE_WIDTH - MIN_SHAPE_WIDTH)) + MIN_SHAPE_WIDTH + 1

    ' hauteur

    h = int(rnd * (MAX_SHAPE_HEIGHT - MIN_SHAPE_HEIGHT)) + MIN_SHAPE_HEIGHT + 1

    ' type (convexe / concave) t$

    t$ = _iif(rnd > 0.5, "convexe", "concave")

    ' facteur de concavité (0..1, pour concave) : ", cf

    cf = rnd



    redim polygon(n - 1) as point_type

    attempts = 0

    generatepolygon n, w, h, t$, cf, polygon()



    dim shape as shape_type

    shape.verticescounter = n

    shape.firstpointindex = ubound(points)+1

    shape.lastpointindex = shape.firstpointindex + n - 1



    redim _preserve points(1 to shape.lastpointindex) as point_type



    dim as point_type min, max

    min.x = 1.0E308 : max.x = - min.x

    min.y = 1.0E308 : max.y = - min.y



    for i = lbound(polygon) to ubound(polygon)

        min.x = _iif(polygon(i).x < min.x,polygon(i).x,min.x)

        min.y = _iif(polygon(i).y < min.y,polygon(i).y,min.y)

        max.x = _iif(polygon(i).x > max.x,polygon(i).x,max.x)

        max.y = _iif(polygon(i).y > max.y,polygon(i).y,max.y)

        points(shape.firstpointindex + i).x = polygon(i).x

        points(shape.firstpointindex + i).y = polygon(i).y

    next i



    shape.min = min

    shape.max = max

    shape.width = max.x - min.x + 1

    shape.height = max.y - min.y + 1

    shape.center.x = shape.width / 2

    shape.center.y = shape.height / 2

    shape.radius = _max(shape.width,shape.height)/2

    shape.imageHandle = _newimage(shape.width,shape.height,32) 

    shape.touchdownHandle = _newimage(shape.width,shape.height,32) 



    for i = lbound(polygon) to ubound(polygon)

        points(shape.firstpointindex + i).x = int(points(shape.firstpointindex + i).x - shape.center.x)

        points(shape.firstpointindex + i).y = int(points(shape.firstpointindex + i).y - shape.center.y)

    next i



    shape.speed = rnd*(MAX_SHAPE_SPEED - MIN_SHAPE_SPEED) + MIN_SHAPE_SPEED

    shape.direction = rnd*TAU

    shape.rotation = (rnd*TAU - TAU/2)/100

    shape.orientation = 0



    shape.rgbaColor = _rgb32(int(rnd*127)+128,int(rnd*127)+128,int(rnd*127)+128)

    shape.coord.x = int(rnd * CANVAS_WIDTH)

    shape.coord.y = int(rnd * CANVAS_HEIGHT)

    shape.index = ubound(shapes)+1



    redim _preserve shapes(lbound(shapes) to shape.index) as shape_type

    shapes(shape.index) = shape



    prepareSpriteImage shape, points()

    prepareTouchdownImage shape, points()



end sub



function randdouble(min#, max#) 'as double

    randdouble = min# + rnd * (max# - min#)

end function



' test for segment intersection (excluding shared endpoints of segments)



function segintersect(ax#, ay#, bx#, by#, cx#, cy#, dx#, dy#)

    dim s1x#, s1y#, s2x#, s2y#, s#, t#

    s1x = bx - ax: s1y = by - ay

    s2x = dx - cx: s2y = dy - cy

    denom = (-s2x * s1y + s1x * s2y)

    if abs(denom) < 1e-12 then

        segintersect = 0

        exit function

    end if

    s = (-s1y * (ax - cx) + s1x * (ay - cy)) / denom

    t = ( s2x * (ay - cy) - s2y * (ax - cx)) / denom

    if s > 0 and s < 1 and t > 0 and t < 1 then

        segintersect = 1

    else

        segintersect = 0

    end if

end function



' detect self intersection



function hasselfintersection(pts() as point_type, n as integer)

    dim i as integer, j as integer

    ' vérifier chaque paire d'arêtes non-adjacentes

    for i = 0 to n - 1

        a1 = i

        a2 = (i + 1) mod n

        for j = i + 1 to n - 1

            b1 = j

            b2 = (j + 1) mod n

            ' ignorer arêtes adjacentes et première/dernière partage

            if a1 = b1 or a1 = b2 or a2 = b1 or a2 = b2 then

                _continue

            end if

            if segintersect(pts(a1).x, pts(a1).y, pts(a2).x, pts(a2).y, _

                            pts(b1).x, pts(b1).y, pts(b2).x, pts(b2).y) then

                hasselfintersection = -1

                exit function

            end if

        next j

    next i

    hasselfintersection = 0

end function



' generate a new polygon



sub generatepolygon(n as integer, w as double, h as double, polytype$ , concavityfactor as double, pts() as point_type)



    if n < 3 then

        print "n doit être >= 3": end

    end if



    dim angles() as double

    dim radii() as double

    redim angles(n - 1)

    redim radii(n - 1)

    dim i as integer



    do

        ' Generate evenly distributed angles with jitter

        for i = 0 to n - 1

            basis = tau * i / n

            perturb = randdouble(-0.3, 0.3) * (tau / n) * 0.3

            angles(i) = basis + perturb

        next i

        ' simple sort (bubble sort acceptable for small n)

        for i = 0 to n - 2

            for j = i + 1 to n - 1

                if angles(i) > angles(j) then

                    swap angles(i), angles(j)

                    'tmp# = angles(i): angles(i) = angles(j): angles(j) = tmp#

                end if

            next j

        next i



        ' initial radii near 1 with small variation

        for i = 0 to n - 1

            radii(i) = 1 + randdouble(-0.15, 0.15)

        next i



        ' If concave: reduce a few radii

        if lcase$(polytype$) = "concave" then

            k = int(_max(1, _round(concavityfactor * n / 3)))

            if k < 1 then k = 1

            ' choose k distinct indices

            dim chosen() as integer

            redim chosen(k - 1)

            m = 0

            do while m < k

                idx = int(rnd * n)

                found = 0

                for t = 0 to m - 1

                    if chosen(t) = idx then found = 1: exit for

                next t

                if found = 0 then

                    chosen(m) = idx

                    m = m + 1

                end if

            loop

            for t = 0 to k - 1

                idx = chosen(t)

                reduction = 1 - (0.3 + 0.65 * concavityfactor * rnd)

                radii(idx) = radii(idx) * reduction

                left = (idx - 1 + n) mod n

                right = (idx + 1) mod n

                radii(left) = radii(left) * (1 + 0.05 * rnd)

                radii(right) = radii(right) * (1 + 0.05 * rnd)

            next t

        end if



        ' build points centered at (0,0) with ellipse rx, ry

        rx = w / 2

        ry = h / 2

        for i = 0 to n - 1

            pts(i).x = radii(i) * cos(angles(i)) * rx

            pts(i).y = radii(i) * sin(angles(i)) * ry

        next i



        ' normalize to fit exactly within [0,w]×[0,h]

        minx = pts(0).x: maxx = pts(0).x

        miny = pts(0).y: maxy = pts(0).y

        for i = 1 to n - 1

            if pts(i).x < minx then minx = pts(i).x

            if pts(i).x > maxx then maxx = pts(i).x

            if pts(i).y < miny then miny = pts(i).y

            if pts(i).y > maxy then maxy = pts(i).y

        next i

        curw = maxx - minx

        curh = maxy - miny

        if curw < 1e-9 then curw = 1

        if curh < 1e-9 then curh = 1

        sx = w / curw

        sy = h / curh

        for i = 0 to n - 1

            pts(i).x = (pts(i).x - minx) * sx

            pts(i).y = (pts(i).y - miny) * sy

        next i



        ' check intersections; if conflicting, regenerate (attempt limit)

        intersects = hasselfintersection(pts(), n)

        attempts = attempts + 1

        if attempts > 200 then

            exit do

        end if

    loop while intersects <> 0



end sub



' stop movement for a shape



sub extraShape ( shape as shape_type, points() as point_type )

    shape.coord.x = CANVAS_WIDTH \ 2

    shape.coord.y = CANVAS_HEIGHT \ 2

    shape.speed = 0

    shape.rotation = 0

end sub



' 



sub disextraShape ( shape as shape_type, points() as point_type )

    shape.speed = rnd*(MAX_SHAPE_SPEED - MIN_SHAPE_SPEED) + MIN_SHAPE_SPEED

    shape.rotation = (rnd*TAU - TAU/2)/100

end sub



' compute a shape movement and rotation



sub moveShape ( shape as shape_type, points() as point_type )

    shape.coord.x = shape.coord.x + cos(shape.direction) * shape.speed

    shape.coord.y = shape.coord.y + sin(shape.direction) * shape.speed

    if shape.coord.x<0 then 

        shape.coord.x = CANVAS_WIDTH - shape.coord.x

    elseif shape.coord.x>CANVAS_WIDTH then 

        shape.coord.x = - (shape.coord.x - CANVAS_WIDTH)

    end if

    if shape.coord.y<0 then 

        shape.coord.y = CANVAS_HEIGHT - shape.coord.y

    elseif shape.coord.y > CANVAS_HEIGHT then 

        shape.coord.y = - (shape.coord.y - CANVAS_HEIGHT)

    end if

    shape.orientation = shape.orientation + shape.rotation

    if shape.orientation < 0 then 

        shape.orientation = TAU + shape.orientation

    elseif shape.orientation > TAU then

        shape.orientation = shape.orientation - TAU

    end if

    for i%=shape.firstPointIndex to shape.lastPointIndex

        x! = points(i%).x

        y! = points(i%).y

        rotation x!, y!, shape.rotation

        points(i%).x = x!

        points(i%).y = y!

    next i%

end sub



' helper to angular rotation



sub rotation (x!, y!, a!)

    xr! = x! * cos(a!) - y! * sin(a!)

    yr! = x! * sin(a!) + y! * cos(a!)

    x! = xr!

    y! = yr!

end sub



Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single)

    ' This assumes you have set your drawing location with _DEST or default to screen.

    ' X, Y - is where you want to put the middle of the image

    ' Image - is the handle assigned with _LOADIMAGE

    ' xScale, yScale - are shrinkage < 1 or magnification > 1 on the given axis, 1 just uses image size.

    ' These are multipliers so .5 will create image .5 size on given axis and 2 for twice image size.

    ' radianRotation is the Angle in Radian units to rotate the image

    ' note: Radian units for rotation because it matches angle units of other Basic Trig functions

    '      and saves a little time converting from degree.

    '      Use the _D2R() function if you prefer to work in degree units for angles.



    Dim px(3) As Single: Dim py(3) As Single ' simple arrays for x, y to hold the 4 corners of image

    Dim W&, H&, sinr!, cosr!, i&, x2&, y2& '  variables for image manipulation

    W& = _Width(Image&): H& = _Height(Image&)

    px(0) = -W& / 2: py(0) = -H& / 2 'left top corner

    px(1) = -W& / 2: py(1) = H& / 2 ' left bottom corner

    px(2) = W& / 2: py(2) = H& / 2 '  right bottom

    px(3) = W& / 2: py(3) = -H& / 2 ' right top

    sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation) ' rotation helpers

    For i& = 0 To 3 ' calc new point locations with rotation and zoom

        x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y

        px(i&) = x2&: py(i&) = y2&

    Next

    _MapTriangle _seamless (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2)), 

    _MapTriangle _seamless (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2)), 

End Sub



' orient (cross product)



function orient (a as point_type, b as point_type, c as point_type)

    orient = (b.x - a.x) * (c.y - a.y) - (b.y - a.y) * (c.x - a.x)

end function



' on segment: p colinear and within bbox of [a,b]

' return -1 if p in the bbox

' EPS = small epsilon tolerance for comparaison



function onsegment (a as point_type, b as point_type, p as point_type)

    dim minx as double, maxx as double, miny as double, maxy as double

    if a.x < b.x then

        minx = a.x: maxx = b.x

    else

        minx = b.x: maxx = a.x

    end if

    if a.y < b.y then

        miny = a.y: maxy = b.y

    else

        miny = b.y: maxy = a.y

    end if



    if (p.x + EPS >= minx) and (p.x - EPS <= maxx) and (p.y + EPS >= miny) and (p.y - EPS <= maxy) then

        onsegment = -1

    else

        onsegment = 0

    end if

end function



' segments intersect

' return -1 if segment p1 to p2 intersects with segment q1 to q2

' EPS = small epsilon tolerance for comparaison



function segmentsintersect (p1 as point_type, p2 as point_type, q1 as point_type, q2 as point_type)

    dim d1 as double, d2 as double, d3 as double, d4 as double



    d1 = orient(p1, p2, q1)

    d2 = orient(p1, p2, q2)

    d3 = orient(q1, q2, p1)

    d4 = orient(q1, q2, p2)



    if (d1 * d2 < -EPS) and (d3 * d4 < -EPS) then

        segmentsintersect = -1

        exit function

    end if



    if (abs(d1) <= EPS) and (onsegment(p1, p2, q1) <> 0) then

        segmentsintersect = -1

        exit function

    end if

    if (abs(d2) <= EPS) and (onsegment(p1, p2, q2) <> 0) then

        segmentsintersect = -1

        exit function

    end if

    if (abs(d3) <= EPS) and (onsegment(q1, q2, p1) <> 0) then

        segmentsintersect = -1

        exit function

    end if

    if (abs(d4) <= EPS) and (onsegment(q1, q2, p2) <> 0) then

        segmentsintersect = -1

        exit function

    end if



    segmentsintersect = 0

end function



' point in polygon (ray casting to +x)

' returns -1 if inside or on edge, 0 if outside



function pointinpolygon (pt as point_type, shape as shape_type, points() as point_type)

    dim i as long, j as long

    dim inside as integer

    dim xi as point_type, xj as point_type

    inside = 0

    j = shape.lastPointIndex

    for i = shape.firstPointIndex to shape.lastPointIndex

        sum xi, points(i), shape.coord

        sum xj, points(j), shape.coord



        ' check if point is exactly on segment

        if abs(orient(xi, xj, pt)) <= eps then

            if onsegment(xi, xj, pt) <> 0 then

                pointinpolygon = -1

                exit function

            end if

        end if



        if ((xi.y > pt.y) <> (xj.y > pt.y)) then

            dim x_intersect as double

            x_intersect = xi.x + (pt.y - xi.y) * (xj.x - xi.x) / (xj.y - xi.y)

            if x_intersect > pt.x then

                inside = not inside

            end if

        end if



        j = i

    next i



    if inside then

        pointinpolygon = -1

    else

        pointinpolygon = 0

    end if

end function



' polygonsintersect

' returns -1 if intersecting (including touching), 0 otherwise



function polygonsintersect (shapeA as shape_type, shapeB as shape_type, points() as point_type)

    dim i as long, j as long

    dim a1 as point_type, a2 as point_type, b1 as point_type, b2 as point_type



    h% = _hypot(shapeA.coord.x-shapeB.coord.x,shapeA.coord.y-shapeA.coord.y)

    r% = shapeA.radius + shapeB.radius

    if h% > r% then

        polygonsintersect = 0

        exit function

    end if



    for i = shapeA.firstPointIndex to shapeA.lastPointIndex

        sum a1, points(i), shapeA.coord

        if i = shapeA.lastPointIndex then

            sum a2, points(shapeA.firstPointIndex), shapeA.coord

        else

            sum a2, points(i+1), shapeA.coord

        end if

        for j = shapeB.firstPointIndex to shapeB.lastPointIndex

            sum b1, points(j), shapeB.coord

            if i = shapeB.lastPointIndex then

                sum b2, points(shapeB.firstPointIndex), shapeB.coord

            else

                sum b2, points(i+1), shapeB.coord

            end if

            if segmentsintersect(a1, a2, b1, b2) <> 0 then

                polygonsintersect = -1

                exit function

            end if

        next j

    next i



    ' no edge intersections: test containment

    sum a1, points(shapeA.firstPointIndex), shapeA.coord 

    if pointinpolygon(a1, shapeB, points()) <> 0 then

        polygonsintersect = -1

        exit function

    end if

    sum b1, points(shapeB.firstPointIndex), shapeB.coord

    if pointinpolygon(b1, shapeA, points()) <> 0 then

        polygonsintersect = -1

        exit function

    end if



    polygonsintersect = 0

end function



' sum point 1 and 2 given point 0



sub sum(p0 as point_type, p1 as point_type, p2 as point_type)

    p0.x = p1.x + p2.x

    p0.y = p1.y + p2.y

end sub



' calculation of the areas affected by the shape



sub evaluateShapeSector ( shape as shape_type, areas() as area_type, targets() as integer )



    ' shape outside the canvas, so not in an area



    if shape.coord.x < 0 or shape.coord.x > CANVAS_WIDTH or shape.coord.y < 0 or shape.coord.y > CANVAS_HEIGHT then

        shape.area = -1

        exit sub

    end if



    ' computes area



    shape.areaX = shape.coord.x \ AREA_SIDE_WIDTH

    shape.areaY = shape.coord.y \ AREA_SIDE_WIDTH

    shape.area = shape.areaY * AREAS_COLUMNS_COUNT + shape.areaX



    ' search other potential areas around



    if shape.area>=0 then 



        redim targets(-1) as integer



        x0! = shape.coord.x - shape.radius

        y0! = shape.coord.y - shape.radius

        sx0% = x0! \ AREA_SIDE_WIDTH

        sy0% = y0! \ AREA_SIDE_WIDTH



        x2! = shape.coord.x + shape.radius

        y2! = shape.coord.y + shape.radius

        sx2% = x2! \ AREA_SIDE_WIDTH

        sy2% = y2! \ AREA_SIDE_WIDTH



        s0% = sy0% * AREAS_COLUMNS_COUNT + sx0%

        s1% = sy0% * AREAS_COLUMNS_COUNT + shape.areaX

        s2% = sy0% * AREAS_COLUMNS_COUNT + sx2%

        s3% = shape.areaY * AREAS_COLUMNS_COUNT + sx0%

        s4% = shape.areaY * AREAS_COLUMNS_COUNT + shape.areaX

        s5% = shape.areaY * AREAS_COLUMNS_COUNT + sx2%

        s6% = sy2% * AREAS_COLUMNS_COUNT + sx0%

        s7% = sy2% * AREAS_COLUMNS_COUNT + shape.areaX

        s8% = sy2% * AREAS_COLUMNS_COUNT + sx2%



        addUniqueInteger targets(), s0%

        addUniqueInteger targets(), s1%

        addUniqueInteger targets(), s2%

        addUniqueInteger targets(), s3%

        addUniqueInteger targets(), s4%

        addUniqueInteger targets(), s5%

        addUniqueInteger targets(), s6%

        addUniqueInteger targets(), s7%

        addUniqueInteger targets(), s8%



        ' remembers the presence of the shape in the area in the character array



        for i% = 0 to ubound(targets)

            if targets(i%)>=0 and targets(i%)<=AREAS_COUNT then 

                if targets(i%)>=lbound(areas) and targets(i%)<=ubound(areas) then

                    mid$(areas(targets(i%)).shapeLocator,shape.index+1,1) = "*"

                end if

            end if

        next i%



    end if

end sub



' helper to keep only unique values



sub addUniqueInteger ( t() as integer, v as integer )

    for i%=lbound(t) to ubound(t)

        if t(i%)=v then exit sub

    next i%

    redim _preserve t(ubound(t)+1) as integer

    t(ubound(t)) = v

end sub



' detects collisions between shapes



function collision% ( shapes() as shape_type, points() as point_type, area as area_type )



    collision% = 0



    redim obj(-1) as integer



    ' collect unique shape indices from the area string (positions of '*')



    p0% = instr(area.shapeLocator,"*")

    do until p0% = 0

        s0% = p0%

        found% = 0

        for i%=lbound(obj) to ubound(obj)

            if obj(i%) = s0% then

                found% = -1

                exit for

            end if

        next i%

        if not found% then

            redim _preserve obj(ubound(obj)+1) as integer

            obj(ubound(obj)) = s0%

        end if

        p0% = instr(p0%+1,area.shapeLocator,"*")

    loop



    ' pairwise collision test (circle-circle) then test pixel-perfect 

    ' when the distance is short enough to have a possible collision



    for i%=lbound(obj) to ubound(obj)

        for j%=i%+1 to ubound(obj)

            if shapes(obj(i%)-1).collid and shapes(obj(j%)-1).collid then exit sub

            if polygonsintersect(shapes(obj(i%)-1),shapes(obj(j%)-1),points()) then

                shapes(obj(i%)-1).collid = -1

                shapes(obj(j%)-1).collid = -1

                collision% = -1

                exit for

            end if

        next j%

    next i%



end function



sub showInfo (infos() as string)

    for i% = lbound(infos) to ubound(infos)

        _printstring (30  + X_DECAY,i%*16 + Y_DECAY), left$(" " + infos(i%) + space$(72-len(infos(i%))),73)

    next i%

end sub



sub resetInfo (infos() as string)

    redim infos(-1) as string

end sub



sub addInfo (infos() as string, info as string)

    redim _preserve infos(1 to ubound(infos)+1) as string

    infos(ubound(infos)) = info

end sub