visionmercer/pixler
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Hush screaming code, save a bit of space.

Browse source
This commit is contained in:
visionmercer 2026-05-26 13:26:36 +02:00
commit 5a1d279b0a
1 changed files with 354 additions and 354 deletions
Download patch file Download diff file Expand all files Collapse all files

690
tools/polystudio.bas
View file

@ -1,389 +1,389 @@
$CONSOLE
_SCREENHIDE
IF COMMAND$ = "" THEN _ECHO "please specify image file to process": SYSTEM 1
_SCREENSHOW
$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 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
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
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
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
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)
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
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
state.change=0
end if
' Render quantized base image
_PUTIMAGE (0, 0), state.handle
_putimage (0,0),state.handle
' Render the vector transparent overlay shapes on top
_PUTIMAGE (0, 0), state.overlay
_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
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
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
_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
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 + ")"
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
_clipboard$=clipstr
' Render transparent vector overlay on overlay handler sheet
DIM oldDest AS LONG
oldDest = _DEST
_DEST state.overlay
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
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
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 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
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
dim x as long,y as long,l as integer
dim numsteps as integer
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
if state.levels<2 then state.levels=2
numsteps=state.levels-1
_SOURCE osource
_DEST odest
END SUB
for y=0 to _height-1
for x=0 to _width-1
l=luma(point(x,y))
FUNCTION luma (col AS _UNSIGNED LONG)
luma = 0.21 * _RED(col) + 0.72 * _GREEN(col) + 0.07 * _BLUE(col)
END FUNCTION
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)
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
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
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
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
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
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