+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: Petr (https://qb64phoenix.com/forum/forumdisplay.php?fid=52)
+---- Thread: Some random goofy stuff just for fun (/showthread.php?tid=4180)
Some random goofy stuff just for fun - Petr - 12-02-2025
Hi, this little program was made just for fun. It’s a small simulation of tuning an old analog TV. Using the + and – keys you simulate tuning. The goal was to blur or sharpen the picture depending on how “tuned in” it is, and also add noise to the audio. To run the program you’ll need one image and one MP3 file.
Code: (Select All)
imag = _LoadImage("masicko.jpg", 32)
snd = _SndOpen("01.mp3")
image = _NewImage(800, 600, 32)
_PutImage , imag, image
_FreeImage imag
Dim As Integer X, Y, W, H, R, nX, nY
W = _Width(image)
H = _Height(image)
Screen _NewImage(W, H, 32)
Dim arr(W - 1, H - 1) As _Unsigned Long
Dim arb(W - 1, H - 1) As _Unsigned Long
Dim As _MEM m, n, o, p, q
o = _MemImage(0)
m = _MemImage(image)
n = _Mem(arr())
p = _Mem(arb())
q = _MemSound(snd, 0)
_MemCopy m, m.OFFSET, m.SIZE To n, n.OFFSET
_MemFree m
_MemFree n
Dim SinPrecalc(179) As Single
Dim CosPrecalc(179) As Single
For f = 0 To 179
SinPrecalc(f) = Sin(_D2R(f))
CosPrecalc(f) = Cos(_D2R(f))
Next f
Dim As Single Le, Ri
SndPntr = 0
SndBuffEmpty = 1
Ra = 5
Do Until _KeyHit = 27
X = 0
Do Until X >= W - 1
Y = 0
i$ = InKey$
If i$ = "+" Then Ra = Ra + 3
If i$ = "-" Then Ra = Ra - 3
Ra = _IIf(Ra < 1, 1, Ra)
Do Until Y >= H - 1
angle = Rnd * 179
R = Rnd * Ra
nX = X + CosPrecalc(angle) * R
nY = Y + SinPrecalc(angle) * R
Do While _SndRawLen < .01
_MemGet q, q.OFFSET + SndP, Le
SndP = SndP + 4
_MemGet q, q.OFFSET + SndP, Ri
SndP = SndP + 4
SndP = _IIf(SndP > q.SIZE - 8, 0, SndP)
noise = Ra / 50
noise = _IIf(noise > 1, 1, noise)
_SndRaw noise * Rnd + (1 - noise) * Le, noise * Rnd + (1 - noise) * Ri
Loop
nX = _IIf(nX > W - 1, W - 1, nX)
nX = _IIf(nX < 0, 0, nX)
nY = _IIf(nY > H - 1, H - 1, nY)
nY = _IIf(nY < 0, 0, nY)
arb(X, Y) = arr(nX, nY)
Y = Y + 1
Loop
X = X + 1
Loop
_MemCopy p, p.OFFSET, p.SIZE To o, o.OFFSET
Loop
_MemFree o
_MemFree p
_FreeImage image
End
RE: Some random goofy stuff just for fun - bplus - 12-02-2025
Quote:Hi, this little program was made just for fun.
+1 just for that!!! but i see you using _IFF and memory stuff too so good for learning.
Learning is always better through fun ways!
It would be a little more handy to put image and sound and code in a zip, but thats my pet pieve!
Keep up the good work @Petr !
RE: Some random goofy stuff just for fun - Petr - 12-04-2025
This is a program for generating a mosaic. It loads your input image and converts it into a mosaic.
I have included two versions here. The first one is fast (provided you use an image with a reasonable resolution). The one below that is slower, and when saving the output to an SVG file, it becomes extremely slow. I noticed that the function _LoadImage supports SVG, so I felt obligated to try it.
Code: (Select All)
Option _Explicit
Const IMG_PATH$ = "6-800-600.jpg"
Dim Shared Seed_Count
Seed_Count = 16000
' 3D shading parameters
Const LIGHT_X! = .6 ' lightning direction X
Const LIGHT_Y! = -0.6 ' lightning direction Y
Const LIGHT_Z! = 0.8 ' lightning direction Z
Const LIGHT_STRENGTH! = 0.65 ' lightning power
Const SHADOW_STRENGTH! = 0.35 ' shadow power
Const GRoutt_COLOR& = &HFF404040~& ' barva spáry (tmavě šedá)
Type Seed
x As Integer
y As Integer
End Type
Dim img As Long
img = _LoadImage(IMG_PATH$, 32)
If img = -1 Then Print "Error loading image!": End
Dim fw As Long, fh As Long
fw = _Width(img)
fh = _Height(img)
' FULL RES SOURCE
ReDim srcFull(fw * fh - 1) As _Unsigned Long
Dim m As _MEM, n As _MEM
m = _MemImage(img)
n = _Mem(srcFull())
_MemCopy m, m.OFFSET, m.SIZE To n, n.OFFSET
_MemFree m: _MemFree n
' HALF RES
Dim hw As Long, hh As Long, f As Long
If fw Mod 2 <> 0 Then hw = fw \ 2 + 1 Else hw = fw \ 2
If fh Mod 2 <> 0 Then hh = fh \ 2 + 1 Else hh = fh \ 2
ReDim srcHalf(hw * hh - 1) As _Unsigned Long
Call DownsampleHalf(srcFull(), fw, fh, srcHalf(), hw, hh)
' DETAIL MAP (halfres)
ReDim detailHalf(hw * hh - 1) As Single
ComputeDetailMap_Sobel srcHalf(), hw, hh, detailHalf()
' GENERATE SEEDS (halfres)
ReDim seeds(Seed_Count - 1) As Seed
GenerateSeeds detailHalf(), hw, hh, seeds()
' VORONOI halfres
ReDim regHalf(hw * hh - 1) As Long
VoronoiAssign regHalf(), seeds(), Seed_Count, hw, hh
' UPSCALE region map
ReDim regFull(fw * fh - 1) As Long
UpscaleRegionMap regHalf(), hw, hh, regFull(), fw, fh
' COMPUTE COLORS (fullres)
ReDim regionColor(Seed_Count - 1) As _Unsigned Long
ComputeRegionColors_Fast srcFull(), regFull(), Seed_Count, fw, fh, regionColor()
' RENDER
ReDim outtFull(fw * fh - 1) As _Unsigned Long
RenderVoronoi regFull(), regionColor(), fw, fh, outtFull()
' APPLY 3D SHADING
Apply3DShading regFull(), regionColor(), fw, fh, outtFull()
' SHOW RESULT
Dim outtImg As Long: outtImg = _NewImage(fw, fh, 32)
Screen outtImg
Dim mm As _MEM, oo As _MEM
mm = _Mem(outtFull())
oo = _MemImage(outtImg)
_MemCopy mm, mm.OFFSET, mm.SIZE To oo, oo.OFFSET
_MemFree mm: _MemFree oo
_PrintString (10, 10), "FAST MODE DONE"
Sleep
End
Sub DownsampleHalf(srcFull() As _Unsigned Long, fw As Long, fh As Long, _
srcHalf() As _Unsigned Long, hw As Long, hh As Long)
Dim x As Long, y As Long
For y = 0 To hh - 1
For x = 0 To hw - 1
srcHalf(y * hw + x) = srcFull((y * 2) * fw + (x * 2))
Next
Next
End Sub
Sub UpscaleRegionMap(regHalf() As Long, hw As Long, hh As Long, _
regFull() As Long, fw As Long, fh As Long)
Dim x As Long, y As Long
For y = 0 To fh - 1
Dim hy As Long: hy = y \ 2
For x = 0 To fw - 1
Dim hx As Long: hx = x \ 2
regFull(y * fw + x) = regHalf(hy * hw + hx)
Next
Next
End Sub
Function Lum (p As _Unsigned Long)
Lum = ((_ShR(p, 16) And 255) * 0.299) + ((_ShR(p, 8) And 255) * 0.587) + ((p And 255) * 0.114)
End Function
Sub ComputeDetailMap_Sobel (src() As _Unsigned Long, w As Long, h As Long, detail() As Single)
Dim x As Long, y As Long, i As Long
Dim gx As Single, gy As Single
Dim l0 As Single, l1 As Single, l2 As Single
Dim l3 As Single, l4 As Single, l5 As Single
Dim l6 As Single, l7 As Single, l8 As Single
Dim idx As Long
For y = 1 To h - 2
For x = 1 To w - 2
idx = (y - 1) * w + (x - 1)
l0 = Lum(src(idx))
l1 = Lum(src(idx + 1))
l2 = Lum(src(idx + 2))
l3 = Lum(src(idx + w))
l4 = Lum(src(idx + w + 1))
l5 = Lum(src(idx + w + 2))
l6 = Lum(src(idx + 2 * w))
l7 = Lum(src(idx + 2 * w + 1))
l8 = Lum(src(idx + 2 * w + 2))
gx = -l0 + l2 - 2 * l3 + 2 * l5 - l6 + l8
gy = -l0 - 2 * l1 - l2 + l6 + 2 * l7 + l8
detail(y * w + x) = Sqr(gx * gx + gy * gy)
Next
Next
Dim mn As Single: mn = 1E+30
Dim mx As Single: mx = -1E+30
For i = 0 To w * h - 1
If detail(i) < mn Then mn = detail(i)
If detail(i) > mx Then mx = detail(i)
Next
Dim scale As Single: scale = 1! / (mx - mn)
For i = 0 To w * h - 1
detail(i) = (detail(i) - mn) * scale
Next
End Sub
Sub GenerateSeeds (detail() As Single, w As Long, h As Long, seeds() As Seed)
Dim sx As Long, sy As Long, cnt As Long
cnt = 0
Randomize Timer
Do While cnt < Seed_Count
sx = Int(Rnd * w)
sy = Int(Rnd * h)
If Rnd < (0.25 + detail(sy * w + sx) * 0.75) Then
seeds(cnt).x = sx
seeds(cnt).y = sy
cnt = cnt + 1
End If
Loop
End Sub
Sub ComputeRegionColors_Fast (src() As _Unsigned Long, reg() As Long, regionCount As Long, fw As Long, fh As Long, col() As _Unsigned Long)
Dim rSum As _Integer64, gSum As _Integer64, bSum As _Integer64
Dim cnt As Long
ReDim rSum(regionCount - 1)
ReDim gSum(regionCount - 1)
ReDim bSum(regionCount - 1)
ReDim cnt(regionCount - 1)
Dim i As Long, px As _Unsigned Long, rid As Long
For i = 0 To fw * fh - 1
rid = reg(i)
If rid >= 0 Then
px = src(i)
rSum(rid) = rSum(rid) + ((_ShR(px, 16)) And 255)
gSum(rid) = gSum(rid) + ((_ShR(px, 8)) And 255)
bSum(rid) = bSum(rid) + (px And 255)
cnt(rid) = cnt(rid) + 1
End If
Next
Dim r As Long, g As Long, b As Long
For rid = 0 To regionCount - 1
If cnt(rid) > 0 Then
r = rSum(rid) \ cnt(rid)
g = gSum(rid) \ cnt(rid)
b = bSum(rid) \ cnt(rid)
col(rid) = _RGB32(r, g, b)
Else
col(rid) = _RGB32(128, 128, 128)
End If
Next
End Sub
Sub RenderVoronoi (reg() As Long, col() As _Unsigned Long, w As Long, h As Long, outt() As _Unsigned Long)
Dim i As Long
For i = 0 To w * h - 1
outt(i) = col(reg(i))
Next
End Sub
Sub Apply3DShading (reg() As Long, col() As _Unsigned Long, w As Long, h As Long, outt() As _Unsigned Long)
Dim i As Long, rid As Long
Dim x As Long, y As Long
Dim nx As Single, ny As Single, nz As Single
Dim Lx As Single, Ly As Single, Lz As Single
Dim dot As Single
Dim px As _Unsigned Long
Dim r As Long, g As Long, b As Long
' Normalize lightning vector
Dim Llen As Single
Llen = Sqr(LIGHT_X * LIGHT_X + LIGHT_Y * LIGHT_Y + LIGHT_Z * LIGHT_Z)
Lx = LIGHT_X / Llen
Ly = LIGHT_Y / Llen
Lz = LIGHT_Z / Llen
For y = 1 To h - 2
For x = 1 To w - 2
i = y * w + x
rid = reg(i)
If (rid <> reg(i - 1) Or rid <> reg(i + 1) Or rid <> reg(i - w) Or rid <> reg(i + w)) Then
' stone border
' outt(i) = GRoutt_COLOR&
Else
' Normal (fake bump map)
nx = reg(i - 1) - reg(i + 1)
ny = reg(i - w) - reg(i + w)
nz = 1
Dim nlen As Single
nlen = Sqr(nx * nx + ny * ny + nz * nz)
nx = nx / nlen
ny = ny / nlen
nz = nz / nlen
' lightning
dot = nx * Lx + ny * Ly + nz * Lz
dot = (dot + 1) / 2
px = outt(i)
r = ((_ShR(px, 16)) And 255)
g = ((_ShR(px, 8)) And 255)
b = (px And 255)
r = r * (1 + LIGHT_STRENGTH * (dot - 0.5))
g = g * (1 + LIGHT_STRENGTH * (dot - 0.5))
b = b * (1 + LIGHT_STRENGTH * (dot - 0.5))
r = (r * (1 - SHADOW_STRENGTH)) + (r * dot * SHADOW_STRENGTH)
g = (g * (1 - SHADOW_STRENGTH)) + (g * dot * SHADOW_STRENGTH)
b = (b * (1 - SHADOW_STRENGTH)) + (b * dot * SHADOW_STRENGTH)
If r < 0 Then r = 0 Else If r > 255 Then r = 255
If g < 0 Then g = 0 Else If g > 255 Then g = 255
If b < 0 Then b = 0 Else If b > 255 Then b = 255
outt(i) = _RGB32(r, g, b)
End If
Next
Next
End Sub
Sub VoronoiAssign (regID() As Long, seeds() As Seed, seedCount As Long, w As Long, h As Long)
Dim As Long stp, idx, Poss, Best, BestDist, ox, oy, nx, ny, ni, px, py, i, total, sid, d
total = w * h
' For each pixel we store: nearest seed index
For i = 0 To total - 1
regID(i) = -1
Next
' Initialize with seeds
For i = 0 To seedCount - 1
idx = seeds(i).y * w + seeds(i).x
If idx >= 0 And idx < total Then regID(idx) = i
Next
' JFA stps
stp = 1
Do While stp < w Or stp < h
stp = stp * 2
Loop
Do While stp > 0
For py = 0 To h - 1
For px = 0 To w - 1
Poss = py * w + px
Best = regID(Poss)
If Best >= 0 Then
BestDist = (px - seeds(Best).x) * (px - seeds(Best).x) + (py - seeds(Best).y) * (py - seeds(Best).y)
Else
BestDist = 2147483647
End If
' check neighbors in 8 directions
For oy = -1 To 1
For ox = -1 To 1
nx = px + ox * stp
ny = py + oy * stp
If nx >= 0 And nx < w And ny >= 0 And ny < h Then
ni = ny * w + nx
sid = regID(ni)
If sid >= 0 Then
d = (px - seeds(sid).x) * (px - seeds(sid).x) + (py - seeds(sid).y) * (py - seeds(sid).y)
If d < BestDist Then
BestDist = d
Best = sid
End If
End If
End If
Next
Next
regID(Poss) = Best
Next
Next
stp = stp \ 2
Loop
End Sub
Code: (Select All)
' VORONOI MOSAIC IN QB64PE
' 16000 seed, save image as SVG and then show it
Option _Explicit
Const IMG_PATH$ = "6-800-600.jpg"
Const SEED_COUNT = 16000
Type Seed
x As Integer
y As Integer
End Type
Dim img As Long
Dim w As Long, h As Long
img = _LoadImage(IMG_PATH$, 32)
If img = 0 Then Print "Error loading file": End
w = _Width(img)
h = _Height(img)
ReDim src32(w * h - 1) As _Unsigned Long
ReDim detail(w * h - 1) As Single
Dim seeds(w * h - 1) As Seed
ReDim regionID(w * h - 1) As Long
ReDim out32(w * h - 1) As _Unsigned Long
Dim regionColor(w * h - 1) As _Unsigned Long
' Load image
Dim m As _MEM, n As _MEM
m = _MemImage(img)
n = _Mem(src32())
_MemCopy m, m.OFFSET, m.SIZE To n, n.OFFSET
_MemFree m: _MemFree n
' 1) DETAIL MAP (SOBEL)
ComputeDetailMap_Sobel src32(), w, h, detail()
' 2) GENERATE SEEDS ADAPTIVELY
Dim seeds As Seed
ReDim seeds(SEED_COUNT - 1)
GenerateSeeds detail(), w, h, seeds()
' 3) JUMP FLOOD ALGORITHM – Voronoi
VoronoiAssign regionID(), seeds(), SEED_COUNT, w, h
' 4) COMPUTE AVERAGE COLORS
ComputeRegionColors_Voronoi src32(), regionID(), SEED_COUNT, w, h, regionColor()
' 5) RENDER REGIONS
RenderVoronoi regionID(), regionColor(), w, h, out32()
' 6) DRAW EDGES
'DrawVoronoiEdges regionID(), w, h, out32(), _RGB32(255, 255, 255)
' 7) SHOW RESULT
Dim outImg As Long: outImg = _NewImage(w, h, 32)
Screen outImg
Dim mm As _MEM, oo As _MEM
mm = _Mem(out32())
oo = _MemImage(outImg)
_MemCopy mm, mm.OFFSET, mm.SIZE To oo, oo.OFFSET
_MemFree mm: _MemFree oo
_Title "Image done, wait, creating SVG file!"
ExportVoronoiToSVG regionID(), regionColor(), w, h, "Voronoi.svg"
_PrintString (10, 10), "Voronoi Mosaic done: (" + Str$(SEED_COUNT) + " seeds)"
_PrintString (10, 23), "Saved as Voronoi.svg, press any key for load it..."
_Title "SVG done press key..."
Sleep
Dim Voro As Long
Voro = _LoadImage("Voronoi.svg", 32)
Cls
_PutImage , Voro
_FreeImage Voro
End
' SOBEL DETAIL MAP
Function Lum (p As _Unsigned Long)
Lum = ((_ShR(p, 16) And 255) * 0.299) + ((_ShR(p, 8) And 255) * 0.587) + ((p And 255) * 0.114)
End Function
Sub ComputeDetailMap_Sobel (src32() As _Unsigned Long, w As Long, h As Long, detail() As Single)
Dim As Long idx, x, y, i
Dim As Single mn, scale, l0, l1, l2, l3, l4, l5, l6, l7, l8, gx, gy, mx
For y = 1 To h - 2
For x = 1 To w - 2
idx = (y - 1) * w + (x - 1)
l0 = Lum(src32(idx))
l1 = Lum(src32(idx + 1))
l2 = Lum(src32(idx + 2))
l3 = Lum(src32(idx + w))
l4 = Lum(src32(idx + w + 1))
l5 = Lum(src32(idx + w + 2))
l6 = Lum(src32(idx + 2 * w))
l7 = Lum(src32(idx + 2 * w + 1))
l8 = Lum(src32(idx + 2 * w + 2))
gx = -l0 + l2 - 2 * l3 + 2 * l5 - l6 + l8
gy = -l0 - 2 * l1 - l2 + l6 + 2 * l7 + l8
detail(y * w + x) = Sqr(gx * gx + gy * gy)
Next
Next
' normalize
mn = 1E+30
mx = -1E+30
For i = 0 To w * h - 1
If detail(i) < mn Then mn = detail(i)
If detail(i) > mx Then mx = detail(i)
Next
scale = 1! / (mx - mn)
For i = 0 To w * h - 1
detail(i) = (detail(i) - mn) * scale
Next
End Sub
' SEED GENERATION (DETAIL-WEIGHTED)
Sub GenerateSeeds (detail() As Single, w As Long, h As Long, seeds() As Seed)
Dim i As Long, sx As Long, sy As Long, tries As Long
Dim cnt As Long: cnt = 0
Dim As Single d
Randomize Timer
Do While cnt < SEED_COUNT
sx = Int(Rnd * w)
sy = Int(Rnd * h)
' higher detail higher chance
d = detail(sy * w + sx)
If Rnd < (0.3 + d * 0.7) Then
seeds(cnt).x = sx
seeds(cnt).y = sy
cnt = cnt + 1
End If
Loop
End Sub
' VORONOI – JUMP FLOOD ALGORITHM
'-----------------------------------------------------------
Sub VoronoiAssign (regID() As Long, seeds() As Seed, seedCount As Long, w As Long, h As Long)
Dim As Long stp, idx, Poss, Best, BestDist, ox, oy, nx, ny, ni, px, py, i, total, sid, d
total = w * h
' For each pixel we store: nearest seed index
For i = 0 To total - 1
regID(i) = -1
Next
' Initialize with seeds
For i = 0 To seedCount - 1
idx = seeds(i).y * w + seeds(i).x
If idx >= 0 And idx < total Then regID(idx) = i
Next
' JFA stps
stp = 1
Do While stp < w Or stp < h
stp = stp * 2
Loop
Do While stp > 0
For py = 0 To h - 1
For px = 0 To w - 1
Poss = py * w + px
Best = regID(Poss)
If Best >= 0 Then
BestDist = (px - seeds(Best).x) * (px - seeds(Best).x) + (py - seeds(Best).y) * (py - seeds(Best).y)
Else
BestDist = 2147483647
End If
' check neighbors in 8 directions
For oy = -1 To 1
For ox = -1 To 1
nx = px + ox * stp
ny = py + oy * stp
If nx >= 0 And nx < w And ny >= 0 And ny < h Then
ni = ny * w + nx
sid = regID(ni)
If sid >= 0 Then
d = (px - seeds(sid).x) * (px - seeds(sid).x) + (py - seeds(sid).y) * (py - seeds(sid).y)
If d < BestDist Then
BestDist = d
Best = sid
End If
End If
End If
Next
Next
regID(Poss) = Best
Next
Next
stp = stp \ 2
Loop
End Sub
' COMPUTE AVG COLOR FOR EACH REGION
'-----------------------------------------------------------
Sub ComputeRegionColors_Voronoi (src32() As _Unsigned Long, regID() As Long, seedCount As Long, w As Long, h As Long, outColors() As _Unsigned Long)
Dim sumR As Double, sumG As Double, sumB As Double
Dim cnt As Long
ReDim sumR(seedCount - 1)
ReDim sumG(seedCount - 1)
ReDim sumB(seedCount - 1)
ReDim cnt(seedCount - 1)
ReDim outColors(seedCount - 1)
Dim i As Long, px As _Unsigned Long, sid As Long
For i = 0 To w * h - 1
sid = regID(i)
If sid >= 0 Then
px = src32(i)
sumR(sid) = sumR(sid) + ((_ShR(px, 16)) And 255)
sumG(sid) = sumG(sid) + ((_ShR(px, 8)) And 255)
sumB(sid) = sumB(sid) + (px And 255)
cnt(sid) = cnt(sid) + 1
End If
Next
For sid = 0 To seedCount - 1
If cnt(sid) > 0 Then
outColors(sid) = _RGB32(sumR(sid) / cnt(sid), sumG(sid) / cnt(sid), sumB(sid) / cnt(sid))
Else
outColors(sid) = _RGB32(128, 128, 128)
End If
Next
End Sub
' RENDER REGIONS
Sub RenderVoronoi (regID() As Long, col() As _Unsigned Long, w As Long, h As Long, out32() As _Unsigned Long)
Dim i As Long
For i = 0 To w * h - 1
out32(i) = col(regID(i))
Next
End Sub
' DRAW EDGES
Sub DrawVoronoiEdges (regID() As Long, w As Long, h As Long, out32() As _Unsigned Long, edgeCol As _Unsigned Long)
Dim x As Long, y As Long, i As Long
For y = 0 To h - 1
For x = 0 To w - 1
i = y * w + x
If x < w - 1 Then
If regID(i) <> regID(i + 1) Then
out32(i) = edgeCol
End If
End If
If y < h - 1 Then
If regID(i) <> regID(i + w) Then
out32(i) = edgeCol
End If
End If
Next
Next
End Sub
' VORONOI EXPORT TO SVG
Sub ExportVoronoiToSVG (regionID() As Long, col() As _Unsigned Long, w As Long, h As Long, file$)
Dim ff As Long
ff = FreeFile
Open file$ For Output As ff
Print #ff, "<svg width=" + Chr$(34) + LTrim$(Str$(w)) + Chr$(34) + _
" height=" + Chr$(34) + LTrim$(Str$(h)) + Chr$(34) + _
" xmlns=" + Chr$(34) + "http://www.w3.org/2000/svg" + Chr$(34) + ">"
Dim hexColor$
Dim outline$
Dim As Long region, total, start, i, x, y, bx, by, cx, cy, dir, k, nd, nx, ny, R, G, B
Dim c As _Unsigned Long
Dim As _Byte visitedStart, FoundNext
total = w * h
For region = 0 To UBound(col)
' 1) Search start pixel in region
start = -1
For i = 0 To total - 1
If regionID(i) = region Then
x = i Mod w: y = i \ w
If IsEdge(regionID(), region, x, y, w, h) Then
start = i
Exit For
End If
End If
Next
If start < 0 Then _Continue
' 2) BORDER TRACE
outline$ = ""
bx = start Mod w
by = start \ w
cx = bx: cy = by
dir = 0
visitedStart = 0
Do
outline$ = outline$ + LTrim$(Str$(cx)) + "," + LTrim$(Str$(cy)) + " "
FoundNext = 0
For k = 0 To 7
nd = (dir + k) And 7
NeighborDir nd, cx, cy, nx, ny
If nx >= 0 And nx < w And ny >= 0 And ny < h Then
If regionID(ny * w + nx) = region Then
cx = nx: cy = ny
dir = (nd + 6) And 7
FoundNext = -1
Exit For
End If
End If
Next k
If FoundNext = 0 Then Exit Do
If cx = bx And cy = by Then
If visitedStart Then Exit Do
visitedStart = -1
End If
Loop
' 3) region color -> hex string
c = col(region)
R = (_ShR(c, 16)) And 255
G = (_ShR(c, 8)) And 255
B = c And 255
hexColor$ = "#" + Right$("0" + Hex$(R), 2) + Right$("0" + Hex$(G), 2) + Right$("0" + Hex$(B), 2)
' 4) SAVE POLYGON - with border
'----------------------------------------------
GoTo noBorder
Print #ff, "<polygon points=" + Chr$(34) + outline$ + Chr$(34) + _
" fill=" + Chr$(34) + hexColor$ + Chr$(34) + _
" stroke=" + Chr$(34) + "#ffffff" + Chr$(34) + _
" stroke-width=" + Chr$(34) + "1" + Chr$(34) + "/>"
noBorder:
'without border
Print #ff, "<polygon points=" + Chr$(34) + outline$ + Chr$(34) + _
" fill=" + Chr$(34) + hexColor$ + Chr$(34) + _
" stroke=" + Chr$(34) + hexcolor$ + Chr$(34) + "/>" '_
'" stroke-width=" + Chr$(34) + "1" + Chr$(34) + "/>"
Next region
Print #ff, "</svg>"
Close #ff
End Sub
' is it Edge?
Function IsEdge%% (regionID() As Long, region As Long, x As Long, y As Long, w As Long, h As Long)
Dim i As Long: i = y * w + x
If x > 0 Then If regionID(i - 1) <> region Then IsEdge = -1: Exit Function
If x < w - 1 Then If regionID(i + 1) <> region Then IsEdge = -1: Exit Function
If y > 0 Then If regionID(i - w) <> region Then IsEdge = -1: Exit Function
If y < h - 1 Then If regionID(i + w) <> region Then IsEdge = -1: Exit Function
End Function
' find Neighbor direction
Sub NeighborDir (dir As Long, x As Long, y As Long, nx As Long, ny As Long)
Select Case dir
Case 0: nx = x + 1: ny = y
Case 1: nx = x + 1: ny = y + 1
Case 2: nx = x: ny = y + 1
Case 3: nx = x - 1: ny = y + 1
Case 4: nx = x - 1: ny = y
Case 5: nx = x - 1: ny = y - 1
Case 6: nx = x: ny = y - 1
Case 7: nx = x + 1: ny = y - 1
End Select
End Sub
![[Image: 6-800-600.jpg]](https://i.ibb.co/xQqygjx/6-800-600.jpg)
RE: Some random goofy stuff just for fun - bplus - 12-04-2025
@Petr What is reasonable resolution? I tried two images and both said subscript out of range on line 124 using the faster first code. 2nd image was smaller 700 X 700 or so, thats not small enough?
Does this have to be a jpg image? I just tried an 83 X 83 .PNG and still get subscript out of range!
RE: Some random goofy stuff just for fun - Petr - 12-04-2025
@bplus
First source code has fixed. The problem was caused by an odd number of pixels in width or height. I didn't even think of that, of course, because my image has an even number of pixels in both directions.
RE: Some random goofy stuff just for fun - bplus - 12-04-2025
+1 @Petr yep! that fixed it. Nice effect and is very fast!!!
Candy Corn Trees 4.png through Petr's Mosaic:
RE: Some random goofy stuff just for fun - Petr - 12-06-2025
Such a small thing. Try listening to the audio if you wrote it uncompressed to a lower bit depth than 8 bits:
Code: (Select All)
_Title "Listening to music in 2 to 8 bites"
Dim p As _MEM
s = _SndOpen("slunce.mp3") ' <---- change mp3 file here
p = _MemSound(s)
Dim As Long d
Dim As Integer R, L, B
B = 8 'emulate 3 bit sound...
Do Until _KeyHit = 27
d = 0
Do Until d >= p.SIZE
left = _MemGet(p, p.OFFSET + d, Single)
right = _MemGet(p, p.OFFSET + d + 4, Single)
Locate 4: Print "press 'q' or 'a' for change maximal amplitude value"
Locate 5: Print "Maximal amplitude value is:"; B; "this can be writed to"; _Ceil(Log(B) / Log(2)); "bits! "
c = B / 2
L = (c * left + c)
R = (c * right + c)
lmin = _Min(lmin, L): rmin = _Min(rmin, R)
lmax = _Max(lmax, L): rmax = _Max(rmax, R)
_SndRaw L / B, R / B
Do Until _SndRawLen < .1
Locate 2
Print "Left:"; L; "Right:"; R; " "
Print "Center (zero):"; c; "Lmin"; lmin; "Lmax"; lmax; "Rmin"; rmin; "Rmax"; rmax; " "
i$ = LTrim$(InKey$)
Select Case i$
Case "q": B = B - 1: lmin = 0: rmin = 0: lmax = 0: rmax = 0
Case "a": B = B + 1: lmin = 0: rmin = 0: lmax = 0: rmax = 0
End Select
B = _IIf(B < 2, 255, B)
B = _IIf(B > 255, 2, B)
Loop
d = d + 8
Loop
Loop