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
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 ' Restore background source monitor pointer

            ' SAFEGUARD 1: Do not attempt to parse pure black background/borders
            if targetcolor<>_rgb32(0,0,0) and targetcolor<>_rgba32(0,0,0,0) then
                totalpoints=0
                tracecontour targetcolor,clickx,clicky

                if totalpoints>=3 and totalpoints<(_width(state.orgimg)*_height(state.orgimg)) then
                    redim _preserve contour(totalpoints-1) as point2d
                    simplifypolygon

                    if totalpoints>=3 then
                        ' Build flat 1D coordinate matrix map array (X1, Y1, X2, Y2...)
                        dim 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
        mouseclicked=0
    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

' =========================================================================
' SUBROUTINE: Solid Filled Scanning Polygon Vector Renderer
' =========================================================================
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 ' SAFEGUARD 2: Larger intersection limit
    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)
                    ' SAFEGUARD 3: Array bounds protection
                    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

' =========================================================================
' SUBROUTINE: Moore-Neighbor Contour Tracer
' =========================================================================
sub tracecontour (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

    ' Calculate absolute ceiling area parameter to handle escape routes
    dim maxallowedpoints as long
    maxallowedpoints=_width(state.handle)*_height(state.handle)

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

        ' SAFEGUARD 4: Break if loop gets stuck spinning in empty coordinates
        if totalpoints>=maxallowedpoints then
            totalpoints=0
            exit do
        end if

        if totalpoints>=ubound(contour) then
            redim _preserve contour(ubound(contour)+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

' =========================================================================
' SUBROUTINE: SimplifyPolygon
' =========================================================================
sub simplifypolygon
    dim numpoints as long
    numpoints=totalpoints

    if numpoints>2 then
        if contour(numpoints-1).x=contour(0).x and contour(numpoints-1).y=contour(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)=contour(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=contour(i).x-contour(previdx).x
        dim dy1 as single:dy1=contour(i).y-contour(previdx).y
        dim dx2 as single:dx2=contour(nextidx).x-contour(i).x
        dim dy2 as single:dy2=contour(nextidx).y-contour(i).y

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

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

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