 |
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 |
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
 Verfasst am: 23.04.2019, 19:55 Titel: Rutt Etra Izer Effect v0.7 |
 |
|
Um das Test Bild zu erstellen, bitten den Code hier ExtractTestImage.bas in den vorher gleichen Ordner erstellen, kompilieren und ausführen. Es sollte nun das Test Bild "Panda_800x800.bmp" erstellt worden sein (NUR FÜR WINDOWS!)!
Jetzt Rutt_Etra_Izer_FX.bas starten.
| Code: |
'Coded by UEZ v0.7 build 2019-04-24
'Thanks to eukalyptus for the fast ASM sin / cos functions and vdecampo for the DrawAALine function
#Include "fbgfx.bi"
Using FB
Declare Function _ASM_Sin6th(fX As Double) As Double
Declare Function _ASM_Cos6th(fX As Double) As Double
Declare Sub Translate3Dto2D(fXin As Single, fYin As Single, fZin As Single, _
fRotX As Single, fRotY As Single, fRotZ As Single, _
Byref xout As Single, Byref yout As Single, _
fCenterX As Single = 0, fCenterY As Single = 0.0, _
fScale As Single = 1.0, fZDeepCorrection As Single = 1000.0)
Declare Function ipart(x As Single) As Integer
Declare Function round(x As Single) As Integer
Declare Function fpart(x As Single) As Single
Declare Function rfpart(x As Single) As Single
Declare Sub Plot(x As Short, y As Short, baseclr As Ulong, c As Single)
Declare Sub DrawAALine(x0 As Single,y0 As Single,x1 As Single,y1 As Single, clr As Ulong)
#Define _GetPixel(_x, _y) *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2)
#Define _SetPixel(_x, _y, iCol) *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (iCol)
#Define _Red(iCol) ((iCol And &hFF0000) Shr 16)
#Define _Green(iCol) ((iCol And &h00FF00) Shr 8)
#Define _Blue(iCol) ((iCol And &h0000FF))
#Define _Max(a, b) (Iif(a > b, a, b))
#Define _Min(a, b) (Iif(a < b, a, b))
Dim As Any Ptr pBitmap, pImage
Dim Shared As Integer pitch, pitch2
Dim Shared As Any Pointer imgData, imgData2
Dim Shared As Ushort sw = 1200, sh = 800, bAA = 0
Dim As UShort iw, ih, wh, hh, swh = sw \ 2, shh = sh \ 2, cx, cy, iStepX = 4, iStepY = 4, x, y
Dim As String sImage = "Panda_800x800.bmp"
iw = 800
ih = 800
Screenres sw, sh, 32, 2
Screenset 1, 0
Windowtitle "Rutt Etra Izer Effect v0.7 by UEZ"
pBitmap = Imagecreate(iw, ih, 0, 32)
Bload sImage, pBitmap
Imageinfo(pBitmap, , , , pitch, imgData)
pImage = Imagecreate(sw, sh, 0, 32)
Imageinfo(pImage, , , , pitch2, imgData2)
cx = (sw - iw) \ 2
cy = (sh - ih) \ 2
Type vec4
As Single x, y, z
As Ulong col
End Type
Dim As Ushort iUBY = ih \ iStepY + 1, iUBX = iw \ iStepX + 1, xx = 0, yy = 0
wh = iw \ 2
hh = ih \ 2
Dim As vec4 aPixels(iUBY, iUBX)
For y = 0 To ih - 1 Step iStepY
For x = 0 To iw - 1 Step iStepX
aPixels(yy, xx).x = x - wh
aPixels(yy, xx).y = y - hh
aPixels(yy, xx).col = _GetPixel(x, y)
aPixels(yy, xx).z = 255 - (_Red(aPixels(yy, xx).col) + _Green(aPixels(yy, xx).col) + _Blue(aPixels(yy, xx).col)) / 6
xx += 1
Next
yy += 1
xx = 0
Next
Dim As Single px1, py1, px2, py2, fPi = Acos(-1), fSpeed = fPi / (8 * 180), fAngle = 0, f2Pi = 2 * fPi, xr, yr, xrot, yrot, dx = cx + wh, dy = cy + hh, fScale = 1.0, s
Dim As Integer mx, my, mb, mw, mc, mwo, mxo, myo
Dim As Ushort iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer
Do
Line pImage, (0, 0) - (sw - 1, sh - 1), Rgba(0, 0, 0, 200), BF 'clear image
'helper lines
'Line pImage, (0, shh) - (sw, shh), Rgba(64, 64, 64, 192)
'Line pImage, (swh, 0) - (swh, sh), Rgba(64, 64, 64, 192)
Getmouse mx, my, mw, mb, mc
If mb = 1 And (mx <> mxo Or my <> myo) Then
xrot = -(mx / sw) * f2Pi + fPi
yrot = (my / sh) * f2Pi + fPi
mxo = mx
myo = my
Elseif mb = 2 Then
xrot = 0
yrot = 0
End If
If mc = 0 Then mwo = mw
s = _Min(_Max(fScale + Iif(mc = -1, mwo, mw) / 20, 0.1), 4) 'scale factor
For y = 0 To Ubound(aPixels) - 1
For x = 1 To Ubound(aPixels, 2) - 2
Translate3Dto2D(aPixels(y, x - 1).x, aPixels(y, x - 1).y, aPixels(y, x - 1).z, yrot, -xrot, 0, px1, py1, dx, dy, s)
Translate3Dto2D(aPixels(y, x).x, aPixels(y, x).y, aPixels(y, x).z, yrot, -xrot, 0, px2, py2, dx, dy, s)
If bAA Then
DrawAALine(px1, py1, px2, py2, aPixels(y, x).col)
Else
Line pImage, (px1, py1)-(px2, py2), aPixels(y, x).col
End If
Next
Next
Put (0, 0), pImage, Pset
Draw String(1, 1), iFPS_current & " fps", Rgb(&h00, &hFF, &h00)
Flip
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
Sleep(10, 1)
Loop Until Inkey = Chr(27)
Imagedestroy pBitmap
Imagedestroy pImage
Sub Translate3Dto2D(fXin As Single, fYin As Single, fZin As Single, _
fRotX As Single, fRotY As Single, fRotZ As Single, _
Byref xout As Single, Byref yout As Single, _
fCenterX As Single = 0, fCenterY As Single = 0, _
fScale As Single = 1.0, fZDeepCorrection As Single = 1000.0)
Dim As Single fCosRotX, fSinRotX, fCosRotY, fSinRotY, fCosRotZ, fSinRotZ, f1, f2, f3, f4, f5, f6, fXPos, fYPos, fZPos, fZPerspCorrection
fCosRotX = _ASM_Cos6th(fRotX)
fSinRotX = _ASM_Sin6th(fRotX)
fCosRotY = _ASM_Cos6th(fRotY)
fSinRotY = _ASM_Sin6th(fRotY)
fCosRotZ = _ASM_Cos6th(fRotZ)
fSinRotZ = _ASM_Sin6th(fRotZ)
f1 = fCosRotY * fXin
f2 = fSinRotX * fYin
f3 = fCosRotX * fZin
f4 = fCosRotX * fYin
f5 = fSinRotX * fZin
f6 = f1 - fSinRotY * (f2 + f3)
fXPos = (fCosRotZ * f6 - fSinRotZ * (f4 - f5)) * fScale
fYPos = (fSinRotZ * f6 + fCosRotZ * (f4 - f5)) * fScale
fZPos = (fSinRotY * fXin + fCosRotY * (f2 + f3)) * fScale
fZPerspCorrection = 1 / (fZPos / fZDeepCorrection + 1)
xout = fXPos * fZPerspCorrection + fCenterX
yout = fYPos * fZPerspCorrection + fCenterY
'fZ = fZPos
End Sub
Function _ASM_Sin6th(fX As Double) As Double
'By Eukalyptus
Asm
jmp 0f
1: .Double 683565275.57643158
2: .Double -0.0000000061763971109087229
3: .Double 6755399441055744.0
0:
movq xmm0, [fX]
mulsd xmm0, [1b]
addsd xmm0, [3b]
movd ebx, xmm0
lea eax, [ebx*2+0x80000000]
sar eax, 2
imul eax
sar ebx, 31
lea eax, [edx*2-0x70000000]
lea ecx, [edx*8+edx-0x24000000]
imul edx
Xor ecx, ebx
lea eax, [edx*8+edx+0x44A00000]
imul ecx
cvtsi2sd xmm0, edx
mulsd xmm0, [2b]
movq [Function], xmm0
End Asm
End Function
Function _ASM_Cos6th(fX As Double) As Double
'By Eukalyptus
Asm
jmp 0f
1: .Double 683565275.57643158
2: .Double -0.0000000061763971109087229
3: .Double 6755399441055744.0
0:
movq xmm0, [fX]
mulsd xmm0, [1b]
addsd xmm0, [3b]
movd ebx, xmm0
Add ebx, 0x40000000 'SinToCos
lea eax, [ebx*2+0x80000000]
sar eax, 2
imul eax
sar ebx, 31
lea eax, [edx*2-0x70000000]
lea ecx, [edx*8+edx-0x24000000]
imul edx
Xor ecx, ebx
lea eax, [edx*8+edx+0x44A00000]
imul ecx
cvtsi2sd xmm0, edx
mulsd xmm0, [2b]
movq [Function], xmm0
End Asm
End Function
/'
https://www.freebasic.net/forum/viewtopic.php?t=24443#p216462
Xiaolin Wu's line algorithm
An algorithm for line antialiasing,
which was presented in the article
an efficient antialiasing technique
in the July 1991 issue of Computer
Graphics, as well as in the article
Fast Antialiasing in the June 1992
issue of Dr. Dobb's Journal.
'/
'// Integer part of x
Function ipart(x As Single) As Integer
Return Int(x)
End Function
Function round(x As Single) As Integer
Return ipart(x + 0.5)
End Function
' fractional part of x
Function fpart(x As Single) As Single
If x < 0 Then Return 1 - (x - Fix(x))
Return x - Fix(x)
End Function
Function rfpart(x As Single) As Single
Return 1 - fpart(x)
End Function
Sub Plot(x As Short, y As Short, baseclr As Ulong, c As Single)
baseclr = (_Red(baseclr) * c) Shl 16 Or (_Green(baseclr) * c) Shl 8 Or (_Blue(baseclr) * c) Shl 0
*Cptr(Ulong Ptr, imgData2 + (Iif(y < 0, 0, Iif(y > sh - 1, sh - 1, y))) * pitch2 + (Iif(x < 0, 0, Iif(x > sw - 1, sw - 1, x))) Shl 2) = baseclr
End Sub
Sub DrawAALine(x0 As Single,y0 As Single,x1 As Single,y1 As Single, clr As Ulong)
Dim As Integer steep = Abs(y1 - y0) > Abs(x1 - x0)
Dim As Single dx,dy,gradient,xend,yend,xgap,xpxl1,ypxl1,xpxl2,ypxl2,intery
If steep Then
Swap x0, y0
Swap x1, y1
End If
If x0 > x1 Then
Swap x0, x1
Swap y0, y1
End If
dx = x1 - x0
dy = y1 - y0
gradient = dy / dx
' handle first endpoint
xend = round(x0)
yend = y0 + gradient * (xend - x0)
xgap = rfpart(x0 + 0.5)
xpxl1 = xend ' This will be used in the main Loop
ypxl1 = ipart(yend)
If steep Then
plot(ypxl1, xpxl1, clr, rfpart(yend) * xgap)
plot(ypxl1+1, xpxl1, clr, fpart(yend) * xgap)
Else
plot(xpxl1, ypxl1 , clr, rfpart(yend) * xgap)
plot(xpxl1, ypxl1+1, clr, fpart(yend) * xgap)
End If
intery = yend + gradient ' first y-intersection For the main Loop
' handle Second endpoint
xend = round(x1)
yend = y1 + gradient * (xend - x1)
xgap = fpart(x1 + 0.5)
xpxl2 = xend 'This will be used in the main Loop
ypxl2 = ipart(yend)
If steep Then
plot(ypxl2 , xpxl2, clr, rfpart(yend) * xgap)
plot(ypxl2+1, xpxl2, clr, fpart(yend) * xgap)
Else
plot(xpxl2, ypxl2, clr, rfpart(yend) * xgap)
plot(xpxl2, ypxl2+1, clr, fpart(yend) * xgap)
End If
' Line Loop
For x As Integer = xpxl1 + 1 To xpxl2 - 1
If steep Then
plot(ipart(intery) , x, clr, rfpart(intery))
plot(ipart(intery)+1, x, clr, fpart(intery))
Else
plot(x, ipart(intery), clr, rfpart(intery))
plot(x, ipart(intery)+1, clr, fpart(intery))
End If
intery = intery + gradient
Next
End Sub
|
Die linke Maustaste gedrückt halten und die Maus bewegen, um das Objekt zu drehen. Das Mausrad dient zum Zoomen.
_________________
Gruß
UEZ |
|
| Nach oben |
|
 |
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 23.02.2020, 15:19 Titel: Growing plant in the breeze v0.70 |
|
|
Vorschau:
| Code: |
'Ported To FreeBasic by UEZ build 2020-02-23
'Original code by civet -> http://wa.zozuar.org/code.php?c=9KQy
#Define Min(a, b) (Iif(a < b, a, b))
#Define Max(a, b) (Iif(a > b, a, b))
#Define _Alpha(iCol) ((iCol And &hFF000000) Shr 24)
#Define _Red(iCol) ((iCol And &h00FF0000) Shr 16)
#Define _Green(iCol) ((iCol And &h0000FF00) Shr 8)
#Define _Blue(iCol) ((iCol And &h000000FF))
#Define Round(x) ((x + 0.5) Shr 0)
#Define fpart(x) (Frac(x))
#Define rfpart(x) (1 - Frac(x))
#Define Floor(x) (((x) * 2.0 - 0.5) Shr 1)
Const fPI = Acos(-1), fRAD = fPI / 180, fPI80 = fPI / 80
Const iW = 800, iH = 600, iW2 = iW \ 2, iH2 = iH \ 2
'https://en.wikipedia.org/wiki/Xiaolin_Wu%27s_line_algorithm
Sub DrawLineAAWu(pTarget As Any Ptr = 0, x0 As Short, y0 As Short, x1 As Short, y1 As Short, col As Ulong)
Dim As Boolean steep = Abs(y1 - y0) > Abs(x1 - x0)
If steep Then
Swap x0, y0
Swap x1, y1
End If
If x0 > x1 Then
Swap x0, x1
Swap y0, y1
End If
Dim As Short dx, dy, xend, yend, xgap, xpxl1, ypxl1, xpxl2, ypxl2
Dim As Single gradient, intery, f
Dim As Ulong _rgb = col And &h00FFFFFF
Dim As Ubyte a = _Alpha(col)
dx = x1 - x0
dy = y1 - y0
gradient = dy / dx
If dx = 0 Then gradient = 1
'handle first endpoint
xend = Round(x0)
yend = y0 + gradient * (xend - x0)
xgap = rfpart(x0 + 0.5)
xpxl1 = xend
ypxl1 = Floor(yend)
If steep Then
f = rfpart(yend) * xgap
Pset pTarget, (ypxl1, xpxl1), (a * f) Shl 24 Or _rgb
f = fpart(yend) * xgap
Pset pTarget, (ypxl1 + 1, xpxl1), (a * f) Shl 24 Or _rgb
Else
f = rfpart(yend) * xgap
Pset pTarget, (xpxl1, ypxl1), (a * f) Shl 24 Or _rgb
f = fpart(yend) * xgap
Pset pTarget, (xpxl1, ypxl1 + 1), (a * f) Shl 24 Or _rgb
End If
intery = yend + gradient
'handle second endpoint
xend = Round(x1)
yend = y1 + gradient * (xend - x1)
xgap = rfpart(x1 + 0.5)
xpxl2 = xend
ypxl2 = Floor(yend)
If steep Then
f = rfpart(yend) * xgap
Pset pTarget, (ypxl2, xpxl2), (a * f) Shl 24 Or _rgb
f = fpart(yend) * xgap
Pset pTarget, (ypxl2 + 1, xpxl2), (a * f) Shl 24 Or _rgb
Else
f = rfpart(yend) * xgap
Pset pTarget, (xpxl2, ypxl2), (a * f) Shl 24 Or _rgb
f = fpart(yend) * xgap
Pset pTarget, (xpxl2, ypxl2 + 1), (a * f) Shl 24 Or _rgb
End If
'main line
If steep Then
For x As Short = xpxl1 + 1 to xpxl2 - 1
f = rfpart(intery)
Pset pTarget, (Floor(intery), x), (a * f) Shl 24 Or _rgb
f = fpart(intery)
Pset pTarget, (Floor(intery) + 1, x), (a * f) Shl 24 Or _rgb
intery += gradient
Next
Else
For x As Short = xpxl1 + 1 to xpxl2 - 1
f = rfpart(intery)
Pset pTarget, (x, Floor(intery)), (a * f) Shl 24 Or _rgb
f = fpart(intery)
Pset pTarget, (x, Floor(intery) + 1), (a * f) Shl 24 Or _rgb
intery += gradient
Next
End If
End Sub
'Bresenham algorithm
Sub DrawLineThickAA(pTarget As Any Ptr = 0, x0 As Short, y0 As Short, x1 As Short, y1 As Short, col As Ulong, th As Single)
Dim As Single dx = Abs(x1 - x0), dy = Abs(y1 - y0)
Dim As Byte sx = Iif(x0 < x1, 1, -1), sy = Iif(y0 < y1, 1, -1)
Dim As Single ierr, e2 = Sqr(dx * dx + dy * dy)
If th <= 1 Or e2 = 0 Then
DrawLineAAWu(pTarget, x0, y0, x1, y1, col)
Else
dx *= 255 / e2
dy *= 255 / e2
th = 255 * (th - 1)
If dx < dy Then
x1 = Round((e2 + th / 2) / dy)
ierr = x1 * dy - th / 2
x0 -= x1 * sx
While y0 <> y1
x1 = x0
Pset pTarget, (x1, y0), Rgba(_Red(col), _Green(col), _Blue(col), Max(0, _Alpha(col) - ierr))
e2 = dy - ierr - th
While e2 + dy < 255
x1 += sx
Pset pTarget, (x1, y0), col
e2 += dy
Wend
Pset pTarget, (x1 + sx, y0), Rgba(_Red(col), _Green(col), _Blue(col), Max(0, _Alpha(col) - e2))
ierr += dx
If ierr > 255 Then
ierr -= dy
x0 += sx
End If
y0 += sy
Wend
Else
y1 = Round((e2 + th / 2) / dx)
ierr = y1 * dx - th / 2
y0 -= y1 * sy
While x0 <> x1
y1 = y0
Pset pTarget, (x0, y1), Rgba(_Red(col), _Green(col), _Blue(col), Max(0, _Alpha(col) - ierr))
e2 = dx - ierr - th
While e2 + dx < 255
y1 += sy
Pset pTarget, (x0, y1), col
e2 += dx
Wend
Pset pTarget, (x0, y1 + sy), Rgba(_Red(col), _Green(col), _Blue(col), Max(0, _Alpha(col) - e2))
ierr += dy
If ierr > 255 Then
ierr -= dx
y0 += sy
End If
x0 += sx
Wend
End If
End If
End Sub
Sub CreatePlantRecursive(pTarget As Any Ptr = 0,px As Single, py As Single, angle As Single, fStep As Single, _Len As Integer, fGrowth As Single, n As Integer)
If n > 0 Then
Dim As Single x1, y1, x2, y2, a_l, a_r, t = 0.1 * _len, f0, f1, f2
angle += 3 * Cos(fStep) - 2
f0 = angle * fRAD
f1 = Cos(f0)
f2 = Sin(f0)
x1 = px + t * f1
y1 = py - t * f2
x2 = px + _len * f1
y2 = py - _len * f2
DrawLineThickAA(pTarget, px, py, x2, y2, &hF0437C17, n - 1)
If n > 2 Then Line pTarget, (px, py) - (x2, y2), &h8052D017
If n = 1 Then Circle pTarget, (x2, y2), 2.5 * (1.5 + fGrowth), &hE87F38EC, , , , F
a_l = angle + 30
a_r = angle - 30
_len *= fGrowth
Dim As Integer i = n - 1
CreatePlantRecursive(pTarget, x2, y2, angle - 3 * Sin(fStep), fStep, _len, fGrowth, i)
CreatePlantRecursive(pTarget, x1, y1, a_l, fStep, _len * fGrowth,fGrowth, i)
CreatePlantRecursive(pTarget, x1, y1, a_r, fStep, _len * fGrowth,fGrowth, i)
CreatePlantRecursive(pTarget, x2, y2, a_l, fStep, _len * fGrowth,fGrowth, i)
CreatePlantRecursive(pTarget, x2, y2, a_r, fStep, _len * fGrowth,fGrowth, i)
End If
End Sub
'
' main
'
Randomize , 2
Screenres iW, iH, 32, 2, 100 'GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
Screenset 1, 0
Windowtitle("Growing plant in the breeze v0.70")
Dim As Single n = 10, m = 10
Dim As Single fGrowth = 1 / 20, fStep
Dim As Integer iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer
Do
Line (0, 0) - (iW - 1, iH - 1), &hF0FFFFFF, BF
CreatePlantRecursive(0, iW2, iH, 90, fStep, n, fGrowth, 5)
If n > 110 Then
CreatePlantRecursive(0, iW2, iH, 45, fStep, m, fGrowth, 4)
CreatePlantRecursive(0, iW2, iH, 135, fStep, m, fGrowth, 4)
fStep += fPI80 * Sin(-Cos(-Timer) + Timer) * 2
If fGrowth < 0.67 And n > 110 Then fGrowth += 0.001
End If
If n < 220 Then n += 0.5
If m < 111 And n > 110 Then m += 0.5
Draw String(1, 1), iFPS_current & " fps", Rgba(&h00, &h00, &hFF, &hFF)
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
End If
Flip
Sleep(10)
Loop Until Len(Inkey())
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Sebastian
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland
|
|
| Nach oben |
|
|
Roland Chastain
Anmeldungsdatum: 05.12.2011
Beiträge: 194
Wohnort: Frankreich
|
| Verfasst am: 23.02.2020, 23:16 Titel: |
|
|
| Sehr schön. Der Brise-Effekt ist sehr erfolgreich! |
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1283
Wohnort: Ruhrpott
|
| Verfasst am: 25.02.2020, 16:07 Titel: |
|
|
Wäre direkt etwas für einen elektronischen Bilderrahmen. 
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 04.03.2020, 16:07 Titel: Magnifier build 2020-03-05 [Windows only] ^^ |
|
|
Das nächste Beispiel: Desktop Lupe.
Source Code: Pastebin
Vorschau:
Source Code + kompilierte Exe kann hier heruntergeladen werden: Mediafire.com
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 27.03.2020, 14:35 Titel: COVID-19 Ausbreitungssimulation |
|
|
Nicht wissenschaftliche Simulation der COVID-19 Ausbreitung.
| Code: |
'Coded by UEZ build 2020-04-02
#include "string.bi"
#Define _Dist(x1, x2, y1, y2) (((y2 - y1) * (y2 - y1) + (x2 - x1) * (x2 - x1)))
#Define _Round(x) ((x + 0.5) Shr 0)
#Define Ceiling(x) (-((-(x) * 2.0 - 0.5) Shr 1))
#Define Map(a, b, c) (a / b * c)
Const iW = 1024, iH = 768, iPeople = 19999, iPSize = 1, iMaxSickDays = 14, fDaySpeed = 0.0075, iDayInoFound = 60, probDeath = 0.05, infProb = 0.25, gH = 100
Type vZone
Dim As Ushort x1, y1, x2, y2
Dim As Uinteger pp(iPeople + 1) 'index of people
Dim As Ulong c
End Type
Declare Sub Motion()
Declare Function RandomRange(fStart As Single, fEnd As Single) As Single
Declare Sub CreateGridZones(Zones() As vZone, iZones As Ushort, imgw As Ushort, imgh As Ushort)
Const As ULong iBGColor = &hFF000000
ScreenRes iW, iH, 32, 2, 100
ScreenSet 1, 0
Dim Shared As Any Ptr img, img_clr
img = Imagecreate(iW, iH, &hFF404040, 32)
img_clr = Imagecreate(iW, iH - gH, iBGColor, 32)
Randomize , 2
Dim Shared As Uinteger iPSize2, iPrevDaysPassed = 0
iPSize2 = iPSize^2
Dim Shared As Single fDaysPassed = 0
Type vPeople
Dim As Single x, y, vx, vy, sickdays, healthydays
Dim As Ulong c
Dim As Ubyte status, zone 'status: healthy = 0, infected = 1, cured = 2, dead = 3, inoculated = 4
End Type
Dim Shared As Ushort p0, iGridZones = 12^2
Dim Shared As vZone GridZone(iGridZones)
Dim As Uinteger i, j
CreateGridZones(GridZone(), iGridZones, iW, iH - gH)
iGridZones -= 1
For j = 0 To iGridZones 'create color for each grid zone for debugging purpose
GridZone(j).c = &h80000000 Or Culng(Rnd() * &hFFFFFF)
Next
Dim Shared As vPeople People(iPeople)
For i = 0 To iPeople
People(i).x = RandomRange(iPSize + 1, iW - iPSize - 1)
People(i).y = RandomRange(iPSize + 1, iH - iPSize - gH - 1)
People(i).c = &hFFFFFFFF
People(i).vx = 0.15 * Rnd() - 0.075
People(i).vy = 0.15 * Rnd() - 0.075
People(i).status = 0
People(i).sickdays = 0
People(i).healthydays = 0
Next
p0 = Cuint(Rnd * iPeople) 'gunman aka patient zero
People(p0).c = &hFFFF0000
People(p0).status = 1
'People(p0).vx *= 5
'People(p0).vy *= 4
Dim As Ulong iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer
Do
Put img, (0, 0), img_clr, Pset
Motion()
Put (0, 0), img, Pset
Draw String(1, 1), iFPS_current & " fps", Rgba(&hF0, &hF0, &h10, &hFF)
Flip
fDaysPassed += fDaySpeed
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
End If
Sleep 1, 1
Loop Until Len(InKey())
Imagedestroy(img_clr)
Imagedestroy(img)
Sub Motion()
Dim As Uinteger i, j, k, l, iBucket, index, iHealthy = 0, iInfected = 0, iCured = 0, iDead = 0, iInoculated = 0
Static As Single cr = 0
Dim As Single t1, t2
For j = 0 To iGridZones 'reset amount if people in the bucket
GridZone(j).pp(0) = 0
'Line img, (GridZone(j).x1, GridZone(j).y1)-(GridZone(j).x2, GridZone(j).y2), GridZone(j).c, BF 'display GridZone for debugging
Next
For i = 0 To iPeople
'move each people if not dead
If People(i).status <> 3 Then 'skip dead people
People(i).x += People(i).vx
People(i).y += People(i).vy
End If
'check border collision
If People(i).x < 0 Or People(i).x > iW - iPSize - 1 Then People(i).vx *= -1
If People(i).y < 0 Or People(i).y > iH - iPSize - gh - 1 Then People(i).vy *= -1
'group people into GridZone for more efficient collision check afterwards
For j = 0 To iGridZones
If People(i).x > GridZone(j).x1 And People(i).x < GridZone(j).x2 - iPSize And People(i).y > GridZone(j).y1 And People(i).y < GridZone(j).y2 - iPSize Then
GridZone(j).pp(0) += 1
GridZone(j).pp(GridZone(j).pp(0)) = i
'People(i).c = GridZone(j).c
People(i).zone = j
Exit For
End If
Next
If fDaysPassed > 7 And People(i).status = 0 And Rnd() < 0.000000075 Then
If People(i).status = 0 Then People(i).status = 1 'make random people sick. People came back from infected country
End If
If People(i).status = 0 Then People(i).healthydays += fDaySpeed
If People(i).healthydays > iDayInoFound And People(i).status = 0 Then 'immunisation has been found -> inoculation started
If Rnd() < 0.0015 Then People(i).status = 4 'add a delay as not each people will be incoculated at the same time
End If
If People(i).sickdays > iMaxSickDays Then
People(i).sickdays = 0
If Rnd() < probDeath Then 'probability of death at 5%
People(i).status = 3
People(i).vx = 0
People(i).vy = 0
Else 'cured
People(i).status = 2
End If
End If
Select Case People(i).status
Case 0
iHealthy += 1
Case 1
People(i).sickdays += fDaySpeed
iInfected += 1
If i = p0 Then 'show patient zero with a circle during infection phase and color flash
People(p0).c = &hFF000000 Or (cr Shl 16)
cr += 10
t1 = iPSize / 2
'Circle img, (People(i).x + t1, People(i).y + t1), 2 * iPSize, &hFFC0C000
Else
People(i).c = &hFFF00000
End If
Case 2
iCured += 1
People(i).c = &hFF00F000
Case 3
iDead += 1
People(i).c = &hFFE238EC
Case 4
iInoculated += 1
People(i).c = &hFF2020FF
End Select
Line img, (People(i).x, People(i).y)-(People(i).x + iPSize, People(i).y + iPSize), People(i).c, BF
Next
'collision check of infected peoples
For i = 0 To iPeople
If People(i).status = 1 Then 'don't check dead and healty peoples
iBucket = GridZone(People(i).zone).pp(0)
For j = 1 To iBucket
index = GridZone(People(i).zone).pp(j)
If People(index).status = 0 And index <> i Then
If Int(_Dist(People(i).x, People(index).x, People(i).y, People(index).y)) <= iPSize2 And Rnd() > infProb Then 'infect people by 75% probability
People(index).status = 1
'increase the speed of infection
'People(index).vx *= -1
'People(index).vy *= -1
'decrease the speed of infection -> infected people will move reverse direction on infection
'People(i).vx *= -1
'People(i).vy *= -1
End If
End If
Next
End If
Next
Dim As Ushort iSum = iHealthy + iCured + iInoculated
Windowtitle("Corona Infection Simulation by UEZ / h: " & iSum & ", inf: " & iInfected & Format(iInfected / (iPeople - iDead), " (0.00%)") & _
", c: " & iCured & ", d: " & iDead & Format(iDead / (iPeople + 1), " (0.00%)") & _
", ino: " & iInoculated & ", day: " & Format(fDaysPassed, "#"))
Static As Single posx = 0
If posx <= iW Then
If Cushort(fDaysPassed) Mod 7 = 0 And fDaysPassed > 1 And iPrevDaysPassed < Cushort(fDaysPassed) Then
Line img, (posx, iH - gH)-(posx, iH), &hFF000000
iPrevDaysPassed = fDaysPassed
'posx += 1
Else
t2 = gH / (iPeople + 1)
Line img, (posx, iH)-(posx, iH - (iHealthy * t2)), &h40FFFFFF
Line img, (posx, iH)-(posx, iH - (iInfected * t2)), &h40FF0000
If iDead Then Line img, (posx, iH)-(posx, iH - (iDead * t2)), &hF0E238EC
If iCured Then Line img, (posx, iH - gH)-(posx, iH - gH + (iCured * t2)), &h4000F000
If iInoculated Then Line img, (posx, iH - gH)-(posx, iH - gH + (iInoculated * t2)), &hF02020FF
End If
posx += fDaySpeed * 10
End If
End Sub
'Original code by Neptilo @ https://math.stackexchange.com/questions/466198/algorithm-to-get-the-maximum-size-of-n-squares-that-fit-into-a-rectangle-with-a
'Modified by UEZ
Sub CreateGridZones(Zones() As vZone, iZones As Ushort, imgw As Ushort, imgh As Ushort)
Dim As Single ratio = Iif(Frac(Sqr(iZones)) = 0, 1, Iif(imgw >= imgh, imgw / imgh, imgh / imgw))
Dim As Single ncols_float = Sqr(iZones * ratio), nrows_float = iZones / ncols_float
'Find best option filling the whole height
Dim As Uinteger nrows1 = Ceiling(nrows_float), ncols1 = Ceiling(iZones / nrows1)
While nrows1 * ratio < ncols1
nrows1 += 1
ncols1 = Ceiling(iZones / nrows1)
Wend
Dim As Single cell_size1 = imgh / nrows1
'Find best option filling the whole width
Dim As Uinteger ncols2 = Ceiling(ncols_float), nrows2 = Ceiling(iZones / ncols2)
While ncols2 < nrows2 * ratio
ncols2 += 1
nrows2 = Ceiling(iZones / ncols2)
Wend
Dim As Single cell_size2 = imgw / ncols2
'Find the best values
Dim As Uinteger nrows, ncols
If cell_size1 < cell_size2 Then
nrows = nrows1
ncols = ncols1
Else
nrows = nrows2
ncols = ncols2
End If
Dim As Uinteger i,j, k, x, y
Dim As Integer dz = iZones - (nrows * ncols), bz = Iif(dz <> 0, 1, 0)
Dim As Single dx = imgw / ncols, dy = imgh / nrows
For j = 0 To nrows - 1 - bz
For i = 0 To ncols - 1
x = Cuint(i * dx)
Zones(k).x1 = x
Zones(k).x2 = x + dx
Zones(k).y1 = (j Mod nrows) * dy
Zones(k).y2 = Zones(k).y1 + dy
k += 1
Next
Next
If bz Then
ncols = iZones - k
dx = imgw / ncols
For i = 0 To ncols - 1
x = Cuint(i * dx)
Zones(k).x1 = x
Zones(k).x2 = x + dx
Zones(k).y1 = (j Mod nrows) * dy
Zones(k).y2 = Zones(k).y1 + dy
k += 1
Next
End If
End Sub
Function RandomRange(fStart As Single, fEnd As Single) As Single
Return Rnd() * (fEnd - fStart) + fStart
End Function
|
h: Anzahl gesunder Pixels (weiß + grün + blau)
inf: infizierte Pixels (rot)
c: geheilte Pixels (grün)
d: tote Pixels (lila)
ino: geimpfte Pixels (blau)
Am besten als x64 und -gen gcc -O 3 -s gui kompilieren.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 18.04.2020, 13:17 Titel: Twister Effect build 2020-04-17 |
|
|
| Code: | 'Ported to FreeBasic by UEZ build 2020-04-17
'Original code by neur0sys -> 'https://codepen.io/neuro_sys/pen/QpxMvp
#Include "fbgfx.bi"
#include "file.bi"
Using FB
#Define PixelSet(_x, _y, colour) *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (colour)
#Define PixelGet(_x, _y, iArrayPos) *Cptr(Ulong Ptr, aImageInfoData(iArrayPos) + (_y) * aImageInfoPitch(iArrayPos) + (_x) Shl 2)
#Define LinearInterpolate(a1, a2, m) ((a1 * (1 - m) + a2 * m))
#Define Alpha(colors) ((colors Shr 24) And 255)
#Define Red(colors) ((colors Shr 16) And 255)
#Define Green(colors) ((colors Shr 8) And 255)
#Define Blue(colors) (colors And 255)
'https://en.wikipedia.org/wiki/BMP_file_format
Type tBitmap_Header Field = 1 '54 bytes
As UShort bfType 'for windows bitmap it must be 19778 (&h4D42) aka "BM" in little-endian format
As Long bfSize
As ULong bfReserved
As ULong bfOffBits
As ULong biSize
As Long biWidth = 0
As Long biHeight = 0
As Ushort biPlanes
As Ushort biBitCount
As ULong biCompression
As ULong biSizeImage
As Long biXPelsPerMeter
As Long biYPelsPerMeter
As ULong biClrUsed
As ULong biClrImportant
End Type
Declare Sub drawTextureLineH(x As Ushort, y As Ushort, k As Ushort, p As Ubyte, bf as Single = 0.90)
Declare Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Declare Function GetBitmapHeaderInfo(filename As String) As tBitmap_Header
Dim As String sFile = CurDir & "/Test1.bmp" 'read 1st image to get the image dimension.
Dim As tBitmap_Header BmpInfo = GetBitmapHeaderInfo(sFile)
If BmpInfo.biWidth = 0 Or BmpInfo.biHeight = 0 Then
BmpInfo.biWidth = 1200 : BmpInfo.biHeight = 200
End If
Dim Shared As Ushort iW, iH, iW2, iH2, amp, iCenter, iDir, barpos = 0
If BmpInfo.biWidth < BmpInfo.biHeight Then barpos = 1 ' pos = 0 = horizontal, 1 = vertical
iW = Iif(barpos = 1, BmpInfo.biWidth * 1.5, BmpInfo.biWidth) : iH = Iif(barpos = 0, BmpInfo.biHeight * 1.5, BmpInfo.biHeight)
amp = Iif(barpos = 0, BmpInfo.biHeight \ 2, BmpInfo.biWidth \ 2) : iDir = Iif(barpos = 0, iW, iH) : iCenter = Iif(barpos = 0, iH \ 2, iW \ 2)
Const fPI = Acos(-1), fRAD = fPI / 180, surfaces = 4, angle = 360 / surfaces 'surfaces must be greater than 1
Dim As Ushort i, s, j, aSurfaces(surfaces)
Dim As Single t, freq, c, d
Screenres iW, iH, 32, , GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
Windowtitle("Twister Effect v0.85")
Dim Shared As Integer w, h, pitch, w2, h2
Dim Shared As Any Pointer imgData
Dim Shared As Any Ptr pImage, aImages(0 To surfaces - 1), aImageInfoData(0 To surfaces - 1)
Dim Shared As Integer aImageInfoPitch(0 To surfaces - 1)
pImage = Imagecreate(iW, iH, , 32)
Randomize Timer, 2
For i = 0 To surfaces - 1 'all images must have same dimension!
aImages(i) = Imagecreate(BmpInfo.biWidth, BmpInfo.biHeight, &hFF000000 Or Rnd() * &hFFFFFF, 32)
Bload(CurDir & "/Test" & i + 1 & ".bmp", aImages(i))
Imageinfo(aImages(i), w2, h2, , aImageInfoPitch(i), aImageInfoData(i))
Next
Imageinfo(pImage, w, h, , pitch, imgData)
Dim As Ulong iFPS = 0
Do
Screenlock
Line pImage, (0, 0) - (iW, iH), &hF0404040, BF
t = Cos(d / 50) * iDir
d += 1.5
freq = Sin(d / 125) / 4
For j = 0 To iDir - 1
c = (j + t) * freq
For i = 0 To surfaces - 1
aSurfaces(i) = iCenter + Sin((c + angle * i) * fRAD) * amp
Next
For i = 0 To surfaces - 2
If aSurfaces(i) < aSurfaces(i + 1) Then
Select Case barpos
Case 0
drawTextureLineH(j, aSurfaces(i), aSurfaces(i + 1) - aSurfaces(i), i)
Case 1
drawTextureLineH(aSurfaces(i), j, aSurfaces(i + 1) - aSurfaces(i), i)
End Select
End If
Next
aSurfaces(i) = iCenter + Sin((c + angle * i) * fRAD) * amp
If aSurfaces(i) < aSurfaces(0) Then
Select Case barpos
Case 0
drawTextureLineH(j, aSurfaces(i), aSurfaces(0) - aSurfaces(i), i)
Case 1
drawTextureLineH(aSurfaces(i), j, aSurfaces(0) - aSurfaces(i), i)
End Select
End If
Next
Put (0, 0), pImage, Alpha
Draw String(1, 1), iFPS & " fps", Rgba(&hFF, &h00, &h00, &hFF)
Screenunlock
Sleep (Regulate(30, iFPS), 1)
Loop Until Len(Inkey())
Imagedestroy(pImage)
For i = 0 To surfaces - 1
Imagedestroy(aImages(i))
Next
End
Sub drawTextureLineH(x As Ushort, y As Ushort, k As Ushort, p As Ubyte, bf as Single = 0.90)
Dim As Ushort u, v
Dim As Ulong texel
Dim As Single f, r, g, b
For i As Ushort = 0 To k - 1
Select Case barpos
Case 0
u = LinearInterpolate(0, w2, x / iW)
v = LinearInterpolate(0, h2, i / k)
Case 1
u = LinearInterpolate(0, w2, i / k)
v = LinearInterpolate(0, h2, y / iH)
End Select
texel = PixelGet(u, v, p)
f = k / amp * bf
r = Red(texel) * f
r = Iif(r > 255, 255, r)
g = Green(texel) * f
g = Iif(g > 255, 255, g)
b = Blue(texel) * f
b = Iif(b > 255, 255, b)
Select Case barpos
Case 0
PixelSet(x, y + i, Rgba(r, g, b, &hF8))
Case 1
PixelSet(x + i, y, Rgba(r, g, b, &hF8))
End Select
Next
End Sub
Function Regulate(MyFps 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) >= 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
Function GetBitmapHeaderInfo(filename As String) As tBitmap_Header
Dim As tBitmap_Header BmpInfo
If FileExists(filename) = 0 Then Return BmpInfo
Dim As Integer f
f = FreeFile
Open filename For Binary As #f
Get #f, , BmpInfo
Close #f
Return BmpInfo
End Function |
Kompilierte Version (Windows) inkl. Souce Code + Bilder kann hier heruntergeladen werden: FB_Twister_Effect.zip
Ohne die Bilder wird jede Oberfläche mit einer zufälligen Farbe dargestellt.
Läuft am schnellsten, wenn man mit -gen gcc -Wc -Ofast -s gui kompiliert.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 24.04.2020, 13:30 Titel: Atomic Cell World |
|
|
| Code: |
'Coded by UEZ build 2020-04-22
#Include "fbgfx.bi"
Using FB
Const iW = 800, iH = 600
Dim Shared As Ulong Ptr pScrn
Sub _Circle(x As Short, y As Short, r As Short, c As Ulong)
Dim As Short cy, r2 = r * r
Dim As Ulong cx, cyy, py, px1, px2, xx
For cy = -r to r
cx = Sqr(r2 - cy * cy) + 0.5
cyy = cy + y ': cyy = Iif(cyy > iH - 1, iH - 1, cyy)
py = cyy * iW + x
px1 = py - cx
px2 = py + cx
For xx = px1 To px2 'fill circle
pScrn[xx] = c
Next
Next
End Sub
Screenres iW, iH, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP 'Or GFX_ALPHA_PRIMITIVES
ScreenSet 1, 0
Windowtitle("Atomic Cell World v0.50 by UEZ")
pScrn = Screenptr()
Type tPoint
As Single x, y, vx, vy, s
As Ubyte r, g, b
End Type
Dim As Ubyte AmountBalls = 50, BallSize = 100, i
Dim As Single j, c, d, e, cc = 255 / BallSize, fSpeed = 2 'BallSize / 255
Dim As tPoint Points(AmountBalls - 1)
Dim As Ulong iFPS
Randomize Timer, 2
For i = 0 To AmountBalls - 1
Points(i).x = BallSize + Rnd() * (iW - 2 * BallSize - 1)
Points(i).y = BallSize + Rnd() * (iH - 2 * BallSize - 1)
Points(i).vx = Rnd() - 0.5
Points(i).vy = Rnd() - 0.5
Points(i).r = Rnd() * 255 'Iif(Rnd() > 0.50, 1, 0)
Points(i).g = 0 'Iif(Rnd() > 0.50, 1, 0)
Points(i).b = 0 'Iif(Rnd() > 0.50, 1, 0)
Next
Dim As Ushort cfps = 0, currfps = 0
Dim As Single curAvFPS = 0, fTimer = Timer
Do
'Cls
'Line (0, 0)-(iW - 1, iH - 1), &hFF000000, BF
Line (1, 1)-(200, 10), 0, BF
For j = 1 To BallSize Step fSpeed
c = (j * cc) Shl 8
d = (BallSize - j) '- Abs(Sin((j + e) / 100) * 50)
'e += 0.001
For i = 0 To AmountBalls - 1
'Circle(Points(i).x, Points(i).y), d, c, , , , F
'_Circle(Points(i).x, Points(i).y, d, Rgb(Iif(Points(i).r, c, 0), Iif(Points(i).g, c, 0), Iif(Points(i).b, c, 0))) 'different color
_Circle(Points(i).x, Points(i).y, d, c) 'static color
Next
Next
For i = 0 To AmountBalls - 1
Points(i).x += Points(i).vx
Points(i).y += Points(i).vy
If Points(i).x < BallSize Or Points(i).x > (iW - BallSize) Then Points(i).vx = -Points(i).vx
If Points(i).y < BallSize Or Points(i).y > (iH - BallSize) Then Points(i).vy = -Points(i).vy
Next
Draw String(1, 1), iFPS & " fps / average: " & Str(Cushort(curAvFPS) + 1) & " fps", Rgb(&hFF, &hFF, &hFF)
Flip
cfps += 1
currfps += 1
curAvFPS += (iFPS - curAvFPS) / currfps
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep(1)
Loop Until Len(Inkey())
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 30.04.2020, 07:58 Titel: Hungry Greedy Worm |
|
|
| Code: |
'Ported to FB by UEZ build 2020-06-16
'Original code by EliK -> https://www.openprocessing.org/sketch/875675
'Thanks to dodicat for the Regulate function
#Include "fbgfx.bi"
Using FB
Const iW = 1000, iH = 600, maxLength = 128
Sub DrawCircleAA(xm As Short, ym As Short, r As Short, col As Ulong) 'Alois Zingl -> https://github.com/w8r/bresenham-zingl
Dim As Long x = -r, y = 0, x2, e2, ierr = 2 - 2 * r, a, a1, a2, c
Dim As Ulong iCol
r = 1 - ierr
While x < 0
c = 255 * Abs(ierr - 2 * (x + y) - 2) / r
a1 = c / 255 : a2 = (1 - a1) * 255
iCol = (255 - c) Shl 24 Or (col And &hFFFFFF)
Pset(xm + x, ym - y), icol
Pset(xm + y, ym + x), icol
Pset(xm - x, ym + y), icol
Pset(xm - y, ym - x), icol
e2 = ierr
x2 = x
If (ierr + y > 0) Then
c = 255 * (ierr - 2 * x - 1) / r
If c < 256 Then
a1 = c / 255 : a2 = (1 - a1) * 255
iCol = (255 - c) Shl 24 Or (col And &hFFFFFF)
Pset(xm + x, ym - y - 1), icol
Pset(xm + y + 1, ym + x ), icol
Pset(xm - x, ym + y + 1), icol
Pset(xm - y - 1, ym - x ), icol
End If
x += 1
ierr += x * 2 + 1
End If
If e2 + x2 <= 0 Then
c = 255 * (2 * y + 3 - e2) / r
If c < 256 Then
a1 = c / 255 : a2 = (1 - a1) * 255
iCol = (255 - c) Shl 24 Or (col And &hFFFFFF)
Pset(xm + x2 + 1, ym - y ), icol
Pset(xm + y , ym + x2 + 1), icol
Pset(xm - x2 - 1, ym + y ), icol
Pset(xm - y , ym - x2 - 1), icol
End If
y += 1
ierr += y * 2 + 1
End If
Wend
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) >= 1 Then t3 = t : fps = frames : frames = 0
Var sleeptime =_lastsleeptime + ((1 / TargetFPS) - t + timervalue) * 1000
If sleeptime < 1 Then sleeptime = 1
_lastsleeptime = sleeptime
timervalue = t
Return sleeptime
End Function
Type Worm
Public:
Declare Constructor()
Declare Destructor()
Declare Sub Init()
Declare Sub Draw()
Private:
As Ushort up, up2, c, wormSize, dist, speed
As Single x2, y2, tx, ty, t, WormSlices(Any, Any)
End Type
Constructor Worm()
Redim WormSlices(maxLength, 1)
Init()
End Constructor
Destructor Worm()
Redim WormSlices(0, 0)
End Destructor
Sub Worm.Init()
Randomize Timer, 5
x2 = 500 :tx = 510 :y2 = -600 : ty = 0 : t = 0 : up = 0 : up2 = 0 : c = 0 : wormSize = 25 : dist = 60 : speed = 17.5
End Sub
Sub Worm.Draw()
Static As Ulong FPS
Dim As Single tt
'Cls
Line (0, 0)-(iW, iH), &hF0FFFFFF, BF
t += 1
If t < 5 Then
up = Iif(Rnd() > 0.5, 1, 0)
up2 = Iif(Rnd() > 0.5, 1, 0)
End If
tt = t / speed
If up = 0 Then tx -= tt
If up = 1 Then tx += tt
If up2 = 0 Then ty -= tt
If up2 = 1 Then ty += tt
If t > dist Then t = 0
If tx > x2 Then x2 += (tx - x2) / dist
If tx < x2 Then x2 -= (x2 - tx) / dist
If ty > y2 Then y2 += (ty - y2) / dist
If ty < y2 Then y2 -= (y2 - ty) / dist
If c < maxLength + 1 Then 'fill up array first
WormSlices(c, 0) = x2
WormSlices(c, 1) = y2
c += 1
Else
'simulation of the JavaScript slice array function
For i As Ushort = 0 To maxLength - 1 'shift array values from top to down
WormSlices(i, 0) = WormSlices(i + 1, 0)
WormSlices(i, 1) = WormSlices(i + 1, 1)
Next
'add new element to top
WormSlices(maxLength, 0) = x2
WormSlices(maxLength, 1) = y2
End If
Dim as UShort s
Static as Single k = 0
Dim As Single h, p
Static As Single e1 = 0
'draw
For i As Ushort = 0 To c - 1
If WormSlices(i, 0) > iW Then up = 0
If WormSlices(i, 1) > iH Then up2 = 0
If WormSlices(i, 0) < 0 Then up = 1
If WormSlices(i, 1) < 0 Then up2 = 1
s = IIf(i > c - 12, wormSize - 12 + (c - i), iif(i < 17.5, wormSize - 17.5 + i, wormSize))
h = Sin(k / 2500 - (i shl 1)) * 8
If i = c - 1 Then
Circle(WormSlices(i, 0), WormSlices(i, 1)), s, &hF0B07A69, , , , F ''draw head
DrawCircleAA(WormSlices(i, 0), WormSlices(i, 1), s + 0.5, &h6E5326)
Circle(WormSlices(i, 0), WormSlices(i, 1)), Abs((s * 0.25) * Sin(e1)), &h60000000, , , , F 'mouth
e1 += 0.05
Else
p = s + h
Circle(WormSlices(i, 0), WormSlices(i, 1)), p, &h58FA8D1B, , , , F
DrawCircleAA(WormSlices(i, 0), WormSlices(i, 1), p + 0.5, &h6E5326)
end if
k += 1
Next
Dim As Ushort o = wormSize Shr 1
'draw food
Circle(tx, ty), o, &hE0FF0000, , , , F
DrawCircleAA(tx, ty, o, &hFFFF0000)
.Draw String (tx + o + 10, ty), "Yumyum", &hFF20B020
.Draw String (4, 4), Str(FPS) + " fps", &hFF000000
'Screensync
Flip
Sleep(Regulate(60, FPS), 1)
End Sub
'ScreenControl SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_HIGH_PRIORITY
ScreenSet 1, 0
Windowtitle("Greedy Worm")
Color , &hFFFFFFFF
Cls
Dim As Worm Worms
Worms.Init
Do
Worms.Draw
Loop Until Len(Inkey())
|
_________________
Gruß
UEZ
Zuletzt bearbeitet von UEZ am 16.06.2020, 10:17, insgesamt 2-mal bearbeitet |
|
| Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4711
Wohnort: ~/
|
| Verfasst am: 30.04.2020, 12:28 Titel: |
|
|
Da es hier ja naturbedingt immer recht wenig Rückmeldung gibt, will ich mich doch mal rühren: Da sind immer wieder sehr hübsche Sachen dabei, und auch der Wurm gefällt mir wieder sehr gut! 
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 30.04.2020, 19:43 Titel: |
|
|
| nemored hat Folgendes geschrieben: | | Da es hier ja naturbedingt immer recht wenig Rückmeldung gibt, will ich mich doch mal rühren: Da sind immer wieder sehr hübsche Sachen dabei, und auch der Wurm gefällt mir wieder sehr gut! |
Danke für dein Feedback.
Wenn ich mich anhand der Rückmeldungen richten würde, dürfte ich kaum was posten. 
Aber "naturbedingt"? Wie meinst du das?
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4711
Wohnort: ~/
|
| Verfasst am: 01.05.2020, 19:31 Titel: |
|
|
Ich bin schon lange genug im Forum um zu wissen, dass Rückmeldungen zu Programmen allgemein sehr spärlich sind 
Liegt natürlich auch sehr stark an der kleinen Community. Solange dich das nicht beunruhigt und du weiter postest, ist ja alles gut. Ich schaue mir die Pogramme jedenfalls immer wieder gerne an.
Ich wünschte, ich käme auch mal wieder zum Programmieren - im Moment komme ich, wenn ich sehr fleißig bin, auf 100 Zeilen im Monat ...
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 10.07.2020, 07:51 Titel: Einfaches Feuerwerk |
|
|
Fireworks v0.50.bas (ohne Sound):
| Code: |
'Fireworks v0.50 build 2020-07-13 beta coded by UEZ
'Credits To:
' D.J.Peters aka Joshy For the SimplexNoise2D() Function
' dodicat For the Regulate() Function
#Include "fbgfx.bi"
#Include "String.bi"
Using FB
Dim As String sTitle = "Simple Fireworks v0.50 build 2020-07-13 beta coded by UEZ"
Declare Function RandomRange(fStart As Single, fEnd As Single) As Single
Declare Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85
Const iParticlesTail = 6, fGravity = 0.75, fRad = Acos(-1) / 180
Randomize Timer, 2
'--------------------------------------------------------------------------------------------------
Type float As Single 'Double
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}
Function SimplexNoise2D(xin As float, yin As float, scale As float = 20.0) As float 'by D.J.Peters aka Joshy
Const As float F2 = 0.5*(Sqr(3.0)-1.0)
Const As float G2 = (3.0-Sqr(3.0))/6.0
Const As float G22 = G2 + G2
Static As Integer grad2(11,1) = {{ 1, 1},{-1, 1},{1,-1},{-1,-1}, _
{ 1, 0},{-1, 0},{1, 0},{-1, 0}, _
{ 0, 1},{ 0,-1},{0, 1},{ 0,-1}}
Dim As float s = (xin+yin)*F2
Dim As Integer i = Int(xin+s)
Dim As Integer j = Int(yin+s)
Dim As float t = (i+j)*G2
Dim As float x = i-t , y = j-t
Dim As float x0 = xin-x, y0 = yin-y
Dim As Integer i1=Any, j1=Any
i And=255
j And=255
If (x0>y0) Then
i1=1: j1=0
Else
i1=0: j1=1
End If
Dim As float x1 = x0 - i1 + G2
Dim As float y1 = y0 - j1 + G2
Dim As float x2 = x0 - 1.0 + G22
Dim As float y2 = y0 - 1.0 + G22
Dim As Integer ii = i 'And 255
Dim As Integer jj = j 'And 255
Dim As Integer ind = Any
Dim As float n=Any
t = 0.5 - x0*x0-y0*y0
If (t<0) Then
n=0
Else
ind = perm(i+perm(j)) Mod 12
n = t*t*t*t * (grad2(ind,0)*x0 + grad2(ind,1)*y0)
End If
t = 0.5 - x1*x1-y1*y1
If (t<0) Then
Else
ind = perm(i+i1+perm(j+j1)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x1 + grad2(ind,1)*y1)
End If
t = 0.5 - x2*x2-y2*y2
If(t<0) Then
Else
i+=1:j+=1
ind= perm(i+perm(j)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x2 + grad2(ind,1)*y2)
End If
' scaled in the interval [-1,1].
Return scale * n
End Function
'--------------------------------------------------------------------------------------------------
Type tagBoom
As Single power
As Single x
As Single y
As Single vx
As Single vy
As Ubyte r
As Ubyte g
As Ubyte b
As Ubyte a
As Single size
As Ubyte flag1
End Type
Type Kaboom
Public:
Declare Constructor()
Declare Destructor()
Declare Sub init()
Declare Sub update()
As Boolean detonate, set
As Single rocketx, rockety, rocketvx, rocketvy, radius, life, heigh, power
As tagBoom Boom(5000)
As Ubyte r, g, b, a, rr, gg, bb, aa, c1, c2
As Ulong particles
As Ubyte KType, flimmer
End Type
Constructor Kaboom()
This.Init()
End Constructor
Destructor Kaboom()
End Destructor
Sub Kaboom.init()
This.detonate = False
This.set = False
This.rocketx = scrw / 2 + RandomRange(-scrw / 10, scrw / 10)
This.rockety = scrh
This.rocketvx = RandomRange(-5, 5)
This.rocketvy = -(5 + Rnd() * 5)
This.heigh = scrh * 0.15 + Rnd() * (scrh * 0.30)
This.life = 255
This.power = 0.99 - Rnd() * 0.03
This.r = &hA0
This.g = &hA0
This.b = &hA0
This.a = &hFF
This.rr = &h40 + Rnd() * &h6F
This.gg = &h40 + Rnd() * &h6F
This.bb = &h40 + Rnd() * &h6F
This.c1 = 0
This.flimmer = 0
If Rnd() > 0.75 Then This.flimmer = 1
This.particles = 100 + Rnd() * 600
Dim As Single RndRGBColor = Rnd()
This.ktype = Cubyte(RandomRange(1, 3))
Select Case This.ktype
Case 3
Dim As Single h, g = 360 / (This.particles - 1), r
For i As Ulong = 0 To This.particles - 1
This.Boom(i).power = 0.5 + Rnd() * 7
This.Boom(i).vx = Sin(h * fRad) * This.Boom(i).power
This.Boom(i).vy = Cos(h * fRad) * This.Boom(i).power
If This.Boom(i).power > 6 - Rnd() * 2 Then
This.Boom(i).size = 2
Select Case RndRGBColor
Case 0 To 0.33
This.Boom(i).r = 250
This.Boom(i).g = Rnd() * &h7F
This.Boom(i).b = Rnd() * &h7F
Case 0.34 To 0.66
This.Boom(i).r = Rnd() * &h7F
This.Boom(i).g = 250
This.Boom(i).b = Rnd() * &h7F
Case Else
This.Boom(i).r = Rnd() * &h7F
This.Boom(i).g = Rnd() * &h7F
This.Boom(i).b = 250
End Select
This.Boom(i).a = This.a
Else
This.Boom(i).size = 1.333
This.Boom(i).r = This.rr
This.Boom(i).g = This.gg
This.Boom(i).b = This.bb
This.Boom(i).a = This.aa
End If
h += g
Next
Case 2
For i As Ulong = 0 To This.particles - 1
This.Boom(i).size = 1.333
This.Boom(i).vx = RandomRange(-1.0, 1.0) * (0.5 + Rnd() * 5)
This.Boom(i).vy = RandomRange(-1.0, 1.0) * (0.5 + Rnd() * 5)
This.Boom(i).r = This.r + Rnd() * &h5F
This.Boom(i).g = This.g + Rnd() * &h4F
This.Boom(i).b = This.b + Rnd() * &h4F
This.Boom(i).a = This.a
Next
Case 1
Dim As Single h, g = 360 / (This.particles - 1), r
For i As Ulong = 0 To This.particles - 1
This.Boom(i).power = 0.5 + Rnd() * 7
This.Boom(i).vx = Sin(h * fRad) * This.Boom(i).power
This.Boom(i).vy = Cos(h * fRad) * This.Boom(i).power
If This.Boom(i).power > 6 - Rnd() * 2 Then
This.Boom(i).size = 2
This.Boom(i).r = This.r + Rnd() * &h5F
This.Boom(i).g = This.g + Rnd() * &h5F
This.Boom(i).b = This.b + Rnd() * &h5F
This.Boom(i).a = This.a
Else
This.Boom(i).size = 1.333
This.Boom(i).r = This.rr
This.Boom(i).g = This.gg
This.Boom(i).b = This.bb
This.Boom(i).a = This.aa
End If
h += g
Next
End Select
End Sub
Sub Kaboom.Update()
If This.rockety > This.heigh Then
This.rocketx += This.rocketvx
This.rockety += This.rocketvy
Else
If This.set = False Then
For i As Ulong = 0 To This.particles - 1
This.Boom(i).x = This.rocketx
This.Boom(i).y = This.rockety
This.set = TRUE
Next
This.detonate = TRUE
End If
Dim As Ubyte aGlimmer(0 To 127) '= {255}
aGlimmer(Int(Rnd * Ubound(aGlimmer))) = 255
For i As Ulong = 0 To This.particles - 1
This.Boom(i).x += This.Boom(i).vx
This.Boom(i).y += This.Boom(i).vy + fGravity
This.Boom(i).vx *= This.power
This.Boom(i).vy *= This.power
This.Boom(i).a = This.life
If This.Boom(i).a < &h7F And This.flimmer = 1 Then
This.Boom(i).r = aGlimmer(This.c1)
This.Boom(i).g = aGlimmer(This.c1)
This.Boom(i).b = aGlimmer(This.c1)
This.Boom(i).a = &hFF - This.life
This.c1 += 1
If This.c1 = Ubound(aGlimmer) Then This.c1 = 0
Endif
Next
This.life -= 1
'This.a = This.life * This.power
If This.life = 0 Then This.init()
EndIf
End Sub
'--------------------------------------------------------------------------------------------------
Type tagParticleTail
As Single x
As Single y
As Single vx
As Single vy
As Ubyte r
As Ubyte g
As Ubyte b
As Ubyte a
End Type
Type ParticleTail
Declare Constructor()
Declare Destructor()
Declare Sub Add(x As Single, y As Single, iLife As Ushort = 35, vx As Single = 0, vy As Single = 0)
As tagParticleTail ParticleTail(iParticlesTail - 1)
As Ushort count
As UShort life
End Type
Constructor ParticleTail()
This.count = 0
End Constructor
Destructor ParticleTail()
End Destructor
Sub ParticleTail.Add(x As Single, y As Single, iLife As Ushort = 35, vx As Single = 0, vy As Single = 0)
For i As Ubyte = 0 To iParticlesTail - 1
ParticleTail(i).x = x
ParticleTail(i).y = y
ParticleTail(i).vx = Iif(vx = 0, RandomRange(-0.25, 0.25), vx)
ParticleTail(i).vy = Iif(vy = 0, Rnd() * 1, vy)
ParticleTail(i).r = &hFF
ParticleTail(i).g = &hB0
ParticleTail(i).b = &h60
ParticleTail(i).a = &hB0
Next
This.life = iLife
This.count += 1
End Sub
'--------------------------------------------------------------------------------------------------
Type _Stack
Public:
As ParticleTail aStack(Any)
As UInteger iPos = 1
Declare Constructor()
Declare Destructor()
Declare Sub Push(Byref oPT As ParticleTail)
Declare Function Get(iPos As UInteger) As ParticleTail
End Type
Constructor _Stack()
Redim This.aStack(0 To 10000) As ParticleTail
End Constructor
Destructor _Stack()
Redim This.aStack(0)
End Destructor
Sub _Stack.Push(Byref oPT As ParticleTail)
If This.iPos > Ubound(This.aStack) Then
Redim Preserve This.aStack(0 To This.iPos Shl 1)
End If
This.aStack(iPos) = oPT
This.iPos += 1
End Sub
Function _Stack.Get(iPos As UInteger) As ParticleTail
If iPos > 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function
'--------------------------------------------------------------------------------------------------
Dim Shared As _Stack Stack1, Stack2
Type Fireworks
Declare Constructor(iAmountRockets As Ubyte = 1)
Declare Destructor()
Declare Sub Update()
Declare Sub Plot()
Private:
As Ushort AmountRockets
As Kaboom Ptr pBuffer
As ParticleTail Ptr pBuffer2
As Image Ptr Img_Empty, Img_Fireworks, Img_Blur
End Type
Constructor Fireworks(iAmountRockets As Ubyte)
Img_Empty = Imagecreate(scrw, scrh, &h28000000, 32)
Img_Fireworks = Imagecreate(scrw, scrh, , 32)
This.AmountRockets = iAmountRockets
pBuffer = New Kaboom[This.AmountRockets]
pBuffer2 = New ParticleTail[1]
End Constructor
Destructor Fireworks()
Delete[] pBuffer
Delete[] pBuffer2
pBuffer = 0
pBuffer2 = 0
Imagedestroy This.Img_Empty
Imagedestroy This.Img_Fireworks
End Destructor
Sub Fireworks.Plot()
Dim As Uinteger iParticleSum = 0
Put This.Img_Fireworks, (0, 0), This.Img_Empty, Pset
For y As Ushort = 0 To This.AmountRockets - 1
Select Case pBuffer[y].detonate
Case False
If Rnd() > 0.666667 Then
pBuffer[y].rocketx += SimplexNoise2D(pBuffer[y].rocketx, pBuffer[y].rockety, 10) + Sin((pBuffer[y].rocketx - pBuffer[y].rockety) / 10) * 1.25
'pBuffer[y].rockety += SimplexNoise2D(pBuffer[y].rockety, pBuffer[y].rocketx, 15) + Cos(pBuffer[y].rocketx / 17) * 5.5
End If
Circle This.Img_Fireworks, (pBuffer[y].rocketx, pBuffer[y].rockety), 1.5 + SimplexNoise2D(pBuffer[y].rocketx, pBuffer[y].rockety, 150), Rgba(&hFF, &hFF, &hF0, &hE0),,, 1.5,F
pBuffer2[0].Add(pBuffer[y].rocketx, pBuffer[y].rockety, 7.5 + Rnd() * (20 * pBuffer[y].power))
Stack1.Push(pBuffer2[0])
iParticleSum += 1
Case Else
Dim as Single r, r2, cy, cyy, cx
For i As Ulong = 0 To pBuffer[y].particles - 1
r = pBuffer[y].Boom(i).size - 1
r2 = r * r
For cy = -r to r
cx = Sqr(r2 - cy * cy)
cyy = cy + pBuffer[y].Boom(i).y
Line This.Img_Fireworks, (pBuffer[y].Boom(i).x - cx, cyy)-(pBuffer[y].Boom(i).x + cx, cyy), _
Rgba(pBuffer[y].Boom(i).r, pBuffer[y].Boom(i).g, pBuffer[y].Boom(i).b, pBuffer[y].Boom(i).a)
Next
'Circle This.Img_Fireworks, (pBuffer[y].Boom(i).x, pBuffer[y].Boom(i).y), pBuffer[y].Boom(i).size, _
' Rgba(pBuffer[y].Boom(i).r, pBuffer[y].Boom(i).g, pBuffer[y].Boom(i).b, pBuffer[y].Boom(i).a),,,,F
iParticleSum += 1
Next
End Select
pBuffer[y].update
Next
Stack2.iPos = 1
For y As Ulong = 1 To Stack1.iPos - 1
Dim As ParticleTail oPT = Stack1.Get(y)
If oPT.life > 0 Then
For i As Ubyte = 0 To iParticlesTail - 1
Circle This.Img_Fireworks, (oPT.ParticleTail(i).x, oPT.ParticleTail(i).y), 0.1, Rgba(oPT.ParticleTail(i).r, oPT.ParticleTail(i).g, oPT.ParticleTail(i).b, oPT.ParticleTail(i).a),,,,F
oPT.ParticleTail(i).x += oPT.ParticleTail(i).vx
oPT.ParticleTail(i).y += oPT.ParticleTail(i).vy
If oPT.ParticleTail(i).a - 5 > 0 Then oPT.ParticleTail(i).a -= 5
iParticleSum += 1
Next
End If
oPT.life -= 1
If oPt.life > 0 Then Stack2.Push(oPT)
Next
'clean-up stack
For y As ULong = 1 To Stack2.iPos - 1
Stack1.aStack(y) = Stack2.aStack(y)
Next
Stack1.iPos = Stack2.iPos
Draw String (1, scrh - 10), "Particles:" & iParticleSum, Rgb(&hFF, &h00, &h00)
Put (0, 0), This.Img_Fireworks, Alpha
End Sub
'--------------------------------------------------------------------------------------------------
#Ifdef __Fb_win32__
#Include "windows.bi"
Enum PROCESS_DPI_AWARENESS
DPI_AWARENESS_INVALID = -1, PROCESS_DPI_UNAWARE = 0, PROCESS_SYSTEM_DPI_AWARE = 1, PROCESS_PER_MONITOR_DPI_AWARE = 2
End Enum
Function _WinAPI_GetDpiForWindow(hWnd As HWND) As Ubyte 'requires Win10 v1607+ / no server support
Dim As Any Ptr pLib = Dylibload("User32.dll")
If pLib = NULL Then Exit Function
Dim pGetDpiForWindow As Function (Byval hWND As HWND) As UINT
pGetDpiForWindow = Dylibsymbol(pLib, "GetDpiForWindow")
If pGetDpiForWindow Then Function = pGetDpiForWindow(hWnd)
Dylibfree(pLib)
End Function
Function _WinAPI_SetProcessDpiAwareness(DPIAware As Integer) As Ubyte 'requires Windows 8.1+ / no server support
Dim As Any Ptr pLib = Dylibload("Shcore.dll")
If pLib = NULL Then Exit Function
Dim pSetProcessDpiAwareness As Function (Byval DPIAware As Integer) As HRESULT
pSetProcessDpiAwareness = Dylibsymbol(pLib, "SetProcessDpiAwareness")
If pSetProcessDpiAwareness Then Function = pSetProcessDpiAwareness(DPIAware)
Dylibfree(pLib)
End Function
_WinAPI_SetProcessDpiAwareness(PROCESS_PER_MONITOR_DPI_AWARE)
Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)
Dim tWorkingArea As RECT
SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Else
Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)
#Endif
Windowtitle(sTitle)
Dim As Fireworks Firework = Fireworks(20)
Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer
Do
Screenlock
Firework.Plot()
Draw String(1, 1), iFPS_current & " fps", Rgba(&hFF, &h00, &h00, &hE0)
Screenunlock
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
Sleep(Regulate(60), 1)
Loop Until Inkey = Chr(27)
'--------------------------------------------------------------------------------------------------
Function RandomRange(fStart As Single, fEnd As Single) As Single
Return Rnd() * (fEnd - fStart) + fStart
End Function
'--------------------------------------------------------------------------------------------------
Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
|
Mit Sound Effekten: FB Fireworks v0.60 build 2020-07-13 beta.zip (Source Code + kompilierte Exe)
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Roland Chastain
Anmeldungsdatum: 05.12.2011
Beiträge: 194
Wohnort: Frankreich
|
| Verfasst am: 25.07.2020, 03:25 Titel: Re: Einfaches Feuerwerk |
|
|
| UEZ hat Folgendes geschrieben: | Fireworks v0.50.bas (ohne Sound):
|
Sehr schön!
Kleines Detail. Um unter Linux zu kompilieren, müssen wir "String.bi" durch "string.bi" ersetzen. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 03.09.2020, 09:37 Titel: Sternenflug zu den Nebula Wolken |
|
|
| Code: |
'Coded by UEZ build 2020-09-03
'Additional code (Perling Noise and Nebula) by Tapio Vierros and Regulate by dodicat
#Include "fbgfx.bi"
Using FB
Randomize
Dim Shared As Boolean bFullscreen = False, bRotation = False, bNebula = True, bSpeedControl = False, bStaticNebula = True
If bRotation Then bNebula = False
'Perlin Noise
Declare Sub BuildNoiseTables(seed As Double = -1, num As Byte = 1)
Declare Sub BuildNoiseTable(seed As Double = -1, k As Byte = 0)
Const MAX_PERMS = 10
Dim Shared As UByte perm(512, 1 To MAX_PERMS)
Dim Shared As Double ms_grad4(256, 1 To MAX_PERMS)
Dim Shared As Double kkf(256)
For i As Integer = 0 To 255
kkf(i) = -1.0f + 2.0f * (i / 255.0f)
Next
#Define BlendMul(a, b) (((a) * (b)) Shr 8)
#Define FADE(_t) (_t * _t * _t * (_t * (_t * 6 - 15) + 10))
#Define NLERP(_t, _a, _b) ((_a) + (_t) * ((_b) - (_a)))
'' Inititalize some permutation tables for different noises
Sub BuildNoiseTables(seed As Double = -1, num As Byte = 1)
If seed <> -1 Then Randomize seed
For k As Integer = 1 To num
BuildNoiseTable(-1, k)
Next k
End Sub
'' Buil a permutation table
Sub BuildNoiseTable(seed As Double = -1, k As Byte = 0)
If seed <> -1 Then Randomize seed
If k = 0 Then BuildNoiseTables(seed, MAX_PERMS): Exit Sub
Dim As Integer i, j
For i = 0 To 255
perm(i, k) = i
Next i
For i = 0 To 255
j = Rnd * 256
Swap perm(i, k), perm(j, k)
Next i
For i = 0 To 255
perm(i + 256, k) = perm(i, k)
Next i
For i As Integer = 0 To 255
ms_grad4(i, k) = kkf(perm(i, k)) * 0.507f
Next i
End Sub
'' Perlin noise function
Function Noise(x As Double, y As Double, px As Double, py As Double, noiseId As Byte = 1) As Double
Dim As Integer ix0, iy0, ix1, iy1
Dim As Double fx0, fy0
Dim As Double s, t, nx0, nx1, n0, n1
ix0 = CInt(x - 0.5f)
iy0 = CInt(y - 0.5f)
fx0 = x - ix0
fy0 = y - iy0
If px < 1 Then px = 1
If py < 1 Then py = 1
ix1 = ((ix0 + 1) Mod px) And &hff
iy1 = ((iy0 + 1) Mod py) And &hff
ix0 = (ix0 Mod px) And &hff
iy0 = (iy0 Mod py) And &hff
t = FADE(fy0)
s = FADE(fx0)
nx0 = ms_grad4(perm(ix0 + perm(iy0, noiseId), noiseId), noiseId)
nx1 = ms_grad4(perm(ix0 + perm(iy1, noiseId), noiseId), noiseId)
n0 = NLERP( t, nx0, nx1 )
nx0 = ms_grad4(perm(ix1 + perm(iy0, noiseId), noiseId), noiseId)
nx1 = ms_grad4(perm(ix1 + perm(iy1, noiseId), noiseId), noiseId)
n1 = NLERP(t, nx0, nx1)
Return NLERP(s, n0, n1)
End Function
'' The actual Perlin noise function that sums octaves.
'' Call this.
'' Returns UByte.
Function Perlin(x As Double, y As Double, xsizemax As Double, ysizemax As Double, size As Double, noiseId As Byte = 1) As UByte
' size must be 2 ^ n
Dim As Double value = 0.0, initialSize = size
While(size >= 1)
value += Noise(x / size, y / size, xsizemax / size, ysizemax / size, noiseId) * size
size /= 2.0 '1.5
Wend
Return (128.0 * value / initialSize) + 127
End Function
'' Exponent filter for making clouds
Function ExpFilter(value As UByte, cover As Double, sharpness As Double) As UByte
Dim As Double c = value - (255.0f - cover) '''''255
If c < 0 Then c = 0
value = 255.0f - (CDbl(sharpness^c) * 255.0f)
Return CUByte(value)
End Function
If bStaticNebula Then
BuildNoiseTables(10, 10)
Else
BuildNoiseTables(Rnd() * Timer, 1 + Rnd() * 126)
end if
#Define csize 256 ' Color noise feature size, use power of 2 values
#Define PokePixel(_x, _y, _color) Cptr(Ulong Ptr, imgData + _y * pitch + _x Shl 2)[0] = _color
#Define Map(val, source_start, source_stop, dest_start, dest_stop) ((val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)
Function RandomRange(fStart As Single, fEnd As Single) As Single
Return Rnd() * (fEnd - fStart) + fStart
End Function
Function Regulate(TargetFPS As Long, Byref fps As UShort) As Long '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 / TargetFPS) - t + timervalue) * 1000
If sleeptime < 1 Then sleeptime = 1
_lastsleeptime = sleeptime
timervalue = t
Return sleeptime
End Function
Dim Shared As Integer iW, iH
Dim As Integer x = 0, y = 0
#Ifdef __FB_WIN32__
#Include "windows.bi"
Dim As RECT tDesktop
Dim As hwnd hHWND_Dt
hHWND_Dt = FindWindow("Progman","Program Manager")
GetWindowRect(hHWND_Dt, @tDesktop)
x = tDesktop.left
y = tDesktop.top
iW = tDesktop.right + Abs(x)
iH = tDesktop.bottom + Abs(y)
#Else
ScreenControl GET_DESKTOP_SIZE, iW, iH 'not dpi aware!
#Endif
Dim As Long flags = GFX_FULLSCREEN Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_NO_FRAME
If bFullscreen = False Then
iW = 1200
iH = 800
flags Xor= GFX_NO_FRAME
flags Or= GFX_WINDOWED Or GFX_NO_SWITCH
End If
Dim Shared As Ushort iW2, iH2
iW2 = iW \ 2 : iH2 = iH \ 2
Screenres iW, iH, 32, 2, flags
Screenset 1, 0
If bFullscreen Then ScreenControl SET_WINDOW_POS, x, y
If bSpeedControl Then SetMouse iW2, iH * 0.95 'Iif(bRotation, iH * 0.95, iH * 0.85)
Type vec4
As Single x, y, z, pz
End Type
Type Starfield
Declare Constructor(quantity As Ulong = 19999)
Declare Destructor()
As Single speed
As Double a
As Ubyte maxRadius
As Ulong n
As vec4 star(Any)
Declare Sub Init(quantity As Ulong)
Declare Sub Anim()
End Type
Constructor Starfield(quantity As Ulong)
This.Init(quantity)
End Constructor
Destructor Starfield()
End Destructor
Sub Starfield.Init(quantity As Ulong)
This.speed = 2.0
This.a = RandomRange(-2 * Acos(1), 2 * Acos(1))
This.n = quantity + 1
This.maxRadius = 2
ReDim This.star(quantity) As vec4
For i As Ulong = 0 To Ubound(This.star)
This.star(i).x = RandomRange(-iW, iW)
This.star(i).y = RandomRange(-iH, iH)
This.star(i).z = Rnd() * (iW + iH) / 2
This.star(i).pz = This.star(i).z
Next
End Sub
Sub Starfield.Anim()
Dim As Single sx, sy, r, px, py, ppx, ppy, t1 = 0, t2 = 0
Dim As Ubyte c
If bSpeedControl Then
Dim As Integer mx, my
Getmouse(mx, my)
This.speed = Map(my, 0, iH, 25, 0.5) 'set speed according to y mouse position -> top fastest, bottom slowest speed
End If
For i As Ulong = 0 To Ubound(This.star)
If bRotation Then
t1 = Sin(This.a / 75) * This.star(i).z
t2 = -Cos(This.a / 200) * This.star(i).z
This.a += 0.00002
End If
sx = Map(This.star(i).x / This.star(i).z, 0, 1, 0, iW) + t1
sy = Map(This.star(i).y / This.star(i).z, 0, 1, 0, iH) + t2
px = Map(This.star(i).x / This.star(i).pz, 0, 1, 0, iW) + t1 'previous x
py = Map(This.star(i).y / This.star(i).pz, 0, 1, 0, iH) + t2 'previous y
r = Map(This.star(i).z, 0, (iW + iH) / 2, This.maxRadius, 0.25) 'radius
c = Map(This.star(i).z, 0, (iW + iH) / 2, &hF8, &h08) 'color value for greyscale
ppx = iW2 + px
ppy = iH2 + py
If ppx > -r And ppx < iW And ppy > -r And ppy < iH Then
Line(ppx, ppy) - (iW2 + sx, iH2 + sy), Rgba(255, 255, 255, c)
'If c > 210 Then Circle(iW2 + sx, iH2 + sy), r, Rgba(255, 255, 255, c),,,, F
Circle(iW2 + sx, iH2 + sy), r, Rgba(255, 255, 255, c),,,, F
End If
This.star(i).pz = This.star(i).z 'previous z
This.star(i).z -= This.speed
If This.star(i).z < 1 Then
This.star(i).x = RandomRange(-iW, iW)
This.star(i).y = RandomRange(-iH, iH)
This.star(i).z = (iW + iH) / 2
This.star(i).pz = This.star(i).z
End If
Next
End Sub
Dim As Any Ptr pImageNebula = Imagecreate(iW, iH, &hFF000000, 32), imgData
Dim As Integer pitch
ImageInfo(pImageNebula, , , , pitch, imgData)
Union Col
As Ulong arbg
Type
As Ubyte b, g, r, a
End Type
End Union
Dim As Col col
Dim As Ubyte ww
If bNebula Then
'Create Nebula
For x = 0 To iW - 1
For y = 0 To iH - 1
ww = Perlin(x, y, iW, iH, 256, 1)
ww = ExpFilter(ww, 128, 0.99)
col.r = BlendMul(Perlin(x, y, iW, iH, csize, 2), ww)
col.g = BlendMul(Perlin(x, y, iW, iH, csize, 3), ww)
col.b = BlendMul(Perlin(x, y, iW, iH, csize, 4), ww)
col.a = &hE8
If Rnd() < 0.50 Then
PSet pImageNebula, (x, y), Col.arbg
If Rnd() < 0.0003 Then
PokePixel(CInt(Rnd() * (iW - 1)), CInt(Rnd() * (iH - 1)), Rgba(255, 255, 255, 255 * (0.50 + Rnd() * 0.33)))
Circle pImageNebula, (Rnd() * (iW - 1), Rnd() * (iH - 1)), 0.50 + Rnd(), Rgba(255, 255, 255, 255 * (0.66 + Rnd() * 0.33)),,,, F
end if
Else
If Rnd() < 0.00025 Then
PokePixel(CInt(Rnd() * (iW - 1)), CInt(Rnd() * (iH - 1)), Rgba(255, 255, 255, &hFF))
End if
PSet pImageNebula, (x, y), Col.arbg
end if
'PokePixel(x, y, Col.arbg)
Next
Next
End If
Dim As Starfield Stars = Starfield()
Dim As Ushort iFps = 0
Windowtitle("3D Starfield v0.75 coded by UEZ / Stars quantity: " & Stars.n)
Dim As Double fTimer = Timer
Do
Put (0, 0), pImageNebula, Pset
Stars.Anim()
Draw String(8, iH - 16), iFps & " fps", RGB(&hE0, &hE0, &hE0)
Flip
Sleep(Regulate(60, iFPS), 1)
Loop Until Len(Inkey())
Imagedestroy(pImageNebula)
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Sebastian
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland
|
|
| Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4711
Wohnort: ~/
|
| Verfasst am: 03.09.2020, 20:27 Titel: |
|
|
Ich weiß nicht warum, aber ich liebe vorbeifliegende Sterne.
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 17.09.2020, 13:50 Titel: Around the Sphere build 2020-09-22 |
|
|
@Sebastian und nemored: vielen Dank für euer Feedback.
Und weiter geht's...
Around the Sphere
| Code: |
'Coded by UEZ build 2020-09-22
'Thanks to dodicat for some funtions I used from his code :-) and Martijn van Iersel for the CreateGradientSphere function. 
#include "file.bi"
#Include "fbgfx.bi"
Using FB
Declare Function LZW_Decode Alias "fb_hDecode" (Byval in_buffer As Any Ptr, Byval in_size As Integer, Byval out_buffer As Any Ptr, Byref out_size As Integer) As Integer
#Define Map(Val, source_start, source_stop, dest_start, dest_stop) ((Val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)
#Define Round(x) ((x + 0.5) Shr 0)
Const w = 1200, h = 800, w2w = w Shl 1, w2 = w \ 2, h2 = h \ 2, pi = Acos(-1), pi2 = Acos(-1) / 2, radius = 350
Const phi0 = 0.0, phi1 = pi, theta0 = 0.0, theta1 = 2.0 * pi, radians = pi / 180, deg = 180 / pi, cc1 = -270 * radians, cc2 = 1025 * radians
Union _Color
As Ulong argb
Type
As Ubyte b, g, r, a
End Type
End Union
Type vec3
As Single x, y, z
End Type
Dim Shared As Const vec3 eyepoint = Type(w2, h2, h)
Type vec5
As Single x, y, z
As _Color col
End Type
'Taylor series
'Sum n = 0 to inf (-1)^n * x^(2n) / (2n)! = 1 - x^2 / 2! + x^4 / 4! -x^6 / 6! + ...
Function Cos_(x As Single) As Single
If x < 0 Then x = -x
While x >= 3.141592653589793 'pi
x -= 6.283185307179586 '2 * pi
Wend
Dim As Single xx = x * x
Return 1.0 - (xx / 2) * (1 - (xx / 12) * (1 - (xx / 30) * (1 - xx / 56))) 'approximation of Taylor serie
End Function
Function Sin_(x As Single) As Single
Return Cos_(x - 1.570796326794897) 'pi / 2
End Function
Sub Object3Dto2D(wa() As vec5, result() As vec5, angle As vec3, centre As vec3, rad As Single = 1.0, flag As Boolean = True) 'by dodicat
Dim As Single dx,dy,dz,ww
Dim As Single SinAX=Sin_(angle.x)
Dim As Single SinAY=Sin_(angle.y)
Dim As Single SinAZ=Sin_(angle.z)
Dim As Single CosAX=Cos_(angle.x)
Dim As Single CosAY=Cos_(angle.y)
Dim As Single CosAZ=Cos_(angle.z)
For z As Uinteger=Lbound(wa) To Ubound(wa)
dx=wa(z).x-centre.x
dy=wa(z).y-centre.y
dz=wa(z).z-centre.z
Result(z).x=rad*((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x
result(z).y=rad*((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y
result(z).z=rad*((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+centre.z
If flag Then
ww = 1 + (result(z).z/eyepoint.z)
result(z).x = (result(z).x-eyepoint.x)/ww+eyepoint.x
result(z).y = (result(z).y-eyepoint.y)/ww+eyepoint.y
result(z).z = (result(z).z-eyepoint.z)/ww+eyepoint.z
Endif
result(z).col=wa(z).col
Next z
result(Ubound(wa)).z = -radius 'center sphere, which is the last entry, always in the middle
End Sub
Sub QsortZ(array() As vec5, begin As Integer, Finish As Uinteger) 'by dodicat
Dim As Integer i = begin, j = finish
Dim As vec5 X = array(((I + J) \ 2))
While I <= J
While array(I).z > X .z : I += 1 : Wend
While array(J).z < X .z : J -= 1 : Wend
If I <= J Then Swap array(I), array(J) : I += 1 : J -= 1
Wend
If J > begin Then QsortZ(array(), begin, J)
If I < Finish Then QsortZ(array(), I, Finish)
End Sub
'CreateGradientSphere function by Martijn van Iersel -> http://www.helixsoft.nl/articles/sphere/sphere.html
Function CreateGradientSphere(centerX As Single, centerY As Single, r As Single, longitude As Single, latitude As Single) As Any Ptr
Dim As Any Ptr pImage, imgData
Dim As Integer pitch, iw, ih
pImage = Imagecreate(r Shl 1, r Shl 1, 0, 32)
Imageinfo(pImage, iw, ih, , pitch, imgData)
Dim As Single x, y, z, lightx, lighty, lightz, q_cos, light, c, lati1, lati2, longi1, longi2
lati1 = Cos_(latitude)
lati2 = Sin_(latitude)
longi1 = Cos_(longitude)
longi2 = Sin_(longitude)
'calculate the light vector
lightx = longi2 * lati1
lighty = Sin_(latitude)
lightz = longi1 * lati1
For y = -r To r
q_cos = Cos_(-Asin(y / r)) * r
For x = -q_cos + 1 To q_cos - 1
z = Sqr(r * r - x * x - y * y)
c = (x / r * lightx + y / r * lighty + z / r * lightz)
light = Iif(c < 0, 0, c) * 255
Pset pImage, (x + centerX, y + centerY), Rgba(light / 6, light / 4, light, 255 - light)
Next
Next
Return pImage
End Function
Function Base128Decode(sString As String, Byref iBase128Len as UInteger) As Ubyte Ptr
If sString = "" Then
Error 1
Return 0
EndIf
Dim As String sB128, sDecoded
sB128 = "!#$%()*,.0123456789:;=@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎ"
Dim i As UInteger
Dim aChr(0 To Len(sString)) As String
For i = 0 To UBound(aChr)
aChr(i) = Mid(sString, i + 1, 1)
Next
Dim As Long r, rs = 8, ls = 7, nc, r1
For i = 0 To UBound(aChr) - 1
nc = InStr(sB128, aChr(i)) - 1
If rs > 7 Then
rs = 1
ls = 7
r = nc
Continue For
EndIf
r1 = nc
nc = ((nc Shl ls) And &hFF) or r
r = r1 Shr rs
rs += 1
ls -= 1
sDecoded &= Chr(nc)
Next
iBase128Len = Len(sDecoded)
'workaround For multiple embedded file other crash will occure
Static As Ubyte aReturn(0 To iBase128Len - 1)
Redim aReturn(0 To iBase128Len - 1) As Ubyte
For i = 0 to Len(sDecoded) - 1 'convert result string to ascii code values
aReturn(i) = Asc(sDecoded, i + 1)
Next
Return @aReturn(0) 'return pointer to the array
End Function
Screenres w, h, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
ScreenSet 1, 0
#Define PixelGet(_x, _y) *Cptr(Ulong Ptr, imgDataTxt + (_y) * pitchTxt + (_x) Shl 2)
Dim As Any Ptr pImageTxt = Imagecreate(500, 39), imgDataTxt, pImageSphere = CreateGradientSphere(radius, radius, radius, -pi / 8, -pi / 4)
Dim as string sFile = CurDir & "/Text_500x39.bmp"
If FileExists(sFile) = 0 Then
Dim As UInteger iLines, iCompression, iFileSize, iCompressedSize
Dim As String sBaseType, sBase128, aB128(1)
Restore __Label0:
Read iLines
Read iCompression
Read iFileSize
Read iCompressedSize
Read sBaseType
For i As Ushort = 0 To iLines - 1
Read aB128(0)
sBase128 &= aB128(0)
Next
Dim As UInteger l
Dim As Ubyte Ptr aBinary = Base128Decode(sBase128, l)
Dim As Boolean bError = False
If iCompression Then
If iCompressedSize <> l Then bError = TRUE
Else
If iFileSize <> l Then bError = TRUE
Endif
If bError <> False Then
'? "Something went wrong"
'Sleep
End -1
End If
Dim As Integer hFile
hFile = Freefile()
Open sFile For Binary Access Write As #hFile
If iCompression Then
Dim As Ubyte Ptr aBinaryC = Allocate(iFileSize)
LZW_Decode(aBinary, iCompressedSize, aBinaryC, iFileSize)
Put #hFile, 0, aBinaryC[0], iFileSize
Deallocate(aBinaryC)
Else
Put #hFile, 0, aBinary[0], iFileSize
Endif
Close #hFile
aBinary = 0
Bload(sFile, pImageTxt)
Else
Bload(sFile, pImageTxt)
end if
Dim As Integer pitchTxt, iw, ih
Imageinfo(pImageTxt, iw, ih, , pitchTxt, imgDataTxt)
Dim As Uinteger particles = 10000, i, ub
Dim As Single x, y, theta, rho, phi, f1, f2, ang, z1, z2, px, py, pz, c1, zoom = 1.0
Dim As Ulong iCol, iCounter = 0
Dim As vec5 aParticles(particles - 1), aResult(particles - 1)
Dim As Boolean b1 = False, b2 = False
Dim As Single dimx = 0, dimy = 0
For xx As Short = 0 To iw - 1
For yy As Short = 0 To ih - 1
If PixelGet(xx, yy) <> &hFF000000 Then
If xx > dimx Then dimx = xx
If yy > dimy Then dimy = yy
End If
Next
Next
'Map string to sphere form
For xx As Short = dimx To 0 Step -1
theta = Map(-cc2 + xx / 4, 0, dimx, theta0, theta1)
For yy As Short = dimy To 0 Step -1
iCol = PixelGet(xx, yy)
If iCol <> &hFF000000 Then
phi = Map(cc2 + yy / 16, 0, dimy, phi0, phi1)
c1 = radius * Sin_(phi)
px = c1 * Cos_(theta)
py = c1 * Sin_(theta)
pz = radius * Cos_(phi)
aParticles(iCounter).x = w2 + px
aParticles(iCounter).y = h2 + py
aParticles(iCounter).z = pz
aParticles(iCounter).col.argb = iCol
iCounter += 1
End If
Next
Next
'blue sphere coordinate
aParticles(iCounter).col.argb = 0
Redim Preserve aParticles(iCounter)
Redim Preserve aResult(iCounter)
ub = Ubound(aParticles)
Dim As String sWintitle = "Around the Sphere coded by UEZ"
Windowtitle(sWintitle & " / " & Str(ub) & " Pixel")
Imagedestroy(pImageTxt)
Dim As Ulong iFPS
Dim As Uinteger cfps = 0, s = 4
Dim As Single fTimer = Timer
Do
Line (0, 0) - (w, h * 0.75), &hFF404040, BF
Line (0, h * 0.75 + 1) - (w, h), &hFF808080, BF
ang += .0033
Object3Dto2D(aParticles(), aResult(), Type<vec3>(cc1, 2 * ang, 0), Type<vec3>(w2, h2, 0), zoom)
Qsortz(aResult(), 0, ub)
For i = 0 To ub
If aResult(i).col.argb <> 0 Then aResult(i).col.a = Map(aResult(i).z, -2500, 600, &hF0, &h02)
Line (aResult(i).x, aResult(i).y) - (aResult(i).x + s, aResult(i).y + s), aResult(i).col.argb, BF
' aResult(i).col.a \= 2
' aResult(i).col.r \= 1
' aResult(i).col.g \= 1
' aResult(i).col.b \= 1
' Line (aResult(i).x, aResult(i).y) - (aResult(i).x + s, aResult(i).y + s), aResult(i).col.argb, B
'Pset (aResult(i).x, aResult(i).y), aResult(i).col.argb
'If aParticles(iCounter).col.r < &hC0 Andalso aParticles(iCounter).col.g < &hC0 Andalso aParticles(iCounter).col.b < &hC0 Then
' Circle (aResult(i).x, aResult(i).y), 2.5, aResult(i).col.argb, , , , F
'Else
' Circle (aResult(i).x, aResult(i).y), 5, aResult(i).col.argb, , , , F
'End If
' If aResult(i).z < -radius Then Circle (aResult(i).x, aResult(i).y), s, Rgba(&h20, &h20, &h20, Map(aResult(i).z, -2500, -radius, &hF0, &h20))
If aResult(i).col.argb = 0 Then Put (w2 - radius, h2 - radius), pImageSphere, Alpha
Next
Draw String(1, 1), iFPS & " fps", Rgb(&hFF, &hFF, &hFF)
Flip
cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep(1)
Loop Until Len(Inkey())
Imagedestroy(pImageSphere)
'Code below was generated by: FB File2Bas Code Generator v1.05 build 2020-08-08 beta
'Text_500x39.bmp
__Label0:
Data 24,8,20578,10151,"Base128"
Data "nJ:7*J#!lJ;.b!#J7|l$mH(!(±0R7D((|J7.V!:J7Pl)¿L³.(LoB8hp!!N!!$¯t!!*!:#!7!S$!R!¦(!¯!h0!¯#7:!!(|P!!0!z!!;lG#!V!j$!¯!$)!|#71!l%d;!l,JS!!7J¡!!L!R#!t!¡$!B#V)!l$³1!J)¯=!!2¿U!!Al¦!!Zl]#!³!·$!|#¤)!Z%d2!!,.A!l5lX!!H¯«!!j!i#!!#Ì$!.$!*!J(33!¯.ZB!!97[!!O!²!!xls#!F#9%!l$T*!7)¯3!l1¦C!l=¯^!!VJ·!!¨!~#!d#Q%!Ç$¢*!!*_4!J3!E!!CZb!!^l¼!!·lª#!¢#h%!Z%Í*!¿*.5!!5RF!lF!e!!f¯Á!!Å!¶#!¿#}%!·%R,!¯,ª5!¯6|G!!J|g!!m!Ç!!(mÀ#!3$µ%!J(~,!|.Z6!l8ÇH!lMJj!!tJÌ!!9#Ë#!R$Ê%!¦(Ë,!l0(7!J:JJ!!Q¿l!!{l$#!Jm*$!p$7(!7)P.!Z1¦7!!=tK!lTlo!!¤¯,#!X#8$!¯$"
Data "O(!t)|.!J2V8!¯@¿L!!X7r!!«!4#!hmE$!Ë$f(!!*É.!73!9!lBBN!l[¯t!!³J9#!v#P$!B%{(!d*N0!!4¢9!JDlO!!aZw!!ºlA#!¦mZ$!_%³(!¿*z0!¿4R:!!F·P!ld!z!!Á¯F#!µ#g$!|%È(!R,Ç0!¯5Ë:!¯G7R!!h||!!È!L#!Ãmq$!»%5)!¯,L1!|6|;!lIdS!lkJ¡!!!KQ#!$$|$!.(M)!B.x1!l7N=!JK¯T!!o¿£!!,mV#!7n¨$!N(d)!|.Å1!Z8Ç=!!M.V!lrl¦!!5°[#!H$´$!l(y)!.0J2!J9x@!¯NZW!!v7©!!=#c#!Vn¾$!ª(±)!l0v2!7:JA!lP¦X!ly¯«!!FKh#!f$É$!Ç(Æ)!Ç0Ã2!!;ÃA!JR!Z!!}Z¯!!Mmm#!tn(%!;)3*!Z1H3!¿;tB!!TR[!l¢!²!!T°r#!¤$6%!Z)K*!·1t3!¯=FC!¯U|]!!¦|´!![#x#!³nC%!x)b*!J2Á3!|@¿C!lWÇ^!l©J·!!dK}#!Á$N%!·)"
Data "w*!¦2F4!lApD!JYJa!!®¿¹!!km¤#!!oX%!(*¯*!73r4!ZBBE!![tb!l±l¼!!r°©#!5%e%!J*Ä*!t3¿4!JC»E!¯]¿c!!µ7¿!!y#°#!Foo%!h*1,!!4D5!7DlF!l_Be!l¸¯Á!!¢Kµ#!T%z%!¦*I,!d4p5!!E;G!Jblf!!¼ZÄ!!©mº#!do¦%!Ã*_,!¿4½5!¿E·G!!d·g!l¿!Ç!!±°¿#!r%²%!7,u,!R5B6!¯FhH!¯e7i!!Ã|É!!¸#Å#!¢o¼%!V,¬,!¯5n6!|G7I!lgdj!lÆJÌ!!¿KÊ#!±%Ç%!t,Â,!B6»6!lH³I!Ji¯k!!Ê¿Î!!Æm!$!¿o$(!³,..!|6@7!ZIdJ!!k.m!lÍl$#!Í°)$!Í%4³M¿JGt,Éml|7N(4KNR0]nz7;;)SK1l8J)L!=(*qK]·3Lo¹7E;*À#1°C¯!½|H³,ÌKlR79p*}H;!l#oKcB)7(Lp0aLz·:nn1nͯF3$|t=fqZ}VN2SK(¯9¦4¯%fl,¼L².CTrt78ZHË,l°9]r¨8cÃ4mM"
Data "Mt#R)joÈZ7hKÀRH~sD}p7$C%G±H1t(~m_.=!¢lcJ6;$1l7[N4011%V%ίB;#5SO]uX~6¢!t$«#i·.@9x(;§NBlU¿6toQJ!(OSuT¨s.!PZE¢,6K)¦vµ~i;!·$»mkl1P!¨pAÄO¦.#t(_%¦N@ÈOq0CÉ!ÁnÎJH¦.iS2t%Nl9p!3#Vl$|:¤!@¯!BK)¯)¦$ÁlH|*¦!%!.±!xlE|*B#§SxZ$d!¢NTV#E$,±!·l3l%)!5J1d%µ!9!$.!%!).#!~7;!p!VJ)7zh(#!%x#;Jg±mJlBl(;!Ft!d#·lº°,d#4!39!@l4l)ÇPX!lÁ8f}¼|:°!GJ3t%Ç!Cl$(R¹0aÁm$l5Z*ª!4Tmd!r!G¿f»#KJf$8¢!CJ3=K%J)7%XsH¯)l!X¹.T!j!G|,ª#Slt1¡Dl:|*¿#gJ0d!l|%|(¢#c!1Z|$!.¿$ÇJ,l0¦%X,G¿%tRH.qÁ$½lA!(³.,¯)|!@=5(#_Q)!*!¥ª!4ZU#Kg!j7u(==Ã!!#]!5Ç$hl)!Y8.%¯)7%~£2£]«R"
Data "il4¿#*!3¯*Ã#@º¶f¢½l@!%F*¬mDJn(l;J=B*wl!l%»n±J.;K@lGB2D%¿lF·*R°:t!h7B¯8;*ªmbZ37nAZ!R$kKT¿!ªpnZC¯$,¹p.!¤#»!9ZMfn@!1;%½!E7*Hm;¯$X$z!*7K*¯:R3lnH¯fO1!°_d,J¡0=2d*XK3Z¡9lZ¿=³*xQe.4n$UJi0K$!,Z,t$ª¿CË*²K_R1nm]£J;!{!cZ6¨nm7A|*,xad1!mlqJR#Zm[R(Ë¢0m$V(¥#JǬ1(7|7(*°#Â05$%r|)!N(JZJ4h#:_#¿$Vma¯ht%·7;ª$*w.Á#±m«7F3,©°]R1h#0ZSG!v!Qd3_oÀ7F;*#mr±m1!K79B*¨#cl3¨$a!(Ç%X°8¿8*!:l7B*UVe!5Ç$k¿)¦SLL,l*±$·lEt*j#Nd%.m¢¯6Ë!62mÇ#7nW!$t#*°V.4d%·¯@Z(R!FE81l¥¿I¢,§¯r$%*n¬¿DÇ*~#Yl0@#U¤x´#NKa75Ã¥~¤¢8,©#P.$($»lFBaY¼5²4H%¨JAÇ,¤K©1n5!alGp,"
Data "¼!#R)noÆZ33K(¯7.3Ë%4;§Ì,À°K!#hp(¯2(,vy*n5¨m~|!¼!rneÇ6¨$4¤J7!¦mk!5$@$!,N*¡y*±6¨%ÊZG!%N.$7*ªoÂ|4t.:n*t2Ç%¤!(ÃJ2¯JZ6½%i|¬=!q¯Z·6|©Î¯IV*u!X%n$!:|9l,,½k·6BoQ|WyM¬mpÊ6¬%s¯%7.$J:¿4³%b!t¼Zf°kl4$m$K$l%·mpg6l$v;PÇ,ÊmKǽÍlª!§KcÌ#]Z)T¡7¢!Ã#£°mº6;%S!H£1Bmil½Ëo®¿yy.E!Vd¿Ë%ǯG»,3#pB#Å#AƯy,=#0·z5!]lEFdÆKf¯6JoF¯}y.Ê!j¿4Án_(«i,Ä![±m*!uJ%8*NJ1±!xmÄ¿¯¸,b#5!¶R!tlHÃ,Ã#h.6µ%É|Hª,ÇKj¦6Ç%1;Hx)[!L76Í%Í|¹GIG¾ÈÈ5³%sQIÃ,ÀmGÇ6»%EZ(W!2°jd5Zm7]F.bM·172Á%ÍlEV).°MÇ2@«ÄJ3lQ$J7¦3ÉoÌZCd(F°_¦6ÍoÂ|E¿,Æ#iÉ!ªoÎJA¢c6¼bw5$¤;¿@¿,Ími¯3Vnw¯B³h"
Data "D·eB)¬©ZJ¬}cH$,73Ë%¨Z(ÃJ,JI¦Ã]nÆq.p*Ë°¸U4±n¢7C·,u4b¿(p|!!%J)Èm*¹6~%®7=¦)©#jÇ6Å%²l*7.*l@!59©ÂJBR)b#c|ˬohZU4!¥JdJ6¹m´q%=#a°kJ6R¨Bm7R,t¼fR3¢n¦¯E·eË°VJ{D!D¶µ4ljl]tν%ºZ@V)u#il![%W¿kÈ.V¯Vl»Ão¹Z@;*Â#]Â6hoZ|c¸0ÆJh¦$¼nt|7V)µmk|6|n»ÅL¢(,Zkd4h$slAV,fXj·,1p,¿6NMÍ#fJ3¤n¨¯EBdU¿Qd$$l#¯,»*D·f·2Pn}JDª,uy]!²l|qJ¶Kd¥#UÇ05o,ÇId,̯{Â8Nl¼PCe%35¡f(Z%(QGª)QmYZ5$°¨¯8@.B!Rd6¦ou73!%±!Cd*~#b¯4l%Â!IÈ)¯l%J,|*Ì#g¯.h#A$Cf8ªJBZ*¤#d¯5Ë$i¯f¯6@nk¤J¿!U°k¿3Él@±FtilzI.6É%§7.|!*J$¿#N$Æ|¸aq7¯QR6Ço©¿*J!5¯.70LF³rH;U}¾k¯2T®*¤FRPiU#Ç,Á%ÎlER%"
Data "LJ|!$N#¯JÈ4,r!0f!jmÅZ¬Ìs¿±Z¿6É$:|%)!¿JiÇ6±n6|W¿)ª{eR,~l2Z$!#¢JX.67©·JJ´!@°#¢6Fogl*»!:!*!%Ëm¿I¯,B°Áf!lmÀ¯Ip,WK6·#Rl3l,J)È6^.%vp8¦HÃ%z4,¨#]Mο43!#!;d5Ë%Í|B_$I¯(Z#¨lf¯D7VÌ#G7=ǯ8_%|)ÌmkR5Ím=¿$|!JJ=¿1ªouAA¿tI·%¦,¿~ÃZ7B#A¯,.)»$É!§À*wl#.!Íl·JªW%El$R!R!T¿DFi¦!T9!TmÅZ§8(R¯%t!b!QÈ!¬,¼!md!]mÀ¿I·,p#8¿#R!3¿)¿%§#°v5½m#!(()°~]t(Vµ.|(R%ª°ª;3!µ6¢8·e¼#N.%Tl,7(¿$q°Îº59#·£J(%D·)v3hF:;(F)É°j¯3L#3J$»!clJ75ËoË7:¿!ża:5V#7*(W!ÇJg|6pn8e(´!^°kZ3p!8¢*_*ÎmUJ{d#ÿE$Kd!aÇ6RoE¯MÇ!Q#j¿5Ã#[;.³d¨m6¯rF!l7_Í,¿°j;ÌËM5p!·*U7*7!¨lÄÇFJ$"
Data "#T!Ç#¢nοE»#99AR8£®0m%³tomn·mnmkQBJ#1JK!9s%L7gL0d!RZ3Dn7;#¢%ÁKkÇ4Çm:Ç}«$K:ed)(!(¿3B,Á°Id=2p5!@³,É°I7#p¯¿¯H3(P»p¿!f$4p7J!LJZ|m¬n4¯O[!°!WB3L³1¿W*K3¯FÇ!u%RJiG!aJO.3.n«Ã%Ä#|mk|5¯#o£#B%¡°·¡1Tl.|:ª,ÁKGt)2(ZZ¸S*Y.*¦3¤Jc|jL!ÌRi.*.(AJBË,Æ#TÇGKp2¿2|)Z#:¯!¤#ÄJI¿)aJCE(3%Ì7AlkJ.Ml»¹%g¿v9.=JP¦.8%ifLt!q°¸E3¯µ£eRS%¼mkl3!m»e!¦$©mk¯5¦#Ç;%3)Ç°ËVIm|1¿93{6#~Êm.!k7IN,¢l.Á(¬oUQFÄ$1ÃZ%n(!TZH¯,G°QM71!Y!Vv)$ÃK°)Wn{¢JB#hm*É5r·ÍÇL@0v°¸g$7!q¿I³,Em9£:x¬½Z*7Y©J5i8§I¿T)ÇJ~l_²3¨!C¿BÃ,ÉmKRY2p(!(¿¦H±0Ç2Í%į5;e(n*R1F®qZ$N!¾JfÇ5¤#}vMx$"
Data "¨mkJ3¨!$¯1Z¡,°MWµJ$³*9d!µ!gÇ6t%L!Y)!;!,·7V!mÉ%)!S!Z¿6·ox!·¬0F¯}G8|m¼¤AZ#XT[^1L%[J#»!xKkl4¯!dÅ#x*ÌKiB((lV7Î0*Çts¦(ÃoÈl~=!¹!²N45maA!x!C!#J$³nS¢3x¨($.d1½o¦7((Kw£k·1_lOO(!*Ë#g|(QpR7GÇ,j#8lw@%YU(£!Q°]M,~½NK6xrÍbm¦X©Uɸ([#§Kk!6Tmƨ%£#s¡RÇPe|(l77¨}!m.ZAR6¢#x%ÈmdB*F¨8J¹e*hlz|1rKR¯}¸$CYry;tR5g!RmÆK6.#ZºÄ7ÄÀJ4!Ç£4±VeÃ@§tH±*Ç21«=¯%#$5¢_J%z#XRA;#¤[Xw,·Ft7;z.(¯@!5Å%©ltµ%¼mg|*d»4J;¯,«°:l!Rm¿¿HRNHtHd!Y$;Jh¬,ͯP(nª¼DA(C!±!f¯6.%.F*[(wXIRek7BJ¨Ä(yÇs2,¿%Ìl53!H#]Ê)fNTJCi$©nW7¸ÅmO·M;$~°kZ27[6m(x)ÆKTdUi|p|Id,µY,D!|#ʯI»("
Data "n1)t1n·X¯!Ã%ÊmiÇ,tÀ6#,h,90FH8h!}lIR,h:mt#nnʯ«HKt!c7½L#»ºMR!bmkÇ47Z6¢$ª)Î#cÇf¶.#E(£!1mj|4LmO´#¦(_Ã9¿B!oίE³#Gt,.7ÀYͦp@^O°t´(¤!¸¯IF¯G·%¿.|F´0·°$»°$*ÄÉ$1Q4Ê._JTW4ÇlnlH·,8#{a²bnίF¯#J·!R(DX°¯)V!$Kh¿5~#5g$N(Âmel*@!S!Fª,3#qÄ8d½ÎJ:|#k#k75N#ohL!±i¿,n!ÃmÎÅ9¢gSR!!17Ea¯,ÊJx¯b^.;»$K0ls6°#dQÎ%I|%0!®¯]¡(µq¸¿I3,t¯.±)¬µÌ§%G#f#jZ1fl7Ã7¿,ÃÇ,D)ÍG¥!%;.cJl_3r³E79)*k_.n!t_˯:VgU$=·5Ço¤!6°!IKO5iy7,J7l,¥bUËm(l_!b1(Q!)¿!Dl)7#F!)JvZ$zo²DZ8®%b¬¹#Z!4|8lnr¯~D!9$xd2l5}°kJ3pÁ0K!d*ÌmY¤k¼«xZ³¨$h¯b·69ois%u!A°kd4JV8¢!hµ}em¦#Å$Í¿C_#"
Data "Ht1lWO%HJ9ËIA#8t(hm[J1!$Ul(·!;!tC(0![JN.,d]t)0¢*Ë°X|$B!qlHd,·!s)#n²¹r#p$®°i¿.FÃ0À2pd@#5BËj%b7.l$²lA¦(¿l7¿#Z!0!Ef|i7$l%_V)°jd6h$M!0¿$²¯;.(¦!2JbI!yDpl0ÍI_7ÈÁJ{lww,j^H|Æ])9¯CÅ6H(gc4(}89.75Í%À¿2($}lŤ(¹l7!$!¾w.EÇ5Í%u¿e¾Zo#j71¯Q7³7»,e¨,T(foÎ|@¿{L))~,|~)!9·,À°CR|0(0Z87¨º!.n$½Áº¯r92H£Ojnj!QdI¯(É@pl#bdzµIt,¨°Y.19nj!7Ë(É#h·,5¢!gHJ%GR$.,|o¬l,¦%ÈKc·Cº¡n¿u¥[{¯)h2Xb6KA»,je·(xQp#7F¶,¤!3R4Ë%ÀJTv»°§a¦t^9yWsÁ»f#k!55mOÇ(·¤x°4B.5K0sIV,}mP|%½ÇÆb5Z,È#R·#D!u|n@%¬4mJ#B$ÉlEd$,¯:Ç4Ç%¦!=ÂJ©lÃÊ.±!®7ÎudÇKdÇ2Ë#4lJ!±5mtb(¤oÁl,¯%"
Data "J9O¶5H%z¿.·¼(±I¦°8$6z%}#~4NÇ!f7F¯Rj)0lsÌ6(J:¹4»dT5,drOFοHÇ*kKG!IomIu=texZ[l6j$^Ç%4(PhG½mÅÃÎl=ZZ6!eÇ6|o{;!ª#±KkZ3ËÉ7;%J)ÎKc!(l|$|6«,³!Tf#_$ÊltIKc¯cl½omgÊPa)D½_^5;m58¯¹,Ëlu¼#ªnͯC!$°¯id5ª#s*#h(ÎKd·(ttI¸=¢¸GRW|6¿Y,¿Q¨Â)±!t4À%QZ%ǦÁmjI8P!{¿I¦*jHµj)JÂozJ»!0«h..Zg5p)B*!©2Zmsh½¸=xÅQtºvT²%elH¹(ÉKg.*¬U67=³,z°3B!¨fS6gÅJ±!A_.r!À§»oyµ!TÁbÈ%¥|%[!4#}=)pmÃZ¿Â,dmiÆmfm2.AR#DÇ,.½¤n̪J($¿#kR01l¤!§0(G.#!,rgZh¿:¨³JÈv4Ío´JAÎÉ@}QJÈg|l7IFÀ.Ë~º0p}W7Î}(:L$BM¶oÌD(È!kmk!4DÂ5_¥Ì,(#bc#;G4¾(0!ʯwË3Å!Ê4!(!{!²»4¢$«JBJ*yK_J4]%ÁZh±)"
Data "8gTÅ6(%½¾M!$RfZ!%9#Ä|H_(I¦1l2Í%´lFÊ$νSJ{f|§7·AU5!ÊVÃA»²¿Ãa#bH(;2vfV#;tÉMFµb·YNWIÎi*]2,~%Jo7È%³#9=hl*;!4!*B$¥!D¦,Ç$̯I¢(vË.9!b!aJ¨iÄMÁ%ÇE§oWJi4!¹Je¯6n$yO¾¾,L#%Â8µmhË4B!¿!A³3¬l*J(³#xlAÇ*7$]sH¢´¬$]Ê5Ë!AÄ$Z*wY6!%h»ÅZ5J!b^8d)z#k¯@.JL°¿¼mZ!~¿H¦,E°.ÎmX!ª¯PÉ^.¹I!Ȩm#¿2³k©mn,n¸m4ANA!į·Ê2±l*l(³#zJB!,Ln3QFl$#J0Çu«og7M64u#nqÊe7ËvÆÊ.Ƽj.6¢#(#%·¤©m¯5!·!r§BÇÉ[v1Z4Å%¬l¹ÊJr!v52;p1|9¢,¤®01#FnM·R©rSl[¿6$o9J!Z!@¯,Z$¦!E!6J,yÊB4Z{¬{lHy.¦!³¾1nl87¶¼)WËn£)t%ίÄ19~YUB±e7^1Îb!Gj_¿ÈMr|eG_!$J6tΨ%Q¯O}!L°kR4;ËTι®t¨jÍw6_$Sh!3%"
Data "¹°kZ0J!0J:Flwm0.|R!~!QÂ$DB¥1(¦n4¬I¢*xu(Z1Í%Å|2RYH!X|½b#(7¾Î*DRfZ)nLR{ë$j²^BÀD$1«,7q:¸Ys»É%¬¿lÎdTJed7ql.¯8»,Ìm_B¬Pp37:¯,·°CR¹e|1¦m:,ºlc:¡¬lVB#³Í·°PÅ8Bl·¯À*$$¯,7¼½oj¿L9!P¾g¯4%!0VCK({a!d(t«©¿Kd!ÎJ·c3Ã!5³)V*Ç°P|¿k|j!It,«¯¨2*]H½!*!0¥¯§:0!§0¿kH,%±,D!¹!¼!I_)jD.v$*¼¶lF¥!:#iZÌ{7A¿BÇ,Ì°LR¹gÁu|~¥$X1$l,»%Å|3_R#¤*$6Z$yqJZ!$Kɤ,1l#J6¢f¯¯kx$xSů5¢P²¯*c2±f6m=³,Çc%Z%¼%i!¸=!ͯ·Â2N;*¿=Ç,;½n²8B!S!q¤*Ã0¡]ÄcÅVI}²¦¯¯^«#jnË|§µPmJPµ6vn5¿J4!À¼k!§I_$¿(B(s:(»3Tml´$x}¹E.·8(!9¯9¦,ÌKTJ{Á̾7§4*d!X2!*mkyD(¸*lkÊ6¦o^|#Ã.@¯RBHAnl´¼¹J"
Data "Æ°VÇ$@8Ç@Hle4¯!J%t«Ì¯;F#,T#B*noÍ|B¢#Dd©d0µOÁl4¢!RS!R#j$¸71J.#¯5·3Ã%~!5A!À¯L_3@A%!®XjµlRa!¨lÂÅGl®x±bXv~m%|K(!:;kl6($0O!¦#¦=jJ2D¨6s$¿%·#u£¿k|i¿HÃ,}#9lÃ9!V¯¹Å,1K¾¹SÈ%ÁZ0!ª³!cj0Hº]b,lZJ#¨Y7Vl@IFJ©;¯MJ6r%Y7$Ç0jn{¦!;lÉ«b²$8XfB(x»$K!Z$·°j|0hizirb*³em¯)ÍNu¥Ih*ÅJ7l%¬#Á¯IZ*Tź.|m%dl(Z!9l3Ç1½%Î!Bdp°J·_¢i7~!It,´T%tuÎoÈ¿ef!,¯*·*JÍÉZ4_Q_l]BAqoi7.¦#~lR.ÀHRÉpS§ÉEg¤{·¾%%SG»%M!#.!Nlk!Au*k¯mÉ*¯J1Æ3¦#_JE¯)¾%XJ%ÆJ*l1Z,Ddy,Fl(ua¤6¸¤J¥J0x#gJD·2¿oÍ!DB¸OLUsÇPH´l1t!M$3Ç1¿%Í!;|QrnU¦.ºo~l0p#j¯¡Ë6Bo;|J|!AtmÃ6~oi¿.|#¯l[55@m*m°Íu"
Data "·zE7Fªm¥uGN%Êg,T$ËnÎ¥Hp)®l5B(¦½ÍZ5³nq¢i|6vnAJ$R!N!GÇ:¾oX|G¼!QmÁw6@$Nl*N$)KlªÀ¯Y¾k%N)*Xh·0@#CZ0.{ÊKZd¯«pPZ©mθJ6¦%jm©¿Î´,DmnÎm¿mqÇI_,D°=t%¹lQJ:tjÌ°YJ{5,A,@|·¬k1t8Yo7yh2$¬Ki|0*¾5N$¿(Ç°eZ)1l0Z8x,É°dR4]zx:Â|*}#Vd)hÌ6Ã!RfÍ#YB$ͧ2|CÇ,§#FYEL~¦¿y¬$r9[¦3ÁIͯF¿NÍ°gd.bp(¯3(,Ìmf.3v$¤7Dhl½KC7r]mI§8ÉJ~aiR¤D!ÂT%¼,}°S¿0¿$A,ÍUz*J9l~QªÃJEpgD.a¿¡k70¿0drÂ!RJ6³o¤l5l%¶¯7¿»_iÍZCx)C6g·2L$o!=ˤÉK,Y7JllJG·JÇmbt4@«Íl;!ÈIt$l*1oqt¤z){!7UPGeÅ¿D(,v¾k!5|#[;¾Î*Å#V·3PH¾7=J(4°Z¦.woV7G)!YlC£m¨%¹lF³kÄK=!tB!Î|Il*g#]º6¨o»¿OÉÃøq.,$NJuE»*"
Data "¸.jR1V!:Ã.t¸D.j!5x%´QE¿r)±0Z3ÇoÌJC_)K#[ÇWÈo¥Zp¾Zo@n%6Z%¸A§e,mhu·$¿©0sGª*µ°j¿6foX7g9¢4F»;´X±8E:|QJ·G¦Ã9EË¿E.Pt4{:X0pi¿Î£$Ç1$d.ÁoÉZ6¿³%½cR6Tn½w%i!4°h¦5zm(J$N(²¾t¾3Él½{a;*Ì°hd,Åc¤S¹i,_Is7(¦%Í|:¦X|Jc¦6X$r¿¾SbÍ#aJ)@8Mp@Fl¡4kl3·A$}yÎ,y°2¿mDnÉ!Îb!µah¦Ã|EÉ!8Çɬ®(!0±«%sDǸ[T2R1@o·JD(,ËmjJ5N%·|Bª(k!$|ÄÈ%¨l5ÃÂDthB4a7Æ!2n.dJXd!=©Í¯Eª$DB,]!½l90°y,sKBÇV0p]f±Äov4i|1H«9}£{,*#O.À_¬Äl2¹Jrm±W77l]¯*zbÇ#[JÈ6!ËlI¦)½lB¢»P¹a!¥4![lUd!=EÍ7EN%D¦sB#¬m·JÈSbÈ°TtVK@r!AKc¹#EÇ6%lflºGd½K7Q79lb7FÃou¼h¦1(b$K*_)tGfÂH¸:7¢5VfÁ#°n½¢om¯º5)"
Data "Ë#id¯y·X!H³,Nm¬G¿j%ÉZ9t±Ft%J.¯oÅ|~v!,°ÇEÁI%K|Êw1=°L»¡k|#lN¶,(°pZ!¬m´Å_y.[JZ¿5@¦aJDËkM¤[¯)hÌ)Ê)Ë(ic]M6·nKl4m#t°kÇ25d5_3F,x#_¨!Ë$Ìl;!(µ£]%6.$**Lp!ÊJÁ²Gy%«J¨}*@¯,]!r#ªz~©)Nl¤¶6zn=Z1Nj¡¼hÇ.hÍ!!)»(¯~*¨6¿$M|¢2K1J=Ç3~EµJ5F¿FR)J1Çoµ!:!*ÁKjp3Ë#7|K´Ê®mhl*zlo!GppD.dB)XN%!1.*:Ìk¦5N$:7Ju[É#K·!V#®¿Î¸h¥mF7q,!8|97,Ì7jd2LmÌW.²#L°d·,«%{¯*R~@!F!4ÉK(ÆEJ%~dx¯)!oÎQ%u,mK#Ä5tÂ0}#|$k°LFÀx%rl(³ºSJLZ5É°©AA_,È#PJ{l7f!N¤)3#Äy»·%±J3h!!uO¦6l$:wM³!r#k!3r¸8O.JN9m;5{¿#¬@7l!8JK!k¤$j||;;))H¦,9nY¯ÂÊJ]¯_¿6¿%_¯³Á.J!ft¿j¨.J³6,²ºpl!ÉlW¿)G!"
Data "QJ=·,Í#VJ(h¥¹b8l.±$§|9d$FJÅh!r#|¿1|·)$(|%±!(K!3#rJ.t!·lel:ª)O°G·%jÂE°(t$ÊJJ·)¯lA¯AË,¡#¨Y9*m¬lCª*³#=p½¶{ȯG!)Fl¤¶6dn4l!¦_£mhB6±%±Z3_SGR(J%lmlZ5($DJƾm3!Z¿Exw¾°Ql$Ãb$Z*V%cl%¯#·!QJ1ª#JJ¹yÆk%Ç¿2N!6J9Z1~%Ê%G3)o¯,X9f!L757(¯J3BPKpC!3¢¸%J,¯(Ámn¿2Z#lb!Ç!³!Y!7x%o¯*Çmw|0J*Ç$!°E¿%B¢5(#;#ÆlSl2p$c!*¿³)J,R(¹mo|3³#LJOl0M·8´%J$ÁlJ|)¯!Y®Mb!]lAÇ,ÁmRZ)V$¥#jZ0Ë_7N5FnIm*¦$P#i¯7h%m!©±lam%½W}#¾l4Z]0($¯,¿N;KÆ´m@ldJGÃN:!(¯zw%Z!·*!ÄE¹f*l³º7%ÊJ2!´¤5pY¾6)B,ÊKYÇy¸94¿±z*ocpc)¦%Á¿3t!=¯,¿#N(W{Ip(33vd#l!0|Ê{K*l:¯)4ÀQ|¢wKÈÍcÇ5P#Ia#Ã!"
Data "HJ$|m4¡;Ã!¯g¼°(VpÍ!ae9ǸJ.Fd(k$SV.4!blZv0*¾5N#Z%·KiJ0LQk!H;,¯!tc²xnÀ¸9h¤%g@.6Á%sZUytðhJ.Fg£N%¿)xkÆyuV#ÅlF7Ä3dL{.hjLN!d#s4kB4»l½I)´Ê®Kg¦(_f²¢*G!ÇXgB¬1}IJWr(3»,É*~}{J12L$l2l4»oz¯Âʬµ¯eZ6]n2¯#»%¾#e¿)lh:;]rN®K8ǦllFÆCNi=JU·6loI¯B=.D!Y¿6B%SF:§$»#eJ¹C¿p¬73¬xR%|.F7¬JZ©KÈÍc·57#:ºB#L,!¬²5¦!I;]¨*ÆKMZ#n7b7ÂÌ(~Ç79$LoÊl;¦!tfBR5¿%|!%_!ǯgB5dm~5*)!·Jp23ËÃÇc7ª,aª#|%L%9»ÌEPE¯_z3NÀx³1Z,³#S¶l:ÉnZÇ]LHl¢w5r#yH)´Ê®Kgl(xV²(.G!:°k¯5~!I;]¨*Æ°LlÅ2(al2Í(~Ç7É#µÊ£¯Q%K.JBR5Á%¡J%_!ÄlgB5_m~H*y!a4kB*¿=#¿,B,³Z)ZmÀoplLÊOF¯¼O3rSJ¶1Z,"
Data "³#S¶l:ÉnZÇ]LR¯GÌ3Ã!YybQKÈÍc·57#:ºB#L.!´¬5FkDN!.$¥mil.hj5;4¿nIm;Hpd!©7It)1jnP*x%Ì7=»!3lF·5poU¯§MKvJDÁ3B¦Ç_AVjoJR7z©J²pJÃ!r#k.3rSJ¶1Z,³#S¶lQÂnZÇ]LLJS¬4xÃ5(#d$8°6|¸¼À´«GJ$P¤[$p7lRYG»cit!l(]%ʯ}*Kµ!AË0NÀK(%B)ÉmXB±k|(!4_ºS°*¦!¯mÅ!Ft$Id3¹!dnÌ|Hª%IÇv!¤º%{Z^b*Vl[D8jl¶ZIÃ)¬Hµb)¦%Ál¢Ê.K¯[¿6.n½w.q!A°}¢0y·GJCt,5m9,n.!YlF_,sluax!}(¯ÇP,dI4vÆeoÉ|p)K´¯*Î0NÀK¢$¯(ËKZJ·g]b!G³,Pm*¦!ªmÅ¿Ed$Id31!.#=jBpÆHn.·4Ë%%QIÃ(«ÎV9$d%Ì¿@ÇÉB©=¯5t%~½M³#¶ÇI7q0}#¿.J}½°HR#fp!|#³$Ǿ»¥my=hZGZ,pJÆcx½|)|;6ÇjR.*5¹oiZxÉJ³¯*Î0NÀK;$tLv°j%n;!dJGª,"
Data "I#*|!¦#ÅlEB$P¤3D!$$n=6ÇJ7Jdr[U#²³M;#²Kj72HºÁ31N,±mARIE#nt63¡zt%Ç,;IÈl;Ë$dJ2R(9n¥SGp%{£0v!DnÇZG!$D¦[]oBl©ËFh¤aR#7*p%ɯ5ÇÉI·B¦°i$Sh.a!Ålk¿3±f6_#|%ºmid0V!)Z4Z,¨#7B9@l37(33%²¯7$ll.!=£!xJAd)LmO|.7$rl;.*B0]Z2p%8XaJ¬ÌÌ0,D|Qr0pt$x%cFMÆÀO°R¦$ª¢Z7¯s%®È71!Vlx76Â,¾#d¦4t%nOG(({Ä0±!p$CY,BPzR%l3ÍoÁ¿%{K)¯CJ5µobJu:.§J§O0HULN#J%ÍK_!¶ÈEglGx,0m(t!ŨʿDR*wm^J4p5}MÃ.G¤°TB%.!WJEd,»mfd5B6ÂJGl,Âsh·5¢oË¥IpSPlXZ¦mJ²;fO#²KhB.lh:_5V,Äm;Z]E},¯3¦pzªgR2T#7k(a!^#k¿M4:Q¢#7*Ê#Y|m¡|$|37,·°:d²¼!¾7Ix%OiKÁ(³o¸7§ÍJ1!F|5v%V¦¦y)±°°UÅÌ%µ!._!"
Data "$KªºÉa|Î6l"
|
Download Source Code + kompilierte Exe: Around the Sphere build 2020-09-22.zip
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 20.12.2020, 15:35 Titel: Weihnachtsgrüße 2020 |
|
|
3D animierter Weihnachtsbaum inkl. Weihnachtstunes.
Da der Source Code und die Dateien zu groß sind, um sie hier als Code zu verpacken, hier der Link zum Download: FB Merry Christmas build 2020-12-21.zip
Frohe Weihnachten und ein frohes, gesundes neues Jahr 2021.
_________________
Gruß
UEZ
Zuletzt bearbeitet von UEZ am 21.12.2020, 18:18, insgesamt einmal bearbeitet |
|
| 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
