Das deutsche QBasic- und FreeBASIC-Forum :: Thema anzeigen

Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!

FAQ

Suchen

Mitgliederliste

Benutzergruppen

Registrieren

Profil

Einloggen, um private Nachrichten zu lesen

Zur Begleitseite des Forums / Chat / Impressum

Aktueller Forenpartner:

Gfx Spielereien
Gehe zu Seite Zurück 1, 2, 3, 4, 5, 6, 7

Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen

Vorheriges Thema anzeigen :: Nächstes Thema anzeigen

Autor

Nachricht

hhr

Anmeldungsdatum: 15.07.2020
Beiträge: 113

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: 144
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: 113

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: 144
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: 144
Wohnort: Opel Stadt

Verfasst am: 13.08.2025, 22:35 Titel: Einfache 2D-Kugelkollision – Billard-Eröffnung

Eine kleine Billard-Eröffnungssimulation mit Kollisionscheck und Texture Mapping. böse

Code:

'Coded by UEZ build 2025-08-15 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

'hunction 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 = Cos(angle)
Dim s As Double = Sin(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
Dim As ULong mappedColor, outCol
Dim As vec3 spherePoint, normal

'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
Dim As Double dotProduct = normal.x * lightDir.x + normal.y * lightDir.y + normal.z * lightDir.z
Dim As Double 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
Dim As UByte a, r, g, b
a = (mappedColor And &hFF000000) Shr 24
r = (mappedColor And &h00FF0000) Shr 16
g = (mappedColor And &h0000FF00) Shr 8
b = (mappedColor And &h000000FF)

r = Clamp(r * lightFactor, 0, 255)
g = Clamp(g * lightFactor, 0, 255)
b = Clamp(b * lightFactor, 0, 255)

mappedColor = (a Shl 24) Or (r Shl 16) Or (g Shl 8) Or b

'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 = CUShort(w * 0.85)
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.84
Const table_height_m = 1.42
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.3

'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, frameDuration

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 UByte r, g, b, a


Do
Sleep Regulate(RENDER_FPS, fpsRounded)

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
                     a = (.c And &hFF000000) Shr 24
                     r = (.c And &h00FF0000) Shr 16
                     g = (.c And &h0000FF00) Shr 8
                     b = (.c And &h000000FF)

                     r = Clamp(r * lightFactor, 0, 255)
                     g = Clamp(g * lightFactor, 0, 255)
                     b = Clamp(b * lightFactor, 0, 255)

                     illuminatedColor = (a Shl 24) Or (r Shl 16) Or (g Shl 8) Or b

                     '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

If bReset Then
   GetMouse(mmx, mmy, , mmb, clip)
   While (mmb And 1) And clip = 0
      GetMouse(mmx, mmy, , mmb, clip)
      Sleep(1)
   Wend
   bReset = False
   lastTime = Timer : lastRender = 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 m Postausgang.
_________________
Gruß,
UEZ

Nach oben

UEZ

Anmeldungsdatum: 24.06.2016
Beiträge: 144
Wohnort: Opel Stadt

Verfasst am: 15.08.2025, 12:22 Titel: Re: Einfache 2D-Kugelkollision – Billard-Eröffnung

UEZ hat Folgendes geschrieben:

Eine kleine Billard-Eröffnungssimulation mit Kollisionscheck und Texture Mapping. böse

Code:

_________________
Gruß,
UEZ

Nach oben

Beiträge der letzten Zeit anzeigen:

	Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen	Alle Zeiten sind GMT + 1 Stunde Gehe zu Seite Zurück 1, 2, 3, 4, 5, 6, 7
Seite 7 von 7

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.

Impressum :: Datenschutz