Hush screaming code, save a bit of space.

This commit is contained in:
visionmercer 2026-05-26 13:26:36 +02:00
commit 5a1d279b0a

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)
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)
do until done
cls
while _mouseinput:wend
mouseclicked=not _mousebutton(1) and mbd
mbd=_mousebutton(1)
IF state.change THEN
if state.change then
updateimage
state.change=0
END IF
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 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 and totalpoints<(_width(state.orgimg)*_height(state.orgimg)) then
redim _preserve contour(totalpoints-1) as point2d
simplifypolygon
IF TotalPoints >= 3 THEN
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
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="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 + ")"
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)
filledpolygon polypoints(),_rgba32(0,255,0,100)
_DEST oldDest
END IF
END IF
END IF
END IF
_dest olddest
end if
end if
end if
end if
mouseclicked=0
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
if ol<>state.levels then state.change=-1
if ot<>state.threshold then state.change=-1
_LIMIT 30
_DISPLAY
LOOP
SYSTEM
_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"
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"
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
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
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
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))
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 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)
dim currentstep as integer
currentstep=int((adjustedl/256)*state.levels)
IF currentStep < 0 THEN currentStep = 0
IF currentStep > numSteps THEN currentStep = numSteps
if currentstep<0 then currentstep=0
if currentstep>numsteps then currentstep=numsteps
l = INT(currentStep * (255 / numSteps))
l=int(currentstep*(255/numsteps))
PSET (x, y), _RGB32(l)
NEXT x
NEXT y
pset (x,y),_rgb32(l)
next x
next y
_SOURCE osource
_DEST odest
END SUB
_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
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
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
dim intersections(4999) as single ' SAFEGUARD 2: Larger intersection limit
dim numintersections as integer
dim y as long
FOR y = 0 TO _HEIGHT - 1
for y=0 to _height-1
numintersections=0
FOR i = 0 TO numpoints - 1
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)
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
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
if numintersections<=ubound(intersections) then
intersections(numintersections)=intersectx
numintersections=numintersections+1
END IF
END IF
END IF
NEXT i
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
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
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
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 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&
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
if not foundstart then
startx=mx:starty=my
end if
DIM dx(0 TO 7) AS INTEGER
DIM dy(0 TO 7) AS INTEGER
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
dim currentx as long,currenty as long
dim backtrackdir as integer,checkdir as integer
dim startbacktrackdir as integer
CurrentX = StartX
CurrentY = StartY
TotalPoints = 0
currentx=startx
currenty=starty
totalpoints=0
BacktrackDir = 1
StartBacktrackDir = 1
backtrackdir=1
startbacktrackdir=1
DIM FirstStep AS _BYTE
FirstStep = -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)
dim maxallowedpoints as long
maxallowedpoints=_width(state.handle)*_height(state.handle)
DO
Contour(TotalPoints).X = CurrentX
Contour(TotalPoints).Y = CurrentY
TotalPoints = TotalPoints + 1
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>=maxallowedpoints then
totalpoints=0
exit do
end if
IF TotalPoints >= UBOUND(Contour) THEN
REDIM _PRESERVE Contour(UBOUND(Contour) + 1000) AS Point2D
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
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)
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 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
if firststep then
startbacktrackdir=backtrackdir
firststep=0
end if
exit do
end if
end if
CheckDir = (CheckDir + 1) MOD 8
Steps = Steps + 1
LOOP
checkdir=(checkdir+1) mod 8
steps=steps+1
loop
IF Steps = 8 THEN EXIT DO
if steps=8 then exit do
LOOP UNTIL (CurrentX = StartX AND CurrentY = StartY AND BacktrackDir = StartBacktrackDir)
_SOURCE oldSource
END SUB
loop until (currentx=startx and currenty=starty and backtrackdir=startbacktrackdir)
_source oldsource
end sub
' =========================================================================
' SUBROUTINE: SimplifyPolygon
' =========================================================================
SUB SimplifyPolygon
DIM numPoints AS LONG
numPoints = TotalPoints
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>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
if numpoints<3 then exit sub
DIM temp(0 TO numPoints - 1) AS Point2D
DIM keepCount AS LONG
dim temp(0 to numpoints-1) as point2d
dim keepcount as long
temp(0) = Contour(0)
keepCount = 1
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 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 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)
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 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
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