Das deutsche QBasic- und FreeBASIC-Forum Foren-bersicht Das deutsche QBasic- und FreeBASIC-Forum
Fr 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 Zurck  1, 2, 3, 4, 5
 
Neues Thema erffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-bersicht -> Projektvorstellungen
Vorheriges Thema anzeigen :: Nchstes Thema anzeigen  
Autor Nachricht
UEZ



Anmeldungsdatum: 24.06.2016
Beitrge: 108
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 ausfhren. Es sollte nun das Test Bild "Panda_800x800.bmp" erstellt worden sein (NUR FR 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 gedrckt 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
Beitrge: 108
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
Beitrge: 5934
Wohnort: Deutschland

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

Schn anzusehen! lcheln Und luft sogar auf meinem Laptop ohne "richtige" Grafikkarte sehr flssig!
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beitrge: 185
Wohnort: Frankreich

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

Sehr schn. 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
Beitrge: 1005
Wohnort: Ruhrpott

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

Wre direkt etwas fr einen elektronischen Bilderrahmen. lcheln

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

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

Das nchste 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
Beitrge: 108
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 + grn + blau)
inf: infizierte Pixels (rot)
c: geheilte Pixels (grn)
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
Beitrge: 108
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 Oberflche mit einer zuflligen Farbe dargestellt.

Luft 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
Beitrge: 108
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
Beitrge: 108
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
Beitrge: 4336
Wohnort: ~/

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

Da es hier ja naturbedingt immer recht wenig Rckmeldung gibt, will ich mich doch mal rhren: Da sind immer wieder sehr hbsche Sachen dabei, und auch der Wurm gefllt mir wieder sehr gut! lcheln Daumen rauf!
_________________
Deine Chance betrgt 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
Beitrge: 108
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 Rckmeldung gibt, will ich mich doch mal rhren: Da sind immer wieder sehr hbsche Sachen dabei, und auch der Wurm gefllt mir wieder sehr gut! lcheln Daumen rauf!

Danke fr dein Feedback. lcheln

Wenn ich mich anhand der Rckmeldungen richten wrde, drfte 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
Beitrge: 4336
Wohnort: ~/

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

Ich bin schon lange genug im Forum um zu wissen, dass Rckmeldungen zu Programmen allgemein sehr sprlich sind grinsen
Liegt natrlich auch sehr stark an der kleinen Community. Solange dich das nicht beunruhigt und du weiter postest, ist ja alles gut. lcheln Ich schaue mir die Pogramme jedenfalls immer wieder gerne an.

Ich wnschte, ich kme auch mal wieder zum Programmieren - im Moment komme ich, wenn ich sehr fleiig bin, auf 100 Zeilen im Monat ...
_________________
Deine Chance betrgt 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
Beitrge: 108
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
Beitrge: 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 schn!

Kleines Detail. Um unter Linux zu kompilieren, mssen wir "String.bi" durch "string.bi" ersetzen.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
UEZ



Anmeldungsdatum: 24.06.2016
Beitrge: 108
Wohnort: Opel Stadt

BeitragVerfasst am: 03.09.2020, 10:37    Titel: Sternenflug zu den Nebula Wolken Antworten mit Zitat



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


Anmeldungsdatum: 10.09.2004
Beitrge: 5934
Wohnort: Deutschland

BeitragVerfasst am: 03.09.2020, 20:36    Titel: Antworten mit Zitat

Hey cool, das sieht ja aus wie in einem Star Trek PC-Spiel, das ich vor 20 Jahren oder so ganz oft gespielt hab! grinsen
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
nemored



Anmeldungsdatum: 22.02.2007
Beitrge: 4336
Wohnort: ~/

BeitragVerfasst am: 03.09.2020, 21:27    Titel: Antworten mit Zitat

Ich wei nicht warum, aber ich liebe vorbeifliegende Sterne. lcheln
_________________
Deine Chance betrgt 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
Beitrge: 108
Wohnort: Opel Stadt

