01-29-2026, 02:56 AM (This post was last modified: 01-29-2026, 04:21 AM by SMcNeill.)
I was hoping to use _MAPTRIANGLE and create a form of 3D text which might end up looking nice and being all rotatable and tiltable and scalable and such.
You can see where I was hoping to add a depth to my text and have maptriangle make it more of a 3d text, but I haven't got there yet.
BUT at this point I *can* rotate on the X/Y/Z axis with my text! And I can scale the text!
I just need to sorts out how to make my 2D text look more 3D, and at the moment I'm thunking my head against the keyboard and not getting the effect I was looking for. Peter, Unseen, MasterGy.... You guys are much better at this 3D stuff than I am. Any ideas on how to get that depth working with my text here?
Feel free to modify, expand, blow up this code as you will. I'll keep pondering and working with it, but hopefully one of you guys will have some insight into this. I remember ages ago that Galleon did a demo of mapping a 2D sprite of mario in a car and making it look pseduo-3d. Does anyone have that old demo saved anywhere? It seems to almost be what I'm looking to do here and might be a good place to start on getting to it do that final 3d enhancement.
Updated the above with what is an *almost* fully working version.
For those who are curious and aren't wanting to grab it and test it until I finish cleaning it up fully, here's an image of what the text it creates looks like:
Do
Cls
Line (512 - 5, 384)-(512 + 5, 384), _RGB(255, 0, 0)
Line (512, 384 - 5)-(512, 384 + 5), _RGB(255, 0, 0)
k = _KeyHit
Select Case k
Case 18432 'up
y = y - 1
Case 20480 'down
y = y + 1
Case 19200 'left
x = x - 1
Case 19712 'right
x = x + 1
Case Asc("A"), Asc("a")
z = z - 1
Case Asc("Z"), Asc("z")
z = z + 1
Case Asc("R"), Asc("r") 'reset
x = 0: y = 0: z = 0
Case 27, 32
System
End Select
Print x, y, z
Draw3DTextFull "Go team Steve!", font&, Yellow, 512, 384, y, x, z, 2, 10, 10, 1
_Display
Loop
System
Sub Draw3DTextFull (text$, fontHandle&, col~&, x!, y!, rotX!, rotY!, rotZ!, scale!, depth%, dirX!, dirY!)
Dim img&, w%, h%
Dim i%
' Measure text using the chosen font
_Font fontHandle&
w% = 600'_PrintWidth(text$)
h% = _FontHeight+100
' Render text into image using the SAME font
img& = _NewImage(w%, h%, 32)
_Dest img&
_Font fontHandle& ' <<< CRITICAL FIX
Cls , _RGBA(0, 0, 0, 0)
Color col~&, 0
' _PrintString (0, 0), text$
for i=1 to len(text$)
_PrintString (50+i*30, 20+20*sin(i*0.7)), mid$(text$,i,1)
next
dim as _unsigned long r,g,b,cc
_source img&
for yy=0 to _height(img)-1
for xx=0 to _width(img)-1
cc = point(xx, yy)
r = _red(cc)
g = _green(cc)
b = _blue(cc)
if r > 100 then
pset (xx, yy), _rgb(r ,g - 3*yy - 50*sin(xx/20),b)
end if
If you look at the source, you'll see you can use the keyboard to fairly easily manipulate the text here as much as you'd enjoy.
Note that this isn't TRUE 3d text as that's still beyond me to sort out. This takes 2D text and then shadows it to create a 3d effect. And it works well enough for whatever I'd ever actually use it for.
If our 3D gurus would want to take a shot at this, what I think we need is to:
1) map the text to a front face as is.
2) map that same text to a back face as is, but with a depth offset.
3) then calculate the points between those two faces to generate the solid depth so that it's a true 3d figure.
My brain understands the concepts of how to do it, but my 3d skills are lacking and that 3rd step above is one where I fail terribly at. For now, this is psedo-3d text and can be used to create a lot of those old WordArt styles, such as in the screenshots above.
True 3d text is still beyond poor Steve, but I'm moving forwards towards it step by step and year by year as I delve into learning this stuff as my free time and interests allow.
1) remove all edges of the 2D letter - this will give us the border
2) determine the center of the letter and from it use vectors to determine the positions of points on the border of the 2D letter
3) limit the obtained points to a smaller number simply via STEP
4) map the back wall first, then the connections between the upper and lower plates and finally the top side.
I once made that program with _Maptriangle and there I solved it completely differently. Simply, each pixel of the letter was a small cube! Then, if the 3D font had one color, you would have real 3D and you would not see the individual cubes.
Quote:I once made that program with _Maptriangle and there I solved it completely differently. Simply, each pixel of the letter was a small cube! Then, if the 3D font had one color, you would have real 3D and you would not see the individual cubes.
This was my first instinct but unless you uses a much higher resolution source text you'll always get the blocky edges.
In my head a neighbour system would maybe work along with a box blur or something and then you'd get better results as per Petrs step by step approach. Maybe its time for voxels? (Vector orientated pixels)
I'd fail at _Maptriangle variations but if want a GL one ill give it a crack but it (the backend) wont be in qb64!
01-29-2026, 08:47 PM (This post was last modified: 01-29-2026, 10:05 PM by Petr.)
Here’s a program that generates 3D text by extruding vector outlines and building a triangle mesh (front/back + side walls).
It’s a work in progress; beveling and better triangulation are next on the list.
Note: I used AI as a helper for brainstorming and refactoring, but the algorithm and debugging were done iteratively with real tests.
Code: (Select All)
Option _Explicit
' I worked with AI to complete this program. Just because I've written
' something with _MapTriangle doesn't mean I understand everything!
'
' Petr
'
'
'-------------------- WHAT THIS PROGRAM DOES --------------------
'
' Goal:
' Render a 3D "extruded" letter (or text) using _MAPTRIANGLE(3D).
' The 3D mesh is not built from vector outlines. Instead, we:
' 1) Render the glyph to a 32-bit software image with alpha.
' 2) Convert that alpha image into a binary mask (inside/outside).
' 3) Convert the mask into a set of merged rectangles:
' - Fill rectangles (front/back faces) using scanline merging.
' - Edge rectangles (left/right/top/bottom walls) using run-lengths.
' 4) Each rectangle becomes a quad => 2 triangles => drawn with _MAPTRIANGLE(3D).
'
' Why rectangles?
' Because scanline merging can compress thousands of pixels into
' a small number of rectangles. That makes triangulation trivial:
' each rectangle is always 2 triangles. No polygon triangulation needed.
'
' -------------------- QB64PE-SAFE WORKFLOW --------------------
'
' In QB64PE, hardware images (mode 33) act like OpenGL textures.
' The safe pattern used here is:
'
' - Do all "drawing/building" (printing glyph, building mask) in SOFTWARE images (mode 32).
' - Convert the small color textures to hardware textures using _COPYIMAGE(...,33).
' - Use hardware textures ONLY as sources for _MAPTRIANGLE / _PUTIMAGE.
' - Do NOT rely on _DEST to a hardware image for "rendering into it".
'
' Rendering strategy:
' - Screen is software (32).
' - _MAPTRIANGLE(3D) draws to the OpenGL layer over the screen.
' - To clear the OpenGL layer each frame:
' * Clear depth buffer: _DEPTHBUFFER _CLEAR
' * Draw a large background plane far behind the glyph (two triangles).
'
' -------------------- WHERE ROTATION IS SET --------------------
'
' Rotation angles (radians):
' ax, ay, az
' Angular velocities (radians per frame):
' daX, daY, daZ
'
' Each frame:
' ax = ax + daX
' ay = ay + daY
' az = az + daZ
'
' Rotation math happens in TransformPoint().
'
' -------------------- HOW TO RENDER A WHOLE TEXT --------------------
'
' There are TWO reasonable approaches:
'
' A) Extrude the whole string as one big mask (simple, heavier mesh):
' - Set glyph = "HELLO WORLD" (any string).
' - Call BuildGlyph glyph, ...
' - Result: one combined 3D object.
' - Tradeoff: large mask => more rectangles => more triangles.
'
' B) Extrude per character (best for long texts, reusable cache):
' - Prebuild each character into its own rectangle lists.
' - Render them in a loop with an X offset (advance).
' - You need per-character storage (arrays of Rect lists).
'
' PSEUDOCODE for approach B:
' For each char in text:
' BuildGlyph char, ...
' Copy the generated rect arrays into a glyph-cache structure
' During render:
' xOffset = 0
' For each char in text:
' Load rect arrays from cache
' DrawGlyph3D with tx = baseTx + xOffset
' xOffset = xOffset + advanceWidth(char)
'
' Advance width in pixels (for spacing) can be approximated by:
' advancePixels = PrintWidth(char) (measured with the same font setup)
' Then convert to world units using the same scaling as used in DrawGlyph3D:
' advanceWorld = advancePixels * baseScale * aspectCorr
'
' -------------------- QUALITY / PERFORMANCE KNOBS --------------------
'
' maskScale:
' Higher = smoother silhouette (less "stairs") but more rectangles/triangles.
' alphaThresh:
' Higher = tighter mask (can shrink thin antialiased edges).
' depth:
' Extrusion thickness along Z.
' tz:
' Camera translation along Z (must be < -1 for 3D view volume).
' baseScale:
' Overall size of the mesh in world units.
'
'============================================================
Type RectI
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
Type RectEdgeV
xEdge As Long
y1 As Long
y2 As Long
End Type
Type RectEdgeH
yEdge As Long
x1 As Long
x2 As Long
End Type
'---- shared glyph data ----
Dim Shared mw As Long, mh As Long
ReDim Shared mask(0, 0) As _Unsigned _Byte
ReDim Shared rectFill(0) As RectI
Dim Shared rectFillCnt As Long
ReDim Shared rectLeft(0) As RectEdgeV
Dim Shared rectLeftCnt As Long
ReDim Shared rectRight(0) As RectEdgeV
Dim Shared rectRightCnt As Long
ReDim Shared rectTop(0) As RectEdgeH
Dim Shared rectTopCnt As Long
ReDim Shared rectBot(0) As RectEdgeH
Dim Shared rectBotCnt As Long
'---- render / settings ----
Dim sw As Long, sh As Long
Dim texFrontSoft As Long, texSideSoft As Long, texBackSoft As Long, texBgSoft As Long
Dim texFrontHW As Long, texSideHW As Long, texBackHW As Long, texBgHW As Long
Dim glyph As String
Dim fontFile As String
Dim baseFontSize As Long
Dim maskScale As Long
Dim pad As Long
Dim alphaThresh As Long
Dim scaleMul As Single
Dim baseScale As Single
Dim depth As Single
Dim ax As Single, ay As Single, az As Single
Dim daX As Single, daY As Single, daZ As Single
Dim tx As Single, ty As Single, tz As Single
Dim aspectCorr As Single
Dim keyCode As Long
Dim showInfo As Long
' aspectCorr:
' _MAPTRIANGLE(3D) uses a normalized-ish view where X/Y are affected by aspect.
' A simple practical hack is to scale X by (sh/sw) so objects do not look stretched.
aspectCorr = CSng(sh) / CSng(sw)
' textures: SW -> HW (33)
' These are tiny 2x2 color textures used for shading:
' front = bright, side = mid, back = darker, bg = background plane.
texFrontSoft = _NewImage(2, 2, 32)
texSideSoft = _NewImage(2, 2, 32)
texBackSoft = _NewImage(2, 2, 32)
texBgSoft = _NewImage(2, 2, 32)
' ---- glyph setup ----
glyph = "Steve is amazing!" 'for protection, of course...
' (You can set glyph to a full string or just one character...
' glyph = "HELLO WORLD"
' Note: bigger string => bigger mask => more rectangles => slower.)
fontFile = "arial.ttf"
baseFontSize = 80
' maskScale:
' Main "anti-stair" control. Higher = smoother but more geometry.
maskScale = 80
pad = maskScale * 12
alphaThresh = 64
scaleMul = 1
depth = 0.60
' ---- rotation ----
ax = 0: ay = 0: az = 0
daX = 0.012
daY = 0.017
daZ = 0.008
' ---- camera translation ----
' tz must stay < -1.0 (z=-1 is the near plane center in QB64's 3D system).
tx = 0
ty = 0
tz = -4.0
' Clear depth buffer for 3D OpenGL layer
_DepthBuffer _Clear
' Clear the 3D color layer by drawing a big plane BEHIND the glyph.
' This effectively overwrites the previous frame's 3D color.
DrawBackgroundPlane texBgHW, tz - 60, CSng(sw) / CSng(sh)
' Draw glyph (3D triangles) to the OpenGL layer
DrawGlyph3D ax, ay, az, tx, ty, tz, baseScale, depth, aspectCorr, texFrontHW, texBackHW, texSideHW
If showInfo Then
DrawHud glyph, baseScale, depth, mw, mh, rectFillCnt, rectLeftCnt, rectRightCnt, rectTopCnt, rectBotCnt
End If
_Display
Loop
'cleanup
If texFrontHW Then _FreeImage texFrontHW
If texSideHW Then _FreeImage texSideHW
If texBackHW Then _FreeImage texBackHW
If texBgHW Then _FreeImage texBgHW
End
Sub MakeSolidTextureSoft (img As Long, r As Long, g As Long, b As Long)
' Creates a flat-color 2x2 texture in a software image.
' Later we convert it to a hardware texture via _CopyImage(...,33).
Dim oldDest As Long
oldDest = _Dest
_Dest img
Cls
Line (0, 0)-(_Width(img) - 1, _Height(img) - 1), _RGB32(r, g, b), BF
_Dest oldDest
End Sub
Sub DrawHud (glyph As String, sc As Single, dep As Single, w As Long, h As Long, cFill As Long, cL As Long, cR As Long, cT As Long, cB As Long)
' Debug info:
' - Mask size and rectangle counts tell you if the mask is sane.
' If FillRects is 1 and mask is huge => you likely got a "full mask" (alpha background problem).
Dim s1 As String, s2 As String, s3 As String
s1 = "Glyph:[" + glyph + "] zoom(+/-):" + LTrim$(Str$(sc)) + " depth([/]):" + LTrim$(Str$(dep))
s2 = "Mask:" + LTrim$(Str$(w)) + "x" + LTrim$(Str$(h)) + " FillRects:" + LTrim$(Str$(cFill))
s3 = "SideRuns L/R/T/B:" + LTrim$(Str$(cL)) + "/" + LTrim$(Str$(cR)) + "/" + LTrim$(Str$(cT)) + "/" + LTrim$(Str$(cB))
_PrintString (10, 10), s1
_PrintString (10, 28), s2
_PrintString (10, 46), s3
End Sub
Sub AutoFitScale (sc As Single, w As Long, h As Long, tz As Single)
' Very simple "auto scale" so the glyph fits into the view volume.
' Rough idea: projected size ? worldSize / -z
' We aim for about 1.4 in projected units (fits into [-1..1] with margin).
Dim maxDim As Long
Dim wantProj As Single
maxDim = w
If h > maxDim Then maxDim = h
If maxDim < 1 Then maxDim = 1
If tz > -1.1 Then tz = -1.1
wantProj = 1.4
sc = (wantProj * (-tz)) / CSng(maxDim)
End Sub
Sub BuildGlyph (glyph As String, fontFile As String, baseFontSize As Long, wantMaskScale As Long, pad As Long, alphaThresh As Long)
' Pipeline:
' 1) MakeMaskFromText: build binary mask from rendered alpha glyph
' 2) BuildFillRects: scanline merged rectangles for the front/back faces
' 3) Build*EdgeRects: run-length rectangles for the side walls
MakeMaskFromText glyph, fontFile, baseFontSize, wantMaskScale, pad, alphaThresh
BuildFillRects
BuildLeftEdgeRects
BuildRightEdgeRects
BuildTopEdgeRects
BuildBotEdgeRects
End Sub
Sub MakeMaskFromText (glyph As String, fontFile As String, baseFontSize As Long, wantMaskScale As Long, pad As Long, alphaThresh As Long)
' Creates a binary mask from the alpha channel of rendered text.
'
' Key detail:
' Background MUST have alpha = 0, otherwise the bounding box becomes the whole image
' and the mask becomes "all ones" => you only get huge rectangles.
'
' Steps:
' 1) Load font at baseFontSize*maskScale (supersampling in mask space).
' 2) Create 32-bit image, clear with RGBA(0,0,0,0).
' 3) PrintString the glyph in opaque white.
' 4) Find bounding box of pixels with alpha > 0.
' 5) Crop into mask array and threshold alpha.
Dim fontH As Long
Dim useScale As Long
Dim wText As Long, hText As Long
Dim img32 As Long
Dim x As Long, y As Long
Dim a As Long
Dim minX As Long, minY As Long, maxX As Long, maxY As Long
Dim x0 As Long, y0 As Long
Dim imgW As Long, imgH As Long
Dim oldFont As Long
Dim clearCol As _Unsigned Long
Dim textCol As _Unsigned Long
If _FileExists(fontFile) Then
fontH = _LoadFont(fontFile, baseFontSize * useScale)
If fontH = 0 Then useScale = 1
Else
useScale = 1
End If
If fontH <> 0 Then _Font fontH
wText = _PrintWidth(glyph)
hText = _FontHeight
If wText < 1 Then wText = 1
If hText < 1 Then hText = 1
imgW = wText + pad * 2
imgH = hText + pad * 2
img32 = _NewImage(imgW, imgH, 32)
_Dest img32
_DontBlend
Cls , clearCol
_Blend
Color textCol, clearCol
_PrintString (pad, pad), glyph
_Source img32
minX = imgW: minY = imgH
maxX = -1: maxY = -1
For y = 0 To imgH - 1
For x = 0 To imgW - 1
a = _Alpha32(Point(x, y))
If a > 0 Then
If x < minX Then minX = x
If y < minY Then minY = y
If x > maxX Then maxX = x
If y > maxY Then maxY = y
End If
Next x
Next y
For y = 0 To mh - 1
y0 = minY + y
For x = 0 To mw - 1
x0 = minX + x
a = _Alpha32(Point(x0, y0))
If a >= alphaThresh Then
mask(x, y) = 1
Else
mask(x, y) = 0
End If
Next x
Next y
End If
_Source 0
_Dest 0
If img32 Then _FreeImage img32
If fontH <> 0 Then _FreeFont fontH
_Font oldFont
End Sub
Sub BuildFillRects ()
' Builds rectangles covering the "inside" pixels of the mask.
'
' Algorithm:
' For each row y:
' 1) Find all runs of 1s => segments [xStart, xEnd)
' 2) Merge vertically: if a segment matches a previous open rectangle (same xStart/xEnd),
' extend that rectangle down by 1.
' 3) If an open rectangle does not continue, close it and store to rectFill.
'
' Result:
' rectFill[] describes the front/back faces as rectangles in mask pixel space.
Dim x As Long, y As Long
Dim segCnt As Long, openCnt As Long
Dim i As Long, j As Long
Dim hit As Long
Dim xStart As Long, xEnd As Long
' NOTE: these MUST be ARRAYS (so ReDim works)
Dim segX1 As Long, segX2 As Long
Dim openX1 As Long, openX2 As Long
Dim openY1 As Long, openY2 As Long
Dim openUsed As _Unsigned _Byte
rectFillCnt = 0
ReDim rectFill(0) As RectI
If mw < 1 Or mh < 1 Then Exit Sub
ReDim segX1(1 To mw) As Long
ReDim segX2(1 To mw) As Long
ReDim openX1(1 To mw) As Long
ReDim openX2(1 To mw) As Long
ReDim openY1(1 To mw) As Long
ReDim openY2(1 To mw) As Long
ReDim openUsed(1 To mw) As _Unsigned _Byte
openCnt = 0
For y = 0 To mh - 1
segCnt = 0
x = 0
Do While x < mw
If mask(x, y) <> 0 Then
xStart = x
x = x + 1
Do While x < mw
If mask(x, y) = 0 Then Exit Do
x = x + 1
Loop
xEnd = x
segCnt = segCnt + 1
segX1(segCnt) = xStart
segX2(segCnt) = xEnd
Else
x = x + 1
End If
Loop
For j = 1 To openCnt
openUsed(j) = 0
Next j
For i = 1 To segCnt
hit = 0
For j = 1 To openCnt
If openX1(j) = segX1(i) Then
If openX2(j) = segX2(i) Then
openY2(j) = y + 1
openUsed(j) = 1
hit = j
Exit For
End If
End If
Next j
If hit = 0 Then
openCnt = openCnt + 1
openX1(openCnt) = segX1(i)
openX2(openCnt) = segX2(i)
openY1(openCnt) = y
openY2(openCnt) = y + 1
openUsed(openCnt) = 1
End If
Next i
j = openCnt
Do While j >= 1
If openUsed(j) = 0 Then
rectFillCnt = rectFillCnt + 1
If rectFillCnt > UBound(rectFill) Then ReDim _Preserve rectFill(rectFillCnt + 2048) As RectI
rectFill(rectFillCnt).x1 = openX1(j)
rectFill(rectFillCnt).x2 = openX2(j)
rectFill(rectFillCnt).y1 = openY1(j)
rectFill(rectFillCnt).y2 = openY2(j)
openX1(j) = openX1(openCnt): openX2(j) = openX2(openCnt)
openY1(j) = openY1(openCnt): openY2(j) = openY2(openCnt)
openUsed(j) = openUsed(openCnt)
openCnt = openCnt - 1
End If
j = j - 1
Loop
Next y
For j = 1 To openCnt
rectFillCnt = rectFillCnt + 1
If rectFillCnt > UBound(rectFill) Then ReDim _Preserve rectFill(rectFillCnt + 2048) As RectI
rectFill(rectFillCnt).x1 = openX1(j)
rectFill(rectFillCnt).x2 = openX2(j)
rectFill(rectFillCnt).y1 = openY1(j)
rectFill(rectFillCnt).y2 = openY2(j)
Next j
If rectFillCnt < UBound(rectFill) Then ReDim _Preserve rectFill(rectFillCnt) As RectI
End Sub
Sub BuildLeftEdgeRects ()
' Left wall runs:
' A pixel (x,y) contributes to the LEFT wall if:
' mask(x,y)=1 and (x=0 or mask(x-1,y)=0)
' We then merge contiguous y runs for each xEdge into RectEdgeV entries.
Dim x As Long, y As Long
Dim yStart As Long
Dim edge1 As Long, edge2 As Long
rectLeftCnt = 0
ReDim rectLeft(0) As RectEdgeV
If mw < 1 Or mh < 1 Then Exit Sub
For x = 0 To mw - 1
y = 0
Do While y < mh
edge1 = 0
If mask(x, y) <> 0 Then
If x = 0 Then
edge1 = -1
Else
If mask(x - 1, y) = 0 Then edge1 = -1
End If
End If
If edge1 Then
yStart = y
y = y + 1
Do While y < mh
edge2 = 0
If mask(x, y) <> 0 Then
If x = 0 Then
edge2 = -1
Else
If mask(x - 1, y) = 0 Then edge2 = -1
End If
End If
If edge2 = 0 Then Exit Do
y = y + 1
Loop
rectLeftCnt = rectLeftCnt + 1
If rectLeftCnt > UBound(rectLeft) Then ReDim _Preserve rectLeft(rectLeftCnt + 2048) As RectEdgeV
rectLeft(rectLeftCnt).xEdge = x
rectLeft(rectLeftCnt).y1 = yStart
rectLeft(rectLeftCnt).y2 = y
Else
y = y + 1
End If
Loop
Next x
If rectLeftCnt < UBound(rectLeft) Then ReDim _Preserve rectLeft(rectLeftCnt) As RectEdgeV
End Sub
Sub BuildRightEdgeRects ()
' Right wall runs:
' mask(x,y)=1 and (x=mw-1 or mask(x+1,y)=0)
Dim x As Long, y As Long
Dim yStart As Long
Dim edge1 As Long, edge2 As Long
rectRightCnt = 0
ReDim rectRight(0) As RectEdgeV
If mw < 1 Or mh < 1 Then Exit Sub
For x = 0 To mw - 1
y = 0
Do While y < mh
edge1 = 0
If mask(x, y) <> 0 Then
If x = mw - 1 Then
edge1 = -1
Else
If mask(x + 1, y) = 0 Then edge1 = -1
End If
End If
If edge1 Then
yStart = y
y = y + 1
Do While y < mh
edge2 = 0
If mask(x, y) <> 0 Then
If x = mw - 1 Then
edge2 = -1
Else
If mask(x + 1, y) = 0 Then edge2 = -1
End If
End If
If edge2 = 0 Then Exit Do
y = y + 1
Loop
rectRightCnt = rectRightCnt + 1
If rectRightCnt > UBound(rectRight) Then ReDim _Preserve rectRight(rectRightCnt + 2048) As RectEdgeV
rectRight(rectRightCnt).xEdge = x + 1
rectRight(rectRightCnt).y1 = yStart
rectRight(rectRightCnt).y2 = y
Else
y = y + 1
End If
Loop
Next x
If rectRightCnt < UBound(rectRight) Then ReDim _Preserve rectRight(rectRightCnt) As RectEdgeV
End Sub
Sub BuildTopEdgeRects ()
' Top wall runs:
' mask(x,y)=1 and (y=0 or mask(x,y-1)=0)
Dim y As Long, x As Long
Dim xStart As Long
Dim edge1 As Long, edge2 As Long
rectTopCnt = 0
ReDim rectTop(0) As RectEdgeH
If mw < 1 Or mh < 1 Then Exit Sub
For y = 0 To mh - 1
x = 0
Do While x < mw
edge1 = 0
If mask(x, y) <> 0 Then
If y = 0 Then
edge1 = -1
Else
If mask(x, y - 1) = 0 Then edge1 = -1
End If
End If
If edge1 Then
xStart = x
x = x + 1
Do While x < mw
edge2 = 0
If mask(x, y) <> 0 Then
If y = 0 Then
edge2 = -1
Else
If mask(x, y - 1) = 0 Then edge2 = -1
End If
End If
If edge2 = 0 Then Exit Do
x = x + 1
Loop
rectTopCnt = rectTopCnt + 1
If rectTopCnt > UBound(rectTop) Then ReDim _Preserve rectTop(rectTopCnt + 2048) As RectEdgeH
rectTop(rectTopCnt).yEdge = y
rectTop(rectTopCnt).x1 = xStart
rectTop(rectTopCnt).x2 = x
Else
x = x + 1
End If
Loop
Next y
If rectTopCnt < UBound(rectTop) Then ReDim _Preserve rectTop(rectTopCnt) As RectEdgeH
End Sub
Sub BuildBotEdgeRects ()
' Bottom wall runs:
' mask(x,y)=1 and (y=mh-1 or mask(x,y+1)=0)
Dim y As Long, x As Long
Dim xStart As Long
Dim edge1 As Long, edge2 As Long
rectBotCnt = 0
ReDim rectBot(0) As RectEdgeH
If mw < 1 Or mh < 1 Then Exit Sub
For y = 0 To mh - 1
x = 0
Do While x < mw
edge1 = 0
If mask(x, y) <> 0 Then
If y = mh - 1 Then
edge1 = -1
Else
If mask(x, y + 1) = 0 Then edge1 = -1
End If
End If
If edge1 Then
xStart = x
x = x + 1
Do While x < mw
edge2 = 0
If mask(x, y) <> 0 Then
If y = mh - 1 Then
edge2 = -1
Else
If mask(x, y + 1) = 0 Then edge2 = -1
End If
End If
If edge2 = 0 Then Exit Do
x = x + 1
Loop
rectBotCnt = rectBotCnt + 1
If rectBotCnt > UBound(rectBot) Then ReDim _Preserve rectBot(rectBotCnt + 2048) As RectEdgeH
rectBot(rectBotCnt).yEdge = y + 1
rectBot(rectBotCnt).x1 = xStart
rectBot(rectBotCnt).x2 = x
Else
x = x + 1
End If
Loop
Next y
If rectBotCnt < UBound(rectBot) Then ReDim _Preserve rectBot(rectBotCnt) As RectEdgeH
End Sub
Sub DrawBackgroundPlane (tex As Long, zBg As Single, invAspect As Single)
' Clears the 3D OpenGL color layer by overdrawing it.
' We draw a large quad (2 triangles) far behind the glyph.
'
' zBg should be much smaller (more negative) than the glyph's tz,
' otherwise it may intersect/occlude the mesh.
Dim s As Single
Dim x0 As Single, y0 As Single, z0 As Single
Dim x1 As Single, y1 As Single, z1 As Single
Dim x2 As Single, y2 As Single, z2 As Single
Dim x3 As Single, y3 As Single, z3 As Single
Sub DrawGlyph3D (ax As Single, ay As Single, az As Single, tx As Single, ty As Single, tz As Single, sc As Single, dep As Single, aspectCorr As Single, texF As Long, texB As Long, texS As Long)
' Converts rectangle lists into 3D quads (front/back/sides), then draws them.
'
' Coordinate mapping:
' mask pixel space:
' x grows to the right
' y grows downwards
' world space used here:
' x grows to the right, y grows up
' we center the glyph around (0,0) by subtracting (mw/2, mh/2)
' z:
' front face at z=0
' back face at z=-dep
'
' aspectCorr:
' simple correction to avoid horizontal stretching.
Dim cosx As Single, sinx As Single
Dim cosy As Single, siny As Single
Dim cosz As Single, sinz As Single
Dim cx As Single, cy As Single
Dim i As Long
Dim xL As Single, xR As Single
Dim yT As Single, yB As Single
Dim zF As Single, zB As Single
' Left wall
For i = 1 To rectLeftCnt
xE = (CSng(rectLeft(i).xEdge) - cx) * sc * aspectCorr
yT = (cy - CSng(rectLeft(i).y1)) * sc
yB = (cy - CSng(rectLeft(i).y2)) * sc
DrawQuad3D texS, cosx, sinx, cosy, siny, cosz, sinz, tx, ty, tz, xE, yT, zF, xE, yT, zB, xE, yB, zB, xE, yB, zF
Next i
' Right wall
For i = 1 To rectRightCnt
xE = (CSng(rectRight(i).xEdge) - cx) * sc * aspectCorr
yT = (cy - CSng(rectRight(i).y1)) * sc
yB = (cy - CSng(rectRight(i).y2)) * sc
DrawQuad3D texS, cosx, sinx, cosy, siny, cosz, sinz, tx, ty, tz, xE, yT, zF, xE, yB, zF, xE, yB, zB, xE, yT, zB
Next i
' Top wall
For i = 1 To rectTopCnt
yE = (cy - CSng(rectTop(i).yEdge)) * sc
xL = (CSng(rectTop(i).x1) - cx) * sc * aspectCorr
xR = (CSng(rectTop(i).x2) - cx) * sc * aspectCorr
DrawQuad3D texS, cosx, sinx, cosy, siny, cosz, sinz, tx, ty, tz, xL, yE, zF, xR, yE, zF, xR, yE, zB, xL, yE, zB
Next i
' Bottom wall
For i = 1 To rectBotCnt
yE = (cy - CSng(rectBot(i).yEdge)) * sc
xL = (CSng(rectBot(i).x1) - cx) * sc * aspectCorr
xR = (CSng(rectBot(i).x2) - cx) * sc * aspectCorr
DrawQuad3D texS, cosx, sinx, cosy, siny, cosz, sinz, tx, ty, tz, xL, yE, zF, xL, yE, zB, xR, yE, zB, xR, yE, zF
Next i
End Sub
Sub DrawQuad3D (tex As Long, _
cosx As Single, sinx As Single, _
cosy As Single, siny As Single, _
cosz As Single, sinz As Single, _
tx As Single, ty As Single, tz As Single, _
x0 As Single, y0 As Single, z0 As Single, _
x1 As Single, y1 As Single, z1 As Single, _
x2 As Single, y2 As Single, z2 As Single, _
x3 As Single, y3 As Single, z3 As Single)
' Draws a quad as 2 triangles using _MAPTRIANGLE(3D).
' IMPORTANT:
' Do not overwrite input vertices (x0..z3) during transform!
' We write transformed vertices into vx0..vz3.
Dim vx0 As Single, vy0 As Single, vz0 As Single
Dim vx1 As Single, vy1 As Single, vz1 As Single
Dim vx2 As Single, vy2 As Single, vz2 As Single
Dim vx3 As Single, vy3 As Single, vz3 As Single
Sub TransformPoint (xIn As Single, yIn As Single, zIn As Single, cosx As Single, sinx As Single, cosy As Single, siny As Single, cosz As Single, sinz As Single, tx As Single, ty As Single, tz As Single, xRes As Single, yRes As Single, zRes As Single)
' Applies rotation around X, then Y, then Z, then translation.
' This is the only place that defines the rotation order.
Dim x1 As Single, y1 As Single, z1 As Single
Dim x2 As Single, y2 As Single, z2 As Single
Dim x3 As Single, y3 As Single, z3 As Single
(01-29-2026, 08:47 PM)Petr Wrote: Here’s a program that generates 3D text by extruding vector outlines and building a triangle mesh (front/back + side walls).
@grymmjack: yes all supported fonts, but is better writning full path to file, because in MakeMaskFromText is this solved and tested with _Fileexists, so if font path is not valid, program continue and use font 16. Change variable fontFile row 207.
![[Image: oghyu7d.png]](https://i.imgur.com/oghyu7d.png)
