 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
hhr
Anmeldungsdatum: 15.07.2020
Beiträge: 117
|
 Verfasst am: 14.03.2025, 22:37 Titel: |
 |
|
Die beigefügte exe-Datei funktioniert in meinem Rechner nicht.
Wenn ich selbst kompiliere, mit fbc32 oder fbc64, funktioniert es. |
|
| Nach oben |
|
 |
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 14.03.2025, 22:51 Titel: |
|
|
| hhr hat Folgendes geschrieben: | Die beigefügte exe-Datei funktioniert in meinem Rechner nicht.
Wenn ich selbst kompiliere, mit fbc32 oder fbc64, funktioniert es. |
Das kann sein, denn ich habe mit den Parametern:
-gen gcc -Wc -Ofast,-march=native,-funroll-loops,-mfpmath=sse
als x64 kompiliert und es kann sein, dass der Code speziell für meine Intel CPU erstellt wurde.
Hast du einen AMD Prozessor?
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
hhr
Anmeldungsdatum: 15.07.2020
Beiträge: 117
|
| Verfasst am: 14.03.2025, 23:12 Titel: |
|
|
| Mein Rechner hat Pentium Dual-Core CPU E5300 2x2,6 GHz. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 15.03.2025, 00:07 Titel: |
|
|
| hhr hat Folgendes geschrieben: | | Mein Rechner hat Pentium Dual-Core CPU E5300 2x2,6 GHz. |
Meine CPU ist: Intel Core Ultra 5 135U.
Anscheinend gibt es Befehle, die nicht von deiner "älteren" CPU unterstützt werden, wenn ich mit diesen Parametern kompiliere.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 13.08.2025, 22:35 Titel: Einfache 2D-Kugelkollision – Billard-Eröffnung 5 |
|
|
Siehe nächsten Beitrag
_________________
Gruß
UEZ
Zuletzt bearbeitet von UEZ am 07.09.2025, 15:12, insgesamt 2-mal bearbeitet |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 15.08.2025, 12:22 Titel: Re: Einfache 2D-Kugelkollision – Billard-Eröffnung 5 |
|
|
Eine kleine Billard-Eröffnungssimulation mit Kollisionscheck und Texture Mapping. 
| Code: |
'Coded by UEZ build 2025-09-06 beta
#cmdline "-gen gcc -Wc -Ofast -Wc -march=native -Wc -funroll-loops -Wc -mfpmath=sse"
#include "fbgfx.bi"
#include "crt/math.bi"
Using FB
#define _pi 3.141592653589793238462643383279
#define _3pi2 4.712388980384689857693965074919
#define _2pi 6.283185307179586476925286766559
#define _pi2 1.570796326794896619231321691639
#define PixelSetScrn(_x, _y, colour) *CPtr(ULong Ptr, pScrn + (_y) * pitch + (_x) Shl 2) = (colour)
Const iTableColor = &hFF185539, iTableLineColor = &hFF286549
Dim Shared As Long pitchS, bppS
Dim Shared As Any Ptr pixelS
Dim Shared As Any Ptr pScrn
Dim Shared As Long pitch
Dim Shared As Long w, h, h2
Union Farbe '...'
argb As ULong
Type '...'
As UByte b, g, r, a 'little-endian byte order
End Type
End Union
Function _ASM_Cos6th2 Naked cdecl(ByVal fX As Double) As Double 'by Eukalyptus '...'
'By Eukalyptus - modified by srvaldez
Asm
'if FB-32-bit, then load fx from stack, else it's already in xmm0
'ebx/rbx needs to be preserved, not sure about ecx/rcx
#ifndef __FB_64BIT__
lea eax, [esp+4]
push ebx
push ecx
movq xmm0, [eax]
#else
push rbx
push rcx
#endif
mulsd xmm0, [1f]
addsd xmm0, [3f]
movd ebx, xmm0
add ebx, 0x40000000 'SinToCos
lea eax, [ebx * 2 + &h80000000]
sar eax, 2
imul eax
sar ebx, 31
lea eax, [edx * 2 - &h70000000]
lea ecx, [edx * 8 + edx - &h24000000]
imul edx
xor ecx, ebx
lea eax, [edx * 8 + edx + &h44A00000]
imul ecx
cvtsi2sd xmm0, edx
mulsd xmm0, [2f]
'if FB-32-bit, then transfer xmm0 into fpu, else we are done
'restore saved registers
#ifndef __FB_64BIT__
pop ecx
pop ebx
movq [esp - 12], xmm0
fld qword ptr [esp - 12]
#else
pop rcx
pop rbx
#endif
ret
1: .Double 683565275.57643158
2: .Double -0.0000000061763971109087229
3: .Double 6755399441055744.0
End Asm
End Function
Function _ASM_Sin6th2 Naked cdecl(ByVal fX As Double) As Double 'by Eukalyptus '...'
'By Eukalyptus - modified by srvaldez
Asm
'if FB-32-bit, then load fx from stack, else it's already in xmm0
'ebx/rbx needs to be preserved, not sure about ecx/rcx
#ifndef __FB_64BIT__
lea eax, [esp + 4]
push ebx
push ecx
movq xmm0, [eax]
#else
push rbx
push rcx
#endif
mulsd xmm0, [1f]
addsd xmm0, [3f]
movd ebx, xmm0
lea eax, [ebx * 2 + &h80000000]
sar eax, 2
imul eax
sar ebx, 31
lea eax, [edx * 2 - &h70000000]
lea ecx, [edx * 8 + edx - &h24000000]
imul edx
xor ecx, ebx
lea eax, [edx * 8 + edx + &h44A00000]
imul ecx
cvtsi2sd xmm0, edx
mulsd xmm0, [2f]
'if FB-32-bit, then transfer xmm0 into fpu, else we are done
'restore saved registers
#ifndef __FB_64BIT__
pop ecx
pop ebx
movq [esp-12], xmm0
fld qword ptr [esp-12]
#else
pop rcx
pop rbx
#endif
ret
1: .Double 683565275.57643158
2: .Double -0.0000000061763971109087229
3: .Double 6755399441055744.0
End Asm
End Function
'--- helper: clamp ---
Function Clamp01(v As Double) As Double '...'
If v < 0 Then Return 0
If v > 1 Then Return 1
Return v
End Function
Function Clamp(value As Double, min_val As Double, max_val As Double) As Double '...'
Return IIf(value < min_val, min_val, IIf(value > max_val, max_val, value))
End Function
'--- helper: blend ARGB (srcArgb over dstArgb) with alpha in [0..1] ---
Function BlendARGB(src As ULong, dst As ULong, a As Double) As ULong '...'
Dim As Farbe s, d, o
s.argb = src
d.argb = dst
'effective alpha: combine src alpha and passed alpha
Dim As Double srcAlpha = (s.a / 255.0) * Clamp01(a)
Dim As Double outA = srcAlpha + (d.a / 255.0) * (1 - srcAlpha)
If outA <= 0 Then Return 0
o.a = CUByte(outA * 255 + 0.5)
o.r = CUByte(s.r * srcAlpha + d.r * (1 - srcAlpha) + 0.5)
o.g = CUByte(s.g * srcAlpha + d.g * (1 - srcAlpha) + 0.5)
o.b = CUByte(s.b * srcAlpha + d.b * (1 - srcAlpha) + 0.5)
Return o.argb
End Function
'--- draw anti-aliased circle outline ---
Sub DrawAACircleOutline(cx As Double, cy As Double, radius As Double, col As ULong, thickness As Double = 1.5) '...'
'thickness: width of the soft edge in pixels (e.g. 1.0..2.5)
Dim As Long x0 = floor(cx - radius - thickness)
Dim As Long x1 = ceil (cx + radius + thickness)
Dim As Long y0 = floor(cy - radius - thickness)
Dim As Long y1 = ceil (cy + radius + thickness)
Dim As Long xi, yi
Dim As Double dx, dy, dist, edgeDist, alpha
Dim As ULong Ptr pPix
Dim As ULong dstCol, outCol
'clip to screen
If x0 < 0 Then x0 = 0
If y0 < 0 Then y0 = 0
If x1 > w - 1 Then x1 = w - 1
If y1 > h - 1 Then y1 = h - 1
For yi = y0 To y1
For xi = x0 To x1
dx = xi + 0.5 - cx
dy = yi + 0.5 - cy
dist = Sqr(dx*dx + dy*dy)
'edgeDist: negative inside, positive outside; we want a band around radius
edgeDist = Abs(dist - radius)
If edgeDist <= thickness Then
'compute alpha: 1.0 at exact edge (or inside), 0 at distance==thickness
'use linear falloff; you can use smootherstep if you want
alpha = 1.0 - (edgeDist / thickness)
alpha = Clamp01(alpha)
'fetch dest pixel
pPix = pScrn + yi * pitch + xi Shl 2
dstCol = pPix[0]
outCol = BlendARGB(col, dstCol, alpha)
'write pixel
If (xi >= 0 AndAlso xi <= w - 1 AndAlso yi >= 0 AndAlso yi <= h - 1) Then PixelSetScrn(xi, yi, outCol)
End If
Next
Next
End Sub
'define a vector type for 3D coordinates
Type vec3 '...'
As Double x, y, z
End Type
'define a rotation matrix for 3D transformations
Type Matrix3x3 '...'
m(2, 2) As Double
End Type
'helper function to create an identity matrix
Function CreateIdentityMatrix() As Matrix3x3 '...'
Dim matrix As Matrix3x3
matrix.m(0, 0) = 1 : matrix.m(0, 1) = 0 : matrix.m(0, 2) = 0
matrix.m(1, 0) = 0 : matrix.m(1, 1) = 1 : matrix.m(1, 2) = 0
matrix.m(2, 0) = 0 : matrix.m(2, 1) = 0 : matrix.m(2, 2) = 1
Return matrix
End Function
'helper function to create a rotation matrix around the X-axis
Function CreateRotationX(angle As Double) As Matrix3x3 '...'
Dim matrix As Matrix3x3 = CreateIdentityMatrix()
Dim As Single ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2(angle)
matrix.m(1, 1) = ca : matrix.m(1, 2) = -sa
matrix.m(2, 1) = sa : matrix.m(2, 2) = ca
Return matrix
End Function
'helper function to create a rotation matrix around the Y-axis
Function CreateRotationY(angle As Double) As Matrix3x3 '...'
Dim matrix As Matrix3x3 = CreateIdentityMatrix()
Dim As Single ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2(angle)
matrix.m(0, 0) = ca : matrix.m(0, 2) = sa
matrix.m(2, 0) = -sa : matrix.m(2, 2) = ca
Return matrix
End Function
'helper function to create a rotation matrix around the Z-axis
Function CreateRotationZ(angle As Double) As Matrix3x3 '...'
Dim matrix As Matrix3x3 = CreateIdentityMatrix()
Dim As Single ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2(angle)
matrix.m(0, 0) = ca : matrix.m(0, 1) = -sa
matrix.m(1, 0) = sa : matrix.m(1, 1) = ca
Return matrix
End Function
'helper function to transform a vector with a matrix
Function TransformVector(v As vec3, m As Matrix3x3) As vec3 '...'
Dim result As vec3
result.x = v.x * m.m(0, 0) + v.y * m.m(0, 1) + v.z * m.m(0, 2)
result.y = v.x * m.m(1, 0) + v.y * m.m(1, 1) + v.z * m.m(1, 2)
result.z = v.x * m.m(2, 0) + v.y * m.m(2, 1) + v.z * m.m(2, 2)
Return result
End Function
'function to multiply two matrices
Function MultiplyMatrix(A As Matrix3x3, B As Matrix3x3) As Matrix3x3 '...'
Dim result As Matrix3x3
Dim As Byte i, j, k
For i = 0 To 2
For j = 0 To 2
result.m(i, j) = 0
For k = 0 To 2
result.m(i, j) += A.m(i, k) * B.m(k, j)
Next
Next
Next
Return result
End Function
Function CreateRotationMatrix(ax As Double, ay As Double, az As Double, angle As Double) As Matrix3x3 '...'
Dim matrix As Matrix3x3
Dim c As Double = _ASM_Cos6th2(angle)
Dim s As Double = _ASM_Sin6th2(angle)
Dim t As Double = 1 - c
'normalize the axis (ax, ay, az)
Dim axisLength As Double = Sqr(ax * ax + ay * ay + az * az)
If axisLength = 0 Then Return CreateIdentityMatrix() 'if axis is 0, return identical matrix
ax /= axisLength
ay /= axisLength
az /= axisLength
matrix.m(0, 0) = t * ax * ax + c
matrix.m(0, 1) = t * ax * ay - s * az
matrix.m(0, 2) = t * ax * az + s * ay
matrix.m(1, 0) = t * ax * ay + s * az
matrix.m(1, 1) = t * ay * ay + c
matrix.m(1, 2) = t * ay * az - s * ax
matrix.m(2, 0) = t * ax * az - s * ay
matrix.m(2, 1) = t * ay * az + s * ax
matrix.m(2, 2) = t * az * az + c
Return matrix
End Function
'bilinear texture sampling (ARGB)
Function SampleTextureBilinear( tex As Any Ptr, texW As Integer, texH As Integer, _ '...'
pitch As Integer, bpp As Integer, pixelPtr As Any Ptr, _
u As Double, v As Double) As ULong
Dim As Double fx = (u - floor(u)) * texW, fy = (v - floor(v)) * texH
'integer parts
Dim As Long x0 = floor(fx), y0 = floor(fy), x1 = x0 + 1, y1 = y0 + 1
x1 = IIf(x1 < 0, 0, IIf(x1 > texW - 1, texW - 1, x1))
y1 = IIf(y1 < 0, 0, IIf(y1 > texH - 1, texH - 1, y1))
'fractional parts
Dim As Double tx = fx - x0, ty = fy - y0
Dim As Farbe c00, c10, c01, c11, cx0, cx1, outC
Dim As ULong p1 = y0 * pitch, p2 = y1 * pitch, p3 = x0 * bpp, p4 = x1 * bpp
'fetch 4 neighbours
c00.argb = *Cast(ULong Ptr, pixelPtr + p1 + p3)
c10.argb = *Cast(ULong Ptr, pixelPtr + p1 + p4)
c01.argb = *Cast(ULong Ptr, pixelPtr + p2 + p3)
c11.argb = *Cast(ULong Ptr, pixelPtr + p2 + p4)
'interpolate horizontally
cx0.a = c00.a + (c10.a - c00.a) * tx
cx0.r = c00.r + (c10.r - c00.r) * tx
cx0.g = c00.g + (c10.g - c00.g) * tx
cx0.b = c00.b + (c10.b - c00.b) * tx
cx1.a = c01.a + (c11.a - c01.a) * tx
cx1.r = c01.r + (c11.r - c01.r) * tx
cx1.g = c01.g + (c11.g - c01.g) * tx
cx1.b = c01.b + (c11.b - c01.b) * tx
'interpolate vertically
outC.a = cx0.a + (cx1.a - cx0.a) * ty
outC.r = cx0.r + (cx1.r - cx0.r) * ty
outC.g = cx0.g + (cx1.g - cx0.g) * ty
outC.b = cx0.b + (cx1.b - cx0.b) * ty
Return outC.argb
End Function
'maps a source image onto a sphere with lighting and rotation
Sub MapImage2Sphere5(px As Double, py As Double, radius As Double, pSourceImage As Any Ptr, ByRef matCombined As Matrix3x3) '...'
Dim As Long pitchS, bppS, texW, texH, lx, ly
Dim As Any Ptr pixelS
ImageInfo(pSourceImage, texW, texH, bppS, pitchS, pixelS)
Dim As Double x, y, z, theta, phi, dist, edgeAlpha, u, v, edgeWidth = radius * 0.063, dotProduct, lightFactor
Dim As ULong mappedColor, outCol
Dim As vec3 spherePoint, normal
Dim As Farbe iCol
'the light source is now positioned directly above the center of the sphere.
'the vector (0, 0, 1) points directly out of the screen.
Dim As vec3 lightDir
lightDir.x = 0.0
lightDir.y = 0.0
lightDir.z = 1.0
For y = -radius To radius
For x = -radius To radius
dist = Sqr(x * x + y * y)
If dist <= radius Then
z = Sqr(radius * radius - (x * x + y * y))
'normal vector in the local coordinate system of the sphere.
'this vector is NOT rotated, so the lighting remains static.
normal.x = x / radius
normal.y = y / radius
normal.z = z / radius
'calculate the lighting factor
dotProduct = normal.x * lightDir.x + normal.y * lightDir.y + normal.z * lightDir.z
lightFactor = IIf(dotProduct > 0, dotProduct, 0)
lightFactor += 0.3 'Add ambient light
'create a spherePoint for texture lookup and apply rotation to it
spherePoint.x = x
spherePoint.y = y
spherePoint.z = z
spherePoint = TransformVector(spherePoint, matCombined)
'convert spherical coordinates to [0,1] UV coordinates
theta = Atan2(spherePoint.y, spherePoint.x)
phi = Atan2(Sqr(spherePoint.x * spherePoint.x + spherePoint.y * spherePoint.y), spherePoint.z)
u = (theta + _pi) / _2pi
v = phi / _pi
'bilinear texture sampling
mappedColor = SampleTextureBilinear(pSourceImage, texW, texH, pitchS, bppS, pixelS, u, -v)
'apply the lighting effect
iCol.argb = mappedColor
With iCol
.r = Clamp(.r * lightFactor, 0, 255)
.g = Clamp(.g * lightFactor, 0, 255)
.b = Clamp(.b * lightFactor, 0, 255)
End With
mappedColor = iCol.argb
'anti-aliasing for the edge
If dist > radius - edgeWidth Then
edgeAlpha = Clamp01((radius - dist) / edgeWidth)
outCol = BlendARGB(mappedColor, iTableColor, edgeAlpha)
Else
outCol = mappedColor
End If
'draw the pixel with screen clipping
lx = px + x
ly = py + y
If (lx >= 0 AndAlso lx < w AndAlso ly >= 0 AndAlso ly < h) Then
PixelSetScrn(lx, ly, outCol)
End If
End If
Next
Next
End Sub
Function _Dist(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Boolean '...'
Dim As Double xd = x2 - x1, yd = y2 - y1
Return Sqr(xd * xd + yd * yd) < (r1 + r2)
End Function
Function Regulate(ByVal MyFps As Long, ByRef fps As UShort) As Long 'code by dodicat '...'
Static As Double timervalue, _lastsleeptime, t3, frames
Var t = Timer
frames += 1
If (t - t3) >= 1 Then t3 = t : fps = frames : frames = 0
Var sleeptime = _lastsleeptime + ((1 / MyFps) - t + timervalue) * 1000
If sleeptime < 1 Then sleeptime = 1
_lastsleeptime = sleeptime
timervalue = t
Return sleeptime
End Function
ScreenInfo w, h
w = Int(w * 0.95)
h = w Shr 1
h2 = h Shr 1
ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFF, iTableColor
pScrn = ScreenPtr()
ScreenInfo , , , , pitch
Randomize, 5
Type vecBalls
As Double x, y, vx, vy, d, r, m
As ULong c, c2
As Matrix3x3 rotMatrix
End Type
'real-world dimensions
Const table_width_m = 2.54
Const table_height_m = 1.27
Const ball_diameter_m = 0.05715
Const ball_mass_kg = 0.17
'adjustable scale factor for visibility (1.0 = realistic)
Const ball_scale_factor = 1.2
'Scale calculations
Dim As Double pixels_per_meter = w / table_width_m
Dim As Double BallDiameter = ball_diameter_m * pixels_per_meter * ball_scale_factor
Dim As UShort Ballradius = BallDiameter \ 2
'physics constants
Const PHYSICS_FPS = 120 'physics updates per second
Const RENDER_FPS = 60 'target rendering frames per second
Const DECEL_MPS2 = 0.35 'rolling resistance equivalent
Dim As Double friction = 1.0 - (DECEL_MPS2 / PHYSICS_FPS)
Const iBALLS = 16, BALLS_ROWS = 5, BALLS_COLS = 5
Dim As Double dx, dy, dist, nx, ny, rvx, rvy, rvdotn, impulse, overlap, mx, my, t1, t2, w23 = w * 2 / 3
Dim As Long i, j, bc, x, y, q = (Ballradius Mod 4), px, py
Ballradius = Ballradius + IIf(q < 2, -q, 4 - q) 'ball radius must be divisible by 4, otherwise graphics errors will occur during initialization.
Dim As Long Balls_Offset_x = w / 8, Balls_Offset_y = h2 - (BALLS_COLS - 1) * Ballradius, _
Row_Offset_x = BallDiameter, Row_Offset_y = BallDiameter, U = BallDiameter * _pi
Dim As vecBalls aBalls(iBALLS - 1)
Dim As Any Ptr pBalls(iBALLS - 1)
Dim As UShort iW = 310, iH = 156
For i = 1 To iBALLS - 1
pBalls(i - 1) = ImageCreate(iW, iH, 0, 32)
BLoad(ExePath & "\" & Str(i) & ".bmp", pBalls(i - 1))
Next
Dim As Boolean rndTexAngle = True, bReset = False
Dim As Double _ax, _ay, _az, _ln, _ang
#macro ResetBalls() '...'
bc = 0
'arrange billiard balls on the table
For y = 0 To BALLS_ROWS - 1
For x = y To 0 Step -1
If rndTexAngle Then
_ax = Rnd() * 2 - 1
_ay = Rnd() * 2 - 1
_az = Rnd() * 2 - 1
_ln = Sqr(_ax * _ax + _ay * _ay + _az * _az)
If _ln = 0 Then _ax = 1 : _ay = 0 : _az = 0 : _ln = 1
_ax /= _ln : _ay /= _ln : _az /= _ln
_ang = Rnd() * _2pi
EndIf
With aBalls(bc)
.vx = 0
.vy = 0
.r = Ballradius
.d = BallDiameter
.x = Balls_Offset_x + x * (Row_Offset_x - Ballradius / 4)
.y = Balls_Offset_y + y * Row_Offset_y - Ballradius * x - 1
.m = ball_mass_kg
.rotMatrix = IIf(rndTexAngle, CreateRotationMatrix(_ax, _ay, _az, _ang), CreateIdentityMatrix())
End With
bc += 1
Next
Next
bc = iBALLS - 1
With aBalls(bc) 'cue ball
.vx = -Ballradius - Rnd() * Ballradius * ball_mass_kg 'power of cue ball
.vy = (Rnd() - 0.5)
.r = Ballradius
.d = BallDiameter
.x = w23 + BallDiameter - .vx
.y = h2 + Rnd() - 0.5
.c = &hFFFEFCFF
.c2 = &h40101080
.m = ball_mass_kg
End With
#endmacro
ResetBalls()
Dim As Long mmx, mmy, mmb, clip
Dim As Double dxMove, dyMove, distMove, ax, ay, az, angle, c, s, t
Dim As Matrix3x3 rotStep
Const PHYSICS_DT = 1.0 / PHYSICS_FPS
Const RENDER_DT = 1.0 / RENDER_FPS
Dim As Double lastTime = Timer, lastRender = Timer
Dim As Double accumPhysics = 0.0, frameStart, frameEnd, deltaTime
Dim As UShort frameCount = 0, fpsRounded
Dim As Double currentFPS = 0, fpsTimer = Timer
Dim As String fpsText
Dim As Double lightX, lightY, lightZ, dotProduct, lightFactor
Dim As ULong illuminatedColor
Dim As vec3 normal, lightDir
Dim As Farbe iCol2
Do
GetMouse(mmx, mmy, , mmb, clip)
If (mmb And 1) And clip = 0 Then
ResetBalls()
bReset = True
End If
frameStart = Timer
deltaTime = frameStart - lastTime
lastTime = frameStart
'this will run the physics step at fixed intervals (PHYSICS_DT)
accumPhysics += deltaTime
While accumPhysics >= PHYSICS_DT
For i = 0 To iBALLS - 1 '...'
With aBalls(i)
'apply movement
.x += .vx
.y += .vy
'collision with border edges
If .x > w - 1 - .r Then .vx = -.vx : .x = w - 1 - .r
If .x < .r Then .vx = -.vx : .x = .r
If .y > h - 1 - .r Then .vy = -.vy : .y = h - 1 - .r
If .y < .r Then .vy = -.vy : .y = .r
'collision between balls
For j = i + 1 To iBALLS - 1
If _Dist(.x, .y, .r, aBalls(j).x, aBalls(j).y, aBalls(j).r) Then '...'
dx = aBalls(j).x - .x
dy = aBalls(j).y - .y
dist = Sqr(dx * dx + dy * dy)
nx = dx / dist
ny = dy / dist
rvx = aBalls(j).vx - .vx
rvy = aBalls(j).vy - .vy
rvdotn = rvx * nx + rvy * ny
impulse = 2 * rvdotn / (.m + aBalls(j).m)
t1 = impulse * aBalls(j).m
.vx += t1 * nx
.vy += t1 * ny
t2 = impulse * .m
aBalls(j).vx -= t2 * nx
aBalls(j).vy -= t2 * ny
overlap = (.r + aBalls(j).r) - dist
t1 = overlap / dist
mx = dx * t1
my = dy * t1
t1 = mx / 2
t2 = my / 2
.x -= t1
.y -= t2
aBalls(j).x += t1
aBalls(j).y += t2
End If
Next
'update rotation based on current movement
dxMove = .vx
dyMove = .vy
distMove = Sqr(dxMove * dxMove + dyMove * dyMove)
'threshold for ignoring tiny movements.
If distMove > 0.001 Then '...'
ax = dyMove / distMove
ay = -dxMove / distMove
az = 0
angle = distMove / .r
c = _ASM_Cos6th2(angle)
s = _ASM_Sin6th2(angle)
t = 1 - c
rotStep.m(0, 0) = t * ax * ax + c
rotStep.m(0, 1) = t * ax * ay - s * az
rotStep.m(0, 2) = t * ax * az + s * ay
rotStep.m(1, 0) = t * ay * ax + s * az
rotStep.m(1, 1) = t * ay * ay + c
rotStep.m(1, 2) = t * ay * az - s * ax
rotStep.m(2, 0) = t * az * ax - s * ay
rotStep.m(2, 1) = t * az * ay + s * ax
rotStep.m(2, 2) = t * az * az + c
.rotMatrix = MultiplyMatrix(.rotMatrix, rotStep)
End If
'apply friction
.vx *= friction
.vy *= friction
End With
Next
'decrease accumulated time by one physics step
accumPhysics -= PHYSICS_DT
Wend
'only render if enough time has passed since last render
If (frameStart - lastRender) >= RENDER_DT Then
Cls
Circle (w23 - 2, h2), h2 Shr 1, iTableLineColor, _3pi2, _pi2
Line (w23 - 1, 0) - (w23 + 1, h), iTableLineColor, BF
For i = 0 To iBALLS - 1 '...'
With aBalls(i)
If i < iBALLS - 1 Then
MapImage2Sphere5(.x, .y, .r, pBalls(i), .rotMatrix)
Else
'Draw the white cue ball with lighting effect
'Here we draw a "texture-less" sphere, so we have to manually apply lighting
'Define a fixed light direction
lightDir.x = 0.0
lightDir.y = 0.0
lightDir.z = 1.0
'Loop through the pixels of the ball to apply lighting
For lightY = -.r To .r
For lightX = -.r To .r
If lightX * lightX + lightY * lightY <= .r * .r Then
lightZ = Sqr(.r * .r - (lightX * lightX + lightY * lightY))
'Calculate the normal vector for this pixel
normal.x = lightX / .r
normal.y = lightY / .r
normal.z = lightZ / .r
'Calculate the lighting factor
dotProduct = normal.x * lightDir.x + normal.y * lightDir.y + normal.z * lightDir.z
lightFactor = IIf(dotProduct > 0, dotProduct, 0)
lightFactor += 0.3 'Add ambient light
'Apply lighting to the base color
iCol2.argb = .c
With iCol2
.r = Clamp(.r * lightFactor, 0, 255)
.g = Clamp(.g * lightFactor, 0, 255)
.b = Clamp(.b * lightFactor, 0, 255)
End With
illuminatedColor = iCol2.argb
'Draw the pixel
px = .x + lightX
py = .y + lightY
If px > - 1 AndAlso px < w AndAlso py > -1 And py < h Then PixelSetScrn(px, py, illuminatedColor)
End If
Next
Next
DrawAACircleOutline(.x + 0.5, .y + 0.5, .r, iTableColor, 2)
End If
End With
Next
'show FPS
fpsText = Str(fpsRounded) & " fps"
Draw String(4, 4), fpsText, &hFFFFFFFF
Flip
frameCount += 1
If Timer - fpsTimer >= 1.0 Then
currentFPS = frameCount / (Timer - fpsTimer)
frameCount = 0
fpsTimer = Timer
End If
lastRender = frameStart
End If
Sleep Regulate(RENDER_FPS, fpsRounded)
If bReset Then
GetMouse(mmx, mmy, , mmb, clip)
While (mmb And 1) And clip = 0
GetMouse(mmx, mmy, , mmb, clip)
Sleep(10)
Wend
bReset = False
accumPhysics = 0 : frameCount = 0 : currentFPS = 0
lastTime = Timer : lastRender = Timer : fpsTimer = Timer
End If
Loop Until Len(Inkey())
For i = 0 To iBALLS - 1
ImageDestroy(pBalls(i))
Next
|
So sollte es aussehen:
https://i.ibb.co/W4cZQvsM/Captured.webp
Die Bitmaps, Source Code und kompilierte Exe können von meinem OneDrive heruntergeladen werden.
Falls ihr keinen MS Account habt, könnt ihr die Dateien leider nur einzeln herunterladen. Mit einem MS Account können die markierten Files als Zip heruntergeladen werden.
@Sebastian: leider bleiben meine Antworten an dich nur im Postausgang.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 20.09.2025, 00:30 Titel: Flag Simulation v0.41 alpha |
|
|
Ich bin nicht ganz zufrieden mit dem Ergebnis, aber hier der Code.
| Code: |
' Flag Simulation v0.41 alpha
' Coded by UEZ build 2025-09-20
#include "crt/math.bi"
#include "fbgfx.bi"
Using FB
#define Min(a, b) (IIf(a < b, a, b))
#define Max(a, b) (IIf(a > b, a, b))
' Grid and physics constants
Const nX = 90, nY = Int(nX * 1.5) ' Grid points
Const Spacing = 2 ' Distance between points
Const diagSpacing = Spacing * Sqr(2) ' Diagonal spacing
Const Damping = 0.992 ' Physics damping factor
Const Gravity = 0.2 ' Gravity force
Const ConstraintIter = 2 ' Constraint iterations
' 2D Vector type
Type Vec2D
x As Double
y As Double
End Type
Dim Shared As Vec2D posi(nX, nY), oldPos(nX, nY)
' Perlin Noise implementation by Joshy aka D.J. Peters (R.I.P.)
Type REAL As Double
#define rAbs(x_) IIf( (x_) < 0, -(x_), (x_) )
Const As REAL rPI = Acos(-1)
Const As REAL rDeg2Rad = rPI / 180
Type PERLINNOISE '...'
Declare Constructor
Declare Sub NoiseSeed(ByVal seed As Double)
Declare Sub NoiseDetail(ByVal lod As Integer)
Declare Sub NoiseDetail(ByVal lod As Integer, ByVal falloff As REAL)
Declare Function Noise1D(ByVal x As REAL) As REAL
Declare Function Noise2D(ByVal x As REAL, ByVal y As REAL) As REAL
Declare Function Noise3D(ByVal x As REAL, ByVal y As REAL, ByVal z As REAL) As REAL
Private:
Const As REAL SINCOS_PRECISION = 0.5
Const As Integer SINCOS_LENGTH = (360 / SINCOS_PRECISION)
Const As Integer PERLIN_YWRAPB = 4
Const As Integer PERLIN_YWRAP = 1 Shl PERLIN_YWRAPB
Const As Integer PERLIN_ZWRAPB = 8
Const As Integer PERLIN_ZWRAP = 1 Shl PERLIN_ZWRAPB
Const As Integer PERLIN_SIZE = 4095
Const As Integer PERLIN_TWOPI = SINCOS_LENGTH
Const As Integer PERLIN_PI = PERLIN_TWOPI Shr 1
As Integer perlin_octaves = 4 ' Default to medium smooth
As REAL perlin_amp_falloff = 0.5 ' 50% reduction per octave
As REAL perlin_cosTable(SINCOS_LENGTH-1)
As REAL perlin(PERLIN_SIZE)
Declare Sub reInit
Declare Function noise_fsc(ByVal i As REAL) As REAL
End Type
Constructor PERLINNOISE '...'
For i As Integer = 0 To SINCOS_LENGTH - 1
perlin_cosTable(i) = Cos(i * rDeg2Rad * SINCOS_PRECISION)
Next
reInit
End Constructor
Sub PERLINNOISE.reInit '...'
For i As Integer = 0 To PERLIN_SIZE
perlin(i) = Rnd()
Next
End Sub
Function PERLINNOISE.noise_fsc(ByVal i As REAL) As REAL '...'
Dim As Integer index = Int(i * PERLIN_PI)
Return 0.5 * (1.0 - perlin_cosTable(index Mod SINCOS_LENGTH))
End Function
Sub PERLINNOISE.NoiseSeed(ByVal seed As Double) '...'
Randomize(seed) : reInit
End Sub
Sub PERLINNOISE.NoiseDetail(ByVal lod As Integer) '...'
If (lod > 0) Then perlin_octaves = lod
End Sub
Sub PERLINNOISE.NoiseDetail(ByVal lod As Integer, ByVal falloff As REAL) '...'
If (lod > 0) Then perlin_octaves = lod
If (falloff > 0) Then perlin_amp_falloff = falloff
End Sub
Function PERLINNOISE.Noise1D(ByVal x As REAL) As REAL '...'
Return Noise3D(x, 0, 0)
End Function
Function PERLINNOISE.Noise2D(ByVal x As REAL, ByVal y As REAL) As REAL '...'
Return Noise3D(x, y, 0)
End Function
Function PERLINNOISE.Noise3D(ByVal x As REAL, ByVal y As REAL, ByVal z As REAL) As REAL '...'
x = rAbs(x) : y = rAbs(y) : z = rAbs(z)
Dim As Integer xi = Int(x), yi = Int(y), zi = Int(z)
Dim As REAL xf = x - xi, yf = y - yi, zf = z - zi
Dim As REAL r, ampl = 0.5
For i As Integer = 0 To perlin_octaves - 1
Dim As Integer of = xi + (yi Shl PERLIN_YWRAPB) + (zi Shl PERLIN_ZWRAPB)
Dim As REAL rxf = noise_fsc(xf)
Dim As REAL ryf = noise_fsc(yf)
Dim As REAL n1 = perlin(of And PERLIN_SIZE)
n1 += rxf * (perlin((of + 1) And PERLIN_SIZE) - n1)
Dim As REAL n2 = perlin((of + PERLIN_YWRAP) And PERLIN_SIZE)
n2 += rxf * (perlin((of + PERLIN_YWRAP + 1) And PERLIN_SIZE) - n2)
n1 += ryf * (n2 - n1)
of += PERLIN_ZWRAP
n2 = perlin(of And PERLIN_SIZE)
n2 += rxf * (perlin((of + 1) And PERLIN_SIZE) - n2)
Dim As REAL n3 = perlin((of + PERLIN_YWRAP) And PERLIN_SIZE)
n3 += rxf * (perlin((of + PERLIN_YWRAP + 1) And PERLIN_SIZE) - n3)
n2 += ryf * (n3 - n2)
n1 += noise_fsc(zf) * (n2 - n1)
r += n1 * ampl
ampl *= perlin_amp_falloff
xi Shl = 1: xf *= 2
yi Shl = 1: yf *= 2
zi Shl = 1: zf *= 2
If (xf >= 1) Then xi += 1 : xf -= 1
If (yf >= 1) Then yi += 1 : yf -= 1
If (zf >= 1) Then zi += 1 : zf -= 1
Next
Return r
End Function
' Triangle drawing function with scanline filling
Sub DrawFilledTriangle(x1 As Long, y1 As Long, _ '...'
x2 As Long, y2 As Long, _
x3 As Long, y3 As Long, _
col As ULong)
Dim As Long minY, maxY, y, x
Dim As Long intersections, xIntersect(2)
Dim As Single slope1, slope2, xStart, xEnd
' Determine Y range
minY = y1
If y2 < minY Then minY = y2
If y3 < minY Then minY = y3
maxY = y1
If y2 > maxY Then maxY = y2
If y3 > maxY Then maxY = y3
' For each scanline
For y = minY To maxY
intersections = 0
' Calculate intersections with three edges
If ((y1 <= y And y < y2) Or (y2 <= y And y < y1)) And y1 <> y2 Then
xIntersect(intersections) = x1 + (y - y1) * (x2 - x1) / (y2 - y1)
intersections += 1
End If
If ((y2 <= y And y < y3) Or (y3 <= y And y < y2)) And y2 <> y3 Then
xIntersect(intersections) = x2 + (y - y2) * (x3 - x2) / (y3 - y2)
intersections += 1
End If
If ((y3 <= y And y < y1) Or (y1 <= y And y < y3)) And y3 <> y1 Then
xIntersect(intersections) = x3 + (y - y3) * (x1 - x3) / (y1 - y3)
intersections += 1
End If
' Draw line between intersection points
If intersections = 2 Then
If xIntersect(0) > xIntersect(1) Then
Swap xIntersect(0), xIntersect(1)
End If
Line (xIntersect(0), y)-(xIntersect(1), y), col
End If
Next
End Sub
' Filled quadrilateral drawing function with scanline filling
Sub DrawFilledQuad(x1 As Long, y1 As Long, _ '...'
x2 As Long, y2 As Long, _
x3 As Long, y3 As Long, _
x4 As Long, y4 As Long, _
col As ULong)
Dim As Long minY, maxY, y
Dim As Long intersections, xIntersect(4)
Dim As Long i, j, temp
' Determine Y range
minY = y1
If y2 < minY Then minY = y2
If y3 < minY Then minY = y3
If y4 < minY Then minY = y4
maxY = y1
If y2 > maxY Then maxY = y2
If y3 > maxY Then maxY = y3
If y4 > maxY Then maxY = y4
' For each scanline
For y = minY To maxY
intersections = 0
' Calculate intersections with all four edges
' Edge 1-2
If ((y1 <= y And y < y2) Or (y2 <= y And y < y1)) And y1 <> y2 Then
xIntersect(intersections) = x1 + (y - y1) * (x2 - x1) / (y2 - y1)
intersections += 1
End If
' Edge 2-3
If ((y2 <= y And y < y3) Or (y3 <= y And y < y2)) And y2 <> y3 Then
xIntersect(intersections) = x2 + (y - y2) * (x3 - x2) / (y3 - y2)
intersections += 1
End If
' Edge 3-4
If ((y3 <= y And y < y4) Or (y4 <= y And y < y3)) And y3 <> y4 Then
xIntersect(intersections) = x3 + (y - y3) * (x4 - x3) / (y4 - y3)
intersections += 1
End If
' Edge 4-1
If ((y4 <= y And y < y1) Or (y1 <= y And y < y4)) And y4 <> y1 Then
xIntersect(intersections) = x4 + (y - y4) * (x1 - x4) / (y1 - y4)
intersections += 1
End If
' Sort intersection points
If intersections >= 2 Then
For i = 0 To intersections - 2
For j = i + 1 To intersections - 1
If xIntersect(i) > xIntersect(j) Then
temp = xIntersect(i)
xIntersect(i) = xIntersect(j)
xIntersect(j) = temp
End If
Next
Next
' Draw lines between pairs of intersection points
For i = 0 To intersections - 1 Step 2
If i + 1 < intersections Then
Line (xIntersect(i), y) - (xIntersect(i + 1), y), col
End If
Next
End If
Next
End Sub
' Apply distance constraint between two points
Sub ApplyConstraint(i1 As Long, j1 As Long, i2 As Long, j2 As Long, targetDist As Double) '...'
Dim As Double dx = posi(i2, j2).x - posi(i1, j1).x
Dim As Double dy = posi(i2, j2).y - posi(i1, j1).y
Dim As Double dist = Sqr(dx * dx + dy * dy)
If dist = 0 Then Exit Sub
Dim As Double diff = (dist - targetDist) / dist
' If one point is fixed (column 0) -> apply full correction to movable point
If i1 = 0 Then
posi(i2, j2).x -= dx * diff
posi(i2, j2).y -= dy * diff
ElseIf i2 = 0 Then
posi(i1, j1).x += dx * diff
posi(i1, j1).y += dy * diff
Else
' Both points movable -> split correction
posi(i1, j1).x += dx * diff * 0.5
posi(i1, j1).y += dy * diff * 0.5
posi(i2, j2).x -= dx * diff * 0.5
posi(i2, j2).y -= dy * diff * 0.5
End If
End Sub
' Center window on screen
Sub CenterFBWin(iW As Long, iH As Long, iTBw As Long = 0, iTBh As Long = 0) '...'
Dim As Long iScreenWidth, iScreenHeight
ScreenControl GET_DESKTOP_SIZE, iScreenWidth, iScreenHeight
ScreenControl SET_WINDOW_POS, (iScreenWidth - iW) \ 2 - iTBw, (iScreenHeight - iH) \ 2 - iTBh
End Sub
' ===== Flag in Wind Simulation =====
Randomize
' Initialize Perlin noise
Dim Shared pn As PERLINNOISE
pn.NoiseSeed(-Timer)
pn.NoiseDetail(4, 0.5)
' FPS counter variables
Dim As UShort iFPS, cfps = 0
Dim As Double fTimer
Dim As Long i, j, iter
' Screen setup
Const w = 1200, h = 800
ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFFFFFFFF, &hFF202020
Cls
' Initialize flag grid positions
Dim As Long px = w \ 2 - 15, py = 100
For i = 0 To nX
For j = 0 To nY
posi(i, j).x = px + i * Spacing
posi(i, j).y = py + j * Spacing
oldPos(i, j) = posi(i, j)
Next
Next
' Simulation variables
Dim As Double t, wind, fx, fy
Dim As Double gust, windStrength, baseWind
Dim As Double w1x, w1y, w2x, w2y, w3x, w3y
Dim As Double scale, vx, vy
Dim As Double x0, y0, x1, y1, x2, y2, x3, y3
Dim As Double dx, dy, bright, factor, n, flicker, dx1, dy1, dx2, dy2, cross
Dim As Long baseR, baseG, baseB
Dim As Long r, g, b
Dim As ULong col
Dim As Vec2D temp
' Main simulation loop
Do
Cls
' Draw flag pole
Line (px - 5, py - 30) - (px + 5, h), &hFF999999, BF
Circle (px, py - 30), 10, &hFFDADBDD, , , , F
' 1) Verlet Integration - Physics simulation for each point
For i = 1 To nX
For j = 0 To nY
temp = posi(i, j)
' Base movement = (current position - old position) * damping
vx = (posi(i, j).x - oldPos(i, j).x) * Damping
vy = (posi(i, j).y - oldPos(i, j).y) * Damping
' Wind force calculation per point
' Wind strength over time
windStrength = 0.02 * pn.Noise1D(-t * 1.002)
' Smooth transition (avoid harsh jumps)
If windStrength < 0.1 Then windStrength = 0
gust = 0.05 + pn.Noise1D(t * 0.05)
' Base wind fluctuates over time
baseWind = windStrength
' Large, slow wave
w1x = (pn.Noise3D(i * 0.05, j * 0.08, t * 0.2) - 0.5) * 5
w1y = (pn.Noise3D(i * 0.05, j * 0.08, t * 0.2 + 50) - 0.5) * 2
' Medium structure
w2x = (pn.Noise3D(i * 0.12, j * 0.15, t * 0.6) - 0.5) * 6
w2y = (pn.Noise3D(i * 0.12, j * 0.15, t * 0.6 + 100) - 0.5) * 3
' Fine fluttering
w3x = (pn.Noise3D(i * 0.25, j * 0.25, t * 1.2) - 0.5) * 2
w3y = (pn.Noise3D(i * 0.25, j * 0.25, t * 1.2 + 200) - 0.5) * 1.1
' Total wind = wind strength * (gusts + waves)
scale = i / nX
fx = scale * (baseWind + gust * (w1x + w2x + w3x))
fy = scale * gust * (w1y + w2y + w3y + Gravity)
' Verlet integration: calculate new position
posi(i, j).x += vx + fx
posi(i, j).y += vy + fy + Gravity
oldPos(i, j) = temp
Next
Next
' 2) Constraint system: correct distances between points
For iter = 0 To ConstraintIter
For i = 0 To nX
For j = 0 To nY
' Horizontal connections
If i < nX Then ApplyConstraint(i, j, i + 1, j, Spacing)
' Vertical connections
If j < nY Then ApplyConstraint(i, j, i, j + 1, Spacing)
' Diagonal connections for stability
If i < nX And j < nY Then
ApplyConstraint(i, j, i + 1, j + 1, diagSpacing)
ApplyConstraint(i + 1, j, i, j + 1, diagSpacing)
End If
Next
Next
Next
' 3) Fix first column to flag pole
For j = 0 To nY
posi(0, j).x = px
posi(0, j).y = py + j * Spacing
Next
' 4) Rendering: draw flag as triangles
For i = 0 To nX - 1
For j = 0 To nY - 1
' Corner points of the cell
x0 = posi(i, j).x : y0 = posi(i, j).y
x1 = posi(i + 1, j).x : y1 = posi(i + 1, j).y
x2 = posi(i, j + 1).x : y2 = posi(i, j + 1).y
x3 = posi(i + 1, j + 1).x : y3 = posi(i + 1, j + 1).y
' German flag colors: black-red-gold
Select Case (j \ (nY / 3)) Mod 3
Case 0: baseR = 24 : baseG = 24 : baseB = 24 ' Black
Case 1: baseR = 200 : baseG = 0 : baseB = 0 ' Red
Case 2: baseR = 240 : baseG = 200 : baseB = 40 ' Gold
End Select
'baseR = &hF0 : baseG = &h00 : baseB = &h00
' Shading through wave deformation
dx = ((x1 + x3) - (x0 + x2)) / 2
dy = ((y2 + y3) - (y0 + y1)) / 2
' Cross product -> curvature, Abs() for symmetric brightness
cross = dx * dy
bright = 0.7 + 0.3 * (Abs(cross) / (Spacing * Spacing))
' Limit for realistic values
If bright < 0.1 Then bright = 0.1
If bright > 1.0 Then bright = 1.0
' Final color calculation
r = baseR * bright
g = baseG * bright
b = baseB * bright
col = RGBA(r, g, b, &hF0)
' Draw two triangles per quad
'DrawFilledTriangle(x0, y0, x1, y1, x2, y2, col)
'DrawFilledTriangle(x1, y1, x3, y3, x2, y2, col)
DrawFilledQuad(x0, y0, x1, y1, x3, y3, x2, y2, col)
Next
Next
t += 0.33333
' Display FPS counter
Draw String(4, 4), iFPS & " fps", &hFFFFFFFF
Flip
' FPS calculation
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
cfps += 1
Sleep(10)
Loop Until Len(Inkey())
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 07.10.2025, 21:18 Titel: Blitz Simulation v0.6 |
|
|
| Code: |
'Coded by UEZ build 2025-10-07
#include "crt/math.bi"
#include "fbgfx.bi"
Using FB
#define _pi (3.141592653589793)
#define _pi2 (1.5707963267948965)
#define _pi4 (0.7853981633974483)
#define _2pi (6.283185307179586)
#define fRad (0.017453292519943294)
#define Min(a, b) (IIf(a < b, a, b))
#define Max(a, b) (IIf(a > b, a, b))
#define Col(c) Max(0, Min(255, (c)))
Randomize Timer, 2
Const w = 1600, h = 900, maxBranch = 1000, stem = 4
ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFF, &hA0FCF9FA
Cls
Type Lightning '...'
As Double x, y, px, py, a, s, l
As Long deep
As ULong num
As Double pathX(0 To 2047)
As Double pathY(0 To 2047)
As Integer pathCount
End Type
Dim Shared As ULong iNightCol
iNightCol = &hFF0C090A
Dim Shared As Any Ptr pImage
pImage = ImageCreate(w, h, iNightCol, 32)
Dim Shared As Lightning aBlitz(maxBranch)
Dim Shared As Long i, count
' Perlin Noise implementation by Joshy aka D.J. Peters (R.I.P.)
Type REAL As Double
#define rAbs(x_) IIf( (x_) < 0, -(x_), (x_) )
Const As REAL rPI = Acos(-1)
Const As REAL rDeg2Rad = rPI / 180
Type PERLINNOISE '...'
Declare Constructor
Declare Sub NoiseSeed(ByVal seed As Double)
Declare Sub NoiseDetail(ByVal lod As Integer)
Declare Sub NoiseDetail(ByVal lod As Integer, ByVal falloff As REAL)
Declare Function Noise1D(ByVal x As REAL) As REAL
Declare Function Noise2D(ByVal x As REAL, ByVal y As REAL) As REAL
Declare Function Noise3D(ByVal x As REAL, ByVal y As REAL, ByVal z As REAL) As REAL
Private:
Const As REAL SINCOS_PRECISION = 0.5
Const As Integer SINCOS_LENGTH = (360 / SINCOS_PRECISION)
Const As Integer PERLIN_YWRAPB = 4
Const As Integer PERLIN_YWRAP = 1 Shl PERLIN_YWRAPB
Const As Integer PERLIN_ZWRAPB = 8
Const As Integer PERLIN_ZWRAP = 1 Shl PERLIN_ZWRAPB
Const As Integer PERLIN_SIZE = 4095
Const As Integer PERLIN_TWOPI = SINCOS_LENGTH
Const As Integer PERLIN_PI = PERLIN_TWOPI Shr 1
As Integer perlin_octaves = 4 ' Default to medium smooth
As REAL perlin_amp_falloff = 0.5 ' 50% reduction per octave
As REAL perlin_cosTable(SINCOS_LENGTH-1)
As REAL perlin(PERLIN_SIZE)
Declare Sub reInit
Declare Function noise_fsc(ByVal i As REAL) As REAL
End Type
Constructor PERLINNOISE '...'
For i As Integer = 0 To SINCOS_LENGTH - 1
perlin_cosTable(i) = Cos(i * rDeg2Rad * SINCOS_PRECISION)
Next
reInit
End Constructor
Sub PERLINNOISE.reInit '...'
For i As Integer = 0 To PERLIN_SIZE
perlin(i) = Rnd()
Next
End Sub
Function PERLINNOISE.noise_fsc(ByVal i As REAL) As REAL '...'
Dim As Integer index = Int(i * PERLIN_PI)
Return 0.5 * (1.0 - perlin_cosTable(index Mod SINCOS_LENGTH))
End Function
Sub PERLINNOISE.NoiseSeed(ByVal seed As Double) '...'
Randomize(seed) : reInit
End Sub
Sub PERLINNOISE.NoiseDetail(ByVal lod As Integer) '...'
If (lod > 0) Then perlin_octaves = lod
End Sub
Sub PERLINNOISE.NoiseDetail(ByVal lod As Integer, ByVal falloff As REAL) '...'
If (lod > 0) Then perlin_octaves = lod
If (falloff > 0) Then perlin_amp_falloff = falloff
End Sub
Function PERLINNOISE.Noise1D(ByVal x As REAL) As REAL '...'
Return Noise3D(x, 0, 0)
End Function
Function PERLINNOISE.Noise2D(ByVal x As REAL, ByVal y As REAL) As REAL '...'
Return Noise3D(x, y, 0)
End Function
Function PERLINNOISE.Noise3D(ByVal x As REAL, ByVal y As REAL, ByVal z As REAL) As REAL '...'
x = rAbs(x) : y = rAbs(y) : z = rAbs(z)
Dim As Integer xi = Int(x), yi = Int(y), zi = Int(z)
Dim As REAL xf = x - xi, yf = y - yi, zf = z - zi
Dim As REAL r, ampl = 0.5
For i As Integer = 0 To perlin_octaves - 1
Dim As Integer of = xi + (yi Shl PERLIN_YWRAPB) + (zi Shl PERLIN_ZWRAPB)
Dim As REAL rxf = noise_fsc(xf)
Dim As REAL ryf = noise_fsc(yf)
Dim As REAL n1 = perlin(of And PERLIN_SIZE)
n1 += rxf * (perlin((of + 1) And PERLIN_SIZE) - n1)
Dim As REAL n2 = perlin((of + PERLIN_YWRAP) And PERLIN_SIZE)
n2 += rxf * (perlin((of + PERLIN_YWRAP + 1) And PERLIN_SIZE) - n2)
n1 += ryf * (n2 - n1)
of += PERLIN_ZWRAP
n2 = perlin(of And PERLIN_SIZE)
n2 += rxf * (perlin((of + 1) And PERLIN_SIZE) - n2)
Dim As REAL n3 = perlin((of + PERLIN_YWRAP) And PERLIN_SIZE)
n3 += rxf * (perlin((of + PERLIN_YWRAP + 1) And PERLIN_SIZE) - n3)
n2 += ryf * (n3 - n2)
n1 += noise_fsc(zf) * (n2 - n1)
r += n1 * ampl
ampl *= perlin_amp_falloff
xi Shl = 1: xf *= 2
yi Shl = 1: yf *= 2
zi Shl = 1: zf *= 2
If (xf >= 1) Then xi += 1 : xf -= 1
If (yf >= 1) Then yi += 1 : yf -= 1
If (zf >= 1) Then zi += 1 : zf -= 1
Next
Return r
End Function
Sub DrawThickLineSmooth(ax As Double, ay As Double, bx As Double, by As Double, thickness As Double, depth As Integer) '...'
Dim As UByte r, g, b
Select Case depth
Case 0: r = 250: g = 250: b = 255
Case 1: r = 200: g = 220: b = 255
Case 2: r = 150: g = 180: b = 255
Case Else: r = 100: g = 140: b = 255
End Select
Dim As Double dx = bx - ax, dy = by - ay
Dim As Double lineLength = Sqr(dx * dx + dy * dy)
If lineLength < 0.5 Then Exit Sub
' Hauptlinie
Line pImage, (ax, ay) - (bx, by), RGBA(r, g, b, &hFF)
' Verdicken durch mehrere parallele Linien mit Offset
Dim As Integer i
Dim As Double offset, fadeAlpha
Dim As ULong c
For i = 1 To CInt(thickness)
offset = i * 0.7
fadeAlpha = &h80 * (1.0 - i / (thickness + 2))
c = RGBA(r, g, b, Col(fadeAlpha * 0.6666))
' 4 Richtungen für runden Effekt
Line pImage, (ax + offset, ay) - (bx + offset, by), c
Line pImage, (ax - offset, ay) - (bx - offset, by), c
Line pImage, (ax, ay + offset) - (bx, by + offset), c
Line pImage, (ax, ay - offset) - (bx, by - offset), c
Next
Dim As Double glowOffset, glowFade
' Glow vereinfacht
For i = 1 To Int(thickness + 4)
glowOffset = (thickness + i)
glowFade = (1.0 - i / 7)
If glowFade > 0 Then
Circle pImage, (ax, ay), glowOffset, RGBA(r * 0.66, g * 0.77, b, (10 * glowFade)),,,, F
Circle pImage, (bx, by), glowOffset, RGBA(r * 0.66, g * 0.77, b, (10 * glowFade)),,,, F
End If
Next
End Sub
Sub DrawLaserLine(x1 As Double, y1 As Double, x2 As Double, y2 As Double, thickness As Single, depth As ULong) '...'
Dim As Double dx, dy, l, stepX, stepY
Dim As Double t, px, py, fade, r
Dim As UByte rr, gg, bb
Dim As ULong c
dx = x2 - x1
dy = y2 - y1
l = Sqr(dx * dx + dy * dy)
If l < 0.001 Then Exit Sub
' Basisfarbe Blau
rr = &h60
gg = &h60
bb = &hFF
stepX = dx / l
stepY = dy / l
' --- Dicke abhängig von depth ---
Dim As Single localThickness
localThickness = thickness * (0.9 ^ depth)
' Stamm nicht zu fett machen
If depth = 0 And localThickness > stem Then localThickness = stem
If localThickness < 2 Then localThickness = 2
' Glow-Radius abhängig von Tiefe
Dim As Single glowRadius
If depth = 0 Then
glowRadius = localThickness * 3.5
Else
glowRadius = localThickness * 8
End If
If glowRadius < 1 Then glowRadius = 1
' --- Normaler Glow am Blitz selbst ---
For t = 0 To l Step 1
px = x1 + stepX * t
py = y1 + stepY * t
For r = glowRadius To 0 Step -2.5
fade = r / glowRadius
c = RGBA(rr, gg, bb, Col(6 * (1 - fade)))
Circle pImage, (px, py), localThickness * r / 2, c,,,, F
Next
Next
' Kern verstärken
For t = 0 To l
px = x1 + stepX * t
py = y1 + stepY * t
c = RGBA(255, 255, 255, Col(&h40 - localThickness))
Circle pImage, (px, py), localThickness / 3, c, , , , F
Next
' Weißer Kern
Line pImage, (x1, y1) - (x2, y2), RGBA(255, 255, 255, Col(255 - localThickness / 4))
End Sub
Sub DrawAmbientGlowAlongPathSmooth(aBlitz() As Lightning, blitzCount As Integer, intensity As Double) '...'
Dim As Integer px, py, blitzIdx, segIdx
Dim As Double fade, minDist, dist, alpha, bx, by, normalizedDist
Dim As UByte r = 120, g = 145, b = 250
' Pixel für Pixel
For py = 0 To h - 1 Step 2 ' Step 3 für Performance
For px = 0 To w - 1 Step 2
minDist = 9999999
' Finde minimale Distanz zu allen Blitz-Segmenten
For blitzIdx = 0 To Min(blitzCount - 1, 50)
If aBlitz(blitzIdx).pathCount < 2 Or aBlitz(blitzIdx).deep > 1 Then Continue For
For segIdx = 0 To aBlitz(blitzIdx).pathCount - 2 Step 8
bx = aBlitz(blitzIdx).pathX(segIdx)
by = aBlitz(blitzIdx).pathY(segIdx)
dist = Sqr((px - bx) * (px - bx) + (py - by) * (py - by))
' Gewichtung nach Tiefe
If aBlitz(blitzIdx).deep = 0 Then dist *= 0.7
If dist < minDist Then minDist = dist
Next
Next
normalizedDist = minDist / (h * 0.4)
fade = Exp(-(normalizedDist * normalizedDist) * 3)
alpha = Col(intensity * fade * 9)
If alpha > 1 Then
PSet pImage, (px, py), RGBA(r, g, b, alpha)
' Zusätzliche Pixel für Füllung
If px + 1 < w Then PSet pImage, (px + 1, py), RGBA(r, g, b, alpha)
If py + 1 < h Then PSet pImage, (px, py + 1), RGBA(r, g, b, alpha)
If px + 1 < w And py + 1 < h Then PSet pImage, (px + 1, py + 1), RGBA(r, g, b, alpha)
End If
Next
Next
End Sub
Sub DrawAmbientGlowAlongPathBlurred(aBlitz() As Lightning, blitzCount As Integer, intensity As Double) '...'
Dim As Integer strips = 20, sizeBlocks = 3 ' Mehr Überlappung
Dim As Integer i, x, blitzIdx, segIdx, xPos, yPos, xWidth, yHeight
Dim As Double fade, minDist, dist, alpha, px, py, bx, by, normalizedDist
Dim As Integer pass, offsetX, offsetY
For pass = 0 To 1 ' 2 Durchgänge mit Versatz
offsetX = pass * (w / strips / 2)
offsetY = pass * (h / strips / 2)
For i = 0 To strips - 1
For x = 0 To strips - 1
px = (x / strips) * w + offsetX
py = (i / strips) * h + offsetY
If px >= w Or py >= h Then Continue For
minDist = 9999999
For blitzIdx = 0 To Min(blitzCount - 1, 50)
If aBlitz(blitzIdx).pathCount < 2 Or aBlitz(blitzIdx).deep > 1 Then Continue For
For segIdx = 0 To aBlitz(blitzIdx).pathCount - 2 Step 8
bx = aBlitz(blitzIdx).pathX(segIdx)
by = aBlitz(blitzIdx).pathY(segIdx)
dist = Sqr((px - bx) * (px - bx) + (py - by) * (py - by))
If aBlitz(blitzIdx).deep = 0 Then dist *= 0.7
If dist < minDist Then minDist = dist
Next
Next
normalizedDist = minDist / (h * 0.4)
fade = Exp(-(normalizedDist * normalizedDist) * 3)
alpha = Col(intensity * fade * 4) ' Niedriger wegen Überlappung
If alpha > 1 Then
xPos = Int(px)
yPos = Int(py)
xWidth = Int(w / strips) + sizeBlocks ' Größer für Überlappung
yHeight = Int(h / strips) + sizeBlocks
Line pImage, (xPos, yPos) - (xPos + xWidth - sizeBlocks - 1, yPos + yHeight - sizeBlocks - 1), RGBA(120, 145, 250, alpha), BF
End If
Next
Next
Next
End Sub
Sub DrawAmbientGlowAlongPathCircles(aBlitz() As Lightning, blitzCount As Integer, intensity As Double) '...'
Dim As Integer gridSize = 30 ' Abstand zwischen Glow-Punkten
Dim As Integer px, py, blitzIdx, segIdx, radius, r
Dim As Double fade, minDist, dist, alpha, bx, by, normalizedDist, circleFade
Dim As UByte circleAlpha
For py = 0 To h Step gridSize
For px = 0 To w Step gridSize
minDist = 9999999
For blitzIdx = 0 To Min(blitzCount - 1, 50) '...'
If aBlitz(blitzIdx).pathCount < 2 Or aBlitz(blitzIdx).deep > 1 Then Continue For
For segIdx = 0 To aBlitz(blitzIdx).pathCount - 2 Step 6
bx = aBlitz(blitzIdx).pathX(segIdx)
by = aBlitz(blitzIdx).pathY(segIdx)
dist = Sqr((px - bx) * (px - bx) + (py - by) * (py - by))
If aBlitz(blitzIdx).deep = 0 Then dist *= 0.7
If dist < minDist Then minDist = dist
Next
Next
normalizedDist = minDist / (h * 0.4)
fade = Exp(-(normalizedDist * normalizedDist) * 3)
alpha = intensity * fade * 0.7
If alpha > 2 Then
' Mehrere Kreise für weichen Übergang
radius = gridSize
For r = radius To 1 Step -4
circleFade = (radius - r) / CDbl(radius)
circleAlpha = alpha * (1.0 - circleFade * 0.5)
If circleAlpha > 1 Then
Circle pImage, (px, py), r, RGBA(120, 145, 250, Col(circleAlpha)),,,, F
End If
Next
End If
Next
Next
End Sub
Function CatmullRom(p0 As Double, p1 As Double, p2 As Double, p3 As Double, t As Double) As Double '...'
Dim As Double t2 = t * t
Dim As Double t3 = t2 * t
Return 0.5 * ((2 * p1) + (-p0 + p2) * t + (2 * p0 - 5 * p1 + 4 * p2 - p3) * t2 + (-p0 + 3 * p1 - 3 * p2 + p3) * t3 )
End Function
Sub DrawBlitzSpline(ast As Lightning) '...'
If ast.pathCount < 4 Then Exit Sub
Dim As Integer i, j
Dim As Double sx, sy, px, py, t
Dim As Integer steps = 4 ' wie fein der Spline interpoliert wird
Dim As Double baseThickness = ast.s
Dim As Double localThickness = baseThickness * (0.8 ^ ast.deep)
If localThickness < 1 Then localThickness = 1
For i = 1 To ast.pathCount - 3
For j = 0 To steps
t = j / steps
sx = CatmullRom(ast.pathX(i - 1), ast.pathX(i), ast.pathX(i + 1), ast.pathX(i + 2), t)
sy = CatmullRom(ast.pathY(i - 1), ast.pathY(i), ast.pathY(i + 1), ast.pathY(i + 2), t)
If i > 1 Or j > 0 Then
'DrawThickLineSmooth(px, py, sx, sy, localThickness, ast.deep)
DrawLaserLine(px, py, sx, sy, localThickness, ast.deep)
End If
px = sx
py = sy
'Put (0, 0), pImage, PSet
'Flip
Next
Next
End Sub
Sub FadeOut() '...'
Dim As Long fade
' Blitz kurz stehen lassen
Sleep 250
' Danach langsam abdunkeln
For fade = 0 To 100
' Schwarzes halbtransparentes Overlay
Line (0, 0) - (w, h), &h12000000, BF
Flip
Sleep 1
Next
End Sub
Sub CenterFBWin(iW As Long, iH As Long, iTBw As Long = 0, iTBh As Long = 0) 'centers the FB-GUI on the primary screen '...'
Dim As Long iScreenWidth, iScreenHeight
ScreenControl GET_DESKTOP_SIZE, iScreenWidth, iScreenHeight
ScreenControl SET_WINDOW_POS, (iScreenWidth - iW) \ 2 - iTBw, (iScreenHeight - iH) \ 2 - iTBh
End Sub
CenterFBWin(w, h)
Dim Shared pn As PERLINNOISE
pn.NoiseSeed(-Timer)
pn.NoiseDetail(4, 0.5)
#macro Init()
count = 1
aBlitz(0).x = w \ 2 + Rnd() * 50 - 100
aBlitz(0).y = 0
aBlitz(0).py = aBlitz(0).y
aBlitz(0).px = aBlitz(0).x
aBlitz(0).num = 1
aBlitz(0).l = 1
aBlitz(0).s = stem
aBlitz(0).a = _pi2
For i As Integer = 0 To maxBranch - 1
aBlitz(i).pathCount = 0
Next
#endmacro
Init()
Dim As Double t = 0, stepSize = 5, angleRange, deathRate, branchChance, yProgress, minAngle, maxAngle, a, hh
Const lifespan = 0.6, glowIntensity = 5
Do
While aBlitz(0).y < h '...'
i = 0
While aBlitz(i).num > 0
With aBlitz(i)
.x = .px + Cos(.a) * stepSize
.y = .py + Sin(.a) * stepSize
If i = 0 Then
.x += (pn.Noise2D(t * 0.75 + i * 0.2, (.x + .px + t) * 2) - 0.5) * 20
.y += (pn.Noise1D(t * 0.3 + i * 0.15) - 0.25) * 1.1
Else
.x += (pn.Noise2D(t * 0.75 + i * 0.2, (.x + .py + t) * 2) - 0.5) * 30
.y += (pn.Noise1D(t * 0.3 + i * 0.15) - 0.25) * 5
.a += (pn.Noise2D(t * 0.2 + i * 0.05, (.x + .y + t) * 0.1) - 0.5) * 0.2
EndIf
If aBlitz(i).l > lifespan Then
If aBlitz(i).pathCount < 2047 Then
aBlitz(i).pathX(aBlitz(i).pathCount) = .x
aBlitz(i).pathY(aBlitz(i).pathCount) = .y
aBlitz(i).pathCount += 1
End If
End If
.px = .x
.py = .y
If i > 0 Then
' Äste sterben schneller ab je tiefer sie sind
deathRate = 0.9925 - (.deep * 0.0015)
aBlitz(i).l *= deathRate
End If
' Branch-Erstellung basierend auf Tiefe und Position
If count < maxBranch - 1 AndAlso .l > lifespan Then
branchChance = 0
yProgress = .y / h ' Fortschritt von oben (0) nach unten (1)
' Branch-Wahrscheinlichkeit nach Tiefe und Position
Select Case .deep
Case 0 ' Hauptstamm
If yProgress > 0.05 And yProgress < 0.3 Then ' Nur im oberen Bereich
branchChance = 8 ' Seltene aber große Äste
End If
Case 1 ' Erste Äste
If yProgress > 0.15 And yProgress < 0.66 Then ' Mittlerer Bereich
branchChance = 6 ' Mäßige Verzweigung
End If
Case 2 ' Zweite Äste
If yProgress > 0.5 Then ' Unterer Bereich
branchChance = 4 ' Häufigere kleine Äste
End If
Case Else ' Tiefere Äste
branchChance = 2.5 ' Viele kleine Verzweigungen
End Select
If (Rnd() * 100) < branchChance Then
aBlitz(count).x = .x
aBlitz(count).y = .y
aBlitz(count).px = .x
aBlitz(count).py = .y
' Lebensdauer basierend auf Tiefe (tiefere Äste leben kürzer)
Select Case .deep
Case 0: aBlitz(count).l = 1.0 ' Lange Hauptäste
Case 1: aBlitz(count).l = 0.9 ' Mittlere Äste
Case 2: aBlitz(count).l = 0.8 ' Kurze Äste
Case Else: aBlitz(count).l = 0.75 ' Sehr kurze Äste
End Select
' Winkel-Abweichung basierend auf Tiefe
Select Case .deep
Case 0
minAngle = 30 * fRad
maxAngle = 60 * fRad ' nur zwischen 30° und 60°
Case 1
minAngle = 135 * fRad
maxAngle = 180 * fRad ' nur zwischen 135° und 180°
Case Else
minAngle = 90 * fRad
maxAngle = 135 * fRad ' nur zwischen 90° und 135°
End Select
a = (maxAngle - minAngle) + minAngle
aBlitz(count).a = .a + (Rnd() * a - a / 2) '.a + (Rnd() * angleRange - angleRange * 2)
aBlitz(count).deep = .deep + 1
aBlitz(count).num = count + 1
' Dicke basierend auf Tiefe
Select Case .deep
Case 0: aBlitz(count).s = .s * 0.8 ' Hauptäste etwas dünner
Case 1: aBlitz(count).s = .s * 0.4 ' Erste Äste deutlich dünner
Case Else: aBlitz(count).s = .s * 0.2 ' Tiefe Äste sehr dünn
End Select
count += 1
End If
End If
End With
i += 1
Wend
t += 0.01
Wend
Cls
Flip
For i = 0 To count - 1
If aBlitz(i).pathCount > 3 Then
DrawBlitzSpline(aBlitz(i))
End If
Next
DrawAmbientGlowAlongPathSmooth(aBlitz(), count, glowIntensity) ' Pixel (beste)
'DrawAmbientGlowAlongPathBlurred(aBlitz(), count, glowIntensity) ' Rechtecke (schnellste)
'DrawAmbientGlowAlongPathCircles(aBlitz(), count, glowIntensity) ' Kreise (häßlichste)
Put (0, 0), pImage, PSet
Flip
FadeOut()
' Reset
Init()
Line pImage, (0, 0) - (w, h), iNightCol, BF
Sleep(700 + Rnd() * 250)
Loop Until Len(Inkey())
ImageDestroy(pImage)
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 149
Wohnort: Opel Stadt
|
| Verfasst am: 19.08.2026, 17:17 Titel: Nachtflug über eine prozedural erzeugte Stadt (OpenGL 1.x) |
|
|
| Code: |
' ===================================================================================
' Nachtflug über eine prozedural erzeugte Stadt (OpenGL 1.x)
'
' Gegenüber der ersten Fassung:
' * Gebäude stehen auf einem festen Raster -> sie können sich nicht mehr
' überschneiden (garantiert durch die Geometrie, nicht durch Kollisionstests)
' * Fassaden mit beleuchteten Fenstern, Dachaufbauten und Attika
' * Straßennetz mit Fahrbahnmarkierungen, Bürgersteigen, Parks sowie Längs-
' und Querverkehr in beiden Fahrtrichtungen (Rechtsverkehr), mit additiv
' gemischten Scheinwerferkegeln
' * Tiefennebel, damit neue Blöcke nicht sichtbar "aufpoppen"
' * Jedes Gebäude liegt in einer Display-Liste -> trotz ~40.000 Quads flüssig
'
' Steuerung: ESC = Ende, Pfeil hoch/runter = Fluggeschwindigkeit,
' V = Kamera umschalten (Vogelperspektive <-> Schrägflug)
'
' Programmiert von UEZ in Kooperation mit Claude :-)
' Danke an dodicat für die Regulate Funktion
' Build: 2026-08-19
' ===================================================================================
#cmdline "-s gui -gen gcc -Wc -Ofast"
#include "fbgfx.bi"
#include "GL/gl.bi"
#include "GL/glu.bi"
Using FB
' Fenstergröße aus der Desktopbreite. ScreenInfo liefert vor dem ersten
' ScreenRes den aktuellen Desktop-Modus.
Dim Shared As Long SCR_W, SCR_H
ScreenInfo SCR_W, SCR_H
SCR_W = Int(SCR_W * 0.8)
SCR_H = Int(SCR_W * 10 / 16)
' --- Stadtraster -------------------------------------------------------------
Const CELL As Single = 16.0 ' Rastermaß: Baublock + Straße
Const STREET_W As Single = 6.0 ' Breite der Straßen
Const PLOT As Single = CELL - STREET_W ' bebaubares Grundstück (10.0)
Const MAX_HALF As Single = PLOT * 0.5 - 0.5 ' max. halbe Grundfläche + Rand
Const COLS = 16 ' Blöcke quer zur Flugrichtung
Const ROWS = 26 ' Blöcke in die Tiefe
Const NUM_BUILDINGS = COLS * ROWS
Const CITY_D As Single = ROWS * CELL ' Wiederholungslänge des Rasters
Const RECYCLE_Z As Single = 48.0 ' hinter der Kamera -> neu setzen
' --- Verkehrsband ------------------------------------------------------------
' Der Verkehr lebt in einem eigenen, zyklischen Band um die Kamera herum. Die
' Z-Länge ist ein exaktes Vielfaches von CELL - nur so landet ein umgesetztes
' Auto wieder genau auf einer Straßenmitte. Beide Grenzen liegen außerhalb des
' Sichtbereichs, damit nichts im Bild aufpoppt.
Const NUM_CARS = 100
Const Z_HI As Single = 64.0
Const Z_SPAN As Single = 24 * CELL ' 384
Const Z_LO As Single = Z_HI - Z_SPAN ' -320
Const X_HI As Single = (COLS - 1) * 0.5 * CELL + CELL
Const X_LO As Single = -X_HI
Const X_SPAN As Single = X_HI - X_LO
' Fahrbahnmarkierung: DASH_N Striche je Straßenabschnitt zwischen zwei
' Kreuzungen. Strich und Lücke sind gleich lang, N Striche und N-1 Lücken füllen
' den Abschnitt damit exakt aus.
Const DASH_N = 3
Const DASH_LEN As Single = (CELL - STREET_W) / (2 * DASH_N - 1)
' --- Nebelbereiche -----------------------------------------------------------
' Im Top-Down-Blick ist nichts weiter als ~130 Einheiten entfernt, dort würde
' der Nebel die ganze Szene nur eintrüben - deshalb wird er weggeschoben.
Const FOG_TOP_START As Single = 200.0
Const FOG_TOP_END As Single = 400.0
Const FOG_OBL_START As Single = 110.0
Const FOG_OBL_END As Single = 320.0
' --- Datentypen --------------------------------------------------------------
Type Building
x As Single ' Zellenmitte quer (fest, ändert sich nie)
z As Single ' Zellenmitte in der Tiefe (scrollt)
lst As GLuint ' Display-Liste mit der fertigen Geometrie
' Das Flugwarnlicht liegt bewusst NICHT in der Display-Liste - die ist
' eingefrorene Geometrie und könnte nicht blinken. Position und Phase
' merkt sich das Gebäude, gezeichnet wird pro Frame in DrawBeacons.
lit As Long ' 1 = Dach trägt ein Flugwarnlicht
lx As Single ' Position des Lichts, lokal zur Zellenmitte
ly As Single
lz As Single
lph As Single ' Phasenversatz des Blinkens, 0..1
End Type
Type Car
x As Single
z As Single
dx As Single ' Fahrtrichtung als Einheitsvektor: entweder (dx,0)...
dz As Single ' ...für Querverkehr oder (0,dz) für Längsverkehr
spd As Single ' Eigengeschwindigkeit relativ zur Stadt
End Type
Dim Shared city(0 To NUM_BUILDINGS - 1) As Building
Dim Shared cars(0 To NUM_CARS - 1) As Car
Dim Shared As GLuint roadList
' 3x5-Bitmapfont für die Anzeige, ein Byte je Zeile, Bit 2 = linke Spalte.
' Reihenfolge: Ziffern 0-9, dann F, P, S.
Dim Shared font(0 To 64) As UByte => { 7,5,5,5,7, 2,6,2,2,7, 7,1,7,4,7, 7,1,7,1,7, 5,5,7,1,1, _
7,4,7,1,7, 7,4,7,5,7, 7,1,2,2,2, 7,5,7,5,7, 7,5,7,1,7, _
7,4,7,4,4, 7,5,7,4,4, 7,4,7,1,7 }
' --- Kleine Helfer -----------------------------------------------------------
Function RndR(lo As Single, hi As Single) As Single
Return lo + Rnd * (hi - lo)
End Function
' Mitte der Rasterspalte c (c = 0 .. COLS-1); Straßen liegen jeweils dazwischen
Function ColX(c As Long) As Single
Return (c - (COLS - 1) * 0.5) * CELL
End Function
' Waagerechte Platte um den lokalen Ursprung
Sub DrawPlate(hx As Single, hz As Single, y As Single)
glBegin(GL_QUADS)
glVertex3f(-hx, y, hz) : glVertex3f( hx, y, hz)
glVertex3f( hx, y, -hz) : glVertex3f(-hx, y, -hz)
glEnd()
End Sub
' Quader ohne Boden, Seitenflächen unterschiedlich abgedunkelt (Fake-Beleuchtung)
Sub DrawBox(cx As Single, cz As Single, hw As Single, hd As Single, y0 As Single, y1 As Single, r As Single, g As Single, b As Single)
Dim As Single xl, xr, zf, zb
xl = cx - hw
xr = cx + hw
zf = cz + hd
zb = cz - hd
glColor3f(r, g, b) ' Dach
glBegin(GL_QUADS)
glVertex3f(xl, y1, zf) : glVertex3f(xr, y1, zf)
glVertex3f(xr, y1, zb) : glVertex3f(xl, y1, zb)
glEnd()
glColor3f(r * 0.80, g * 0.80, b * 0.80) ' vorne / hinten
glBegin(GL_QUADS)
glVertex3f(xl, y0, zf) : glVertex3f(xr, y0, zf)
glVertex3f(xr, y1, zf) : glVertex3f(xl, y1, zf)
glVertex3f(xr, y0, zb) : glVertex3f(xl, y0, zb)
glVertex3f(xl, y1, zb) : glVertex3f(xr, y1, zb)
glEnd()
glColor3f(r * 0.58, g * 0.58, b * 0.58) ' rechts / links
glBegin(GL_QUADS)
glVertex3f(xr, y0, zf) : glVertex3f(xr, y0, zb)
glVertex3f(xr, y1, zb) : glVertex3f(xr, y1, zf)
glVertex3f(xl, y0, zb) : glVertex3f(xl, y0, zf)
glVertex3f(xl, y1, zf) : glVertex3f(xl, y1, zb)
glEnd()
End Sub
' --- Fenster -----------------------------------------------------------------
' warmes Licht, kaltes Büroleuchtstofflicht oder dunkles Fenster
Sub SetWindowColor()
Dim As Single p, k
p = Rnd
k = RndR(0.55, 1.0)
If p < 0.42 Then
glColor3f(k, k * 0.86, k * 0.55)
ElseIf p < 0.56 Then
glColor3f(k * 0.78, k * 0.90, k)
Else
glColor3f(0.05, 0.06, 0.09)
End If
End Sub
' Setzt ein Fensterraster auf alle vier Fassaden. Die Farben werden einmal
' ausgewürfelt und in die Display-Liste gebacken, damit nichts flackert.
'
' Die Fenster liegen EXAKT in der Wandebene - kein geometrischer Versatz nach
' außen. Ein solcher Versatz wäre bei streifendem Blickwinkel (Vogelperspektive!)
' als Parallaxe sichtbar: die Fensterreihen würden über die Fassade wandern,
' während das Gebäude durchs Bild zieht. Getrennt werden beide Ebenen deshalb
' allein im Tiefenpuffer, per glPolygonOffset in CompileBuilding.
Sub AddWindows(cx As Single, cz As Single, hw As Single, hd As Single, h As Single)
Const SX As Single = 1.45, SY As Single = 1.75 ' Rasterabstand
Const WW As Single = 0.34, WH As Single = 0.95 ' halbe Breite, Höhe
Dim As Long i, j, nX, nY, nZ
Dim As Single xl, xr, zf, zb, y, px, pz
nY = Int((h - 2.4 - WH) / SY) + 1
If nY < 1 Then Exit Sub
nX = Int((2 * hw - 1.2) / SX) : If nX < 1 Then nX = 1
nZ = Int((2 * hd - 1.2) / SX) : If nZ < 1 Then nZ = 1
xl = cx - hw : xr = cx + hw
zf = cz + hd : zb = cz - hd
glBegin(GL_QUADS)
For j = 0 To nY - 1
y = 1.4 + j * SY
' Fassade vorne (+Z) und hinten (-Z)
For i = 0 To nX - 1
px = cx + (i - (nX - 1) * 0.5) * SX
SetWindowColor()
glVertex3f(px - WW, y, zf) : glVertex3f(px + WW, y, zf)
glVertex3f(px + WW, y + WH, zf) : glVertex3f(px - WW, y + WH, zf)
SetWindowColor()
glVertex3f(px + WW, y, zb) : glVertex3f(px - WW, y, zb)
glVertex3f(px - WW, y + WH, zb) : glVertex3f(px + WW, y + WH, zb)
Next
' Fassade rechts (+X) und links (-X)
For i = 0 To nZ - 1
pz = cz + (i - (nZ - 1) * 0.5) * SX
SetWindowColor()
glVertex3f(xr, y, pz + WW) : glVertex3f(xr, y, pz - WW)
glVertex3f(xr, y + WH, pz - WW) : glVertex3f(xr, y + WH, pz + WW)
SetWindowColor()
glVertex3f(xl, y, pz - WW) : glVertex3f(xl, y, pz + WW)
glVertex3f(xl, y + WH, pz + WW) : glVertex3f(xl, y + WH, pz - WW)
Next
Next
glEnd()
End Sub
' --- Ein Grundstück erzeugen -------------------------------------------------
' Die Grundfläche wird so gewürfelt, dass |Versatz| + halbe Breite <= MAX_HALF
' bleibt. Damit endet jedes Gebäude vor der Grundstücksgrenze und zwischen zwei
' Nachbarn bleiben immer mindestens STREET_W Einheiten Luft.
Sub CompileBuilding(idx As Long)
Dim As Long t
Dim As Single tx, tz, hw, hd, ox, oz, dc, h, r, g, b
Dim As Single aw, ad, ax, az, ay ' Dachaufbau
Dim As Single topX, topY, topZ ' höchster Punkt des Gebäudes
glNewList(city(idx).lst, GL_COMPILE)
city(idx).lit = 0
' Park statt Bebauung
If Rnd < 0.10 Then
glColor3f(0.07, 0.15, 0.08)
DrawPlate(PLOT * 0.5, PLOT * 0.5, 0.07)
For t = 1 To 5
tx = RndR(-3.5, 3.5)
tz = RndR(-3.5, 3.5)
DrawBox(tx, tz, 0.5, 0.5, 0.1, RndR(1.5, 3.0), 0.10, 0.22, 0.11)
Next
glEndList()
Exit Sub
End If
' Bürgersteig
glColor3f(0.17, 0.17, 0.19)
DrawPlate(PLOT * 0.5, PLOT * 0.5, 0.07)
hw = RndR(2.4, MAX_HALF)
hd = RndR(2.4, MAX_HALF)
ox = RndR(-1.0, 1.0) * (MAX_HALF - hw) ' bleibt im Grundstück
oz = RndR(-1.0, 1.0) * (MAX_HALF - hd)
' Skyline: in der Stadtmitte darf hoch gebaut werden, am Rand nicht
dc = Abs(city(idx).x) / (COLS * 0.5 * CELL)
h = RndR(4.0, 7.0 + 26.0 * (1.0 - dc) ^ 2)
If Rnd < 0.06 Then h *= RndR(1.3, 1.8)
If h > 38.0 Then h = 38.0
r = RndR(0.10, 0.20)
g = RndR(0.10, 0.20)
b = RndR(0.14, 0.26)
' Wand und Fenster liegen in derselben Ebene. glPolygonOffset schiebt die
' Wand im Tiefenpuffer um ein paar Quantisierungsstufen nach hinten - das
' skaliert automatisch mit Entfernung und Blickwinkel, im Gegensatz zu einem
' festen Versatz in Weltkoordinaten.
glEnable(GL_POLYGON_OFFSET_FILL)
glPolygonOffset(1.0, 1.0)
DrawBox(ox, oz, hw, hd, 0.1, h, r, g, b) ' Baukörper
glDisable(GL_POLYGON_OFFSET_FILL)
AddWindows(ox, oz, hw, hd, h) ' Fassaden
DrawBox(ox, oz, hw + 0.18, hd + 0.18, h, h + 0.35, _ ' Attika
r * 0.7, g * 0.7, b * 0.7)
' Höchster Punkt ist zunächst die Attika-Oberkante, mittig auf dem Dach
topX = ox
topY = h + 0.35
topZ = oz
If Rnd < 0.6 Then ' Dachaufbau
aw = RndR(0.6, hw * 0.5)
ad = RndR(0.6, hd * 0.5)
ax = ox + RndR(-1, 1) * (hw - aw)
az = oz + RndR(-1, 1) * (hd - ad)
ay = h + 0.35 + RndR(0.8, 2.4)
DrawBox(ax, az, aw, ad, h + 0.35, ay, 0.16, 0.16, 0.17)
' Der Aufbau steht an einer zufälligen Stelle des Daches und überragt
' die Attika - damit wandert der höchste Punkt auf seine Oberseite.
topX = ax
topY = ay
topZ = az
End If
If h > 24.0 Then ' Flugwarnlicht nur auf hohen Dächern
city(idx).lit = 1
city(idx).lx = topX
city(idx).ly = topY + 0.10
city(idx).lz = topZ
city(idx).lph = Rnd ' eigener Takt je Gebäude
End If
glEndList()
End Sub
' --- Flugwarnlichter ---------------------------------------------------------
' Blinkt mit fester Periode, aber je Gebäude um lph phasenverschoben - sonst
' würde die ganze Skyline im Gleichtakt zucken. Zwei Durchgänge: erst die opaken
' Kerne, dann additiv der Schein drumherum.
Sub DrawBeacons(t As Double)
Const PERIOD As Single = 1.60 ' Sekunden je Blinkzyklus
Const DUTY As Single = 0.16 ' Anteil davon, in dem das Licht an ist
Const CORE As Single = 0.28 ' halbe Kantenlänge des Kerns
Const GLOW As Single = 0.95 ' halbe Kantenlänge des Scheins
Dim As Long i
Dim As Single bx, by, bz
glColor3f(1.0, 0.16, 0.10)
glBegin(GL_QUADS)
For i = 0 To NUM_BUILDINGS - 1
If city(i).lit = 0 Then Continue For
If Frac(t / PERIOD + city(i).lph) >= DUTY Then Continue For
bx = city(i).x + city(i).lx
by = city(i).ly
bz = city(i).z + city(i).lz
glVertex3f(bx - CORE, by, bz + CORE) : glVertex3f(bx + CORE, by, bz + CORE)
glVertex3f(bx + CORE, by, bz - CORE) : glVertex3f(bx - CORE, by, bz - CORE)
Next
glEnd()
glEnable(GL_BLEND)
glBlendFunc(GL_SRC_ALPHA, GL_ONE)
glDepthMask(GL_FALSE)
glColor4f(1.0, 0.12, 0.08, 0.30)
glBegin(GL_QUADS)
For i = 0 To NUM_BUILDINGS - 1
If city(i).lit = 0 Then Continue For
If Frac(t / PERIOD + city(i).lph) >= DUTY Then Continue For
bx = city(i).x + city(i).lx
by = city(i).ly + 0.05 ' knapp über dem Kern, sonst Z-Fighting
bz = city(i).z + city(i).lz
glVertex3f(bx - GLOW, by, bz + GLOW) : glVertex3f(bx + GLOW, by, bz + GLOW)
glVertex3f(bx + GLOW, by, bz - GLOW) : glVertex3f(bx - GLOW, by, bz - GLOW)
Next
glEnd()
glDepthMask(GL_TRUE)
glDisable(GL_BLEND)
End Sub
' --- Straßennetz -------------------------------------------------------------
' Die Markierungen sind in Z periodisch (Periode CELL). Deshalb genügt eine
' einzige Display-Liste, die pro Frame um scroll Mod CELL verschoben wird.
Sub BuildRoads()
Dim As Long c, rw, k
Dim As Single sx, sz, z0, x0
' Als LINIEN, nicht als Quads. Der Grund ist gemessen: dieser Treiber setzt
' GL_POLYGON_SMOOTH nicht um (eine schräge Quad-Kante bekommt null
' Zwischenwerte), GL_LINE_SMOOTH dagegen schon, und Multisampling liefert FB
' hier gar nicht. Ein 0.22 Einheiten breites Quad ist in der Ferne nur noch
' zwei, drei Pixel breit und springt ohne Glättung beim Scrollen in der
' Dicke - genau das Wabbeln. Eine Linie hat dagegen eine feste Breite in
' PIXELN, wird also nie unterpixelig, und ihre Kanten werden geglättet.
roadList = glGenLists(1)
glNewList(roadList, GL_COMPILE)
glColor3f(0.62, 0.62, 0.60) ' weiße Markierung, nachts als Grau
glBegin(GL_LINES)
' Auf Kreuzungen wird nicht markiert - wie auf einer echten Straße, sonst
' würden sich Längs- und Querstriche dort überkreuzen.
'
' Erzeugt wird deshalb ABSCHNITTSWEISE statt aus einem durchlaufenden
' Raster: zwischen zwei Kreuzungen bleiben genau CELL - STREET_W = 10
' Einheiten, und DASH_N Striche mit gleich langen Lücken füllen die exakt
' aus (3 Striche + 2 Lücken = 5 * DASH_LEN). Jeder Abschnitt sieht damit
' gleich aus und endet bündig an beiden Kreuzungskanten. Ein globales
' Raster wäre zur Blockteilung inkommensurabel - bei Schrittweite 4 auf
' Rasterweite 16 ergäbe sich ein unsymmetrisches "- - Lücke - -".
For c = -1 To COLS - 1 ' längs zur Flugrichtung
sx = ColX(c) + CELL * 0.5
For rw = -2 To ROWS + 2
z0 = -rw * CELL - CELL * 0.5 + STREET_W * 0.5 ' Kreuzungskante
For k = 0 To DASH_N - 1
glVertex3f(sx, 0.03, z0 + (2 * k) * DASH_LEN)
glVertex3f(sx, 0.03, z0 + (2 * k + 1) * DASH_LEN)
Next
Next
Next
For rw = -2 To ROWS + 1 ' Querstraßen
sz = -rw * CELL - CELL * 0.5
For c = -1 To COLS - 2
x0 = ColX(c) + CELL * 0.5 + STREET_W * 0.5
For k = 0 To DASH_N - 1
glVertex3f(x0 + (2 * k) * DASH_LEN, 0.03, sz)
glVertex3f(x0 + (2 * k + 1) * DASH_LEN, 0.03, sz)
Next
Next
Next
glEnd()
glEndList()
End Sub
' Nebelbereich zur Kamera passend setzen
Sub SetFogRange(topDown As Long)
If topDown Then
glFogf(GL_FOG_START, FOG_TOP_START)
glFogf(GL_FOG_END, FOG_TOP_END)
Else
glFogf(GL_FOG_START, FOG_OBL_START)
glFogf(GL_FOG_END, FOG_OBL_END)
End If
End Sub
Sub DrawGround()
glColor3f(0.055, 0.055, 0.065) ' Asphalt
glBegin(GL_QUADS)
glVertex3f(-500.0, 0.0, 200.0) : glVertex3f( 500.0, 0.0, 200.0)
glVertex3f( 500.0, 0.0, -700.0) : glVertex3f(-500.0, 0.0, -700.0)
glEnd()
End Sub
' --- Verkehr -----------------------------------------------------------------
' Rechtsverkehr: "rechts von der Fahrtrichtung d" ist d x (0,1,0). Für d = +Z
' ergibt das -X, für d = -Z ergibt es +X, für d = +X ergibt es +Z. Die Fahrspur
' liegt also bei Längsverkehr auf der -dz-Seite, bei Querverkehr auf der
' +dx-Seite der Straßenmitte.
Sub SpawnCar(idx As Long)
Dim As Long c, rw
If Rnd < 0.5 Then
' Längsverkehr auf einer der Nord-Süd-Straßen
c = Int(Rnd * (COLS + 1)) - 1
cars(idx).dx = 0.0
cars(idx).dz = IIf(Rnd < 0.5, 1.0, -1.0)
cars(idx).x = ColX(c) + CELL * 0.5 - cars(idx).dz * 1.4
cars(idx).z = Z_LO + Rnd * Z_SPAN
Else
' Querverkehr auf einer der Ost-West-Straßen. Die Straßenmitten liegen
' bei -rw * CELL - CELL/2; rw = -4 .. 19 deckt genau das Z-Band ab.
rw = Int(Rnd * 24) - 4
cars(idx).dz = 0.0
cars(idx).dx = IIf(Rnd < 0.5, 1.0, -1.0)
cars(idx).z = -rw * CELL - CELL * 0.5 + cars(idx).dx * 1.4
cars(idx).x = X_LO + Rnd * X_SPAN
End If
cars(idx).spd = RndR(0.10, 0.28)
End Sub
' Ein Abschnitt des Fahrzeugs, angegeben in Fahrzeugkoordinaten: a und b sind
' Anfang und Ende entlang der Fahrtrichtung, w die halbe Breite quer dazu. Die
' Umrechnung über Abs(dx)/Abs(dz) dreht das Rechteck für den Querverkehr mit,
' ohne dass eine Rotationsmatrix nötig wäre.
Sub CarPart(x As Single, z As Single, dx As Single, dz As Single, a As Single, b As Single, w As Single)
Dim As Single cx, cz, hx, hz
cx = x + dx * (a + b) * 0.5
cz = z + dz * (a + b) * 0.5
hx = Abs(dx) * (b - a) * 0.5 + Abs(dz) * w
hz = Abs(dz) * (b - a) * 0.5 + Abs(dx) * w
glVertex3f(cx - hx, 0.09, cz + hz) : glVertex3f(cx + hx, 0.09, cz + hz)
glVertex3f(cx + hx, 0.09, cz - hz) : glVertex3f(cx - hx, 0.09, cz - hz)
End Sub
' Querprofil des Lichtkegels: in der Mitte volle Deckkraft, zu den beiden
' Außenkanten hin auf 0. u läuft von -1 (linke Kante) bis +1 (rechte Kante).
Function ConeAlpha(u As Single) As Single
Dim As Single a
a = 1.5 * (1.0 - Abs(u))
If a > 1.0 Then a = 1.0
Return a
End Function
' Der Lichtkegel als Trapezstreifen: die vordere Kante ist genau so breit wie
' die Fahrzeugfront (2 * W0) und liegt direkt an der Stoßstange, die hintere
' Kante fächert auf 2 * W1 auf und ist vollständig durchsichtig. Zusammen mit
' dem Querprofil aus ConeAlpha fällt die Helligkeit dadurch nach vorn UND zu
' beiden Seiten ab, ohne dass eine Textur nötig wäre.
'
' Gezeichnet wird bewusst in EINZELNEN DREIECKEN statt in Quads: OpenGL zerlegt
' ein Quad immer nach dem festen Schema (v0,v1,v2) + (v0,v2,v3), unabhängig von
' den Eckfarben. Bei den Alphawerten AL,AL,0,0 bekommt dabei ein Dreieck zwei
' helle Ecken und das andere nur eine - die Diagonale wird zur sichtbaren
' Helligkeitskante und liegt in jedem Segment auf derselben Seite. Der Kegel
' wirkt dann seitlich verzogen. Deshalb wird die Diagonale hier selbst gesetzt,
' in der linken Hälfte spiegelbildlich zur rechten. SEG muss dafür GERADE sein,
' sonst läge ein Segment über der Mittelachse und ließe sich nicht spiegeln.
' Muss zwischen glBegin(GL_TRIANGLES) und glEnd() aufgerufen werden.
Sub CarCone(x As Single, z As Single, dx As Single, dz As Single)
Const SEG = 4 ' gerade Zahl!
Const L0 As Single = 1.30 ' Beginn direkt vor dem Fahrzeug
Const L1 As Single = 7.50 ' Reichweite
Const W0 As Single = 0.55 ' halbe Breite an der Front = halbe Wagenbreite
Const W1 As Single = 2.00 ' halbe Breite am Ende
Const AL As Single = 0.30 ' Deckkraft an der Front
Dim As Long k
Dim As Single u0, u1, nx, nz, fx, fz, a0, a1
Dim As Single p0x, p0z, p1x, p1z, q0x, q0z, q1x, q1z
' Fahrtrichtung ist (dx, dz), quer dazu liegt (-dz, dx)
nx = x + dx * L0
nz = z + dz * L0
fx = x + dx * L1
fz = z + dz * L1
For k = 0 To SEG - 1
u0 = -1.0 + 2.0 * k / SEG
u1 = -1.0 + 2.0 * (k + 1) / SEG
a0 = AL * ConeAlpha(u0)
a1 = AL * ConeAlpha(u1)
p0x = nx - dz * u0 * W0 : p0z = nz + dx * u0 * W0 ' vorn, u0
p1x = nx - dz * u1 * W0 : p1z = nz + dx * u1 * W0 ' vorn, u1
q0x = fx - dz * u0 * W1 : q0z = fz + dx * u0 * W1 ' hinten, u0
q1x = fx - dz * u1 * W1 : q1z = fz + dx * u1 * W1 ' hinten, u1
If u1 <= 0.0 Then
' linke Hälfte: Diagonale von vorn/u0 nach hinten/u1
glColor4f(1.0, 0.94, 0.72, a0) : glVertex3f(p0x, 0.11, p0z)
glColor4f(1.0, 0.94, 0.72, a1) : glVertex3f(p1x, 0.11, p1z)
glColor4f(1.0, 0.94, 0.72, 0.0) : glVertex3f(q1x, 0.11, q1z)
glColor4f(1.0, 0.94, 0.72, a0) : glVertex3f(p0x, 0.11, p0z)
glColor4f(1.0, 0.94, 0.72, 0.0) : glVertex3f(q1x, 0.11, q1z)
glColor4f(1.0, 0.94, 0.72, 0.0) : glVertex3f(q0x, 0.11, q0z)
Else
' rechte Hälfte: gespiegelt, Diagonale von vorn/u1 nach hinten/u0
glColor4f(1.0, 0.94, 0.72, a0) : glVertex3f(p0x, 0.11, p0z)
glColor4f(1.0, 0.94, 0.72, a1) : glVertex3f(p1x, 0.11, p1z)
glColor4f(1.0, 0.94, 0.72, 0.0) : glVertex3f(q0x, 0.11, q0z)
glColor4f(1.0, 0.94, 0.72, a1) : glVertex3f(p1x, 0.11, p1z)
glColor4f(1.0, 0.94, 0.72, 0.0) : glVertex3f(q1x, 0.11, q1z)
glColor4f(1.0, 0.94, 0.72, 0.0) : glVertex3f(q0x, 0.11, q0z)
End If
Next
End Sub
' Zwei Durchgänge: erst die opaken Fahrzeuge (Rücklicht, Karosserie, Scheinwerfer
' als schmaler heller Streifen), dann additiv die Lichtkegel. Additiv (GL_ONE)
' statt klassischem Alpha-Blending, weil sich Licht auf dunklem Asphalt eben
' aufaddiert - und weil Addition kommutativ ist, spielt die Zeichenreihenfolge
' keine Rolle, es muss also nichts nach Tiefe sortiert werden.
Sub DrawCars(fly As Single)
Dim As Long i
glBegin(GL_QUADS)
For i = 0 To NUM_CARS - 1
cars(i).x += cars(i).dx * cars(i).spd
cars(i).z += cars(i).dz * cars(i).spd + fly
' Zyklisch umsetzen - Z_SPAN ist ein Vielfaches von CELL, die Autos
' bleiben also exakt auf ihrer Straßenmitte.
If cars(i).z > Z_HI Then cars(i).z -= Z_SPAN
If cars(i).z < Z_LO Then cars(i).z += Z_SPAN
If cars(i).x > X_HI Then cars(i).x -= X_SPAN
If cars(i).x < X_LO Then cars(i).x += X_SPAN
glColor3f(0.50, 0.06, 0.05) ' Rücklichter, gedämpft
CarPart(cars(i).x, cars(i).z, cars(i).dx, cars(i).dz, -1.30, -1.00, 0.55)
glColor3f(0.12, 0.13, 0.16) ' Karosserie
CarPart(cars(i).x, cars(i).z, cars(i).dx, cars(i).dz, -1.00, 1.05, 0.55)
glColor3f(1.00, 0.94, 0.72) ' Scheinwerfer
CarPart(cars(i).x, cars(i).z, cars(i).dx, cars(i).dz, 1.05, 1.30, 0.55)
Next
glEnd()
glEnable(GL_BLEND)
glBlendFunc(GL_SRC_ALPHA, GL_ONE)
glDepthMask(GL_FALSE) ' Kegel verdecken einander nicht
glDisable(GL_CULL_FACE) ' der Fächer läuft je nach Richtung anders um
glShadeModel(GL_SMOOTH) ' sonst würde das Alpha nicht interpoliert
glBegin(GL_TRIANGLES)
For i = 0 To NUM_CARS - 1
CarCone(cars(i).x, cars(i).z, cars(i).dx, cars(i).dz)
Next
glEnd()
glShadeModel(GL_FLAT)
glEnable(GL_CULL_FACE)
glDepthMask(GL_TRUE)
glDisable(GL_BLEND)
End Sub
' --- Anzeige -----------------------------------------------------------------
' Im OpenGL-Modus stehen FreeBASICs Grafikbefehle nicht zur Verfügung - es gibt
' keinen zugänglichen Framebuffer, Draw String läuft also ins Leere. Die Ziffern
' werden deshalb als Quads aus dem Bitmapfont oben zusammengesetzt.
' Beide Routinen müssen zwischen glBegin(GL_QUADS) und glEnd() laufen.
Sub DrawGlyph(g As Long, px As Long, py As Long, s As Long)
Dim As Long row, col, bits
For row = 0 To 4
bits = font(g * 5 + row)
For col = 0 To 2
If (bits Shr (2 - col)) And 1 Then
glVertex2f(px + col * s, py + row * s)
glVertex2f(px + col * s + s, py + row * s)
glVertex2f(px + col * s + s, py + row * s + s)
glVertex2f(px + col * s, py + row * s + s)
End If
Next
Next
End Sub
Sub DrawText(txt As String, px As Long, py As Long, s As Long)
Dim As Long i, g, ch
For i = 0 To Len(txt) - 1
ch = txt[i]
Select Case ch
Case Asc("0") To Asc("9") : g = ch - Asc("0")
Case Asc("F") : g = 10
Case Asc("P") : g = 11
Case Asc("S") : g = 12
Case Else : g = -1 ' Leerzeichen rückt nur vor
End Select
If g >= 0 Then DrawGlyph(g, px + i * 4 * s, py, s)
Next
End Sub
' Blendet den Text als 2D-Overlay ein: Projektion auf Bildschirmkoordinaten
' umstellen, Tiefentest und Nebel aus, hinterher alles zurücksetzen.
Sub DrawHUD(txt As String)
Const HUD_S = 2 ' Pixel je Fontpunkt -> Glyphe 6 x 10 Pixel
Const HUD_X = 10, HUD_Y = 10 ' Position links oben
Const HUD_A As Single = 0.55 ' Deckkraft der Schrift
glMatrixMode(GL_PROJECTION)
glPushMatrix()
glLoadIdentity()
glOrtho(0.0, SCR_W, SCR_H, 0.0, -1.0, 1.0) ' Y zeigt nach unten
glMatrixMode(GL_MODELVIEW)
glPushMatrix()
glLoadIdentity()
glDisable(GL_DEPTH_TEST)
glDisable(GL_FOG)
glDisable(GL_CULL_FACE)
' Klassisches Alpha-Blending, nicht das additive aus DrawCars - die Schrift
' soll sich in den Hintergrund einblenden, nicht dazuaddiert werden.
glEnable(GL_BLEND)
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)
' Der Schatten hält die Schrift auch über hellen Fassaden lesbar; er ist
' schwächer gedeckt als die Schrift selbst, sonst wirkt sie bei kleiner
' Größe verschmiert.
glColor4f(0.0, 0.0, 0.0, HUD_A * 0.55)
glBegin(GL_QUADS) : DrawText(txt, HUD_X + 1, HUD_Y + 1, HUD_S) : glEnd()
glColor4f(0.90, 0.95, 1.0, HUD_A)
glBegin(GL_QUADS) : DrawText(txt, HUD_X, HUD_Y, HUD_S) : glEnd()
glDisable(GL_BLEND)
glEnable(GL_CULL_FACE)
glEnable(GL_FOG)
glEnable(GL_DEPTH_TEST)
glPopMatrix()
glMatrixMode(GL_PROJECTION)
glPopMatrix()
glMatrixMode(GL_MODELVIEW)
End Sub
Function Regulate(TargetFPS As Long, Byref fps As Long) As Long 'by dodicat
Static As Double timervalue, _lastsleeptime, t3, frames
Var t = Timer
frames += 1
If (t - t3) >= 0.5 Then t3 = t : fps = frames * 2 : frames = 0
Var sleeptime =_lastsleeptime + ((1 / TargetFPS) - t + timervalue) * 1000
If sleeptime < 1 Then sleeptime = 1
_lastsleeptime = sleeptime
timervalue = t
Return sleeptime
End Function
' --- Initialisierung ---------------------------------------------------------
Dim As Long i, c, rw, viewTop, vPrev, vNow, fps
Dim As Single fly, scroll
Dim As GLuint listBase
Dim fogCol(0 To 3) As Single => {0.03, 0.05, 0.11, 1.0}
' --- Kantenglättung über ein Multisample-FBO ---------------------------------
' fbgfx wählt ein Pixelformat ohne Multisampling: GL_SAMPLES bleibt 0, egal ob
' mit GFX_MULTISAMPLE oder SET_GL_NUM_SAMPLES. Die GPU kann es aber sehr wohl -
' der Kontext ist hier OpenGL 4.6. Deshalb wird nicht direkt ins Fenster
' gezeichnet, sondern in ein selbst angelegtes, multisampled Framebuffer Object;
' am Ende jedes Frames wird das aufgelöste Bild ins Fenster geblittet.
'
' Die dafür nötigen Funktionen fehlen im alten GL-1.1-Header und werden deshalb
' zur Laufzeit über ScreenGLProc geholt. Fehlt eine davon, läuft alles wie
' bisher direkt ins Fenster - nur eben ohne Glättung.
Const GL_FRAMEBUFFER = &h8D40
Const GL_READ_FRAMEBUFFER = &h8CA8
Const GL_DRAW_FRAMEBUFFER = &h8CA9
Const GL_RENDERBUFFER = &h8D41
Const GL_COLOR_ATTACHMENT0 = &h8CE0
Const GL_DEPTH_ATTACHMENT = &h8D00
Const GL_FRAMEBUFFER_COMPLETE = &h8CD5
Const GL_DEPTH_COMPONENT24 = &h81A6
Const GL_SAMPLES = &h80A9
Const MSAA_SAMPLES = 4
Dim Shared glGenFramebuffers As Sub(ByVal As GLsizei, ByVal As GLuint Ptr)
Dim Shared glBindFramebuffer As Sub(ByVal As GLenum, ByVal As GLuint)
Dim Shared glGenRenderbuffers As Sub(ByVal As GLsizei, ByVal As GLuint Ptr)
Dim Shared glBindRenderbuffer As Sub(ByVal As GLenum, ByVal As GLuint)
Dim Shared glRenderbufferStorageMultisample As Sub(ByVal As GLenum, ByVal As GLsizei, _
ByVal As GLenum, ByVal As GLsizei, ByVal As GLsizei)
Dim Shared glFramebufferRenderbuffer As Sub(ByVal As GLenum, ByVal As GLenum, _
ByVal As GLenum, ByVal As GLuint)
Dim Shared glCheckFramebufferStatus As Function(ByVal As GLenum) As GLenum
Dim Shared glBlitFramebuffer As Sub(ByVal As GLint, ByVal As GLint, ByVal As GLint, ByVal As GLint, _
ByVal As GLint, ByVal As GLint, ByVal As GLint, ByVal As GLint, _
ByVal As GLbitfield, ByVal As GLenum)
Dim As GLuint msFBO, msColor, msDepth
Dim As GLint samples
Dim As Long msaaOK
Dim As String msaaText = "aus"
' WICHTIG: FreeBASIC legt OpenGL-Fenster sonst mit nur 16 Bit Tiefenpuffer an.
' Damit ist die Tiefenauflösung in 300 Einheiten Entfernung gröber als der
' Abstand zwischen Fenster und Fassade. 24 Bit muss vor ScreenRes angefordert
' werden.
ScreenControl SET_GL_DEPTH_BITS, 24
ScreenRes SCR_W, SCR_H, 32, , GFX_OPENGL
glGenFramebuffers = ScreenGLProc("glGenFramebuffers")
glBindFramebuffer = ScreenGLProc("glBindFramebuffer")
glGenRenderbuffers = ScreenGLProc("glGenRenderbuffers")
glBindRenderbuffer = ScreenGLProc("glBindRenderbuffer")
glRenderbufferStorageMultisample = ScreenGLProc("glRenderbufferStorageMultisample")
glFramebufferRenderbuffer = ScreenGLProc("glFramebufferRenderbuffer")
glCheckFramebufferStatus = ScreenGLProc("glCheckFramebufferStatus")
glBlitFramebuffer = ScreenGLProc("glBlitFramebuffer")
If glGenFramebuffers <> 0 AndAlso glBindFramebuffer <> 0 AndAlso _
glGenRenderbuffers <> 0 AndAlso glBindRenderbuffer <> 0 AndAlso _
glRenderbufferStorageMultisample <> 0 AndAlso glFramebufferRenderbuffer <> 0 AndAlso _
glCheckFramebufferStatus <> 0 AndAlso glBlitFramebuffer <> 0 Then
glGenFramebuffers(1, @msFBO)
glBindFramebuffer(GL_FRAMEBUFFER, msFBO)
glGenRenderbuffers(1, @msColor)
glBindRenderbuffer(GL_RENDERBUFFER, msColor)
glRenderbufferStorageMultisample(GL_RENDERBUFFER, MSAA_SAMPLES, GL_RGBA8, SCR_W, SCR_H)
glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_RENDERBUFFER, msColor)
glGenRenderbuffers(1, @msDepth)
glBindRenderbuffer(GL_RENDERBUFFER, msDepth)
glRenderbufferStorageMultisample(GL_RENDERBUFFER, MSAA_SAMPLES, GL_DEPTH_COMPONENT24, SCR_W, SCR_H)
glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_DEPTH_ATTACHMENT, GL_RENDERBUFFER, msDepth)
If glCheckFramebufferStatus(GL_FRAMEBUFFER) = GL_FRAMEBUFFER_COMPLETE Then
glGetIntegerv(GL_SAMPLES, @samples)
msaaOK = 1
msaaText = Str(samples)
End If
glBindFramebuffer(GL_FRAMEBUFFER, 0)
End If
WindowTitle("Nachtflug ueber die Stadt - ESC = Ende, Hoch/Runter = Tempo, V = Kamera, MSAA-Samples: " & msaaText)
glViewport(0, 0, SCR_W, SCR_H)
glMatrixMode(GL_PROJECTION)
glLoadIdentity()
' Near-Plane so weit wie möglich nach hinten: sie bestimmt die Tiefenauflösung
' viel stärker als die Far-Plane (Verhältnis far/near geht in die Genauigkeit ein)
gluPerspective(45.0, SCR_W / SCR_H, 4.0, 1000.0)
glMatrixMode(GL_MODELVIEW)
glEnable(GL_DEPTH_TEST)
glEnable(GL_CULL_FACE) ' Rückseiten sparen ~40% Füllrate
glCullFace(GL_BACK)
glFrontFace(GL_CCW)
glShadeModel(GL_FLAT)
glClearColor(0.03, 0.05, 0.11, 1.0)
glEnable(GL_FOG)
glFogi(GL_FOG_MODE, GL_LINEAR)
glFogfv(GL_FOG_COLOR, @fogCol(0))
Randomize Timer, 2
listBase = glGenLists(NUM_BUILDINGS)
For rw = 0 To ROWS - 1
For c = 0 To COLS - 1
i = rw * COLS + c
city(i).x = ColX(c)
city(i).z = -rw * CELL
city(i).lst = listBase + i
CompileBuilding(i)
Next
Next
BuildRoads()
For i = 0 To NUM_CARS - 1 : SpawnCar(i) : Next
' --- Hauptschleife -----------------------------------------------------------
fly = 0.075 ' Einheiten pro Frame (fly × Bildrate)
scroll = 0.0
viewTop = 0 ' 1 = Vogelperspektive (Vorgabe), 0 = Schrägflug
vPrev = 0
fps = 0
SetFogRange(viewTop)
Do
If MultiKey(SC_UP) Then fly += 0.01 : If fly > 2.0 Then fly = 2.0
If MultiKey(SC_DOWN) Then fly -= 0.01 : If fly < 0.01 Then fly = 0.01
vNow = MultiKey(SC_V) ' V schaltet die Kamera um
If vNow AndAlso vPrev = 0 Then
viewTop = 1 - viewTop
SetFogRange(viewTop)
End If
vPrev = vNow
' Das ganze Bild entsteht im Multisample-FBO, nicht direkt im Fenster
If msaaOK Then glBindFramebuffer(GL_FRAMEBUFFER, msFBO)
glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
glLoadIdentity()
If viewTop Then
' Senkrecht von oben. "Oben" auf dem Monitor ist -Z, die Stadt läuft
' also von oben nach unten durchs Bild.
gluLookAt( 0.0, 88.0, -16.0, _
0.0, 0.0, -16.0, _
0.0, 0.0, -1.0 )
Else
' Schrägblick nach vorn - so sieht man Dächer UND beleuchtete Fassaden
gluLookAt( 0.0, 46.0, 34.0, _
0.0, 6.0, -70.0, _
0.0, 1.0, 0.0 )
End If
DrawGround()
' Fahrbahnmarkierungen mitscrollen, als Linien fester Pixelbreite - dadurch
' werden sie in der Ferne nie unterpixelig und wabbeln nicht in der Dicke.
' GL_LINE_SMOOTH wird bei aktivem Multisampling ignoriert (das übernimmt die
' Glättung dann selbst) und bleibt nur als Rückfall stehen, falls das FBO
' auf einem anderen Rechner nicht zustande kommt.
glEnable(GL_BLEND)
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)
glEnable(GL_LINE_SMOOTH)
glHint(GL_LINE_SMOOTH_HINT, GL_NICEST)
glLineWidth(1.6)
glPushMatrix()
glTranslatef(0.0, 0.0, scroll)
glCallList(roadList)
glPopMatrix()
glDisable(GL_LINE_SMOOTH)
glDisable(GL_BLEND)
For i = 0 To NUM_BUILDINGS - 1
glPushMatrix()
glTranslatef(city(i).x, 0.0, city(i).z)
glCallList(city(i).lst)
glPopMatrix()
city(i).z += fly
If city(i).z > RECYCLE_Z Then ' Block wandert ans hintere Ende
city(i).z -= CITY_D ' Vielfaches von CELL -> Raster bleibt
CompileBuilding(i) ' und wird komplett neu ausgewürfelt
End If
Next
DrawBeacons(Timer)
DrawCars(fly)
scroll += fly
If scroll >= CELL Then scroll -= CELL
' fps wird von Regulate() am Schleifenende per Byref gesetzt, die Anzeige
' hinkt also genau einen Frame hinterher - bei 60 Hz nicht wahrnehmbar.
DrawHUD("FPS " & fps)
' Auflösen: das multisampled FBO ins Fenster blitten. GL_NEAREST ist beim
' Auflösen Pflicht - GL_LINEAR ist für multisampled Quellen nicht erlaubt.
If msaaOK Then
glBindFramebuffer(GL_READ_FRAMEBUFFER, msFBO)
glBindFramebuffer(GL_DRAW_FRAMEBUFFER, 0)
glBlitFramebuffer(0, 0, SCR_W, SCR_H, 0, 0, SCR_W, SCR_H, _
GL_COLOR_BUFFER_BIT, GL_NEAREST)
glBindFramebuffer(GL_FRAMEBUFFER, 0)
End If
Flip
Sleep(Regulate(60, fps), 1)
Loop Until Inkey = Chr(27)
|
Drücke v, um die Perspektive zu wechseln.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4728
Wohnort: ~/
|
| Verfasst am: 19.08.2026, 23:08 Titel: |
|
|
Oh, das ist schön. 
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
-----
"Das wissen doch sowieso nur Nerdinauten, die Schlaumeierologie studiert haben." - coldmirror |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
