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

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



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

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



Um das Test Bild zu erstellen, bitten den Code hier ExtractTestImage.bas in den vorher gleichen Ordner erstellen, kompilieren und ausführen. Es sollte nun das Test Bild "Panda_800x800.bmp" erstellt worden sein (NUR FÜR WINDOWS!)!


Jetzt Rutt_Etra_Izer_FX.bas starten.
Code:

'Coded by UEZ v0.7 build 2019-04-24
'Thanks to eukalyptus for the fast ASM sin / cos functions and vdecampo for the DrawAALine function

#Include "fbgfx.bi"

Using FB

Declare Function _ASM_Sin6th(fX As Double) As Double
Declare Function _ASM_Cos6th(fX As Double) As Double
Declare Sub Translate3Dto2D(fXin As Single, fYin As Single, fZin As Single, _            
               fRotX As Single, fRotY As Single, fRotZ As Single, _
               Byref xout As Single, Byref yout As Single, _
               fCenterX  As Single = 0, fCenterY As Single = 0.0, _
               fScale As Single = 1.0, fZDeepCorrection As Single = 1000.0)
Declare Function ipart(x As Single) As Integer
Declare Function round(x As Single) As Integer
Declare Function fpart(x As Single) As Single
Declare Function rfpart(x As Single) As Single
Declare Sub Plot(x As Short, y As Short, baseclr As Ulong, c As Single)
Declare Sub DrawAALine(x0 As Single,y0 As Single,x1 As Single,y1 As Single, clr As Ulong)

#Define _GetPixel(_x, _y)      *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2)
#Define _SetPixel(_x, _y, iCol)   *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (iCol)
#Define _Red(iCol)            ((iCol And &hFF0000) Shr 16)      
#Define _Green(iCol)         ((iCol And &h00FF00) Shr 8)      
#Define _Blue(iCol)            ((iCol And &h0000FF))      
#Define _Max(a, b)            (Iif(a > b, a, b))            
#Define _Min(a, b)            (Iif(a < b, a, b))   

            
Dim As Any Ptr pBitmap, pImage
Dim Shared As Integer pitch, pitch2
Dim Shared As Any Pointer imgData, imgData2
Dim Shared As Ushort sw = 1200, sh = 800, bAA = 0
Dim As UShort iw, ih, wh, hh, swh = sw \ 2, shh = sh \ 2, cx, cy, iStepX = 4, iStepY = 4, x, y
Dim As String sImage = "Panda_800x800.bmp"

iw = 800
ih = 800

Screenres sw, sh, 32, 2
Screenset 1, 0

Windowtitle "Rutt Etra Izer Effect v0.7 by UEZ"

pBitmap = Imagecreate(iw, ih, 0, 32)
Bload sImage, pBitmap
Imageinfo(pBitmap, , , , pitch, imgData)
pImage = Imagecreate(sw, sh, 0, 32)
Imageinfo(pImage, , , , pitch2, imgData2)

cx = (sw - iw) \ 2
cy = (sh - ih) \ 2


Type vec4
   As Single x, y, z
   As Ulong col
End Type

Dim As Ushort iUBY = ih \ iStepY + 1, iUBX = iw \ iStepX + 1, xx = 0, yy = 0

wh = iw \ 2
hh = ih \ 2
Dim As vec4 aPixels(iUBY, iUBX)
For y = 0 To ih - 1 Step iStepY
   For x = 0 To iw - 1 Step iStepX
      aPixels(yy, xx).x = x - wh
      aPixels(yy, xx).y = y - hh
      aPixels(yy, xx).col = _GetPixel(x, y)
      aPixels(yy, xx).z = 255 - (_Red(aPixels(yy, xx).col) + _Green(aPixels(yy, xx).col) + _Blue(aPixels(yy, xx).col)) / 6
      xx += 1
   Next
   yy += 1
   xx = 0
Next

Dim As Single px1, py1, px2, py2, fPi = Acos(-1), fSpeed = fPi / (8 * 180), fAngle = 0, f2Pi = 2 * fPi, xr, yr, xrot, yrot, dx = cx + wh, dy = cy + hh, fScale = 1.0, s
Dim As Integer mx, my, mb, mw, mc, mwo, mxo, myo
Dim As Ushort iFPS = 0, iFPS_current = 0

Dim As Double fTimer = Timer


Do
   Line pImage, (0, 0) - (sw - 1, sh - 1), Rgba(0, 0, 0, 200), BF 'clear image
   
   'helper lines
   'Line pImage, (0, shh) - (sw, shh), Rgba(64, 64, 64, 192)
   'Line pImage, (swh, 0) - (swh, sh), Rgba(64, 64, 64, 192)
   
   Getmouse mx, my, mw, mb, mc
   
   If mb = 1 And (mx <> mxo Or my <> myo) Then
      xrot = -(mx / sw) * f2Pi + fPi
      yrot = (my / sh) * f2Pi + fPi
      mxo = mx
      myo = my
   Elseif mb = 2 Then
      xrot = 0
      yrot = 0
   End If
   
   If mc = 0 Then mwo = mw
   s = _Min(_Max(fScale + Iif(mc = -1, mwo, mw) / 20, 0.1), 4) 'scale factor
      
   For y = 0 To Ubound(aPixels) - 1
      For x = 1 To Ubound(aPixels, 2) - 2
         Translate3Dto2D(aPixels(y, x - 1).x, aPixels(y, x - 1).y, aPixels(y, x - 1).z,    yrot, -xrot, 0, px1, py1, dx, dy, s)
         Translate3Dto2D(aPixels(y, x).x,     aPixels(y, x).y,      aPixels(y, x).z,       yrot, -xrot, 0, px2, py2, dx, dy, s)
         If bAA Then
            DrawAALine(px1, py1, px2, py2, aPixels(y, x).col)
         Else
            Line pImage, (px1, py1)-(px2, py2),  aPixels(y, x).col
         End If
      Next
   Next
   
   Put (0, 0), pImage, Pset
   Draw String(1, 1), iFPS_current & " fps", Rgb(&h00, &hFF, &h00)
   Flip

   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   
   Sleep(10, 1)
Loop Until Inkey = Chr(27)

Imagedestroy pBitmap
Imagedestroy pImage


Sub Translate3Dto2D(fXin As Single, fYin As Single, fZin As Single, _            
               fRotX As Single, fRotY As Single, fRotZ As Single, _
               Byref xout As Single, Byref yout As Single, _
               fCenterX  As Single = 0, fCenterY As Single = 0, _
               fScale As Single = 1.0, fZDeepCorrection As Single = 1000.0)
                   
   Dim As Single fCosRotX, fSinRotX, fCosRotY, fSinRotY, fCosRotZ, fSinRotZ, f1, f2, f3, f4, f5, f6, fXPos, fYPos, fZPos, fZPerspCorrection

   fCosRotX = _ASM_Cos6th(fRotX)
   fSinRotX = _ASM_Sin6th(fRotX)
   fCosRotY = _ASM_Cos6th(fRotY)
   fSinRotY = _ASM_Sin6th(fRotY)
   fCosRotZ = _ASM_Cos6th(fRotZ)
   fSinRotZ = _ASM_Sin6th(fRotZ)

   f1 = fCosRotY * fXin
   f2 = fSinRotX * fYin
   f3 = fCosRotX * fZin
   f4 = fCosRotX * fYin
   f5 = fSinRotX * fZin
   f6 = f1 - fSinRotY * (f2 + f3)
   fXPos = (fCosRotZ * f6 - fSinRotZ * (f4 - f5)) * fScale
   fYPos = (fSinRotZ * f6 + fCosRotZ * (f4 - f5)) * fScale
   fZPos = (fSinRotY * fXin + fCosRotY * (f2 + f3)) * fScale
   
   fZPerspCorrection = 1 / (fZPos / fZDeepCorrection + 1)
   
   xout = fXPos * fZPerspCorrection + fCenterX
   yout = fYPos * fZPerspCorrection + fCenterY
   'fZ = fZPos
End Sub

Function _ASM_Sin6th(fX As Double) As Double
   'By Eukalyptus
   Asm
      jmp 0f
      1: .Double 683565275.57643158
      2: .Double -0.0000000061763971109087229
      3: .Double 6755399441055744.0
       
      0:
         movq xmm0, [fX]
         mulsd xmm0, [1b]
         addsd xmm0, [3b]
         movd ebx, xmm0

         lea  eax, [ebx*2+0x80000000]
         sar  eax, 2
         imul eax
         sar  ebx, 31
         lea  eax, [edx*2-0x70000000]
         lea  ecx, [edx*8+edx-0x24000000]
         imul edx
         Xor  ecx, ebx
         lea  eax, [edx*8+edx+0x44A00000]
         imul ecx

         cvtsi2sd xmm0, edx
         mulsd xmm0, [2b]
         movq [Function], xmm0
   End Asm
End Function

Function _ASM_Cos6th(fX As Double) As Double
   'By Eukalyptus
   Asm
      jmp 0f
      1: .Double 683565275.57643158
      2: .Double -0.0000000061763971109087229
      3: .Double 6755399441055744.0

      0:
         movq xmm0, [fX]
         mulsd xmm0, [1b]
         addsd xmm0, [3b]
         movd ebx, xmm0

         Add ebx, 0x40000000 'SinToCos

         lea  eax, [ebx*2+0x80000000]
         sar  eax, 2
         imul eax
         sar  ebx, 31
         lea  eax, [edx*2-0x70000000]
         lea  ecx, [edx*8+edx-0x24000000]
         imul edx
         Xor  ecx, ebx
         lea  eax, [edx*8+edx+0x44A00000]
         imul ecx

         cvtsi2sd xmm0, edx
         mulsd xmm0, [2b]
         movq [Function], xmm0
   End Asm
End Function


/'
https://www.freebasic.net/forum/viewtopic.php?t=24443#p216462

Xiaolin Wu's line algorithm

An algorithm for line antialiasing,
which was presented in the article
an efficient antialiasing technique
in the July 1991 issue of Computer
Graphics, as well as in the article
Fast Antialiasing in the June 1992
issue of Dr. Dobb's Journal.
'/

'// Integer part of x
Function ipart(x As Single) As Integer
    Return Int(x)
End Function

Function round(x As Single) As Integer
    Return ipart(x + 0.5)
End Function

' fractional part of x
Function fpart(x As Single) As Single
    If x < 0 Then Return 1 - (x - Fix(x))
    Return x - Fix(x)
End Function

Function rfpart(x As Single) As Single
    Return 1 - fpart(x)
End Function

Sub Plot(x As Short, y As Short, baseclr As Ulong, c As Single)
   baseclr = (_Red(baseclr) * c) Shl 16 Or (_Green(baseclr) * c) Shl 8 Or (_Blue(baseclr) * c) Shl 0
    *Cptr(Ulong Ptr, imgData2 + (Iif(y < 0, 0, Iif(y > sh - 1, sh - 1, y))) * pitch2 + (Iif(x < 0, 0, Iif(x > sw - 1, sw - 1, x))) Shl 2) = baseclr
End Sub
   
Sub DrawAALine(x0 As Single,y0 As Single,x1 As Single,y1 As Single, clr As Ulong)
   Dim As Integer steep = Abs(y1 - y0) > Abs(x1 - x0)
   Dim As Single dx,dy,gradient,xend,yend,xgap,xpxl1,ypxl1,xpxl2,ypxl2,intery
   
    If steep Then
        Swap x0, y0
        Swap x1, y1
    End If
   
    If x0 > x1 Then
        Swap x0, x1
        Swap y0, y1
    End If
   
    dx = x1 - x0
    dy = y1 - y0
    gradient = dy / dx
   
    ' handle first endpoint
    xend = round(x0)
    yend = y0 + gradient * (xend - x0)
    xgap = rfpart(x0 + 0.5)
   
    xpxl1 = xend ' This will be used in the main Loop
    ypxl1 = ipart(yend)
   
    If steep Then
        plot(ypxl1,   xpxl1, clr, rfpart(yend) * xgap)
        plot(ypxl1+1, xpxl1, clr,  fpart(yend) * xgap)
    Else
        plot(xpxl1, ypxl1  , clr, rfpart(yend) * xgap)
        plot(xpxl1, ypxl1+1, clr,  fpart(yend) * xgap)
    End If
    intery = yend + gradient ' first y-intersection For the main Loop
   
    ' handle Second endpoint
    xend = round(x1)
    yend = y1 + gradient * (xend - x1)
    xgap = fpart(x1 + 0.5)
   
    xpxl2 = xend 'This will be used in the main Loop
    ypxl2 = ipart(yend)
   
    If steep Then
        plot(ypxl2  , xpxl2, clr, rfpart(yend) * xgap)
        plot(ypxl2+1, xpxl2, clr,  fpart(yend) * xgap)
    Else
        plot(xpxl2, ypxl2, clr,  rfpart(yend) * xgap)
        plot(xpxl2, ypxl2+1, clr, fpart(yend) * xgap)
    End If
   
    ' Line Loop
    For x As Integer = xpxl1 + 1 To xpxl2 - 1
      If steep Then
          plot(ipart(intery)  , x, clr, rfpart(intery))
          plot(ipart(intery)+1, x, clr,  fpart(intery))
      Else
          plot(x, ipart(intery), clr,  rfpart(intery))
          plot(x, ipart(intery)+1, clr, fpart(intery))
      End If
      intery = intery + gradient
    Next
   
End Sub


Die linke Maustaste gedrückt halten und die Maus bewegen, um das Objekt zu drehen. Das Mausrad dient zum Zoomen.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite Zurück  1, 2, 3, 4, 5
Seite 5 von 5

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz