pixler/tools/polystudio.bas

$console
_screenhide
if command$="" then _echo "🫥 please specify image file to process": system 1
_screenshow

type point2d
    x as long
    y as long
end type

type statetype
    change as _byte
    levels as _unsigned _byte
    threshold as _unsigned _byte
    mode as _byte
    handle as long
    orgimg as long
    overlay as long
end type

dim shared state as statetype
dim file as string
dim shared done as _byte
dim shared mouseclicked as _byte
dim shared mbd as _byte

' Global polygon trace registers declared as dynamic
redim shared contour(4999) as point2d
dim shared totalpoints as long

if _fileexists(command$) then file = command$
state.orgimg = _loadimage(file, 32)
state.handle = _copyimage(state.orgimg)
state.overlay = _newimage(_width(state.orgimg), _height(state.orgimg), 32)
state.levels = 10
state.threshold = 127
updateimage

screen _newimage(_width(state.orgimg) + 200, _height(state.orgimg) + 200, 32)

do until done
    cls
    while _mouseinput: wend
    mouseclicked = not _mousebutton(1) and mbd
    mbd = _mousebutton(1)

    if state.change then
        updateimage
        state.change = 0
    end if

    ' Render quantized base image
    _putimage (0, 0), state.handle

    ' Render the vector transparent overlay shapes on top
    _putimage (0, 0), state.overlay

    ' Process interactive trace when clicking inside image viewport
    if mouseclicked then
        dim clickx as long, clicky as long
        clickx = _mousex
        clicky = _mousey

        ' Verify click coordinates are safely within the source image canvas bounding box
        if clickx >= 0 and clickx < _width(state.orgimg) and clicky >= 0 and clicky < _height(state.orgimg) then
            dim targetcolor as _unsigned long

            ' Fetch look-up color index from the generated active handle
            _source state.handle
            targetcolor = point(clickx, clicky)
            _source 0 

            ' FIX 1: Clear out the old polygon completely by resetting the transparent overlay canvas
            dim prevdest as long
            prevdest = _dest
            _dest state.overlay
            cls ,_rgb32(0,0,0,0) ' Wipes the canvas clean
            _dest prevdest

            ' FIX 2: Reset the dynamic buffer array to its clean baseline size right here in the main module
            redim shared contour(4999) as point2d
            totalpoints = 0

            ' Pass the shared dynamic array directly into the tracing routine
            tracecontour contour(), targetcolor, clickx, clicky

            if totalpoints >= 3 and totalpoints < (_width(state.orgimg) * _height(state.orgimg)) then
                redim _preserve contour(totalpoints - 1) as point2d
                
                ' Pass the dynamic array directly into the simplification routine
                simplifypolygon contour()

                if totalpoints >= 3 then
                    ' Build flat 1D coordinate matrix map array (X1, Y1, X2, Y2...)
                    redim polypoints(0 to (totalpoints * 2) - 1) as long
                    dim i as long
                    dim clipstr as string

                    clipstr = "fpolygon("
                    for i = 0 to totalpoints - 1
                        polypoints(i * 2) = contour(i).x
                        polypoints(i * 2 + 1) = contour(i).y

                        clipstr = clipstr + ltrim$(str$(contour(i).x)) + "," + ltrim$(str$(contour(i).y))
                        if i < totalpoints - 1 then clipstr = clipstr + ","
                    next i
                    clipstr = clipstr + ")"

                    ' Send string array payload safely to system clipboard hardware
                    _clipboard$ = clipstr

                    ' Render transparent vector overlay on overlay handler sheet
                    dim olddest as long
                    olddest = _dest
                    _dest state.overlay

                    ' Render with a semi-transparent green color (Alpha = 100)
                    filledpolygon polypoints(), _rgba32(0, 255, 0, 100)

                    _dest olddest
                end if
            end if
        end if
    end if

    ol = state.levels
    ot = state.threshold
    interface
    if ol <> state.levels then state.change = -1
    if ot <> state.threshold then state.change = -1

    _limit 30
    _display
