 |
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: 115
|
 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: 146
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: 115
|
| 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: 146
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: 146
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: 146
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: 146
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 |
|
|
|
|
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
