01-07-2026, 06:40 PM
Code: (Select All)
Option _Explicit
'===============================================================
' Dice meshes + UV atlas + wire overlay
' High-level pipeline (data flow):
' 1) Build a convex polyhedron (primal) as:
' - vertex list v()
' - face list as index soup: pfStart(f), pfSize(f), pfIdx(...)
' 2) Fix face winding so outward normals are consistent (EnsureFacesOutward).
' 3) Normalize size: compute the minimum edge length and scale to DICE_EDGE.
' 4) Generate per-face UV polygons by projecting each real 3D face into a local
' 2D coordinate system (BuildUVForFaces). Each face lands into one atlas tile.
' This is crucial: UVs are derived from actual face geometry, so text warping
' is minimized compared to ad-hoc planar mapping.
' 5) Render the atlas texture (BuildAtlas):
' - purple vignette + deterministic micro-noise per tile
' - draw the exact UV polygon outline used for mapping
' - stamp number sprites into the tile (manual blit + optional rotation)
' 6) Render each die (RenderMesh):
' - apply Euler rotations and translation in 3D
' - painter-sort triangles by average Z (cheap visibility ordering)
' - call _MAPTRIANGLE to project textured triangles to the screen
'
'
' - QB64PE _MAPTRIANGLE consumes source UVs in *source image pixel coordinates*
' and destination vertices in *3D space*. QB64PE handles the final projection.
' - All custom drawing into images relies on _Dest/_Source global state. Any sub
' that changes _Dest or _Source should restore it (or at least be explicit).
' - Text stamping is done with nearest-neighbor sampling (PSet) to keep crisp
' glyph edges. The rotation step uses deterministic pixel rounding to avoid
' "striping" artifacts caused by bankers rounding (see StampSpriteRot).
'
' Key upgrades in this version:
' - UVs are generated by projecting each real 3D face to 2D (much less text warping).
' - Atlas tiles use a purple vignette + subtle noise (not flat color).
' - Numbers are assigned consistently (opposites: D8=9, D12=13, D20=21, D10=0..9 opposite=9).
' - D4 has 3 numbers per face, rotated toward corners (pyramid style).
' - Edges are drawn from the exact UV polygon used by mapping (edges stay crisp).
'===============================================================
Const PI! = 3.14159265358979323846!
Const DICE_EDGE! = .6!
Const D10_SQUASH! = 0.65!
'--- Screen
Const SW& = 800
Const SH& = 800
'--- Wire triangle texture (source triangle in pixels)
Const TEXW& = 256
Const TEXH& = 256
Const TSX1! = 32!: Const TSY1! = 224!
Const TSX2! = 224!: Const TSY2! = 224!
Const TSX3! = 128!: Const TSY3! = 32!
'--- UV atlas / tile settings
Const TILE& = 192
Const MARGIN& = 5
' Flip toggles inside each tile (set to -1 if needed)
' These flips are applied in *tile-local* UV space before adding tile origin.
Const FLIP_U& = 0
Const FLIP_V& = 0
'--- Die kind tags
Const DIE_D4& = 4
Const DIE_D6& = 6
Const DIE_D8& = 8
Const DIE_D10& = 10
Const DIE_D12& = 12
Const DIE_D20& = 20
' ---- die kind ids (index for selection; separate from number of sides)
Const KIND_D4& = 0
Const KIND_D6& = 1
Const KIND_D8& = 2
Const KIND_D10& = 3
Const KIND_D10T& = 4
Const KIND_D12& = 5
Const KIND_D20& = 6
Const TIPK! = 14.0!
Const EDGE_LIN! = 0.20!
Const EDGE_ANG! = 0.35!
Type Vertex3D
X As Single
Y As Single
Z As Single
End Type
Type Vertex2D
U As Single
V As Single
End Type
'3D colission detection
Type RigidBody
pos As Vertex3D
vel As Vertex3D
rot As Vertex3D
angVel As Vertex3D
radius As Single
half As Single ' polovina hrany krychle (jen pro D6)
sleep As Long
restFrames As Long ' poÄTAtadlo klidu pro usnutA
End Type
'--- Per-build shared data (atlas draw uses these)
' gFaceUV is the *authoritative* UV polygon per face (in atlas pixel space).
' The atlas builder draws outlines from the same UV vertices that _MAPTRIANGLE uses.
ReDim Shared gFaceLabel(0) As String
ReDim Shared gFaceTrip(0) As Long ' D4: 3 numbers per face
ReDim Shared gFaceUV(0) As Vertex2D
ReDim Shared gFaceUVStart(0) As Long
ReDim Shared gFaceUVSize(0) As Long
Dim Shared gFontBig As Long, gFontSmall As Long, gFontCorner As Long
Screen _NewImage(SW&, SH&, 32)
_Title "QB64PE Dice: projected UV atlas (purple/gold) + wire overlay"
InitFonts
'--- Per-die arrays (ALWAYS declared as arrays with (0))
' These are *triangle lists* (tri/uv aligned 1:1) to feed _MAPTRIANGLE directly.
ReDim Shared d4Tri(0) As Vertex3D: ReDim Shared d4UV(0) As Vertex2D: ReDim Shared d4Face(0) As Long: Dim Shared d4Tex As Long
ReDim Shared d6Tri(0) As Vertex3D: ReDim Shared d6UV(0) As Vertex2D: ReDim Shared d6Face(0) As Long: Dim Shared d6Tex As Long
ReDim Shared d8Tri(0) As Vertex3D: ReDim Shared d8UV(0) As Vertex2D: ReDim Shared d8Face(0) As Long: Dim Shared d8Tex As Long
ReDim Shared d10Tri(0) As Vertex3D: ReDim Shared d10UV(0) As Vertex2D: ReDim Shared d10Face(0) As Long: Dim Shared d10Tex As Long
'new cube
ReDim Shared d10TTri(0) As Vertex3D: ReDim Shared d10TUV(0) As Vertex2D: ReDim Shared d10TFace(0) As Long: Dim Shared d10tTex As Long
ReDim Shared d12Tri(0) As Vertex3D: ReDim Shared d12UV(0) As Vertex2D: ReDim Shared d12Face(0) As Long: Dim Shared d12Tex As Long
ReDim Shared d20Tri(0) As Vertex3D: ReDim Shared d20UV(0) As Vertex2D: ReDim Shared d20Face(0) As Long: Dim Shared d20Tex As Long
'desk
ReDim tableTri(0) As Vertex3D: ReDim tableUV(0) As Vertex2D: Dim tableTex As Long
'--- Textures
Dim wireTex As Long
'--- Build everything once
' Each BuildD* generates:
' - triangle list (tri)
' - per-vertex UVs in atlas pixel coordinates (uv)
' - atlas texture (atlasTex)
MakeWireTriTexture wireTex
BuildD4 d4Tri(), d4UV(), d4Face(), d4Tex
BuildD6 d6Tri(), d6UV(), d6Face(), d6Tex
BuildD8 d8Tri(), d8UV(), d8Face(), d8Tex
BuildD10 d10Tri(), d10UV(), d10Face(), d10Tex
'new cube
BuildD10Tens d10TTri(), d10TUV(), d10TFace(), d10tTex 'new
BuildD12 d12Tri(), d12UV(), d12Face(), d12Tex
BuildD20 d20Tri(), d20UV(), d20Face(), d20Tex
' --- fyzika: unikA?tnA vrcholy + normA?ly stěn (pro kaLldA? typ kostky)
ReDim d4Verts(0) As Vertex3D: ReDim d4FaceN(0) As Vertex3D
ReDim d6Verts(0) As Vertex3D: ReDim d6FaceN(0) As Vertex3D
ReDim d8Verts(0) As Vertex3D: ReDim d8FaceN(0) As Vertex3D
ReDim d10Verts(0) As Vertex3D: ReDim d10FaceN(0) As Vertex3D
ReDim d10TVerts(0) As Vertex3D: ReDim d10TFaceN(0) As Vertex3D
ReDim d12Verts(0) As Vertex3D: ReDim d12FaceN(0) As Vertex3D
ReDim d20Verts(0) As Vertex3D: ReDim d20FaceN(0) As Vertex3D
BuildUniqueVertsFromTri d4Tri(), d4Verts(): BuildFaceNormalsFromTri d4Tri(), d4Face(), 4, d4FaceN()
BuildUniqueVertsFromTri d6Tri(), d6Verts(): BuildFaceNormalsFromTri d6Tri(), d6Face(), 6, d6FaceN()
BuildUniqueVertsFromTri d8Tri(), d8Verts(): BuildFaceNormalsFromTri d8Tri(), d8Face(), 8, d8FaceN()
BuildUniqueVertsFromTri d10Tri(), d10Verts(): BuildFaceNormalsFromTri d10Tri(), d10Face(), 10, d10FaceN()
BuildUniqueVertsFromTri d10TTri(), d10TVerts(): BuildFaceNormalsFromTri d10TTri(), d10TFace(), 10, d10TFaceN()
BuildUniqueVertsFromTri d12Tri(), d12Verts(): BuildFaceNormalsFromTri d12Tri(), d12Face(), 12, d12FaceN()
BuildUniqueVertsFromTri d20Tri(), d20Verts(): BuildFaceNormalsFromTri d20Tri(), d20Face(), 20, d20FaceN()
'desk
BuildTable tableTri(), tableUV(), tableTex
Dim die As RigidBody
Dim curDieKind As Long
curDieKind = KIND_D6
SelectDieKind curDieKind, die
Const DT! = 1! / 60!
'--- Debug info
PrintMeshInfo "d4", d4Tri()
PrintMeshInfo "d6", d6Tri()
PrintMeshInfo "d8", d8Tri()
PrintMeshInfo "d10", d10Tri()
PrintMeshInfo "d10t", d10TTri()
PrintMeshInfo "d12", d12Tri()
PrintMeshInfo "d20", d20Tri()
_PrintString (8, 120), "Keys: 1-7=die SPACE=throw T=tex W=wire Q/A=zoom ESC=quit"
'--- Render controls
Dim As Long doTex, doWire, keys
Dim As Single t, zDepth
doTex = -1 'make textured model
doWire = 0 'make wired model
t = 1!
zDepth = -5!
'desk
Dim Shared tableX As Single, tableY As Single, tableZ As Single
tableX = 0!
tableY = -2.2! ' STEJN hodnota jako v RenderMesh stolu
tableZ = 0!
Do
_Limit 60
Cls , _RGB32(10, 10, 10)
keys = _KeyHit
If keys = 27 Then Exit Do
If keys = Asc("T") Or keys = Asc("t") Then doTex = Not doTex
If keys = Asc("W") Or keys = Asc("w") Then doWire = Not doWire
' 1..7 = volba typu kostky (fyzika je stejnA?, jen jinA? mesh)
If keys = Asc("1") Then curDieKind = KIND_D4: SelectDieKind curDieKind, die
If keys = Asc("2") Then curDieKind = KIND_D6: SelectDieKind curDieKind, die
If keys = Asc("3") Then curDieKind = KIND_D8: SelectDieKind curDieKind, die
If keys = Asc("4") Then curDieKind = KIND_D10: SelectDieKind curDieKind, die
If keys = Asc("5") Then curDieKind = KIND_D10T: SelectDieKind curDieKind, die
If keys = Asc("6") Then curDieKind = KIND_D12: SelectDieKind curDieKind, die
If keys = Asc("7") Then curDieKind = KIND_D20: SelectDieKind curDieKind, die
If _KeyDown(Asc("Q")) Or keys = Asc("q") Then zDepth = zDepth + 0.08!
If _KeyDown(Asc("A")) Or keys = Asc("a") Then zDepth = zDepth - 0.08!
If zDepth > -1.2! Then zDepth = -1.2!
If zDepth < -30! Then zDepth = -30!
' SPACE = znovu hodit
If keys = 32 Then ResetThrow die, 0!, 1.6!, 0!
'detection colission
'StepBodyVsTable die, DT!, tableY 'sphere
While _MouseInput
zDepth = zDepth + _MouseWheel / 10
Wend
Const SUBSTEPS& = 4
Dim s As Long
For s = 1 To SUBSTEPS&
Select Case curDieKind
Case KIND_D4
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d4Verts(), d4FaceN()
Case KIND_D6
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d6Verts(), d6FaceN()
Case KIND_D8
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d8Verts(), d8FaceN()
Case KIND_D10
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d10Verts(), d10FaceN()
Case KIND_D10T
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d10TVerts(), d10TFaceN()
Case KIND_D12
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d12Verts(), d12FaceN()
Case Else
StepDieVsTableGame die, DT / SUBSTEPS&, tableY, d20Verts(), d20FaceN()
End Select
Next
'StepCubeVsTableStable die, DT!, tableY 'd6
'first: desk (background)
' stul kresli prvni (pozadi)
' RenderMesh tableTri(), tableUV(), tableTex, wireTex, doTex, doWire, tableX, tableY, zDepth + tableZ, 0!, 0!, 0!
' stul jako pozadi
RenderMesh tableTri(), tableUV(), tableTex, wireTex, doTex, doWire, tableX, tableY, zDepth + tableZ, 0!, 0!, 0!
' jedna kostka podle fyziky
ClampToTableTopRect die, 4.0!, 2.5!
Select Case curDieKind
Case KIND_D4
RenderMesh d4Tri(), d4UV(), d4Tex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
Case KIND_D6
RenderMesh d6Tri(), d6UV(), d6Tex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
Case KIND_D8
RenderMesh d8Tri(), d8UV(), d8Tex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
Case KIND_D10
RenderMesh d10Tri(), d10UV(), d10Tex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
Case KIND_D10T
RenderMesh d10TTri(), d10TUV(), d10tTex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
Case KIND_D12
RenderMesh d12Tri(), d12UV(), d12Tex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
Case Else
RenderMesh d20Tri(), d20UV(), d20Tex, wireTex, doTex, doWire, die.pos.X, die.pos.Y, zDepth + die.pos.Z, die.rot.X, die.rot.Y, die.rot.Z
End Select
' RenderMesh d4Tri(), d4UV(), d4Tex, wireTex, doTex, doWire, -2.2!, 2.2!, zDepth, t * 0.8!, t * 1.0!, t * 0.6!
' RenderMesh d6Tri(), d6UV(), d6Tex, wireTex, doTex, doWire, 0.0!, 2.2!, zDepth, t * 0.7!, t * 0.9!, t * 0.5!
' RenderMesh d8Tri(), d8UV(), d8Tex, wireTex, doTex, doWire, 2.2!, 2.2!, zDepth, t * 0.9!, t * 0.6!, t * 0.8!
' RenderMesh d10Tri(), d10UV(), d10Tex, wireTex, doTex, doWire, -2.2!, -0.2!, zDepth, t * 0.6!, t * 1.1!, t * 0.7!
' RenderMesh d12Tri(), d12UV(), d12Tex, wireTex, doTex, doWire, 0.0!, 0, zDepth, t * 0.5!, t * 0.8!, t * 1.0!
' RenderMesh d20Tri(), d20UV(), d20Tex, wireTex, doTex, doWire, 2.2!, 0, zDepth, t * 1.0!, t * 0.7!, t * 0.6!
' RenderMesh d10TTri(), d10TUV(), d10tTex, wireTex, doTex, doWire, 0, -2.2, zDepth, t * 0.65!, t * 0.95!, t * 0.75!
'_PrintString (8, 8), "T=texture: " + Str$(doTex) + " W=wire: " + Str$(doWire) + " zDepth=" + Str$(zDepth)
_PrintString (8, 8), "Keys: 1-7=die SPACE=throw T=tex W=wire Q/A=zoom ESC=quit"
_Display
t = t + 0.02!
Loop
'--- Cleanup
_FreeImage tableTex
_FreeImage wireTex
_FreeImage d4Tex: _FreeImage d6Tex: _FreeImage d8Tex
_FreeImage d10Tex: _FreeImage d12Tex: _FreeImage d20Tex
_FreeImage d10tTex 'new
If gFontBig <> 0 Then _FreeFont gFontBig
If gFontSmall <> 0 Then _FreeFont gFontSmall
If gFontCorner <> 0 Then _FreeFont gFontCorner
End
'===============================================================
' IMPLEMENTATION
'===============================================================
'---------------------------------------------------------------
' PrintMeshInfo
' tri() is a flat triangle list: 3 vertices per triangle.
' This prints counts to verify builders generated sane geometry.
'---------------------------------------------------------------
Sub PrintMeshInfo (jmeno As String, tri() As Vertex3D)
Dim As Long vCount, tCount
vCount = UBound(tri) - LBound(tri) + 1
tCount = vCount \ 3
Print jmeno; " vertices="; vCount; " triangles="; tCount
End Sub
'---------------------------------------------------------------
' VDot / VLen
' Minimal vector algebra used across:
' - normals
' - opposite-face pairing (dot product)
' - basis construction and projection
'---------------------------------------------------------------
Function VDot! (a As Vertex3D, b As Vertex3D)
VDot! = a.X * b.X + a.Y * b.Y + a.Z * b.Z
End Function
Function VLen! (a As Vertex3D)
VLen! = Sqr(a.X * a.X + a.Y * a.Y + a.Z * a.Z)
End Function
'---------------------------------------------------------------
' VSet / VSub / VScale / VCross / VNorm
' Utility ops written as SUBs to avoid temporary allocations.
' VNorm guards zero-length vectors (degenerate geometry).
'---------------------------------------------------------------
Sub VSet (r As Vertex3D, x As Single, y As Single, z As Single)
r.X = x: r.Y = y: r.Z = z
End Sub
Sub VSub (a As Vertex3D, b As Vertex3D, r As Vertex3D)
r.X = a.X - b.X
r.Y = a.Y - b.Y
r.Z = a.Z - b.Z
End Sub
Sub VScale (a As Vertex3D, s As Single, r As Vertex3D)
r.X = a.X * s
r.Y = a.Y * s
r.Z = a.Z * s
End Sub
Sub VCross (a As Vertex3D, b As Vertex3D, r As Vertex3D)
r.X = a.Y * b.Z - a.Z * b.Y
r.Y = a.Z * b.X - a.X * b.Z
r.Z = a.X * b.Y - a.Y * b.X
End Sub
Sub VNorm (a As Vertex3D, r As Vertex3D)
Dim As Single l
l = VLen!(a)
If l = 0! Then
r.X = 0!: r.Y = 0!: r.Z = 0!
Else
r.X = a.X / l
r.Y = a.Y / l
r.Z = a.Z / l
End If
End Sub
'---------------------------------------------------------------
' ReverseFace
' Reverses the index order of a polygonal face in-place.
' Used to flip winding when a computed normal points inward.
'---------------------------------------------------------------
Sub ReverseFace (pfIdx() As Long, startOff As Long, cnt As Long)
Dim As Long i, j, t
i = 0: j = cnt - 1
While i < j
t = pfIdx(startOff + i)
pfIdx(startOff + i) = pfIdx(startOff + j)
pfIdx(startOff + j) = t
i = i + 1
j = j - 1
Wend
End Sub
'---------------------------------------------------------------
' EnsureFacesOutward
' Enforces consistent outward winding for a convex polyhedron.
'
' Mechanism:
' - compute a face normal nn from first 3 vertices
' - compute face centroid cen (average of its vertices)
' - for origin-centered convex solids, dot(nn, cen) > 0 indicates
' that nn points outward (roughly away from origin)
' - if dot < 0, flip the face index order
'
' Assumption: the polyhedron is convex and roughly centered near origin.
' If you later support off-center meshes, you'd use plane tests vs. global
' poly centroid instead of origin-based sign.
'---------------------------------------------------------------
Sub EnsureFacesOutward (v() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long)
Dim As Long f, k, s, n
Dim As Single d
Dim a As Vertex3D, b As Vertex3D, c As Vertex3D
Dim e1 As Vertex3D, e2 As Vertex3D, nn As Vertex3D
Dim cen As Vertex3D, tmp As Vertex3D
For f = LBound(pfStart) To UBound(pfStart)
s = pfStart(f): n = pfSize(f)
If n >= 3 Then
a = v(pfIdx(s + 0))
b = v(pfIdx(s + 1))
c = v(pfIdx(s + 2))
VSub b, a, e1
VSub c, a, e2
VCross e1, e2, nn
cen.X = 0!: cen.Y = 0!: cen.Z = 0!
For k = 0 To n - 1
tmp = v(pfIdx(s + k))
cen.X = cen.X + tmp.X
cen.Y = cen.Y + tmp.Y
cen.Z = cen.Z + tmp.Z
Next
cen.X = cen.X / n
cen.Y = cen.Y / n
cen.Z = cen.Z / n
d = VDot!(nn, cen)
If d < 0! Then ReverseFace pfIdx(), s, n
End If
Next
End Sub
'---------------------------------------------------------------
' MinEdgeLen
' Scans all polygon edges and returns the shortest edge length.
' This is used to compute a uniform scaling factor so that the
' smallest edge becomes DICE_EDGE (good for consistent on-screen size).
'---------------------------------------------------------------
Function MinEdgeLen! (v() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long)
Dim As Long f, k, s, n, i0, i1
Dim As Single ax, ay, az, bx, by, bz, dx, dy, dz, dist, best
best = 1E+30
For f = LBound(pfStart) To UBound(pfStart)
s = pfStart(f): n = pfSize(f)
If n >= 2 Then
For k = 0 To n - 1
i0 = pfIdx(s + k)
i1 = pfIdx(s + ((k + 1) Mod n))
ax = v(i0).X: ay = v(i0).Y: az = v(i0).Z
bx = v(i1).X: by = v(i1).Y: bz = v(i1).Z
dx = ax - bx: dy = ay - by: dz = az - bz
dist = Sqr(dx * dx + dy * dy + dz * dz)
If dist > 0! And dist < best Then best = dist
Next
End If
Next
MinEdgeLen! = best
End Function
'---------------------------------------------------------------
' ScaleVertices
' Uniform scale around origin. Assumes model is centered already.
'---------------------------------------------------------------
Sub ScaleVertices (v() As Vertex3D, s As Single)
Dim As Long i
For i = LBound(v) To UBound(v)
v(i).X = v(i).X * s
v(i).Y = v(i).Y * s
v(i).Z = v(i).Z * s
Next
End Sub
'---------------------------------------------------------------
' BuildDual
' Builds the polar dual of a convex polyhedron.
'
' Inputs (primal):
' pv() : primal vertices
' pfStart() : face start offsets into pfIdx
' pfSize() : vertex count per face
' pfIdx() : concatenated vertex indices for all faces
'
' Outputs (dual):
' dv() : dual vertices (one per primal face)
' dfStart() : dual faces (one per primal vertex) start offsets
' dfSize() : dual face vertex counts
' dfIdx() : indices into dv() forming each dual face
'
' Math sketch:
' Each primal face defines a plane: nx = d (with outward unit normal n).
' The polar dual vertex for that face is: v* = n / d.
' This yields a dual polyhedron where adjacency is swapped:
' primal faces <-> dual vertices
' primal vertices <-> dual faces
'
' Implementation details:
' 1) Compute dv(f) from face normal and plane distance.
' 2) Build incidence lists: for each primal vertex, list incident primal faces.
' 3) Sort those incident faces cyclically around the primal vertex so that the
' resulting dual face is a proper polygon (not a scrambled loop).
' Sorting uses:
' - nrm = normalized primal vertex direction as local "axis"
' - pick a refVec not parallel to nrm
' - build tangent basis (u, vtan) in the plane orthogonal to nrm
' - project dual vertices into that basis and sort by atan2.
'
' Notes:
' - This assumes the primal is convex and (roughly) origin-centered.
' - Numerical stability hinges on consistent outward normals (call EnsureFacesOutward first).
'---------------------------------------------------------------
Sub BuildDual (pv() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long, dv() As Vertex3D, dfStart() As Long, dfSize() As Long, dfIdx() As Long)
Dim As Long fCount, vCount
Dim As Long f, i, k, s, n, total, cur, m, p, q
Dim As Single d, dp, tA
Dim a As Vertex3D, b As Vertex3D, c As Vertex3D
Dim e1 As Vertex3D, e2 As Vertex3D, nn As Vertex3D, nnUnit As Vertex3D
Dim cen As Vertex3D, tmp As Vertex3D
Dim nrm As Vertex3D, refVec As Vertex3D, u As Vertex3D, vtan As Vertex3D
Dim proj As Vertex3D, proj2 As Vertex3D, tmp2 As Vertex3D
Dim incCount(0) As Long
Dim ang(0) As Single
Dim ids(0) As Long
vCount = UBound(pv) - LBound(pv) + 1
fCount = UBound(pfStart) - LBound(pfStart) + 1
ReDim dv(0 To fCount - 1) As Vertex3D
' 1) Dual vertices: one per primal face
For f = 0 To fCount - 1
s = pfStart(f): n = pfSize(f)
a = pv(pfIdx(s + 0))
b = pv(pfIdx(s + 1))
c = pv(pfIdx(s + 2))
VSub b, a, e1
VSub c, a, e2
VCross e1, e2, nn
VNorm nn, nnUnit
cen.X = 0!: cen.Y = 0!: cen.Z = 0!
For k = 0 To n - 1
tmp = pv(pfIdx(s + k))
cen.X = cen.X + tmp.X
cen.Y = cen.Y + tmp.Y
cen.Z = cen.Z + tmp.Z
Next
cen.X = cen.X / n
cen.Y = cen.Y / n
cen.Z = cen.Z / n
If VDot!(nnUnit, cen) < 0! Then
nnUnit.X = -nnUnit.X
nnUnit.Y = -nnUnit.Y
nnUnit.Z = -nnUnit.Z
End If
d = VDot!(nnUnit, a)
If d = 0! Then d = 1E-9
dv(f).X = nnUnit.X / d
dv(f).Y = nnUnit.Y / d
dv(f).Z = nnUnit.Z / d
Next
' 2) Incident face lists per primal vertex
ReDim incCount(0 To vCount - 1) As Long
For f = 0 To fCount - 1
s = pfStart(f): n = pfSize(f)
For k = 0 To n - 1
i = pfIdx(s + k)
incCount(i) = incCount(i) + 1
Next
Next
ReDim dfStart(0 To vCount - 1) As Long
ReDim dfSize(0 To vCount - 1) As Long
total = 0
For i = 0 To vCount - 1
dfStart(i) = total
dfSize(i) = incCount(i)
total = total + incCount(i)
incCount(i) = 0
Next
ReDim dfIdx(0 To total - 1) As Long
For f = 0 To fCount - 1
s = pfStart(f): n = pfSize(f)
For k = 0 To n - 1
i = pfIdx(s + k)
cur = dfStart(i) + incCount(i)
dfIdx(cur) = f
incCount(i) = incCount(i) + 1
Next
Next
' 3) Order each dual face cyclically around primal vertex
For i = 0 To vCount - 1
s = dfStart(i): m = dfSize(i)
If m >= 3 Then
VNorm pv(i), nrm
VSet refVec, 0!, 1!, 0!
dp = Abs(VDot!(nrm, refVec))
If dp > .9 Then VSet refVec, 1!, 0!, 0!
VCross refVec, nrm, tmp2
VNorm tmp2, u
VCross nrm, u, vtan
ReDim ang(0 To m - 1) As Single
ReDim ids(0 To m - 1) As Long
For k = 0 To m - 1
ids(k) = dfIdx(s + k)
proj = dv(ids(k))
dp = VDot!(proj, nrm)
VScale nrm, dp, tmp2
VSub proj, tmp2, proj2
ang(k) = _Atan2(VDot!(proj2, vtan), VDot!(proj2, u))
Next
For p = 0 To m - 2
For q = 0 To m - 2 - p
If ang(q) > ang(q + 1) Then
tA = ang(q): ang(q) = ang(q + 1): ang(q + 1) = tA
cur = ids(q): ids(q) = ids(q + 1): ids(q + 1) = cur
End If
Next
Next
For k = 0 To m - 1
dfIdx(s + k) = ids(k)
Next
End If
Next
End Sub
'---------------------------------------------------------------
' SquashLongestAxis
' Non-uniform scale along the longest AABB axis.
' Used to morph a "raw" dual into the characteristic D10 silhouette.
' This is a stylistic/shape correction step, not a mathematically pure dual.
'---------------------------------------------------------------
Sub SquashLongestAxis (v() As Vertex3D, squash As Single)
If squash = 1! Or squash <= 0! Then Exit Sub
Dim i As Long
Dim minX!, maxX!, minY!, maxY!, minZ!, maxZ!
minX! = v(LBound(v)).X: maxX! = minX!
minY! = v(LBound(v)).Y: maxY! = minY!
minZ! = v(LBound(v)).Z: maxZ! = minZ!
For i = LBound(v) To UBound(v)
If v(i).X < minX! Then minX! = v(i).X
If v(i).X > maxX! Then maxX! = v(i).X
If v(i).Y < minY! Then minY! = v(i).Y
If v(i).Y > maxY! Then maxY! = v(i).Y
If v(i).Z < minZ! Then minZ! = v(i).Z
If v(i).Z > maxZ! Then maxZ! = v(i).Z
Next
Dim rx!, ry!, rz!
rx! = maxX! - minX!
ry! = maxY! - minY!
rz! = maxZ! - minZ!
If rx! >= ry! And rx! >= rz! Then
For i = LBound(v) To UBound(v): v(i).X = v(i).X * squash: Next
ElseIf ry! >= rz! Then
For i = LBound(v) To UBound(v): v(i).Y = v(i).Y * squash: Next
Else
For i = LBound(v) To UBound(v): v(i).Z = v(i).Z * squash: Next
End If
End Sub
'===============================================================
' FONTS + TEXT SPRITES
'===============================================================
'---------------------------------------------------------------
' InitFonts
' Loads three font sizes used by atlas stamping.
' Fonts are loaded once and cached globally (gFont*).
' Failure fallback chains try several common Windows fonts.
'---------------------------------------------------------------
Sub InitFonts
Dim f As Long
If gFontBig <> 0 Then Exit Sub
f = _LoadFont("C:\Windows\Fonts\arialbd.ttf", 56)
If f = 0 Then f = _LoadFont("C:\Windows\Fonts\arial.ttf", 56)
If f = 0 Then f = _LoadFont("arialbd.ttf", 56)
If f = 0 Then f = _LoadFont("verdana.ttf", 56)
gFontBig = f
f = 0
f = _LoadFont("C:\Windows\Fonts\arialbd.ttf", 44)
If f = 0 Then f = _LoadFont("C:\Windows\Fonts\arial.ttf", 44)
If f = 0 Then f = _LoadFont("arialbd.ttf", 44)
If f = 0 Then f = _LoadFont("verdana.ttf", 44)
gFontSmall = f
f = 0
f = _LoadFont("C:\Windows\Fonts\arialbd.ttf", 30)
If f = 0 Then f = _LoadFont("C:\Windows\Fonts\arial.ttf", 30)
If f = 0 Then f = _LoadFont("arialbd.ttf", 30)
If f = 0 Then f = _LoadFont("verdana.ttf", 30)
gFontCorner = f
End Sub
'---------------------------------------------------------------
' PrepareLabelsD4
' D4 convention here: each triangular face carries three numbers, one at each corner,
' matching classic tetrahedral dice where the "result" is read at a vertex.
' gFaceTrip stores 3 values per face (faceCount * 3).
'---------------------------------------------------------------
Sub PrepareLabelsD4 (pfStart() As Long, pfSize() As Long, pfIdx() As Long)
ReDim gFaceLabel(0 To 3) As String
ReDim gFaceTrip(0 To 4 * 3 - 1) As Long
Dim f As Long, k As Long, st As Long
Dim vertVal(0 To 3) As Long
vertVal(0) = 1: vertVal(1) = 2: vertVal(2) = 3: vertVal(3) = 4
For f = 0 To 3
st = pfStart(f)
For k = 0 To 2
gFaceTrip(f * 3 + k) = vertVal(pfIdx(st + k))
Next
gFaceLabel(f) = ""
Next
End Sub
'---------------------------------------------------------------
' PrepareLabelsD6
' Assigns labels using face normal extremes along axes.
' This yields stable "standard" cube numbering independent of face order.
' Mapping chosen:
' +Z=1, -Z=6, +Y=2, -Y=5, +X=3, -X=4
'---------------------------------------------------------------
Sub PrepareLabelsD6 (v() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long)
ReDim gFaceLabel(0 To 5) As String
ReDim gFaceTrip(0) As Long
Dim nrm(0) As Vertex3D
ComputeFaceNormals v(), pfStart(), pfSize(), pfIdx(), nrm()
Dim f As Long
Dim fZp As Long, fZn As Long, fYp As Long, fYn As Long, fXp As Long, fXn As Long
Dim maxZ As Single, minZ As Single, maxY As Single, minY As Single, maxX As Single, minX As Single
maxZ = -1E+30: minZ = 1E+30
maxY = -1E+30: minY = 1E+30
maxX = -1E+30: minX = 1E+30
For f = 0 To 5
If nrm(f).Z > maxZ Then maxZ = nrm(f).Z: fZp = f
If nrm(f).Z < minZ Then minZ = nrm(f).Z: fZn = f
If nrm(f).Y > maxY Then maxY = nrm(f).Y: fYp = f
If nrm(f).Y < minY Then minY = nrm(f).Y: fYn = f
If nrm(f).X > maxX Then maxX = nrm(f).X: fXp = f
If nrm(f).X < minX Then minX = nrm(f).X: fXn = f
Next
' Standard mapping:
' +Z=1, -Z=6, +Y=2, -Y=5, +X=3, -X=4
gFaceLabel(fZp) = "1"
gFaceLabel(fZn) = "6"
gFaceLabel(fYp) = "2"
gFaceLabel(fYn) = "5"
gFaceLabel(fXp) = "3"
gFaceLabel(fXn) = "4"
End Sub
'---------------------------------------------------------------
' PrepareLabelsPairs
' Generic labeling for convex dice where faces come in opposite pairs.
'
' Steps:
' 1) Compute face normals.
' 2) Pair faces by finding, for each face, the other face with the most negative dot product.
' (closest to antiparallel => opposite side of convex polyhedron)
' 3) Choose "top" faces from each opposite pair (FaceGreater by Z/Y/X) to impose a stable ordering.
' 4) Assign numbers so that opposite faces sum to sumConst:
' label(ft) = baseVal + i
' label(fo) = sumConst - label(ft)
'
' This yields standard dice opposites:
' D8 opposite sum 9
' D12 opposite sum 13
' D20 opposite sum 21
' D10 here uses sumConst=9 with baseVal=0 (0..9 mapping convention)
'---------------------------------------------------------------
Sub PrepareLabelsPairs (v() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long, baseVal As Long, sumConst As Long)
Dim faceCount As Long, f As Long, j As Long
faceCount = UBound(pfStart) - LBound(pfStart) + 1
ReDim gFaceLabel(0 To faceCount - 1) As String
ReDim gFaceTrip(0) As Long
Dim nrm(0) As Vertex3D
ComputeFaceNormals v(), pfStart(), pfSize(), pfIdx(), nrm()
Dim pair(0) As Long
ReDim pair(0 To faceCount - 1) As Long
FindOppPairs nrm(), pair()
Dim pairs As Long
pairs = faceCount \ 2
Dim topFaces(0) As Long
ReDim topFaces(0 To pairs - 1) As Long
Dim idx As Long
idx = 0
For f = 0 To faceCount - 1
j = pair(f)
If j >= 0 Then
If f < j Then
If FaceGreater&(nrm(f), nrm(j)) Then
topFaces(idx) = f
Else
topFaces(idx) = j
End If
idx = idx + 1
End If
End If
Next
' sort topFaces by normal (z,y,x desc)
Dim p As Long, q As Long, t As Long
For p = 0 To pairs - 2
For q = 0 To pairs - 2 - p
If FaceGreater&(nrm(topFaces(q + 1)), nrm(topFaces(q))) Then
t = topFaces(q): topFaces(q) = topFaces(q + 1): topFaces(q + 1) = t
End If
Next
Next
Dim i As Long
For i = 0 To pairs - 1
Dim value As Long, ft As Long, fo As Long
value = baseVal + i
ft = topFaces(i)
fo = pair(ft)
gFaceLabel(ft) = LTrim$(Str$(value))
gFaceLabel(fo) = LTrim$(Str$(sumConst - value))
Next
End Sub
'---------------------------------------------------------------
' ComputeFaceNormals
' Computes a unit normal per face from the first triangle of the polygon.
' This assumes each face is planar (true for convex polyhedra here).
'---------------------------------------------------------------
Sub ComputeFaceNormals (v() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long, nrm() As Vertex3D)
Dim faceCount As Long, f As Long, st As Long
Dim a As Vertex3D, b As Vertex3D, c As Vertex3D
Dim e1 As Vertex3D, e2 As Vertex3D, nn As Vertex3D
faceCount = UBound(pfStart) - LBound(pfStart) + 1
ReDim nrm(0 To faceCount - 1) As Vertex3D
For f = 0 To faceCount - 1
st = pfStart(f)
a = v(pfIdx(st + 0))
b = v(pfIdx(st + 1))
c = v(pfIdx(st + 2))
VSub b, a, e1
VSub c, a, e2
VCross e1, e2, nn
VNorm nn, nrm(f)
Next
End Sub
'---------------------------------------------------------------
' FindOppPairs
' Builds an opposite-face pairing by greedy matching on dot product:
' pick the unused face j that minimizes dot(n_i, n_j).
' For convex polyhedra with well-distributed face normals, the most negative dot
' is the best opposite candidate.
'
' Note: This is not a full minimum-weight matching; it's greedy but works reliably
' for these platonic/archimedean-like solids.
'---------------------------------------------------------------
Sub FindOppPairs (nrm() As Vertex3D, pair() As Long)
Dim n As Long, i As Long, j As Long
Dim used(0) As Long
Dim bestDot As Single, d As Single
Dim bestJ As Long
n = UBound(nrm) - LBound(nrm) + 1
ReDim used(0 To n - 1) As Long
For i = 0 To n - 1
pair(i) = -1
Next
For i = 0 To n - 1
If used(i) Then GoTo NextI
bestDot = 1E+30
bestJ = -1
For j = 0 To n - 1
If j = i Then GoTo NextJ
If used(j) Then GoTo NextJ
d = VDot!(nrm(i), nrm(j)) ' most negative => closest opposite
If d < bestDot Then bestDot = d: bestJ = j
NextJ:
Next
If bestJ >= 0 Then
pair(i) = bestJ
pair(bestJ) = i
used(i) = -1
used(bestJ) = -1
End If
NextI:
Next
End Sub
'---------------------------------------------------------------
' FaceGreater
' Deterministic ordering for "which face is more 'top'".
' Primary: Z, then Y, then X. Used to choose top face per opposite pair and to
' sort those top faces into a stable numbering sequence.
'---------------------------------------------------------------
Function FaceGreater& (a As Vertex3D, b As Vertex3D)
If a.Z > b.Z + 1E-6 Then FaceGreater& = -1: Exit Function
If a.Z < b.Z - 1E-6 Then FaceGreater& = 0: Exit Function
If a.Y > b.Y + 1E-6 Then FaceGreater& = -1: Exit Function
If a.Y < b.Y - 1E-6 Then FaceGreater& = 0: Exit Function
If a.X > b.X Then FaceGreater& = -1 Else FaceGreater& = 0
End Function
'===============================================================
' TILE BACKGROUND + POLY HELPERS
'===============================================================
'---------------------------------------------------------------
' FillTileGradient
' Fills a TILE x TILE region at (ox,oy) in the atlas with:
' - radial vignette (dark edges, bright center)
' - deterministic micro-noise based on (x,y,seed)
'
' The noise is intentionally tiny to break banding and make the die look less flat,
' while remaining perfectly reproducible (no RNG state).
'---------------------------------------------------------------
Sub FillTileGradient (ox As Single, oy As Single, baseCol As _Unsigned Long, darkCol As _Unsigned Long, seed As Long)
Dim x As Long, y As Long
Dim cx As Single, cy As Single, dx As Single, dy As Single, d As Single, t As Single
Dim c As _Unsigned Long
cx = (TILE& - 1) / 2!
cy = (TILE& - 1) / 2!
For y = 0 To TILE& - 1
For x = 0 To TILE& - 1
dx = (x - cx) / cx
dy = (y - cy) / cy
d = Sqr(dx * dx + dy * dy)
t = 1! - d
If t < 0! Then t = 0!
If t > 1! Then t = 1!
' pseudo noise (-0.06..+0.06)
Dim nn As Long
Dim n2 As Single
nn = ((x * 13 + y * 17 + seed * 19) And 15) - 8
n2 = nn / 140!
c = LerpCol~&(darkCol, baseCol, t + n2)
PSet (ox + x, oy + y), c
Next
Next
End Sub
'---------------------------------------------------------------
' ClampByte / LerpCol
' Straight per-channel lerp in RGB space (not gamma-correct; intentional simplicity).
' t is clamped; useful when vignette + noise overshoots.
'---------------------------------------------------------------
Function ClampByte% (v As Long)
If v < 0 Then v = 0
If v > 255 Then v = 255
ClampByte% = v
End Function
Function LerpCol~& (c0 As _Unsigned Long, c1 As _Unsigned Long, t As Single)
If t < 0! Then t = 0!
If t > 1! Then t = 1!
Dim r0 As Long, g0 As Long, b0 As Long
Dim r1 As Long, g1 As Long, b1 As Long
Dim r As Long, g As Long, b As Long
r0 = (c0 \ &H10000) And &HFF
g0 = (c0 \ &H100) And &HFF
b0 = (c0 And &HFF)
r1 = (c1 \ &H10000) And &HFF
g1 = (c1 \ &H100) And &HFF
b1 = (c1 And &HFF)
r = ClampByte%(CLng(r0 + (r1 - r0) * t))
g = ClampByte%(CLng(g0 + (g1 - g0) * t))
b = ClampByte%(CLng(b0 + (b1 - b0) * t))
LerpCol~& = _RGB32(r, g, b)
End Function
'---------------------------------------------------------------
' DrawPolyOutlineSeg / PolyCentroidSeg
' Operate on a "segment" inside a packed Vertex2D array:
' pts(startOff ... startOff+cnt-1)
' This matches the gFaceUV storage layout.
'---------------------------------------------------------------
Sub DrawPolyOutlineSeg (pts() As Vertex2D, startOff As Long, cnt As Long, col As _Unsigned Long)
Dim i As Long, j As Long
For i = 0 To cnt - 1
j = i + 1
If j >= cnt Then j = 0
Line (pts(startOff + i).U, pts(startOff + i).V)-(pts(startOff + j).U, pts(startOff + j).V), col
Next
End Sub
Sub PolyCentroidSeg (pts() As Vertex2D, startOff As Long, cnt As Long, cx As Single, cy As Single)
Dim i As Long
cx = 0!: cy = 0!
For i = 0 To cnt - 1
cx = cx + pts(startOff + i).U
cy = cy + pts(startOff + i).V
Next
cx = cx / cnt
cy = cy / cnt
End Sub
'===============================================================
' UV BUILD (PROJECT REAL 3D FACE -> 2D TILE)
'===============================================================
'---------------------------------------------------------------
' BuildUVForFaces
' Core UV generation: per face, construct a local 2D basis in the face plane,
' project vertices, then fit the resulting polygon into a TILE-sized atlas cell.
'
' For each face f:
' - compute face normal nnu
' - choose a stable "up" vector (avoid near-parallel to normal)
' - project "up" into the face plane => vAxis (in-plane)
' - uAxis = vAxis x normal (in-plane orthogonal)
' - subtract face centroid in 3D so coordinates are centered
' - compute (px,py) = dot(tmp,uAxis/vAxis) for each vertex
' - compute bounding box in that 2D space and scale uniformly so it fits within
' tile with margin; invert V to match screen Y+ down
'
' Output data:
' - tri(): explicit triangulation (fan) in 3D for rendering
' - uv(): per-triangle vertex UVs, *in atlas pixel coordinates*
' - triFace(): triangle -> face id mapping (debug / future extensions)
' - gFaceUV* arrays: packed UV polygon per face (for outlining + centroiding)
'
' quadShapeMode is present for future quad-specific heuristics; currently unused.
'---------------------------------------------------------------
SUB BuildUVForFaces (v() AS Vertex3D, pfStart() AS LONG, pfSize() AS LONG, pfIdx() AS LONG, _
cols AS LONG, quadShapeMode AS LONG, tri() AS Vertex3D, uv() AS Vertex2D, triFace() AS LONG)
Dim faceCount As Long, f As Long, n As Long, triCount As Long, outV As Long, outT As Long
Dim startOff As Long, k As Long, i0 As Long, i1 As Long, i2 As Long
Dim ox As Single, oy As Single
Dim a As Vertex3D, b As Vertex3D, c As Vertex3D
Dim e1 As Vertex3D, e2 As Vertex3D, nn As Vertex3D, nnu As Vertex3D
Dim up As Vertex3D, vAxis As Vertex3D, uAxis As Vertex3D, tmp As Vertex3D
Dim dp As Single, px As Single, py As Single
Dim minx As Single, maxx As Single, miny As Single, maxy As Single
Dim sx As Single, sy As Single, sc As Single, cx2d As Single, cy2d As Single
faceCount = UBound(pfStart) - LBound(pfStart) + 1
triCount = 0
For f = 0 To faceCount - 1
n = pfSize(f)
triCount = triCount + (n - 2)
Next
ReDim tri(0 To triCount * 3 - 1) As Vertex3D
ReDim uv(0 To triCount * 3 - 1) As Vertex2D
ReDim triFace(0 To triCount - 1) As Long
Dim totalPoly As Long, curPoly As Long
totalPoly = 0
For f = 0 To faceCount - 1
totalPoly = totalPoly + pfSize(f)
Next
ReDim gFaceUVStart(0 To faceCount - 1) As Long
ReDim gFaceUVSize(0 To faceCount - 1) As Long
ReDim gFaceUV(0 To totalPoly - 1) As Vertex2D
outV = 0: outT = 0
curPoly = 0
Dim projx(0) As Single, projy(0) As Single
Dim cen3 As Vertex3D
Dim uu As Single, vv As Single, uLocal As Single, vLocal As Single
For f = 0 To faceCount - 1
startOff = pfStart(f)
n = pfSize(f)
ox = (f Mod cols) * TILE&
oy = (f \ cols) * TILE& ' integer division -> row
a = v(pfIdx(startOff + 0))
b = v(pfIdx(startOff + 1))
c = v(pfIdx(startOff + 2))
VSub b, a, e1
VSub c, a, e2
VCross e1, e2, nn
VNorm nn, nnu
' stable "up", then project into plane
VSet up, 0!, 0!, 1!
dp = Abs(VDot!(nnu, up))
If dp > .92! Then VSet up, 0!, 1!, 0!
dp = VDot!(nnu, up)
VScale nnu, dp, tmp
VSub up, tmp, vAxis
VNorm vAxis, vAxis
VCross vAxis, nnu, uAxis
VNorm uAxis, uAxis
' centroid 3D
cen3.X = 0!: cen3.Y = 0!: cen3.Z = 0!
For k = 0 To n - 1
tmp = v(pfIdx(startOff + k))
cen3.X = cen3.X + tmp.X
cen3.Y = cen3.Y + tmp.Y
cen3.Z = cen3.Z + tmp.Z
Next
cen3.X = cen3.X / n
cen3.Y = cen3.Y / n
cen3.Z = cen3.Z / n
ReDim projx(0 To n - 1) As Single
ReDim projy(0 To n - 1) As Single
minx = 1E+30: miny = 1E+30
maxx = -1E+30: maxy = -1E+30
For k = 0 To n - 1
tmp = v(pfIdx(startOff + k))
tmp.X = tmp.X - cen3.X
tmp.Y = tmp.Y - cen3.Y
tmp.Z = tmp.Z - cen3.Z
px = VDot!(tmp, uAxis)
py = VDot!(tmp, vAxis)
projx(k) = px
projy(k) = py
If px < minx Then minx = px
If px > maxx Then maxx = px
If py < miny Then miny = py
If py > maxy Then maxy = py
Next
sx = maxx - minx: sy = maxy - miny
If sx <= 1E-9 Then sx = 1E-9
If sy <= 1E-9 Then sy = 1E-9
sc = (TILE& - 2! * MARGIN!) / sx
If (TILE& - 2! * MARGIN!) / sy < sc Then sc = (TILE& - 2! * MARGIN!) / sy
sc = sc * .98!
cx2d = (minx + maxx) / 2!
cy2d = (miny + maxy) / 2!
gFaceUVStart(f) = curPoly
gFaceUVSize(f) = n
For k = 0 To n - 1
uu = (projx(k) - cx2d) * sc
vv = (projy(k) - cy2d) * sc
uLocal = (TILE& / 2!) + uu
vLocal = (TILE& / 2!) - vv
If FLIP_U Then uLocal = (TILE& - 1) - uLocal
If FLIP_V Then vLocal = (TILE& - 1) - vLocal
gFaceUV(curPoly + k).U = ox + uLocal
gFaceUV(curPoly + k).V = oy + vLocal
Next
' triangulate fan
i0 = pfIdx(startOff + 0)
For k = 1 To n - 2
i1 = pfIdx(startOff + k)
i2 = pfIdx(startOff + k + 1)
tri(outV + 0) = v(i0)
tri(outV + 1) = v(i1)
tri(outV + 2) = v(i2)
uv(outV + 0) = gFaceUV(curPoly + 0)
uv(outV + 1) = gFaceUV(curPoly + k)
uv(outV + 2) = gFaceUV(curPoly + k + 1)
triFace(outT) = f
outV = outV + 3
outT = outT + 1
Next
curPoly = curPoly + n
Next
End Sub
'===============================================================
' ATLAS BUILD
'===============================================================
'---------------------------------------------------------------
' BuildAtlas
' Creates a full atlas image sized (cols*TILE) x (rows*TILE).
' For each face tile:
' - draw background (FillTileGradient)
' - draw UV polygon outline (exact mapping polygon)
' - compute polygon centroid for number placement
' - stamp numbers:
' * D4: 3 per face, positioned toward corners and rotated so the glyph "top"
' points outward from centroid toward the vertex.
' * else: one centered label (big/small font chosen by digits)
' - draw a second outline pass as a subtle highlight ("bevel")
'
' Important QB64PE specifics:
' - Stamping uses manual per-pixel PSet to preserve hard edges.
' - _Dest is forced to the working atlas (swi) inside the loop to avoid state leakage.
'---------------------------------------------------------------
Sub BuildAtlas (atlasTex As Long, faceCount As Long, cols As Long, rows As Long, dieKind As Long)
Dim w As Long, h As Long, swi As Long, f As Long
Dim ox As Single, oy As Single, cx As Single, cy As Single
Dim purple As _Unsigned Long, purpleDark As _Unsigned Long, gold As _Unsigned Long
Dim goldShadow As _Unsigned Long, edge As _Unsigned Long, keyCol As _Unsigned Long
If gFontBig = 0 Then InitFonts
w = cols * TILE&
h = rows * TILE&
purple = _RGB32(122, 0, 132)
purpleDark = _RGB32(45, 0, 55)
gold = _RGB32(212, 175, 55)
goldShadow = _RGB32(120, 90, 20)
edge = _RGB32(10, 10, 10)
keyCol = _RGB32(1, 0, 1)
swi = _NewImage(w, h, 32)
Dim i As Long, st As Long, n As Long
Dim vx As Single, vy As Single, px As Single, py As Single, ang As Single
Dim spr As Long
For f = 0 To faceCount - 1
_Dest swi ' pojistka: kreslme pod do atlasu
_Source 0
_PrintMode _KeepBackground
ox = (f Mod cols) * TILE&
oy = (f \ cols) * TILE&
FillTileGradient ox, oy, purple, purpleDark, f * 97
DrawPolyOutlineSeg gFaceUV(), gFaceUVStart(f), gFaceUVSize(f), edge
PolyCentroidSeg gFaceUV(), gFaceUVStart(f), gFaceUVSize(f), cx, cy
If dieKind = DIE_D4 Then
st = gFaceUVStart(f)
n = gFaceUVSize(f) ' should be 3
For i = 0 To n - 1
vx = gFaceUV(st + i).U - cx
vy = gFaceUV(st + i).V - cy
px = gFaceUV(st + i).U - vx * .28!
py = gFaceUV(st + i).V - vy * .28!
' rotation so glyph "top" aims from centroid to corner (screen y+ down)
ang = _Atan2(vx, -vy)
spr = MakeTextSprite(LTrim$(Str$(gFaceTrip(f * 3 + i))), gFontCorner, gold, edge, goldShadow)
StampSpriteRot swi, spr, px, py, ang, 1!, keyCol
_FreeImage spr
Next
Else
Dim s As String
Dim fontH As Long
s = gFaceLabel(f)
If Len(s) <= 1 Then
fontH = gFontBig
Else
fontH = gFontSmall
End If
spr = MakeTextSprite(s, fontH, gold, edge, goldShadow)
StampSpriteRot swi, spr, cx, cy, 0!, 1!, keyCol
'_PutImage , swi, 0
'Sleep
_FreeImage spr
End If
' subtle "bevel" highlight edge
DrawPolyOutlineSeg gFaceUV(), gFaceUVStart(f), gFaceUVSize(f), _RGB32(170, 50, 180)
Next
_Dest 0
atlasTex = _CopyImage(swi, 33)
_FreeImage swi
End Sub
'===============================================================
' WIRE TRIANGLE TEXTURE
'===============================================================
'---------------------------------------------------------------
' MakeWireTriTexture
' Builds a simple "wire" texture containing a triangle outline (plus a few offset
' duplicates for thickness). This texture is later mapped with _MAPTRIANGLE onto
' each 3D triangle, creating a screen-space-ish wire overlay without explicit line
' rasterization in 3D.
'---------------------------------------------------------------
Sub MakeWireTriTexture (tex As Long)
Dim swi As Long
Dim c As _Unsigned Long
swi = _NewImage(TEXW&, TEXH&, 32)
_Dest swi
Cls , _RGBA(0, 0, 0, 0)
c = _RGBA(255, 255, 255, 255)
Line (TSX1!, TSY1!)-(TSX2!, TSY2!), c
Line (TSX2!, TSY2!)-(TSX3!, TSY3!), c
Line (TSX3!, TSY3!)-(TSX1!, TSY1!), c
Line (TSX1! + 1!, TSY1!)-(TSX2! + 1!, TSY2!), c
Line (TSX2! + 1!, TSY2!)-(TSX3! + 1!, TSY3!), c
Line (TSX3! + 1!, TSY3!)-(TSX1! + 1!, TSY1!), c
Line (TSX1!, TSY1! + 1!)-(TSX2!, TSY2! + 1!), c
Line (TSX2!, TSY2! + 1!)-(TSX3!, TSY3! + 1!), c
Line (TSX3!, TSY3! + 1!)-(TSX1!, TSY1! + 1!), c
_Dest 0
tex = _CopyImage(swi, 33)
_FreeImage swi
End Sub
Function MakeTextSprite& (s As String, fontH As Long, fg As _Unsigned Long, outline As _Unsigned Long, shadow As _Unsigned Long)
Dim w As Long, h As Long, img As Long
Dim keyCol As _Unsigned Long
Dim oldDest As Long, oldFont As Long
keyCol = _RGB32(1, 0, 1)
oldDest = _Dest
oldFont = _Font
If fontH <> 0 Then _Font fontH Else _Font 16
w = _PrintWidth(s) + 16
h = _FontHeight + 16
If w < 8 Then w = 8
If h < 8 Then h = 8
img = _NewImage(w, h, 32)
_Dest img
Cls , keyCol
_PrintMode _KeepBackground
If fontH <> 0 Then _Font fontH, img Else _Font 16, img
' Outline (cheap stroke)
Color outline, keyCol
_PrintString (6, 7), s, img
_PrintString (8, 7), s, img
_PrintString (7, 6), s, img
_PrintString (7, 8), s, img
_PrintString (6, 6), s, img
_PrintString (8, 6), s, img
_PrintString (6, 8), s, img
_PrintString (8, 8), s, img
' Shadow
Color shadow, keyCol
_PrintString (9, 9), s, img
' Main
Color fg, keyCol
_PrintString (7, 7), s, img
' ---- underline only for single "6" or "9"
Dim st As String
st = LTrim$(RTrim$(s))
If st = "6" Or st = "9" Then
Dim txtW As Long
Dim x1 As Long, x2 As Long, yLine As Long
txtW = _PrintWidth(st)
x1 = 7 + 2
x2 = 7 + txtW - 3
yLine = 7 + _FontHeight - 6
If x2 > x1 Then
' outline thickness
Line (x1 - 1, yLine - 1)-(x2 + 1, yLine - 1), outline
Line (x1 - 1, yLine + 1)-(x2 + 1, yLine + 1), outline
' shadow
Line (x1, yLine + 2)-(x2, yLine + 2), shadow
' gold bar
Line (x1, yLine)-(x2, yLine), fg
End If
End If
_Dest oldDest
_Font oldFont
MakeTextSprite& = img
End Function
'===============================================================
' RENDER
'===============================================================
'---------------------------------------------------------------
' RenderMesh
' Renders a triangle list with optional textured fill and optional wire overlay.
'
' Steps:
' 1) Apply Euler rotations (X then Y then Z) to each vertex, then translate.
' This is done in software to feed _MAPTRIANGLE with transformed 3D points.
' 2) Painter sort triangles by average Z:
' - Not a true Z-buffer, but good enough for convex solids and demo.
' 3) For each triangle:
' - map atlas texture using its UVs
' - optionally map wire texture using fixed source triangle coords
'
' Important:
' - _MAPTRIANGLE with _SMOOTH enables bilinear filtering of the source texture.
' - Face winding is specified as _ANTICLOCKWISE to match the generated triangles.
'---------------------------------------------------------------
SUB RenderMesh (tri() AS Vertex3D, uv() AS Vertex2D, atlasTex AS LONG, wireTex AS LONG, _
doTex AS LONG, doWire AS LONG, tx AS SINGLE, ty AS SINGLE, tz AS SINGLE, rx AS SINGLE, ry AS SINGLE, rz AS SINGLE)
Dim lb As Long, vCount As Long, tCount As Long, i As Long, t As Long, k As Long, b As Long, p As Long, q As Long, tmpI As Long
Dim cx As Single, sx As Single, cy As Single, sy As Single, cz As Single, sz As Single
Dim x As Single, y As Single, z As Single, y1 As Single, z1 As Single, x2 As Single, z2 As Single, x3 As Single, y3 As Single
Dim tv(0) As Vertex3D
Dim zAvg(0) As Single
Dim ord(0) As Long
lb = LBound(tri)
vCount = UBound(tri) - lb + 1
If vCount < 3 Then Exit Sub
tCount = vCount \ 3
If tCount < 1 Then Exit Sub
cx = Cos(rx): sx = Sin(rx)
cy = Cos(ry): sy = Sin(ry)
cz = Cos(rz): sz = Sin(rz)
ReDim tv(0 To vCount - 1) As Vertex3D
For i = 0 To vCount - 1
x = tri(lb + i).X
y = tri(lb + i).Y
z = tri(lb + i).Z
' Rotate X
y1 = y * cx - z * sx
z1 = y * sx + z * cx
' Rotate Y
x2 = x * cy + z1 * sy
z2 = -x * sy + z1 * cy
' Rotate Z
x3 = x2 * cz - y1 * sz
y3 = x2 * sz + y1 * cz
tv(i).X = x3 + tx
tv(i).Y = y3 + ty
tv(i).Z = z2 + tz
Next
' Painter sort by average Z (far -> near)
ReDim zAvg(0 To tCount - 1) As Single
ReDim ord(0 To tCount - 1) As Long
For t = 0 To tCount - 1
b = t * 3
zAvg(t) = (tv(b + 0).Z + tv(b + 1).Z + tv(b + 2).Z) / 3!
ord(t) = t
Next
For p = 0 To tCount - 2
For q = 0 To tCount - 2 - p
If zAvg(ord(q)) > zAvg(ord(q + 1)) Then
tmpI = ord(q): ord(q) = ord(q + 1): ord(q + 1) = tmpI
End If
Next
Next
For k = 0 To tCount - 1
t = ord(k)
b = t * 3
If doTex Then
_MAPTRIANGLE _ANTICLOCKWISE _
(uv(b + 0).U, uv(b + 0).V)- _
(uv(b + 1).U, uv(b + 1).V)- _
(uv(b + 2).U, uv(b + 2).V), atlasTex TO _
(tv(b + 0).X, tv(b + 0).Y, tv(b + 0).Z)- _
(tv(b + 1).X, tv(b + 1).Y, tv(b + 1).Z)- _
(tv(b + 2).X, tv(b + 2).Y, tv(b + 2).Z), , _SMOOTH
End If
If doWire Then
_MAPTRIANGLE _ANTICLOCKWISE _
(TSX1!, TSY1!)-(TSX2!, TSY2!)-(TSX3!, TSY3!), wireTex TO _
(tv(b + 0).X, tv(b + 0).Y, tv(b + 0).Z)- _
(tv(b + 1).X, tv(b + 1).Y, tv(b + 1).Z)- _
(tv(b + 2).X, tv(b + 2).Y, tv(b + 2).Z), , _SMOOTH
End If
Next
End Sub
'===============================================================
' DICE BUILDERS
'===============================================================
'---------------------------------------------------------------
' BuildD4 / BuildD6 / BuildD8 / BuildD10 / BuildD12 / BuildD20
' Each builder constructs a specific die geometry, normalizes it, builds UVs,
' prepares labels, and finally builds the atlas texture.
'
' The common pattern:
' - define primal vertices v()
' - define faces via pfStart/pfSize/pfIdx
' - EnsureFacesOutward (critical for consistent normals + dual construction)
' - scale to target edge length
' - BuildUVForFaces to generate tri() + uv() + gFaceUV polygon store
' - PrepareLabels* to fill gFaceLabel / gFaceTrip
' - BuildAtlas to bake numbers into an atlas texture
'---------------------------------------------------------------
Sub BuildD4 (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
Dim v(0 To 3) As Vertex3D
Dim pfStart(0 To 3) As Long, pfSize(0 To 3) As Long, pfIdx(0 To 11) As Long
Dim o As Long
Dim edgeNow As Single, sc As Single
VSet v(0), 1!, 1!, 1!
VSet v(1), 1!, -1!, -1!
VSet v(2), -1!, 1!, -1!
VSet v(3), -1!, -1!, 1!
o = 0
pfStart(0) = o: pfSize(0) = 3: pfIdx(o + 0) = 0: pfIdx(o + 1) = 2: pfIdx(o + 2) = 1: o = o + 3
pfStart(1) = o: pfSize(1) = 3: pfIdx(o + 0) = 0: pfIdx(o + 1) = 1: pfIdx(o + 2) = 3: o = o + 3
pfStart(2) = o: pfSize(2) = 3: pfIdx(o + 0) = 0: pfIdx(o + 1) = 3: pfIdx(o + 2) = 2: o = o + 3
pfStart(3) = o: pfSize(3) = 3: pfIdx(o + 0) = 1: pfIdx(o + 1) = 2: pfIdx(o + 2) = 3: o = o + 3
EnsureFacesOutward v(), pfStart(), pfSize(), pfIdx()
edgeNow = MinEdgeLen!(v(), pfStart(), pfSize(), pfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices v(), sc
BuildUVForFaces v(), pfStart(), pfSize(), pfIdx(), 2, 0, tri(), uv(), triFace()
PrepareLabelsD4 pfStart(), pfSize(), pfIdx()
BuildAtlas atlasTex, 4, 2, 2, DIE_D4
End Sub
Sub BuildD6 (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
Dim v(0 To 7) As Vertex3D
Dim pfStart(0 To 5) As Long, pfSize(0 To 5) As Long, pfIdx(0 To 23) As Long
Dim o As Long
Dim edgeNow As Single, sc As Single
VSet v(0), -1!, -1!, -1!
VSet v(1), 1!, -1!, -1!
VSet v(2), 1!, 1!, -1!
VSet v(3), -1!, 1!, -1!
VSet v(4), -1!, -1!, 1!
VSet v(5), 1!, -1!, 1!
VSet v(6), 1!, 1!, 1!
VSet v(7), -1!, 1!, 1!
o = 0
pfStart(0) = o: pfSize(0) = 4: pfIdx(o + 0) = 0: pfIdx(o + 1) = 1: pfIdx(o + 2) = 2: pfIdx(o + 3) = 3: o = o + 4 ' Z-
pfStart(1) = o: pfSize(1) = 4: pfIdx(o + 0) = 4: pfIdx(o + 1) = 7: pfIdx(o + 2) = 6: pfIdx(o + 3) = 5: o = o + 4 ' Z+
pfStart(2) = o: pfSize(2) = 4: pfIdx(o + 0) = 1: pfIdx(o + 1) = 5: pfIdx(o + 2) = 6: pfIdx(o + 3) = 2: o = o + 4 ' X+
pfStart(3) = o: pfSize(3) = 4: pfIdx(o + 0) = 0: pfIdx(o + 1) = 3: pfIdx(o + 2) = 7: pfIdx(o + 3) = 4: o = o + 4 ' X-
pfStart(4) = o: pfSize(4) = 4: pfIdx(o + 0) = 3: pfIdx(o + 1) = 2: pfIdx(o + 2) = 6: pfIdx(o + 3) = 7: o = o + 4 ' Y+
pfStart(5) = o: pfSize(5) = 4: pfIdx(o + 0) = 0: pfIdx(o + 1) = 4: pfIdx(o + 2) = 5: pfIdx(o + 3) = 1: o = o + 4 ' Y-
EnsureFacesOutward v(), pfStart(), pfSize(), pfIdx()
edgeNow = MinEdgeLen!(v(), pfStart(), pfSize(), pfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices v(), sc
BuildUVForFaces v(), pfStart(), pfSize(), pfIdx(), 3, 0, tri(), uv(), triFace()
PrepareLabelsD6 v(), pfStart(), pfSize(), pfIdx()
BuildAtlas atlasTex, 6, 3, 2, DIE_D6
End Sub
Sub BuildD8 (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
Dim v(0 To 5) As Vertex3D
Dim pfStart(0 To 7) As Long, pfSize(0 To 7) As Long, pfIdx(0 To 23) As Long
Dim o As Long
Dim edgeNow As Single, sc As Single
VSet v(0), 1!, 0!, 0!
VSet v(1), -1!, 0!, 0!
VSet v(2), 0!, 1!, 0!
VSet v(3), 0!, -1!, 0!
VSet v(4), 0!, 0!, 1!
VSet v(5), 0!, 0!, -1!
o = 0
pfStart(0) = o: pfSize(0) = 3: pfIdx(o + 0) = 4: pfIdx(o + 1) = 0: pfIdx(o + 2) = 2: o = o + 3
pfStart(1) = o: pfSize(1) = 3: pfIdx(o + 0) = 4: pfIdx(o + 1) = 2: pfIdx(o + 2) = 1: o = o + 3
pfStart(2) = o: pfSize(2) = 3: pfIdx(o + 0) = 4: pfIdx(o + 1) = 1: pfIdx(o + 2) = 3: o = o + 3
pfStart(3) = o: pfSize(3) = 3: pfIdx(o + 0) = 4: pfIdx(o + 1) = 3: pfIdx(o + 2) = 0: o = o + 3
pfStart(4) = o: pfSize(4) = 3: pfIdx(o + 0) = 5: pfIdx(o + 1) = 2: pfIdx(o + 2) = 0: o = o + 3
pfStart(5) = o: pfSize(5) = 3: pfIdx(o + 0) = 5: pfIdx(o + 1) = 1: pfIdx(o + 2) = 2: o = o + 3
pfStart(6) = o: pfSize(6) = 3: pfIdx(o + 0) = 5: pfIdx(o + 1) = 3: pfIdx(o + 2) = 1: o = o + 3
pfStart(7) = o: pfSize(7) = 3: pfIdx(o + 0) = 5: pfIdx(o + 1) = 0: pfIdx(o + 2) = 3: o = o + 3
EnsureFacesOutward v(), pfStart(), pfSize(), pfIdx()
edgeNow = MinEdgeLen!(v(), pfStart(), pfSize(), pfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices v(), sc
BuildUVForFaces v(), pfStart(), pfSize(), pfIdx(), 4, 0, tri(), uv(), triFace()
PrepareLabelsPairs v(), pfStart(), pfSize(), pfIdx(), 1, 9
BuildAtlas atlasTex, 8, 4, 2, DIE_D8
End Sub
Sub BuildD20 (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
Dim phi As Single, edgeNow As Single, sc As Single
Dim v(0 To 11) As Vertex3D
Dim pfStart(0 To 19) As Long, pfSize(0 To 19) As Long, pfIdx(0 To 59) As Long
Dim F(0 To 19, 0 To 2) As Long
Dim o As Long, fi As Long
phi = (1! + Sqr(5!)) / 2!
VSet v(0), -1!, phi, 0!
VSet v(1), 1!, phi, 0!
VSet v(2), -1!, -phi, 0!
VSet v(3), 1!, -phi, 0!
VSet v(4), 0!, -1!, phi
VSet v(5), 0!, 1!, phi
VSet v(6), 0!, -1!, -phi
VSet v(7), 0!, 1!, -phi
VSet v(8), phi, 0!, -1!
VSet v(9), phi, 0!, 1!
VSet v(10), -phi, 0!, -1!
VSet v(11), -phi, 0!, 1!
F(0, 0) = 0: F(0, 1) = 11: F(0, 2) = 5
F(1, 0) = 0: F(1, 1) = 5: F(1, 2) = 1
F(2, 0) = 0: F(2, 1) = 1: F(2, 2) = 7
F(3, 0) = 0: F(3, 1) = 7: F(3, 2) = 10
F(4, 0) = 0: F(4, 1) = 10: F(4, 2) = 11
F(5, 0) = 1: F(5, 1) = 5: F(5, 2) = 9
F(6, 0) = 5: F(6, 1) = 11: F(6, 2) = 4
F(7, 0) = 11: F(7, 1) = 10: F(7, 2) = 2
F(8, 0) = 10: F(8, 1) = 7: F(8, 2) = 6
F(9, 0) = 7: F(9, 1) = 1: F(9, 2) = 8
F(10, 0) = 3: F(10, 1) = 9: F(10, 2) = 4
F(11, 0) = 3: F(11, 1) = 4: F(11, 2) = 2
F(12, 0) = 3: F(12, 1) = 2: F(12, 2) = 6
F(13, 0) = 3: F(13, 1) = 6: F(13, 2) = 8
F(14, 0) = 3: F(14, 1) = 8: F(14, 2) = 9
F(15, 0) = 4: F(15, 1) = 9: F(15, 2) = 5
F(16, 0) = 2: F(16, 1) = 4: F(16, 2) = 11
F(17, 0) = 6: F(17, 1) = 2: F(17, 2) = 10
F(18, 0) = 8: F(18, 1) = 6: F(18, 2) = 7
F(19, 0) = 9: F(19, 1) = 8: F(19, 2) = 1
o = 0
For fi = 0 To 19
pfStart(fi) = o: pfSize(fi) = 3
pfIdx(o + 0) = F(fi, 0)
pfIdx(o + 1) = F(fi, 1)
pfIdx(o + 2) = F(fi, 2)
o = o + 3
Next
EnsureFacesOutward v(), pfStart(), pfSize(), pfIdx()
edgeNow = MinEdgeLen!(v(), pfStart(), pfSize(), pfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices v(), sc
BuildUVForFaces v(), pfStart(), pfSize(), pfIdx(), 5, 0, tri(), uv(), triFace()
PrepareLabelsPairs v(), pfStart(), pfSize(), pfIdx(), 1, 21
BuildAtlas atlasTex, 20, 5, 4, DIE_D20
End Sub
Sub BuildD12 (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
' d12 = dual of icosahedron (d20 primal)
' Practical approach:
' - build icosahedron (same as D20 primal)
' - BuildDual => dodecahedron vertices/faces
' - normalize size, build UVs, label by opposite-pairs sum=13
Dim phi As Single, edgeNow As Single, sc As Single
Dim pv(0 To 11) As Vertex3D
Dim pfStart(0 To 19) As Long, pfSize(0 To 19) As Long, pfIdx(0 To 59) As Long
Dim F(0 To 19, 0 To 2) As Long
Dim o As Long, fi As Long
Dim dv(0) As Vertex3D, dfStart(0) As Long, dfSize(0) As Long, dfIdx(0) As Long
phi = (1! + Sqr(5!)) / 2!
VSet pv(0), -1!, phi, 0!
VSet pv(1), 1!, phi, 0!
VSet pv(2), -1!, -phi, 0!
VSet pv(3), 1!, -phi, 0!
VSet pv(4), 0!, -1!, phi
VSet pv(5), 0!, 1!, phi
VSet pv(6), 0!, -1!, -phi
VSet pv(7), 0!, 1!, -phi
VSet pv(8), phi, 0!, -1!
VSet pv(9), phi, 0!, 1!
VSet pv(10), -phi, 0!, -1!
VSet pv(11), -phi, 0!, 1!
F(0, 0) = 0: F(0, 1) = 11: F(0, 2) = 5
F(1, 0) = 0: F(1, 1) = 5: F(1, 2) = 1
F(2, 0) = 0: F(2, 1) = 1: F(2, 2) = 7
F(3, 0) = 0: F(3, 1) = 7: F(3, 2) = 10
F(4, 0) = 0: F(4, 1) = 10: F(4, 2) = 11
F(5, 0) = 1: F(5, 1) = 5: F(5, 2) = 9
F(6, 0) = 5: F(6, 1) = 11: F(6, 2) = 4
F(7, 0) = 11: F(7, 1) = 10: F(7, 2) = 2
F(8, 0) = 10: F(8, 1) = 7: F(8, 2) = 6
F(9, 0) = 7: F(9, 1) = 1: F(9, 2) = 8
F(10, 0) = 3: F(10, 1) = 9: F(10, 2) = 4
F(11, 0) = 3: F(11, 1) = 4: F(11, 2) = 2
F(12, 0) = 3: F(12, 1) = 2: F(12, 2) = 6
F(13, 0) = 3: F(13, 1) = 6: F(13, 2) = 8
F(14, 0) = 3: F(14, 1) = 8: F(14, 2) = 9
F(15, 0) = 4: F(15, 1) = 9: F(15, 2) = 5
F(16, 0) = 2: F(16, 1) = 4: F(16, 2) = 11
F(17, 0) = 6: F(17, 1) = 2: F(17, 2) = 10
F(18, 0) = 8: F(18, 1) = 6: F(18, 2) = 7
F(19, 0) = 9: F(19, 1) = 8: F(19, 2) = 1
o = 0
For fi = 0 To 19
pfStart(fi) = o: pfSize(fi) = 3
pfIdx(o + 0) = F(fi, 0)
pfIdx(o + 1) = F(fi, 1)
pfIdx(o + 2) = F(fi, 2)
o = o + 3
Next
EnsureFacesOutward pv(), pfStart(), pfSize(), pfIdx()
BuildDual pv(), pfStart(), pfSize(), pfIdx(), dv(), dfStart(), dfSize(), dfIdx()
EnsureFacesOutward dv(), dfStart(), dfSize(), dfIdx()
edgeNow = MinEdgeLen!(dv(), dfStart(), dfSize(), dfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices dv(), sc
BuildUVForFaces dv(), dfStart(), dfSize(), dfIdx(), 4, 0, tri(), uv(), triFace()
PrepareLabelsPairs dv(), dfStart(), dfSize(), dfIdx(), 1, 13
BuildAtlas atlasTex, 12, 4, 3, DIE_D12
End Sub
Sub BuildD10 (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
' d10 (pentagonal trapezohedron) = dual of pentagonal antiprism
' Strategy:
' - build a pentagonal antiprism as primal (two offset pentagons + side triangles)
' - BuildDual to get trapezohedron-like dual
' - SquashLongestAxis to tweak proportions (visual match to common dice)
' - label with baseVal=0 and opposite sum 9
Dim r As Single, h As Single, sPoly As Single, chord As Single
Dim edgeNow As Single, sc As Single, ang As Single
Dim pv(0 To 9) As Vertex3D
Dim pfStart(0 To 11) As Long, pfSize(0 To 11) As Long, pfIdx(0 To (5 + 5 + 10 * 3) - 1) As Long
Dim dv(0) As Vertex3D, dfStart(0) As Long, dfSize(0) As Long, dfIdx(0) As Long
Dim o As Long, k As Long, i As Long, f As Long, u0 As Long, u1 As Long, l0 As Long, l1 As Long
r = 1!
sPoly = 2! * r * Sin(PI! / 5!)
chord = 2! * r * Sin(PI! / 10!)
h = .5 * Sqr(sPoly * sPoly - chord * chord)
For k = 0 To 4
ang = (2! * PI! * k) / 5!
VSet pv(k), r * Cos(ang), r * Sin(ang), h
Next
For k = 0 To 4
ang = (2! * PI! * k) / 5! + (PI! / 5!)
VSet pv(5 + k), r * Cos(ang), r * Sin(ang), -h
Next
o = 0
pfStart(0) = o: pfSize(0) = 5
For k = 0 To 4: pfIdx(o + k) = k: Next
o = o + 5
pfStart(1) = o: pfSize(1) = 5
pfIdx(o + 0) = 5 + 0
pfIdx(o + 1) = 5 + 4
pfIdx(o + 2) = 5 + 3
pfIdx(o + 3) = 5 + 2
pfIdx(o + 4) = 5 + 1
o = o + 5
f = 2
For i = 0 To 4
u0 = i
u1 = (i + 1) Mod 5
l0 = 5 + i
l1 = 5 + ((i + 1) Mod 5)
pfStart(f) = o: pfSize(f) = 3
pfIdx(o + 0) = u0: pfIdx(o + 1) = l0: pfIdx(o + 2) = u1
o = o + 3: f = f + 1
pfStart(f) = o: pfSize(f) = 3
pfIdx(o + 0) = u1: pfIdx(o + 1) = l0: pfIdx(o + 2) = l1
o = o + 3: f = f + 1
Next
EnsureFacesOutward pv(), pfStart(), pfSize(), pfIdx()
BuildDual pv(), pfStart(), pfSize(), pfIdx(), dv(), dfStart(), dfSize(), dfIdx()
EnsureFacesOutward dv(), dfStart(), dfSize(), dfIdx()
SquashLongestAxis dv(), D10_SQUASH!
edgeNow = MinEdgeLen!(dv(), dfStart(), dfSize(), dfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices dv(), sc
BuildUVForFaces dv(), dfStart(), dfSize(), dfIdx(), 5, 0, tri(), uv(), triFace()
PrepareLabelsPairs dv(), dfStart(), dfSize(), dfIdx(), 0, 9
BuildAtlas atlasTex, 10, 5, 2, DIE_D10
End Sub
'---------------------------------------------------------------
' MakeTextSprite
' Renders a string into a small RGBA sprite image with:
' - key-color background (for transparency by colorkey)
' - cheap outline via 8-neighborhood offset prints
' - drop shadow
' - main glyph
'
' State discipline:
' - Saves and restores _Dest and _Font to avoid contaminating caller context.
'
' The sprite is later stamped with StampSpriteRot (manual per-pixel blit).
'---------------------------------------------------------------
'---------------------------------------------------------------
' StampSpriteRot
' Manual sprite blit with rotation and uniform scale.
'
' This is intentionally "brute force" (iterate over source pixels):
' - reads each sprite pixel with Point(sx,sy) from _Source
' - skips key-colored pixels (colorkey transparency)
' - transforms source pixel offset by rotation matrix
' - writes to destination with PSet
'
' Why manual instead of _PutImage?
' - We need per-glyph arbitrary rotation (D4 corner labels).
' - We want crisp edges and deterministic results for atlas baking.
'
' Critical detail: pixel rounding
' QB64PE's CLng uses banker's rounding, which can alternate between neighbors
' for .5 cases under rotation, producing visible "striping" in some digits.
' Using _Ceil makes the mapping consistent per sample, removing the artifact.
'---------------------------------------------------------------
Sub StampSpriteRot (dstImg As Long, spr As Long, cx As Single, cy As Single, ang As Single, scale As Single, keyCol As _Unsigned Long)
Dim swi As Long, shi As Long
Dim sx As Long, sy As Long
Dim cs As Single, sn As Single
Dim dx As Single, dy As Single, rx As Single, ry As Single
Dim px As Long, py As Long
Dim col As _Unsigned Long
Dim hx As Single, hy As Single
Dim oldDest As Long, oldSrc As Long
Dim dw As Long, dh As Long
swi = _Width(spr)
shi = _Height(spr)
If swi <= 0 Or shi <= 0 Then Exit Sub
If scale <= 0! Then scale = 1!
cs = Cos(ang)
sn = Sin(ang)
' !!! sted podle SPRITE, ne podle obrazovky
hx = (swi - 1) / 2!
hy = (shi - 1) / 2!
oldDest = _Dest
oldSrc = _Source
dw = _Width(dstImg)
dh = _Height(dstImg)
_Dest dstImg
_Source spr
For sy = 0 To shi - 1
For sx = 0 To swi - 1
col = Point(sx, sy)
If col <> keyCol Then
dx = (sx - hx) * scale
dy = (sy - hy) * scale
rx = dx * cs - dy * sn
ry = dx * sn + dy * cs
px = _Ceil(cx + rx)
py = _Ceil(cy + ry)
If px >= 0 And px < dw And py >= 0 And py < dh Then
PSet (px, py), col
End If
End If
Next
Next
_Source oldSrc
_Dest oldDest
End Sub
Sub PrepareLabelsD10Tens (v() As Vertex3D, pfStart() As Long, pfSize() As Long, pfIdx() As Long)
' nejdv udlej pry jako 0..9 (opposite sum 9)
PrepareLabelsPairs v(), pfStart(), pfSize(), pfIdx(), 0, 9
' pak z toho udlej 00,10,...,90
Dim f As Long, faceCount As Long
Dim n As Long
faceCount = UBound(gFaceLabel) - LBound(gFaceLabel) + 1
For f = 0 To faceCount - 1
n = Val(gFaceLabel(f)) * 10
If n = 0 Then
gFaceLabel(f) = "00"
Else
gFaceLabel(f) = LTrim$(Str$(n))
End If
Next
End Sub
Sub BuildD10Tens (tri() As Vertex3D, uv() As Vertex2D, triFace() As Long, atlasTex As Long)
' Stejn geometrie jako BuildD10, jen jin labely (00..90)
Dim r As Single, h As Single, sPoly As Single, chord As Single
Dim edgeNow As Single, sc As Single, ang As Single
Dim pv(0 To 9) As Vertex3D
Dim pfStart(0 To 11) As Long, pfSize(0 To 11) As Long, pfIdx(0 To (5 + 5 + 10 * 3) - 1) As Long
Dim dv(0) As Vertex3D, dfStart(0) As Long, dfSize(0) As Long, dfIdx(0) As Long
Dim o As Long, k As Long, i As Long, f As Long, u0 As Long, u1 As Long, l0 As Long, l1 As Long
r = 1!
sPoly = 2! * r * Sin(PI! / 5!)
chord = 2! * r * Sin(PI! / 10!)
h = .5 * Sqr(sPoly * sPoly - chord * chord)
For k = 0 To 4
ang = (2! * PI! * k) / 5!
VSet pv(k), r * Cos(ang), r * Sin(ang), h
Next
For k = 0 To 4
ang = (2! * PI! * k) / 5! + (PI! / 5!)
VSet pv(5 + k), r * Cos(ang), r * Sin(ang), -h
Next
o = 0
pfStart(0) = o: pfSize(0) = 5
For k = 0 To 4: pfIdx(o + k) = k: Next
o = o + 5
pfStart(1) = o: pfSize(1) = 5
pfIdx(o + 0) = 5 + 0
pfIdx(o + 1) = 5 + 4
pfIdx(o + 2) = 5 + 3
pfIdx(o + 3) = 5 + 2
pfIdx(o + 4) = 5 + 1
o = o + 5
f = 2
For i = 0 To 4
u0 = i
u1 = (i + 1) Mod 5
l0 = 5 + i
l1 = 5 + ((i + 1) Mod 5)
pfStart(f) = o: pfSize(f) = 3
pfIdx(o + 0) = u0: pfIdx(o + 1) = l0: pfIdx(o + 2) = u1
o = o + 3: f = f + 1
pfStart(f) = o: pfSize(f) = 3
pfIdx(o + 0) = u1: pfIdx(o + 1) = l0: pfIdx(o + 2) = l1
o = o + 3: f = f + 1
Next
EnsureFacesOutward pv(), pfStart(), pfSize(), pfIdx()
BuildDual pv(), pfStart(), pfSize(), pfIdx(), dv(), dfStart(), dfSize(), dfIdx()
EnsureFacesOutward dv(), dfStart(), dfSize(), dfIdx()
SquashLongestAxis dv(), D10_SQUASH!
edgeNow = MinEdgeLen!(dv(), dfStart(), dfSize(), dfIdx())
sc = DICE_EDGE! / edgeNow
ScaleVertices dv(), sc
BuildUVForFaces dv(), dfStart(), dfSize(), dfIdx(), 5, 0, tri(), uv(), triFace()
PrepareLabelsD10Tens dv(), dfStart(), dfSize(), dfIdx()
BuildAtlas atlasTex, 10, 5, 2, DIE_D10
End Sub
'===============================================================
' TABLE (mesh + texture)
'===============================================================
Sub BuildTable (tri() As Vertex3D, uv() As Vertex2D, tex As Long)
' rozmery v "svete" (ladis podle oka)
Dim As Single topW, topD, topTh
Dim As Single legW, legD, legH, inset
topW = 8.0!
topD = 5.0!
topTh = 0.25!
legW = 0.45!
legD = 0.45!
legH = 2.2!
inset = 0.55!
' 5 kvadru * 12 tri * 3 vrcholy = 180 vrcholu
ReDim tri(0 To 180 - 1) As Vertex3D
ReDim uv(0 To 180 - 1) As Vertex2D
MakeTableTexture tex
Dim outV As Long
outV = 0
' deska: model space -> horni plocha je v y=0, tloustka jde dolu do -topTh
AddBox tri(), uv(), outV, 0!, -topTh / 2!, 0!, topW, topTh, topD, -1 ' -1 = plst nahore
' nohy: visi zespodu desky dolu
Dim As Single x0, x1, z0, z1, yLegCenter
x0 = -topW / 2! + inset
x1 = topW / 2! - inset
z0 = -topD / 2! + inset
z1 = topD / 2! - inset
yLegCenter = -topTh - legH / 2!
AddBox tri(), uv(), outV, x0, yLegCenter, z0, legW, legH, legD, 0
AddBox tri(), uv(), outV, x1, yLegCenter, z0, legW, legH, legD, 0
AddBox tri(), uv(), outV, x0, yLegCenter, z1, legW, legH, legD, 0
AddBox tri(), uv(), outV, x1, yLegCenter, z1, legW, legH, legD, 0
End Sub
Sub MakeTableTexture (tex As Long)
' 256x256:
' - leva pulka (0..127) = zelene platno
' - prava pulka (128..255) = drevo
Dim As Long img, x, y
img = _NewImage(256, 256, 32)
Dim oldDest As Long
oldDest = _Dest
_Dest img
For y = 0 To 255
For x = 0 To 255
If x < 128 Then
' CLOTH: jemny gradient + mikro sum
Dim As Long g, r, b, nn
g = 115 + ((127 - Abs(64 - x)) \ 6) + ((127 - Abs(128 - y)) \ 14)
nn = ((x * 17 + y * 31) And 7) - 3
g = g + nn
If g < 60 Then g = 60
If g > 170 Then g = 170
r = g \ 4
b = g \ 3
PSet (x, y), _RGB32(r, g, b)
Else
' WOOD: pruhy + drobna variace
Dim As Long baze, stripe, rr, gg, bb, n2
stripe = ((y \ 6) And 1)
baze = 140 + stripe * 18
n2 = ((x * 11 + y * 23) And 15) - 8
baze = baze + (n2 \ 2)
rr = baze + 35: gg = baze + 10: bb = baze - 15
If rr > 255 Then rr = 255
If gg > 255 Then gg = 255
If bb < 0 Then bb = 0
PSet (x, y), _RGB32(rr, gg, bb)
End If
Next
Next
_Dest oldDest
tex = _CopyImage(img, 33)
_FreeImage img
End Sub
Sub AddBox (tri() As Vertex3D, uv() As Vertex2D, outV As Long, _
cx As Single, cy As Single, cz As Single, sx As Single, sy As Single, sz As Single, useClothTop As Long)
Dim As Single hx, hy, hz
Dim As Single x0, x1, y0, y1, z0, z1
hx = sx / 2!: hy = sy / 2!: hz = sz / 2!
x0 = cx - hx: x1 = cx + hx
y0 = cy - hy: y1 = cy + hy
z0 = cz - hz: z1 = cz + hz
' UV regiony v pixelech (zdrojova textura)
Dim As Single cu0, cv0, cu1, cv1
Dim As Single wu0, wv0, wu1, wv1
cu0 = 0!: cv0 = 0!: cu1 = 127!: cv1 = 127! ' cloth
wu0 = 128!: wv0 = 0!: wu1 = 255!: wv1 = 255! ' wood
' TOP (+Y) cloth pokud je to deska
If useClothTop Then
AddQuad tri(), uv(), outV, x0, y1, z0, x0, y1, z1, x1, y1, z1, x1, y1, z0, cu0, cv0, cu1, cv1
Else
AddQuad tri(), uv(), outV, x0, y1, z0, x0, y1, z1, x1, y1, z1, x1, y1, z0, wu0, wv0, wu1, wv1
End If
' BOTTOM (-Y)
AddQuad tri(), uv(), outV, x0, y0, z0, x1, y0, z0, x1, y0, z1, x0, y0, z1, wu0, wv0, wu1, wv1
' FRONT (+Z)
AddQuad tri(), uv(), outV, x0, y0, z1, x1, y0, z1, x1, y1, z1, x0, y1, z1, wu0, wv0, wu1, wv1
' BACK (-Z)
AddQuad tri(), uv(), outV, x0, y0, z0, x0, y1, z0, x1, y1, z0, x1, y0, z0, wu0, wv0, wu1, wv1
' RIGHT (+X)
AddQuad tri(), uv(), outV, x1, y0, z0, x1, y1, z0, x1, y1, z1, x1, y0, z1, wu0, wv0, wu1, wv1
' LEFT (-X)
AddQuad tri(), uv(), outV, x0, y0, z0, x0, y0, z1, x0, y1, z1, x0, y1, z0, wu0, wv0, wu1, wv1
End Sub
Sub AddQuad (tri() As Vertex3D, uv() As Vertex2D, outV As Long, _
ax As Single, ay As Single, az As Single, _
bx As Single, by As Single, bz As Single, _
cx As Single, cy As Single, cz As Single, _
dx As Single, dy As Single, dz As Single, _
u0 As Single, v0 As Single, u1 As Single, v1 As Single)
' mapovani:
' a=(u0,v1) b=(u1,v1) c=(u1,v0) d=(u0,v0)
' tri 1: a b c
tri(outV + 0).X = ax: tri(outV + 0).Y = ay: tri(outV + 0).Z = az
tri(outV + 1).X = bx: tri(outV + 1).Y = by: tri(outV + 1).Z = bz
tri(outV + 2).X = cx: tri(outV + 2).Y = cy: tri(outV + 2).Z = cz
uv(outV + 0).U = u0: uv(outV + 0).V = v1
uv(outV + 1).U = u1: uv(outV + 1).V = v1
uv(outV + 2).U = u1: uv(outV + 2).V = v0
outV = outV + 3
' tri 2: a c d
tri(outV + 0).X = ax: tri(outV + 0).Y = ay: tri(outV + 0).Z = az
tri(outV + 1).X = cx: tri(outV + 1).Y = cy: tri(outV + 1).Z = cz
tri(outV + 2).X = dx: tri(outV + 2).Y = dy: tri(outV + 2).Z = dz
uv(outV + 0).U = u0: uv(outV + 0).V = v1
uv(outV + 1).U = u1: uv(outV + 1).V = v0
uv(outV + 2).U = u0: uv(outV + 2).V = v0
outV = outV + 3
End Sub
Function MeshRadius! (tri() As Vertex3D)
Dim i As Long
Dim d As Single, best As Single
Dim x As Single, y As Single, z As Single
best = 0!
For i = LBound(tri) To UBound(tri)
x = tri(i).X: y = tri(i).Y: z = tri(i).Z
d = Sqr(x * x + y * y + z * z)
If d > best Then best = d
Next
MeshRadius! = best
End Function
Function MeshHalfExtent! (tri() As Vertex3D)
Dim i As Long
Dim best As Single, a As Single
best = 0!
For i = LBound(tri) To UBound(tri)
a = Abs(tri(i).X): If a > best Then best = a
a = Abs(tri(i).Y): If a > best Then best = a
a = Abs(tri(i).Z): If a > best Then best = a
Next
MeshHalfExtent! = best
End Function
Sub BuildUniqueVertsFromTri (tri() As Vertex3D, verts() As Vertex3D)
' z trojAshelnAkLZ udělA? unikA?tnA vrcholy (kvLZli fyzice; rychlejL?A neLl prochA?zet vL?echny tri)
Dim i As Long, j As Long, n As Long
Dim dx As Single, dy As Single, dz As Single
Dim eps2 As Single
eps2 = 0.0000001! ' (1e-3)^2 v mÄ›L™Atku scA©ny je aLl moc; tady jemnÄ›ji
ReDim verts(0 To 0) As Vertex3D
n = 0
For i = LBound(tri) To UBound(tri)
If n = 0 Then
verts(0) = tri(i)
n = 1
Else
For j = 0 To n - 1
dx = tri(i).X - verts(j).X
dy = tri(i).Y - verts(j).Y
dz = tri(i).Z - verts(j).Z
If dx * dx + dy * dy + dz * dz < eps2 Then Exit For
Next
If j = n Then
ReDim _Preserve verts(0 To n) As Vertex3D
verts(n) = tri(i)
n = n + 1
End If
End If
Next
End Sub
Sub BuildFaceNormalsFromTri (tri() As Vertex3D, triFace() As Long, faceCount As Long, faceN() As Vertex3D)
' vezme prvnA trojAshelnAk kaLldA© stÄ›ny a spoÄTAtA? lokA?lnA normA?lu
Dim f As Long, t As Long, b As Long
Dim a As Vertex3D, c As Vertex3D, d As Vertex3D
Dim ab As Vertex3D, ac As Vertex3D, n As Vertex3D
Dim got As Long
ReDim faceN(0 To faceCount - 1) As Vertex3D
For f = 0 To faceCount - 1
got = 0
For t = 0 To (UBound(triFace) - LBound(triFace))
If triFace(LBound(triFace) + t) = f Then
b = (LBound(tri) + t * 3)
a = tri(b + 0)
c = tri(b + 1)
d = tri(b + 2)
ab.X = c.X - a.X: ab.Y = c.Y - a.Y: ab.Z = c.Z - a.Z
ac.X = d.X - a.X: ac.Y = d.Y - a.Y: ac.Z = d.Z - a.Z
VCross ab, ac, n
VNorm n, n
faceN(f) = n
got = -1
Exit For
End If
Next
If got = 0 Then
faceN(f).X = 0!: faceN(f).Y = 1!: faceN(f).Z = 0!
End If
Next
End Sub
Sub InitBodyFromMesh (b As RigidBody, tri() As Vertex3D)
b.pos.X = 0!: b.pos.Y = 0!: b.pos.Z = 0!
b.vel.X = 0!: b.vel.Y = 0!: b.vel.Z = 0!
b.rot.X = 0!: b.rot.Y = 0!: b.rot.Z = 0!
b.angVel.X = 0!: b.angVel.Y = 0!: b.angVel.Z = 0!
b.radius = MeshRadius!(tri())
b.half = MeshHalfExtent!(tri()) ' "poloviÄTnA rozmÄ›r" (max |x|,|y|,|z|)
b.restFrames = 0
b.sleep = 0
End Sub
Sub SelectDieKind (k As Long, die As RigidBody)
Select Case k
Case KIND_D4
InitBodyFromMesh die, d4Tri()
Case KIND_D6
InitBodyFromMesh die, d6Tri()
Case KIND_D8
InitBodyFromMesh die, d8Tri()
Case KIND_D10
InitBodyFromMesh die, d10Tri()
Case KIND_D10T
InitBodyFromMesh die, d10TTri()
Case KIND_D12
InitBodyFromMesh die, d12Tri()
Case Else
InitBodyFromMesh die, d20Tri()
End Select
ResetThrow die, 0!, 1.6!, 0!
End Sub
Sub ResetThrow (b As RigidBody, x As Single, y As Single, z As Single)
b.pos.X = x: b.pos.Y = y: b.pos.Z = z
' lehk hod dopedu + dol to udl gravitace
b.vel.X = (Rnd * 2! - 1!) * 2.5!
b.vel.Y = 0!
b.vel.Z = (Rnd * 2! - 1!) * 2.0!
' nhodn orientace + rotace
b.rot.X = Rnd * 6.2831853!
b.rot.Y = Rnd * 6.2831853!
b.rot.Z = Rnd * 6.2831853!
b.angVel.X = (Rnd * 2! - 1!) * 8.0!
b.angVel.Y = (Rnd * 2! - 1!) * 8.0!
b.angVel.Z = (Rnd * 2! - 1!) * 8.0!
b.sleep = 0
b.restFrames = 0
End Sub
Sub AxesFromEuler (rx As Single, ry As Single, rz As Single, ax As Vertex3D, ay As Vertex3D, az As Vertex3D)
' R = Rz * Ry * Rx (stejn poad jako RenderMesh)
Dim cx As Single, sx As Single, cy As Single, sy As Single, cz As Single, sz As Single
cx = Cos(rx): sx = Sin(rx)
cy = Cos(ry): sy = Sin(ry)
cz = Cos(rz): sz = Sin(rz)
' sloupce matice = svtov smry loklnch os X,Y,Z
ax.X = cz * cy
ax.Y = sz * cy
ax.Z = -sy
ay.X = cz * sy * sx - sz * cx
ay.Y = sz * sy * sx + cz * cx
ay.Z = cy * sx
az.X = cz * sy * cx + sz * sx
az.Y = sz * sy * cx - cz * sx
az.Z = cy * cx
End Sub
Sub EulerFromAxes (ax As Vertex3D, ay As Vertex3D, az As Vertex3D, rx As Single, ry As Single, rz As Single)
' z os -> matice R, kde sloupce jsou ax, ay, az
' extrakce pro R = Rz*Ry*Rx:
' ry = asin(-R20), rx = atan2(R21,R22), rz = atan2(R10,R00)
Dim R00 As Single, R10 As Single, R20 As Single
Dim R21 As Single, R22 As Single
R00 = ax.X
R10 = ax.Y
R20 = ax.Z
R21 = ay.Z
R22 = az.Z
ry = _Asin(-R20)
Dim cy As Single
cy = Cos(ry)
If Abs(cy) > 1E-6 Then
rx = _Atan2(R21, R22)
rz = _Atan2(R10, R00)
Else
' gimbal fallback (vzcn)
rx = 0!
rz = _Atan2(-ay.X, ay.Y)
End If
End Sub
Sub RotateVecAroundAxis (v As Vertex3D, axis As Vertex3D, ang As Single, outV As Vertex3D)
' Rodrigues rotation: v' = v*c + (axisA—v)*s + axis*(axis·v)*(1-c)
Dim c As Single, s As Single, t As Single
Dim dot As Single
Dim cx As Single, cy As Single, cz As Single
c = Cos(ang)
s = Sin(ang)
t = 1! - c
dot = axis.X * v.X + axis.Y * v.Y + axis.Z * v.Z
' axisA—v
cx = axis.Y * v.Z - axis.Z * v.Y
cy = axis.Z * v.X - axis.X * v.Z
cz = axis.X * v.Y - axis.Y * v.X
outV.X = v.X * c + cx * s + axis.X * (dot * t)
outV.Y = v.Y * c + cy * s + axis.Y * (dot * t)
outV.Z = v.Z * c + cz * s + axis.Z * (dot * t)
End Sub
Sub SnapDieToTable (b As RigidBody, verts() As Vertex3D, faceN() As Vertex3D, tableTopY As Single)
' "hernA" dosednutA: vybere stÄ›nu, kterA? mAL™A nejvAc dolLZ, a jen ji jemnÄ› dorovnA? do roviny stolu.
Dim ax As Vertex3D, ay As Vertex3D, az As Vertex3D
Dim f As Long, best As Single, bottom As Long
Dim nL As Vertex3D, nW As Vertex3D
Dim dot As Single, ang As Single
Dim axis As Vertex3D, axisLen As Single
AxesFromEuler b.rot.X, b.rot.Y, b.rot.Z, ax, ay, az
bottom = LBound(faceN)
best = 1E+30
For f = LBound(faceN) To UBound(faceN)
nL = faceN(f)
nW.X = ax.X * nL.X + ay.X * nL.Y + az.X * nL.Z
nW.Y = ax.Y * nL.X + ay.Y * nL.Y + az.Y * nL.Z
nW.Z = ax.Z * nL.X + ay.Z * nL.Y + az.Z * nL.Z
If nW.Y < best Then best = nW.Y: bottom = f
Next
nL = faceN(bottom)
nW.X = ax.X * nL.X + ay.X * nL.Y + az.X * nL.Z
nW.Y = ax.Y * nL.X + ay.Y * nL.Y + az.Y * nL.Z
nW.Z = ax.Z * nL.X + ay.Z * nL.Y + az.Z * nL.Z
' chceme nW -> down (0,-1,0)
dot = -nW.Y
If dot > 1! Then dot = 1!
If dot < -1! Then dot = -1!
ang = _Acos(dot)
If ang > 0.0002! Then
' osa = nW A— down = (nW.Z, 0, -nW.X)
axis.X = nW.Z
axis.Y = 0!
axis.Z = -nW.X
axisLen = Sqr(axis.X * axis.X + axis.Z * axis.Z)
If axisLen > 1E-6 Then
axis.X = axis.X / axisLen
axis.Z = axis.Z / axisLen
Dim ax2 As Vertex3D, ay2 As Vertex3D, az2 As Vertex3D
RotateVecAroundAxis ax, axis, ang, ax2
RotateVecAroundAxis ay, axis, ang, ay2
RotateVecAroundAxis az, axis, ang, az2
ax = ax2: ay = ay2: az = az2
Dim rx As Single, ry As Single, rz As Single
EulerFromAxes ax, ay, az, rx, ry, rz
b.rot.X = rx: b.rot.Y = ry: b.rot.Z = rz
End If
End If
' dorovnej Y tak, aby nejniLlL?A vrchol sedÄ›l pL™esnÄ› na desce
Dim i As Long
Dim minOff As Single, offn As Single
minOff = 1E+30
For i = LBound(verts) To UBound(verts)
offn = ax.Y * verts(i).X + ay.Y * verts(i).Y + az.Y * verts(i).Z
If offn < minOff Then minOff = offn
Next
b.pos.Y = tableTopY - minOff
b.vel.X = 0!: b.vel.Y = 0!: b.vel.Z = 0!
b.angVel.X = 0!: b.angVel.Y = 0!: b.angVel.Z = 0!
End Sub
Sub StepDieVsTableGame (b As RigidBody, dt As Single, tableTopY As Single, verts() As Vertex3D, faceN() As Vertex3D)
' StabilnA "hernA" fyzika: LlA?dnA? raketovA? vÄ›da, jen aby to vypadalo dobL™e a neodlAtalo to do vesmAru.
Const G! = -9.0!
Const REST! = 0.26!
Const AIR_LIN! = 0.999!
Const AIR_ANG! = 0.999!
Const GROUND_LIN! = 0.88!
Const GROUND_ANG! = 0.92!
Const TIPK! = 6.0!
Const EPSC! = 0.0015!
Const VEL_MAX! = 25.0!
Const ANG_MAX! = 20.0!
Const REST_FRAMES& = 18
Dim ax As Vertex3D, ay As Vertex3D, az As Vertex3D
Dim i As Long
Dim wy As Single
Dim minY As Single, pene As Single
Dim inContact As Long
Dim cp As Vertex3D, cnt As Long
Dim rInv, wxT, wzT, bestY As Single
If b.sleep Then Exit Sub
' --- integrace
b.vel.Y = b.vel.Y + G! * dt
b.vel.X = b.vel.X * AIR_LIN!
b.vel.Z = b.vel.Z * AIR_LIN!
b.pos.X = b.pos.X + b.vel.X * dt
b.pos.Y = b.pos.Y + b.vel.Y * dt
b.pos.Z = b.pos.Z + b.vel.Z * dt
b.rot.X = b.rot.X + b.angVel.X * dt
b.rot.Y = b.rot.Y + b.angVel.Y * dt
b.rot.Z = b.rot.Z + b.angVel.Z * dt
b.angVel.X = b.angVel.X * AIR_ANG!
b.angVel.Y = b.angVel.Y * AIR_ANG!
b.angVel.Z = b.angVel.Z * AIR_ANG!
' bezpeÄTnostnA clamp (proti "odletu")
If b.vel.X > VEL_MAX! Then b.vel.X = VEL_MAX!
If b.vel.X < -VEL_MAX! Then b.vel.X = -VEL_MAX!
If b.vel.Y > VEL_MAX! Then b.vel.Y = VEL_MAX!
If b.vel.Y < -VEL_MAX! Then b.vel.Y = -VEL_MAX!
If b.vel.Z > VEL_MAX! Then b.vel.Z = VEL_MAX!
If b.vel.Z < -VEL_MAX! Then b.vel.Z = -VEL_MAX!
If b.angVel.X > ANG_MAX! Then b.angVel.X = ANG_MAX!
If b.angVel.X < -ANG_MAX! Then b.angVel.X = -ANG_MAX!
If b.angVel.Y > ANG_MAX! Then b.angVel.Y = ANG_MAX!
If b.angVel.Y < -ANG_MAX! Then b.angVel.Y = -ANG_MAX!
If b.angVel.Z > ANG_MAX! Then b.angVel.Z = ANG_MAX!
If b.angVel.Z < -ANG_MAX! Then b.angVel.Z = -ANG_MAX!
AxesFromEuler b.rot.X, b.rot.Y, b.rot.Z, ax, ay, az
' --- minY
minY = 1E+30
For i = LBound(verts) To UBound(verts)
wy = b.pos.Y + ax.Y * verts(i).X + ay.Y * verts(i).Y + az.Y * verts(i).Z
If wy < minY Then minY = wy
Next
inContact = 0
If minY < tableTopY Then
inContact = -1
' vyhoÄZ z penetrace
pene = tableTopY - minY
b.pos.Y = b.pos.Y + pene
' odraz jen pokud jde dolLZ
If b.vel.Y < 0! Then
b.vel.Y = -b.vel.Y * REST!
Else
b.vel.Y = b.vel.Y * 0.25!
End If
' tL™enA + Astlum rotace
b.vel.X = b.vel.X * GROUND_LIN!
b.vel.Z = b.vel.Z * GROUND_LIN!
b.angVel.X = b.angVel.X * GROUND_ANG!
b.angVel.Y = b.angVel.Y * GROUND_ANG!
b.angVel.Z = b.angVel.Z * GROUND_ANG!
ElseIf minY <= tableTopY + EPSC! Then
inContact = -1
End If
Dim BestN As Vertex3D, f As Long, nL As Vertex3D, nW As Vertex3D, tipScale As Single, LinSp As Single, angSp As Single, NeedFrames As Single
If inContact Then
' kontaktní "patch" (kolik vrcholu je dole)
cp.X = 0!: cp.Y = 0!: cp.Z = 0!: cnt = 0
For i = LBound(verts) To UBound(verts)
wy = b.pos.Y + ax.Y * verts(i).X + ay.Y * verts(i).Y + az.Y * verts(i).Z
If wy <= tableTopY + EPSC! Then
cp.X = cp.X + (b.pos.X + ax.X * verts(i).X + ay.X * verts(i).Y + az.X * verts(i).Z)
cp.Y = cp.Y + wy
cp.Z = cp.Z + (b.pos.Z + ax.Z * verts(i).X + ay.Z * verts(i).Y + az.Z * verts(i).Z)
cnt = cnt + 1
End If
Next
If cnt < 1 Then cnt = 1
cp.X = cp.X / cnt: cp.Y = cp.Y / cnt: cp.Z = cp.Z / cnt
' "rolling coupling": když se to hýbe po stole, at se to i otácí stejným smerem
rInv = 1! / (b.radius + 0.0001!)
wxT = -b.vel.Z * rInv
wzT = b.vel.X * rInv
b.angVel.X = b.angVel.X * 0.70! + wxT * 0.30!
b.angVel.Z = b.angVel.Z * 0.70! + wzT * 0.30!
' ------------------------------------------------------------
' TIP ASSIST (OPRAVA + zesílení pro hranu/vrchol)
' Najdi normálu té plochy, která mírí nejvíc dolu (min Y).
' OSA pro preklápení: (n.Z, 0, -n.X) => rotace smerem k "face-down"
' ------------------------------------------------------------
bestY = 1E+30
BestN.X = 0!: BestN.Y = -1!: BestN.Z = 0!
For f = LBound(faceN) To UBound(faceN)
nL = faceN(f)
nW.X = ax.X * nL.X + ay.X * nL.Y + az.X * nL.Z
nW.Y = ax.Y * nL.X + ay.Y * nL.Y + az.Y * nL.Z
nW.Z = ax.Z * nL.X + ay.Z * nL.Y + az.Z * nL.Z
If nW.Y < bestY Then
bestY = nW.Y
BestN = nW
End If
Next
If Abs(b.vel.X) < 2! And Abs(b.vel.Z) < 2! And Abs(b.vel.Y) < 2! Then
tipScale = 1!
If cnt = 1 Then tipScale = 3.0!
If cnt = 2 Then tipScale = 1.8!
b.angVel.X = b.angVel.X + (BestN.Z * TIPK! * tipScale) * dt
b.angVel.Z = b.angVel.Z + (-BestN.X * TIPK! * tipScale) * dt
End If
' ------------------------------------------------------------
' ANTI-STUCK / GAME SLEEP
' - drív jsi spal jen pro cnt>=2 => vrchol nikdy!
' - tady: když je to dlouho líný a porád kontakt, po case to natvrdo snapne.
' ------------------------------------------------------------
LinSp = Abs(b.vel.X) + Abs(b.vel.Y) + Abs(b.vel.Z)
angSp = Abs(b.angVel.X) + Abs(b.angVel.Y) + Abs(b.angVel.Z)
If LinSp < 0.18! And angSp < 0.35! Then
b.restFrames = b.restFrames + 1
Else
b.restFrames = 0
End If
' prahy podle typu opory: plocha rychle, hrana stredne, vrchol nejpozdeji
NeedFrames = 0
If cnt >= 4 Then
NeedFrames = 14
ElseIf cnt >= 2 Then
NeedFrames = 24
Else
NeedFrames = 42
End If
If b.restFrames >= NeedFrames Then
b.vel.X = 0!: b.vel.Y = 0!: b.vel.Z = 0!
b.angVel.X = 0!: b.angVel.Y = 0!: b.angVel.Z = 0!
SnapDieToTable b, verts(), faceN(), tableTopY
b.sleep = -1
End If
End If
End Sub
Sub ClampToTableTopRect (b As RigidBody, halfW As Single, halfD As Single)
' okraje stolu: jednoduchA? "mantinel", aby kostka neodjela do z-depth pekla
Dim xMin As Single, xMax As Single, zMin As Single, zMax As Single
Dim m As Single
m = b.radius
xMin = -halfW + m: xMax = halfW - m
zMin = -halfD + m: zMax = halfD - m
If b.pos.X < xMin Then b.pos.X = xMin: If b.vel.X < 0! Then b.vel.X = -b.vel.X * 0.25!
If b.pos.X > xMax Then b.pos.X = xMax: If b.vel.X > 0! Then b.vel.X = -b.vel.X * 0.25!
If b.pos.Z < zMin Then b.pos.Z = zMin: If b.vel.Z < 0! Then b.vel.Z = -b.vel.Z * 0.25!
If b.pos.Z > zMax Then b.pos.Z = zMax: If b.vel.Z > 0! Then b.vel.Z = -b.vel.Z * 0.25!
' lehkA© tlumenA po kontaktu s mantinelem
b.vel.X = b.vel.X * 0.95!
b.vel.Z = b.vel.Z * 0.95!
b.angVel.Y = b.angVel.Y * 0.90!
End Sub
This is one of those little programs which absolutely blows me away. I didn't create it, @Petr did, but it's hidden in the depths of a "Help Me" topic and likely to get lost and forgotten. I don't want to see that happen at all, so I'm posting it here for highlight and future reference, to see if I can sort out how to plug this into some of my own programs in the future. This is absolutely amazing work and everyone needs to keep a copy of this somewhere on their PC just to make certain if it's ever lost or the forums crash, or whatnot, fifty people can step forward and reload it back to the net for others to study and make use of.