loop
system
'$include: '../include/ui.bm'

sub interface
    if button(10, _height - 34, 60, 23, "exit") then done = -1
    color highlightcolor
    _printstring (10, _height(state.handle) + 10), "levels"
    state.levels = slider(10, _height(state.handle) + 28, 100, state.levels * 10) / 10
    color highlightcolor
    _printstring (118, _height(state.handle) + 28), str$(state.levels)
    _printstring (10, _height(state.handle) + 40), "threshold"
    state.threshold = slider(10, _height(state.handle) + 58, 100, state.threshold / 255 * 100) / 100 * 255
    color highlightcolor
    _printstring (118, _height(state.handle) + 58), str$(state.threshold)
end sub

sub updateimage
    dim odest as long
    dim osource as long
    odest = _dest
    osource = _source
    _source state.orgimg
    _dest state.handle

    dim x as long, y as long, l as integer
    dim numsteps as integer

    if state.levels < 2 then state.levels = 2
    numsteps = state.levels - 1

    for y = 0 to _height - 1
        for x = 0 to _width - 1
            l = luma(point(x, y))

            dim adjustedl as single
            if state.threshold = 0 or state.threshold = 255 then
                adjustedl = l
            elseif l <= state.threshold then
                adjustedl = (l / state.threshold) * 127.5
            else
                adjustedl = 127.5 + ((l - state.threshold) / (255 - state.threshold)) * 127.5
            end if

            dim currentstep as integer
            currentstep = int((adjustedl / 256) * state.levels)

            if currentstep < 0 then currentstep = 0
            if currentstep > numsteps then currentstep = numsteps

            l = int(currentstep * (255 / numsteps))

            pset (x, y), _rgb32(l)
        next x
    next y

    _source osource
    _dest odest
end sub

function luma (col as _unsigned long)
    luma = 0.21 * _red(col) + 0.72 * _green(col) + 0.07 * _blue(col)
end function

sub filledpolygon (points() as long, col as long)
    dim i as integer, j as integer
    dim x1 as single, y1 as single, x2 as single, y2 as single
    dim intersectx as single
    dim numpoints as integer
    numpoints = (ubound(points) + 1) \ 2

    dim intersections(4999) as single
    dim numintersections as integer
    dim y as long

    for y = 0 to _height - 1
        numintersections = 0
        for i = 0 to numpoints - 1
            x1 = points(i * 2)
            y1 = points(i * 2 + 1)
            x2 = points(((i + 1) mod numpoints) * 2)
            y2 = points(((i + 1) mod numpoints) * 2 + 1)

            if ((y1 > y and y2 <= y) or (y2 > y and y1 <= y)) then
                if y2 - y1 <> 0 then
                    intersectx = x1 + (y - y1) * (x2 - x1) / (y2 - y1)
                    if numintersections <= ubound(intersections) then
                        intersections(numintersections) = intersectx
                        numintersections = numintersections + 1
                    end if
                end if
            end if
        next i

        for i = 0 to numintersections - 1
            for j = i + 1 to numintersections - 1
                if intersections(i) > intersections(j) then
                    swap intersections(i), intersections(j)
                end if
            next j
        next i

        for i = 0 to numintersections - 1 step 2
            if i + 1 < numintersections then
                line (intersections(i), y)-(intersections(i + 1), y), col
            end if
        next i
    next y
end sub

' FIX 3: Adjusted signature to cleanly receive the dynamic array as a parameter
sub tracecontour (poly() as point2d, targcolor as _unsigned long, mx as long, my as long)
    dim startx as long, starty as long
    dim foundstart as _byte

    dim oldsource as long
    oldsource = _source
    _source state.handle

    dim y&
    for y& = my to 0 step -1
        if point(mx, y&) <> targcolor then
            startx = mx
            starty = y& + 1
            foundstart = -1
            exit for
        end if
    next y&

    if not foundstart then
        startx = mx: starty = my
    end if

    dim dx(0 to 7) as integer
    dim dy(0 to 7) as integer
    dx(0) = -1: dx(1) = 0: dx(2) = 1: dx(3) = 1: dx(4) = 1: dx(5) = 0: dx(6) = -1: dx(7) = -1
    dy(0) = -1: dy(1) = -1: dy(2) = -1: dy(3) = 0: dy(4) = 1: dy(5) = 1: dy(6) = 1: dy(7) = 0

    dim currentx as long, currenty as long
    dim backtrackdir as integer, checkdir as integer
    dim startbacktrackdir as integer

    currentx = startx
    currenty = starty
    totalpoints = 0

    backtrackdir = 1
    startbacktrackdir = 1

    dim firststep as _byte
    firststep = -1

    dim maxallowedpoints as long
    maxallowedpoints = _width(state.handle) * _height(state.handle)

    do
        poly(totalpoints).x = currentx
        poly(totalpoints).y = currenty
        totalpoints = totalpoints + 1

        if totalpoints >= maxallowedpoints then
            totalpoints = 0
            exit do
        end if

        if totalpoints >= ubound(poly) then
            ' Safely scales the array parameter reference across scopes
            redim _preserve poly(ubound(poly) + 1000) as point2d
        end if

        checkdir = (backtrackdir + 1) mod 8
        dim steps as integer
        steps = 0

        do while steps < 8
            dim nx as long, ny as long
            nx = currentx + dx(checkdir)
            ny = currenty + dy(checkdir)

            if nx >= 0 and nx < _width(state.handle) and ny >= 0 and ny < _height(state.handle) then
                if point(nx, ny) = targcolor then
                    backtrackdir = (checkdir + 4) mod 8
                    currentx = nx
                    currenty = ny

                    if firststep then
                        startbacktrackdir = backtrackdir
                        firststep = 0
                    end if
                    exit do
                end if
            end if

            checkdir = (checkdir + 1) mod 8
            steps = steps + 1
        loop

        if steps = 8 then exit do

    loop until (currentx = startx and currenty = starty and backtrackdir = startbacktrackdir)
    _source oldsource
end sub

' FIX 4: Adjusted signature to cleanly receive the dynamic array as a parameter
sub simplifypolygon (poly() as point2d)
    dim numpoints as long
    numpoints = totalpoints

    if numpoints > 2 then
        if poly(numpoints - 1).x = poly(0).x and poly(numpoints - 1).y = poly(0).y then
            numpoints = numpoints - 1
        end if
    end if

    if numpoints < 3 then exit sub

    dim temp(0 to numpoints - 1) as point2d
    dim keepcount as long

    temp(0) = poly(0)
    keepcount = 1

    dim i as long
    for i = 1 to numpoints - 1
        dim previdx as long: previdx = i - 1
        dim nextidx as long: nextidx = i + 1
        if nextidx > numpoints - 1 then nextidx = 0

        dim dx1 as single: dx1 = poly(i).x - poly(previdx).x
        dim dy1 as single: dy1 = poly(i).y - poly(previdx).y
        dim dx2 as single: dx2 = poly(nextidx).x - poly(i).x
        dim dy2 as single: dy2 = poly(nextidx).y - poly(i).y

        dim crossproduct as single
        crossproduct = (dx1 * dy2) - (dy1 * dx2)

        if abs(crossproduct) > 0.05 then
            temp(keepcount) = poly(i)
            keepcount = keepcount + 1
        end if
    next i

    if keepcount >= 3 then
        redim poly(keepcount - 1) as point2d
        for i = 0 to keepcount - 1
            poly(i) = temp(i)
        next i
        totalpoints = keepcount
    else
        redim poly(numpoints - 1) as point2d
        for i = 0 to numpoints - 1
            poly(i) = temp(i)
        next i
        totalpoints = numpoints
    end if
end sub