Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Gfx Spielereien
Gehe zu Seite Zurück  1, 2, 3, 4, 5
 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
UEZ



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

BeitragVerfasst am: 23.04.2019, 20:55    Titel: Rutt Etra Izer Effect v0.7 Antworten mit Zitat



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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 23.02.2020, 16:19    Titel: Growing plant in the breeze v0.70 Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Sebastian
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 5928
Wohnort: Deutschland

BeitragVerfasst am: 23.02.2020, 21:44    Titel: Antworten mit Zitat

Schön anzusehen! lächeln Und läuft sogar auf meinem Laptop ohne "richtige" Grafikkarte sehr flüssig!
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beiträge: 185
Wohnort: Frankreich

BeitragVerfasst am: 24.02.2020, 00:16    Titel: Antworten mit Zitat

Sehr schön. Der Brise-Effekt ist sehr erfolgreich!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 999
Wohnort: Ruhrpott

BeitragVerfasst am: 25.02.2020, 17:07    Titel: Antworten mit Zitat

Wäre direkt etwas für einen elektronischen Bilderrahmen. lächeln

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 04.03.2020, 17:07    Titel: Magnifier build 2020-03-05 [Windows only] ^^ Antworten mit Zitat

Das nächste Beispiel: Desktop Lupe.

Source Code: Pastebin

Vorschau:


Source Code + kompilierte Exe kann hier heruntergeladen werden: Mediafire.com
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 27.03.2020, 15:35    Titel: COVID-19 Ausbreitungssimulation Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 18.04.2020, 14:17    Titel: Twister Effect build 2020-04-17 Antworten mit Zitat


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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 24.04.2020, 14:30    Titel: Atomic Cell World Antworten mit Zitat



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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 30.04.2020, 08:58    Titel: Hungry Greedy Worm Antworten mit Zitat


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, 11:17, insgesamt 2-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4302
Wohnort: ~/

BeitragVerfasst am: 30.04.2020, 13:28    Titel: Antworten mit Zitat

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! lächeln Daumen rauf!
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 30.04.2020, 20:43    Titel: Antworten mit Zitat

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! lächeln Daumen rauf!

Danke für dein Feedback. lächeln

Wenn ich mich anhand der Rückmeldungen richten würde, dürfte ich kaum was posten. zwinkern

Aber "naturbedingt"? Wie meinst du das?
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4302
Wohnort: ~/

BeitragVerfasst am: 01.05.2020, 20:31    Titel: Antworten mit Zitat

Ich bin schon lange genug im Forum um zu wissen, dass Rückmeldungen zu Programmen allgemein sehr spärlich sind grinsen
Liegt natürlich auch sehr stark an der kleinen Community. Solange dich das nicht beunruhigt und du weiter postest, ist ja alles gut. lächeln 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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 10.07.2020, 08:51    Titel: Einfaches Feuerwerk Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beiträge: 185
Wohnort: Frankreich

BeitragVerfasst am: 25.07.2020, 04:25    Titel: Re: Einfaches Feuerwerk Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    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
Seite 5 von 5

 
Gehe zu:  
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