BeitragVerfasst am: 17.09.2020, 14:50    Titel: Around the Sphere build 2020-09-22 Antworten mit Zitat

@Sebastian und nemored: vielen Dank fr euer Feedback. lcheln

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. happy

#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)=!!2U!!Al!!Zl]#!!$!|#)!Z%d2!!,.A!l5lX!!H!!j!i#!!#$!.$!*!J(33!.ZB!!97[!!O!!!xls#!F#9%!l$T*!7)3!l1C!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!l8H!lMJj!!tJ!!9##!R$%!(,!l0(7!J:JJ!!Ql!!{l$#!Jm*$!p$7(!7)P.!Z17!!=tK!lTlo!!,#!X#8$!$"
Data "O(!t)|.!J2V8!@L!!X7r!!!4#!hmE$!$f(!!*.!73!9!lBBN!l[t!!J9#!v#P$!B%{(!d*N0!!49!JDlO!!aZw!!lA#!mZ$!_%(!*z0!4R:!!FP!ld!z!!F#!#g$!|%(!R,0!5:!G7R!!h||!!!L#!mq$!%5)!,L1!|6|;!lIdS!lkJ!!!KQ#!$$|$!.(M)!B.x1!l7N=!JKT!!o!!,mV#!7n$!N(d)!|.1!Z8=!!M.V!lrl!!5[#!H$$!l(y)!.0J2!J9x@!NZW!!v7!!=#c#!Vn$!()!l0v2!7:JA!lPX!ly!!FKh#!f$$!()!02!!;A!JR!Z!!}Z!!Mmm#!tn(%!;)3*!Z1H3!;tB!!TR[!l!!!Tr#!$6%!Z)K*!1t3!=FC!U|]!!|!![#x#!nC%!x)b*!J23!|@C!lW^!lJ!!dK}#!$N%!)"
Data "w*!2F4!lApD!JYJa!!!!km#!!oX%!(**!73r4!ZBBE!![tb!ll!!r#!5%e%!J**!t34!JCE!]c!!7!!y##!Foo%!h*1,!!4D5!7DlF!l_Be!l!!K#!T%z%!*I,!d4p5!!E;G!Jblf!!Z!!m#!do%!*_,!45!EG!!dg!l!!!#!r%%!7,u,!R5B6!FhH!e7i!!|!!##!o%!V,,!5n6!|G7I!lgdj!lJ!!K#!%%!t,,!B66!lHI!Jik!!ʿ!!m!$!o$(!,..!|6@7!ZIdJ!!k.m!ll$#!Ͱ)$!%4MJGt,ml|7N(4KNR0]nz7;;)SK1l8J)L!=(*qK]3Lo7E;*#1C!|H,KlR79p*}H;!l#oKcB)7(Lp0aLz:nn1nͯF3$|t=fqZ}VN2SK(94%fl,L.CTrt78ZH,l9]r8c4mM"
Data "Mt#R)joZ7hKRH~sD}p7$C%GH1t(~m_.=!lcJ6;$1l7[N4011%V%ίB;#5SO]uX~6!t$#i.@9x(;NBlU6toQJ!(OSuTs.!PZE,6K)v~i;!$mkl1P!pAO.#t(_%N@Oq0C!nJH.iS2t%Nl9p!3#Vl$|:!@!BK))$lH|*!%!.!xlE|*B#SxZ$d!NTV#E$,!l3l%)!5J1d%!9!$.!%!).#!~7;!p!VJ)7zh(#!%x#;JgmJlBl(;!Ft!d#l,d#4!39!@l4l)PX!l8f}|:!GJ3t%!Cl$(R0am$l5Z*!4Tmd!r!Gf#KJf$8!CJ3=K%J)7%XsH)l!X.T!j!G|,#Slt1Dl:|*#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*#@fl@!%F*mDJn(l;J=B*wl!l%nJ.;K@lGB2D%lF*R:t!h7B8;*mbZ37nAZ!R$kKT!pnZC$,p.!#!9ZMfn@!1;%!E7*Hm;$X$z!*7K*:R3lnHfO1!_d,J0=2d*XK3Z9lZ=*xQe.4n$UJi0K$!,Z,t$C*K_R1nm]J;!{!cZ6nm7A|*,xad1!mlqJR#Zm[R(ˢ0m$V(#JǬ1(7|7(*#05$%r|)!N(JZJ4h#:_#$Vmaht%7;$*w.#m7F3,]R1h#0ZSG!v!Qd3_o7F;*#mrm1!K79B*#cl3$a!(%X88*!:l7B*UVe!5$k)SLL,l*$lEt*j#Nd%.m6!62m#7nW!$t#*V.4d%@Z(R!FE81lI,r$%*nD*~#Yl0@#Ux#NKa75å~8,#P.$($lFBaY54H%JA,K1n5!alGp,"
Data "!#R)noZ33K(7.3%4;,K!#hp(2(,vy*n5m~|!!rne6$4J7!mk!5$@$!,N*y*6%ZG!%N.$7*o|4t.:n*t2%!(J2JZ6%i|=!qZ6|ίIV*u!X%n$!:|9l,,k6BoQ|WyMmp6%s%7.$J:4%b!tZfkl4$m$K$l%mpg6l$v;P,mKǽl!Kc#]Z)T7!#m6;%S!H1Bmiloyy.E!Vd%ǯG,3#pB##AƯy,=#0z5!]lEFdKf6JoF}y.!j4n_(i,![m*!uJ%8*NJ1!xmĿ,b#5!R!tlH,#h.6%|H,Kj6%1;Hx)[!L76%|GIG5%sQI,mG6%EZ(W!2jd5Zm7]F.bM172%lEV).M2@J3lQ$J73oZCd(F_6o|E,#i!oJAc6bw5$;@,mi3VnwBh"
Data "DeB)ZJ}cH$,73%Z(J,JI]nq.p*˰U4n7C,u4b(p|!!%J)m*6~%7=)#j6%l*7.*l@!59JBR)b#c|ˬohZU4!JdJ6mq%=#akJ6RBm7R,tfR3nEe˰VJ{D!D4ljl]tν%Z@V)u#il![%Wk.VVloZ@;*#]6hoZ|c0Jh$nt|7V)mk|6|nL(,Zkd4h$slAV,fXj,1p,6NM#fJ3nEBdUQd$$l#,*Df2Pn}JD,uy]!l|qJKd#U05o,Id,̯{8NlPCe%35f(Z%(QG)QmYZ5$8@.B!Rd6ou73!%!Cd*~#b4l%!I)l%J,|*#g.h#A$Cf8JBZ*#d5$if6@nkJ!Uk3l@FtilzI.6%7.|!*J$#N$|aq7QR6o*J!5.70LFrH;U}k2T*FRPiU#,%lER%"
Data "LJ|!$N#J4,r!0f!jmZsZ6$:|%)!Ji6n6|W){eR,~l2Z$!#JX.67JJ!@#6Fogl*!:!*!%m¿I,Bf!lmIp,WK6#Rl3l,J)6^.%vp8H%z4,#]Mο43!#!;d5%|B_$I(Z#lfD7V#G7=ǯ8_%|)mkR5m=$|!JJ=1ouAAtI%,~Z7B#A,.)$!*wl#.!lJW%El$R!R!TDFi!T9!TmZ8(R%t!b!Q!,!md!]mI,p#8#R!3)%#v5m#!(()~]t(V.|(R%;3!68e#N.%Tl,7($qκ59#J(%D)v3hF:;(F)ɰj3L#3J$!clJ75o7:!ża:5V#7*(W!Jg|6pn8e(!^kZ3p!8*_*mUJ{d#ÿE$Kd!a6RoEM!Q#j5#[;.dm6rF!l7_,j;M5p!*U7*7!lFJ$"
Data "#T!#nοE#99AR80m%tomnmnmkQBJ#1JK!9s%L7gL0d!RZ3Dn7;#%Kk4m:}$K:ed)(!(3B,Id=2p5!@,ɰI7#pH3(Pp!f$4p7J!LJZ|mn4O[!!WB3L1W*K3F!u%RJiG!aJO.3.n%#|mk|5#o#B%1Tl.|:,KGt)2(ZZS*Y.*3Jc|jL!Ri.*.(AJB,#TGKp22|)Z#:!#JI)aJCE(3%7AlkJ.Ml%gv9.=JP.8%ifLt!qE3eRS%mkl3!me!$mk5#;%3)ǰVIm|193{6#~m.!k7IN,l.(oUQF$1Z%n(!TZH,GQM71!Y!Vv)$K)Wn{JB#hm*5rL@0vg$7!qI,Em9:xZ*7YJ5i8IT)J~l_3!CB,mKRY2p(!(H02%į5;e(n*R1FqZ$N!Jf5#}vMx$"
Data "mkJ3!$1Z,MWJ$*9d!!g6t%L!Y)!;!,7V!m%)!S!Z6ox!0F}G8|mAZ#XT[^1L%[J#!xKkl4!d#x*KiB((lV70*ts(ol~=!!N45maA!x!C!#J$nS3x($.d1o7((Kwk1_lOO(!*#g|(QpR7G,j#8lw@%YU(!Q]M,~NK6xrbmXUɸ([#Kk!6Tmƨ%#sRPe|(l77}!m.ZAR6#x%mdB*F8Je*hlz|1rKR}$CYry;tR5g!RmK6.#Z7J4!ǣ4Ve@tH*21=%#$5_J%z#XRA;#[Xw,Ft7;z.(@!5%lt%mg|*d4J;,:l!RmHRNHtHd!Y$;Jh,ͯP(nDA(C!!f6.%.F*[(wXIRek7BJ(ys2,%l53!H#])fNTJCi$nW7mOM;$~kZ27[6m(x)KTdUi|p|Id,Y,D!|#ʯI("
Data "n1)t1nX!%mi,t6#,h,90FH8h!}lIR,h:mt#nnʯHKt!c7L#MR!bmk47Z6$)#cf.#E(!1mj|4LmO#(_9B!oίE#Gt,.7Yͦp@^Ot(!IFG%.|F0$$*$1Q4._JTW4lnlH,8#{abnίF#J!R(DX)V!$Kh5~#5g$N(mel*@!S!F,3#q8dJ:|#k#k75N#ohL!i,n!m9gSR!!17Ea,Jxb^.;$K0ls6#dQ%I|%0!](qI3,t.)̧%G#f#jZ1fl77,,D)G!%;.cJl_3rE79)*k_.n!t_˯:VgU$=5o!6!IKO5iy7,J7l,bUm(l_!b1(Q!)!Dl)7#F!)JvZ$zoDZ8%b#Z!4|8lnr~D!9$xd2l5}kJ3p0K!d*mYkxZ$hb69ois%u!Akd4JV8!h}em#$ͿC_#"
Data "Ht1lWO%HJ9IA#8t(hm[J1!$Ul(!;!tC(0![JN.,d]t)0*˰X|$B!qlHd,!s)#nr#p$i.F02pd@#5Bj%b7.l$lA(l7#Z!0!Ef|i7$l%_V)jd6h$M!0$;.(!2JbI!yDpl0I_7J{lww,j^H|])9C6H(gc4(}89.75%2($}lŤ(l7!$!w.E5%ueZo#j71Q77,e,T(fo|@{L))~,|~)!9,CR|0(0Z87!.n$r92HOjnj!QdI(@pl#bdzIt,Y.19nj!7(#h,5!gHJ%GR$.,|ol,%KcCnu[{)h2Xb6KA,je(xQp#7F,!3R4%JTvat^9yWsf#k!55mO(x4B.5K0sIV,}mP|%b5Z,#R#D!u|n@%4mJ#B$lEd$,:4%!=Jl.!7udKd2#4lJ!5mtb(ol,%"
Data "J9O5H%z.(I8$6z%}#~4N!f7FRj)0ls6(J:4dT5,drOFοH*kKG!IomIu=texZ[l6j$^%4(PhGml=ZZ6!e6|o{;!#KkZ37;%J)Kc!(l|$|6,!Tf#_$ltIKcclomgPa)D_^5;m58,lu#nͯC!$id5#s*#h(Kd(ttI=GRW|6Y,Q)!t4%QZ%ǦmjI8P!{I*jHj)JozJ!0h..Zg5p)B*!2Zmsh=xQtvT%elH(Kg.*U67=,z3B!fS6gJ!A_.r!oy!Tb%|%[!4#}=)pmZ,dmimfm2.AR#D,.n̪J($#kR01l!0(G.#!,rgZh:Jv4oJA@}QJg|l7IF.~0p}W7}(:L$BMoD(!kmk!4D5_,(#bc#;G4(0!ʯw3!4!(!{!4$JBJ*yK_J4]%Zh)"
Data "8gT6(%M!$RfZ!%9#|H_(I1l2%lF$νSJ{f|7AU5!VAa#bH(;2vfV#;tMFbYNWIi*]2,~%Jo7%#9=hl*;!4!*B$!D,$̯I(v.9!b!aJiM%EoWJi4!Je6n$yO,L#%8mh4B!!A3l*J(#xlA*7$]sH$]5!A$Z*wY6!%hZ5J!b^8d)z#k@.JLmZ!~H,E.mX!P^.I!Ȩm#2kmn,nm4ANA!į2l*l(#zJB!,Ln3QFl$#J0uog7M64u#nqe7v.Ƽj.6#(#%m5!!rB[v1Z4%lJr!v52;p1|9,01#FnMRrSl[6$o9J!Z!@,Z$!E!6J,yB4Z{{lHy.!1nl87)Wn)t%ί19~YUBe7^1b!Gj_Mr|eG_!$J6tΨ%QO}!LkR4;Tιtjw6_$Sh!3%"
Data "kZ0J!0J:Flwm0.|R!~!Q$DB1(n4I*xu(Z1%|2RYH!X|b#(7*DRfZ)nLR{ë$j^BD$1,7q:Ys%ldTJed7ql.8,m_BPp37:,CRe|1m:,lc:lVB#ͷP8Bl*$$,7ojL9!Pg4%!0VCK({a!d(tKd!Jc3!5)V*ǰP|k|j!It,2*]H!*!0:0!0kH,%,D!!!I_)jD.v$*lF!:#iZ{7AB,̰LRgu|~$X1$l,%|3_R#*$6Z$yqJZ!$Kɤ,1l#J6fkx$xSů5P*c2f6m=,c%Z%%i!=!ͯ2N;*=,;n8B!S!q*0]cVI}^#jn|PmJP6vn5J4!k!I_$(B(s:(3Tml$x}E.8(!99,KTJ{̾74*d!X2!*mkyD(*lk6o^|#.@RBHAnlJ"
Data "ưV$@8@Hle4!J%t̯;F#,T#B*no|B#Ddd0Ol4!RS!R#j$71J.#53%~!5A!L_3@A%!XjlRa!lGlxbXv~m%|K(!:;kl6($0O!#=jJ2D6s$%#uk|iH,}#9l9!V,1KS%Z0!!cj0H]b,lZJ#Y7Vl@IFJ;MJ6r%Y7$0jn{!;lɫb$8XfB(x$K!Z$j|0hizirb*em)NuIh*J7l%#IZ*Tź.|m%dl(Z!9l31%!BdpJ_i7~!It,T%tuoȿef!,**JZ4_Q_l]BAqoi7.#~lR.HRpSEg{%%SG%M!#.!Nlk!Au*km*J13#_JE)%XJ%J*l1Z,Ddy,Fl(ua6JJ0x#gJD2o!DBOLUsPHl1t!M$31%!;|QrnU.o~l0p#j6Bo;|J|!Atm6~oi.|#l[55@m*mu"
Data "zE7FmuGN%g,T$nΥHp)l5B(Z5nqi|6vnAJ$R!N!G:oX|G!Qmw6@$Nl*N$)KlYk%N)*Xh0@#CZ0.{KZdpPZmθJ6%jmδ,DmnmmqI_,D=t%lQJ:tj̰YJ{5,A,@|k1t8Yo7yh2$Ki|0*5N$(ǰeZ)1l0Z8x,ɰdR4]zx:|*}#Vd)h6!Rf#YB$ͧ2|C,#FYEL~y$r9[3IͯFNͰgd.bp(3(,mf.3v$7DhlKC7r]mI8J~aiRD!T%,}S0$A,Uz*J9l~QJEpgD.ak700dr!RJ6ol5l%7_iZCx)C6g2L$o!=ˤK,Y7JllJGJmbt4@l;!It$l*1oqtz){!7UPGeſD(,vk!5|#[;*#V3PH7=J(4Z.woV7G)!YlCm%lFkK=!tB!|Il*g#]6oOøq.,$NJuE*"
Data ".jR1V!:.tD.j!5x%QEr)0Z3oJC_)K#[WoZpZo@n%6Z%Ae,mhu$0sG*j6foX7g94F;X8E:|QJG9E˿E.Pt4{:X0piΣ$1$d.oZ6%cR6Tnw%i!4h5zm(J$N(t3l{a;*̰hd,cSi,_Is7(%|:X|Jc6X$rSb#aJ)@8Mp@Fl4kl3A$}y,y2mDn!b!ah|E!8ɬ(!0%sDǸ[T2R1@oJD(,mjJ5N%|B(k!$|%l5DthB4a7!2n.dJXd!=ͯE$DB,]!l90y,sKBV0p]fov4i|1H9}{,*#O._l2JrmW77l]*zb#[J6!lI)lBPa!4![lUd!=E7EN%DsB#mJSbȰTtVK@r!AKc#E6%lflGdK7Q79lb7Fouh1(b$K*_)tGfH:75Vf#nom5)"
Data "#idyX!H,NmGj%Z9tFt%J.o|~v!,EI%K|w1=Lk|#lN,(pZ!m_y.[JZ5@aJDkM[)h))(ic]M6nKl4m#tk25d5_3F,x#_!$l;!(]%6.$**Lp!JGy%J}*@,]!r#z~)Nl6zn=Z1Njh.h!!)(~*6$M|2K1J=3~EJ5FFR)J1o!:!*Kjp3#7|Kʮmhl*zlo!GppD.dB)XN%!1.*:k5N$:7Ju[#K!V#θhmF7q,!8|97,7jd2LmW.#Ld,%{*R~@!F!4K(EJ%~dx)!oQ%u,mK#5t0}#|$kLFx%rl(SJLZ5ɰAA_,#PJ{l7f!N)3#y%J3h!!uO6l$:wM!r#k!3r8O.JN9m;5{#@7l!8JK!k$j||;;))H,9nYJ]_6%_.J!ftj.J6,pl!lW)G!"
Data "QJ=,#VJ(hb8l.$|9d$FJh!r#|1|)$(|%!(K!3#rJ.t!lel:)OG%jE(t$JJ)lAA,#Y9*mlC*#=p{ȯG!)Fl6dn4l!_mhB6%Z3_SGR(J%lmlZ5($DJƾm3!ZExwQl$b$Z*V%cl%#!QJ1#JJyk%ǿ2N!6J9Z1~%%G3)o,X9f!L757(J3BPKpC!3%J,(mn2Z#lb!!!Y!7x%o*mw|0J*$!E%B5(#;#lSl2p$c!*)J,R(mo|3#LJOl0M8%J$lJ|)!YMb!]lA,mRZ)V$#jZ0_7N5FnIm*$P#i7h%m!lam%W}#l4Z]0($,N;Kƴm@ldJGN:!(zw%Z!*!Ef*l7%J2!5pY6)B,KYy94z*ocpc)%3t!=,#N(W{Ip(33vd#l!0|{K*l:)4Q|wKc5P#Ia#!"
Data "HJ$|m4;!g(Vp!ae9ǸJ.Fd(k$SV.4!blZv0*5N#Z%KiJ0LQk!H;,!tcxn9h%g@.6%sZUytðhJ.FgN%)xkyuV#lF73dL{.hjLN!d#s4kB4lI)ʮKg(_f*G!XgB1}IJWr(3,*~}{J12L$l2l4ozʬeZ6]n2#%#e)lh:;]rNK8ǦllFCNi=JU6loIB=.D!Y6B%SF:$#eJCp73xR%|.F7JZKc57#:B#L,!5!I;]*KMZ#n7b7(~79$Lol;!tfBR5%|!%_!ǯgB5dm~5*)!Jp23c7,a#|%L%9EPE_z3Nx1Z,#Sl:nZ]LHlw5r#yH)ʮKgl(xV(.G!:k5~!I;]*ưLl2(al2(~7#ʣQ%K.JBR5%J%_!lgB5_m~H*y!a4kB*=#,B,Z)ZmoplLOFO3rSJ1Z,"
Data "#Sl:nZ]LRG3!YybQKc57#:B#L.!5FkDN!.$mil.hj5;4nIm;Hpd!7It)1jnP*x%7=!3lF5poUMKvJD3B_AVjoJR7zJpJ!r#k.3rSJ1Z,#SlQnZ]LLJS4x5(#d$86|GJ$P[$p7lRYGcit!l(]%ʯ}*K!A0NK(%B)mXBk|(!4_S*!m!Ft$Id3!dn|H%Iv!%{Z^b*Vl[D8jlZI)Hb)%l.K[6.nw.q!A}0yGJCt,5m9,n.!YlF_,sluax!}(P,dI4veo|p)K*0NK$(KZJg]b!G,Pm*!mſEd$Id31!.#=jBpHn.4%%QI(V9$d%̿@B=5t%~M#I7q0}#.J}HR#fp!|#$Ǿmy=hZGZ,pJcx|)|;6jR.*5oiZxJ*0NK;$tLvj%n;!dJG,"
Data "I#*|!#lEB$P3D!$$n=6J7Jdr[U#M;#Kj72H31N,mARIE#nt63zt%,;Il;$dJ2R(9nSGp%{0v!DnZG!$D[]oBlFhaR#7*p%ɯ5IBi$Sh.a!lk3f6_#|%mid0V!)Z4Z,#7B9@l37(33%7$ll.!=!xJAd)LmO|.7$rl;.*B0]Z2p%8XaJ0,D|Qr0pt$x%cFMOR$Z7s%71!Vlx76,#d4t%nOG(({0!p$CY,BPzR%l3o%{K)CJ5obJu:.JO0HULN#J%K_!EglGx,0m(t!ŨʿDR*wm^J4p5}M.GTB%.!WJEd,mfd5B6JGl,sh5o˥IpSPlXZmJ;fO#KhB.lh:_5V,m;Z]E},3pzgR2T#7k(a!^#kM4:Q#7*#Y|m|$|37,:d!7Ix%OiK(o7J1!F|5v%Vy)U%!._!"
Data "$Ka|6l"

_________________
Gru,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beitrge der letzten Zeit anzeigen:   
Neues Thema erffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-bersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite Zurck  1, 2, 3, 4, 5
Seite 5 von 5

 
Gehe zu:  
Du kannst keine Beitrge in dieses Forum schreiben.
Du kannst auf Beitrge in diesem Forum nicht antworten.
Du kannst deine Beitrge in diesem Forum nicht bearbeiten.
Du kannst deine Beitrge in diesem Forum nicht lschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz