If you want to use the predefined image settings than you need first the image. Copy / paste the code to your editor and run it. It will convert the JPG to BMP format and save it to disk (Windows only!). Put it to the same folder as Rutt_Etra_Izer_FX.bas below.
ExtractTestImage.bas
Otherwise you must adjust the settings within the code to run it properly.
Rutt_Etra_Izer_FX.bas
Code: Select all
'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
To rotate the image hold lmb pressed and move your mouse. Mouse wheel will scale and rmb will reset the rotation.