Here the result:
Code: Select all
'Coded by UEZ build 2019-03-18
'Inspired by https://codepen.io/HighFlyer/pen/zwPreM
#Include "fbgfx.bi"
#Include "file.bi"
#Include "Images.bi"
Using FB
'Original transformation code by Ben321 @ http://www.vbforums.com/showthread.php?700187-Code-for-a-four-point-transformation-of-an-image
#Define LZFX_H
#Ifndef NULL
# define NULL 0
#Endif
/' Hashtable size (2**LZFX_HLOG entries) '/
#Ifndef LZFX_HLOG
# define LZFX_HLOG 16
#Endif
/' Predefined errors. '/
#Define LZFX_ESIZE -1 /' Output buffer too small '/
#Define LZFX_ECORRUPT -2 /' Invalid Data For decompression '/
#Define LZFX_EARGS -3 /' Arguments invalid (NULL) '/
#Define LZFX_HSIZE (1 Shl (LZFX_HLOG))
/' Define the hash Function '/
#Define LZFX_FRST(p) (((p[0]) Shl 8) Or p[1])
#Define LZFX_NEXT(v,p) (((v) Shl 8) Or p[2])
#Define LZFX_IDX(h) ((( h Shr (3*8 - LZFX_HLOG)) - h ) And (LZFX_HSIZE - 1))
/' These cannot be changed, As they are related To the compressed Format. '/
#Define LZFX_MAX_LIT (1 Shl 5)
#Define LZFX_MAX_OFF (1 Shl 13)
#Define LZFX_MAX_REF ((1 Shl 8) + (1 Shl 3))
/' This macro To reproduce !a in c'/
#Define MY_NOT(value) Iif ( value = 0, 1, 0 )
Type DPOINT
x As Single
y As Single
End Type
Declare Sub AA2(x As Ushort, y As Ushort, w As Ushort, h As Ushort, iScale As Ubyte = 2)
Declare Sub CalculateBack(moveForce As Single = 30, rotateForce As Single = 20, acceleration As Single = 0.33)
Declare Sub CalculateFore(moveForce As Single = 40, rotateForce As Single = 20, acceleration As Single = 1.5)
Declare Function Transform(x As Short, y As Short, ImgWidth As Ushort, ImgHeight As Ushort, Points() As DPOINT) As DPOINT
Declare Function lzfx_getsize(Byval ibuf As Ubyte Ptr , Byval ilen As Ulong , Byref olen As Ulong) As Long
Declare Function lzfx_decompress(Byval ibuf As Ubyte Ptr , Byval ilen As Ulong , Byval obuf As Ubyte Ptr , Byref olen As Ulong) As Long
Declare Function Base128Decode(sString As String, Byref iBase128Len as ULong) As Ubyte Ptr
Declare Sub ExtractImageBack()
Declare Sub ExtractImageFore()
#Define PixelSet(_x, _y, colour) *CPtr(Ulong ptr, imgData_d + (_y) * pitch_d + (_x) Shl 2) = (colour)
#Define PixelGet(_x, _y) *CPtr(ulong ptr, imgData_d + (_y) * pitch_d + (_x) Shl 2)
#Define PixelGetBack(_x, _y) *Cptr(Ulong ptr, imgData_back + (_y) * pitch_back + (_x) Shl 2)
#Define PixelGetFore(_x, _y) *Cptr(Ulong ptr, imgData_fore + (_y) * pitch_fore + (_x) Shl 2)
#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)
Const as ubyte iLineWidth = 8, fRad = Acos(-1) / 180
Type ScreenData
As Integer w, h, depth, pitch
As Any Pointer row
End Type
Dim Shared As Integer ImgBWidth, ImgBHeight, ImgFWidth, ImgFHeight, scrw, scrh, scrw2, scrh2
ImgBWidth = 600
ImgBHeight = 343
ImgFWidth = 613
ImgFHeight = 400
scrw = 1500
scrh = 850
scrw2 = scrw \ 2
scrh2 = scrh \ 2
Dim Shared As Ushort scrw1, scrh1
scrw1 = scrw - 1
scrh1 = scrh - 1
Screenres (scrw, scrh, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_HIGH_PRIORITY Or GFX_NO_SWITCH)
Screenset 1, 0
Windowtitle("Layered Parallax Effect v0.70 by UEZ")
Dim As Image Ptr Img_Back = Imagecreate(ImgBWidth, ImgBHeight, 32), img_Fore = Imagecreate(ImgFWidth, ImgFHeight, 32), Img_Dest = Imagecreate(scrw, scrh, 32)
If Fileexists("Sky.bmp") = 0 Then ExtractImageBack()
If Fileexists("Airplane.bmp") = 0 Then ExtractImageFore()
Bload("Sky.bmp", Img_Back)
Bload("Airplane.bmp", img_Fore)
Dim Shared As Integer pitch_back, pitch_fore, pitch_d
Dim Shared As Any Ptr imgData_back, imgData_fore, imgData_d
Imageinfo(Img_Back, , , , pitch_back, imgData_back)
Imageinfo(img_Fore, , , , pitch_fore, imgData_fore)
Imageinfo(Img_Dest, , , , pitch_d, imgData_d)
Randomize , 2
Dim Shared As DPOINT PointsB(3),PointsF(3), PointsBack(3), PointsFore(3)
PointsB(0).x = (scrw - ImgBWidth) \ 2 : PointsB(0).y = (scrh - ImgBHeight) \ 2 'left upper corner
PointsB(1).x = PointsB(0).x + ImgBWidth : PointsB(1).y = PointsB(0).y 'right upper corner
PointsB(2).x = PointsB(0).x : PointsB(2).y = PointsB(0).y + ImgBHeight 'left lower corner
PointsB(3).x = PointsB(1).x : PointsB(3).y = PointsB(0).y + ImgBHeight 'right lower corner
PointsF(0).x = (scrw - ImgFWidth) \ 2 + 30 : PointsF(0).y = (scrh - ImgFHeight) \ 2 - 50 'left upper corner
PointsF(1).x = PointsF(0).x + ImgFWidth : PointsF(1).y = PointsF(0).y 'right upper corner
PointsF(2).x = PointsF(0).x : PointsF(2).y = PointsF(0).y + ImgFHeight 'left lower corner
PointsF(3).x = PointsF(1).x : PointsF(3).y = PointsF(0).y + ImgFHeight 'right lower corner
Dim Shared As Ushort x, y, xx, yy
Dim Shared As DPOINT Trapezoid, oTrapezoid
Dim Shared As Ulong iCol
Dim Shared As Integer mx, my
Dim As Ushort xp1 = (scrw - ImgFWidth) \ 2 - 35, yp1 = (scrh - ImgFHeight) \ 2 - 20, xp2 = ImgFWidth + 120, yp2 = ImgFHeight + 35
Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim evt As EVENT
Dim As Double fTimer = Timer
Do
Line Img_Dest, (0, 0) - (scrw1, scrh1), Rgba(&h40, &h40, &h40, 255), BF
CalculateBack()
CalculateFore()
AA2(xp1, yp1, xp2, yp2)
Put (0, 0), Img_Dest, Pset
Draw String(1, 1), iFPS_current & " fps", Rgb(&hF0, &hF0, &hF0)
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
Flip
Sleep (10, 1)
If ScreenEvent(@evt) Then
Select Case evt.type
Case EVENT_WINDOW_CLOSE
Exit Do
End Select
EndIf
Loop Until Inkey = Chr(27)
Imagedestroy(Img_Back)
Imagedestroy(img_Fore)
Imagedestroy(Img_Dest)
Sub AA2(x As Ushort, y As Ushort, w As Ushort, h As Ushort, iScale As Ubyte = 2)
Dim As Ulong resultRed, resultGreen, resultBlue, col, gridSize = iScale * iScale
For iY As Ushort = y To (y + h - iScale)
For iX As Ushort = x To (x + w - iScale)
resultRed = 0: resultGreen = 0: resultBlue = 0
For xx As Ubyte = 0 To iScale - 1
For yy As Ubyte = 0 To iScale - 1
col = PixelGet(iX + xx, iY + yy)
resultRed += Red(col)
resultGreen += Green(col)
resultBlue += Blue(col)
Next
Next
PixelSet(iX, iY, RGB(resultRed / gridSize, resultGreen / gridSize, resultBlue / gridSize))
Next
Next
End Sub
Sub CalculateBack(moveForce As Single = 30, rotateForce As Single = 20, acceleration As Single = 0.33)
Dim As Single moveX, moveY, rotateX, rotateY, fRotX, fRotY
Getmouse mx, my
Static As Integer mxo, myo
If mx < 0 Or my < 0 then
mx = mxo
my = myo
Else
mxo = mx
myo = my
End If
moveX = (my - scrh2) / scrh2 * -moveForce
moveY = (mx - scrw2) / scrw2 * -moveForce
Dim As Single rotateForce2 = rotateForce * 2
rotateX = -((mx / scrw * rotateForce2) - rotateForce) * fRad
rotateY = ((my / scrh * rotateForce2) - rotateForce) * fRad
fRotX = Cos(rotateX)
fRotY = Cos(rotateY)
Dim As Single f1 = moveX * fRotX, f2 = moveY * acceleration, f3 = moveY * fRotY, f4 = moveX * acceleration
PointsBack(0).x = PointsB(0).x + f1 - f2
PointsBack(0).y = PointsB(0).y + f3 - f4
PointsBack(1).x = PointsB(1).x - f1 - f2
PointsBack(1).y = PointsB(1).y - f3 - f4
PointsBack(2).x = PointsB(2).x - f1 - f2
PointsBack(2).y = PointsB(2).y - f3 - f4
PointsBack(3).x = PointsB(3).x + f1 - f2
PointsBack(3).y = PointsB(3).y + f3 - f4
For y As Ushort = 0 To ImgBHeight - 1
For x As Ushort = 0 To ImgBWidth - 1
Trapezoid = Transform(x, y, ImgBWidth, ImgBHeight, PointsBack())
Trapezoid.x = Iif(Trapezoid.x < 1, 1, Iif(Trapezoid.x > scrw1, scrw1, Trapezoid.x))
Trapezoid.y = Iif(Trapezoid.y < 1, 1, Iif(Trapezoid.y > scrh1, scrh1, Trapezoid.y))
xx = Trapezoid.x
yy = Trapezoid.y
iCol = PixelGetBack(x, y)
If scrw > ImgBWidth Or scrh > ImgBHeight Then
PixelSet(xx - 1, yy - 1, iCol)
PixelSet(xx, yy - 1, iCol)
PixelSet(xx + 1, yy - 1, iCol)
PixelSet(xx - 1, yy, iCol)
'PixelSet(xx + 1, yy, iCol)
'PixelSet(xx - 1, yy + 1, iCol)
'PixelSet(xx, yy + 1, iCol)
'PixelSet(xx + 1, yy + 1, iCol)
End If
PixelSet(xx, yy, iCol)
Next x
Next y
End Sub
Sub CalculateFore(moveForce As Single = 40, rotateForce As Single = 20, acceleration As Single = 1.5)
Dim As Single moveX, moveY, rotateX, rotateY, fRotX, fRotY
Getmouse mx, my
Static As Integer mxo, myo
If mx < 0 Or my < 0 then
mx = mxo
my = myo
Else
mxo = mx
myo = my
End If
moveX = (my - scrh2) / scrh2 * -moveForce
moveY = (mx - scrw2) / scrw2 * -moveForce
Dim As Single rotateForce2 = rotateForce * 2
rotateX = -((mx / scrw * rotateForce2) - rotateForce) * fRad
rotateY = ((my / scrh * rotateForce2) - rotateForce) * fRad
fRotX = Cos(rotateX)
fRotY = Cos(rotateY)
Dim As Single f1 = moveX * fRotX, f2 = moveY * acceleration, f3 = moveY * fRotY, f4 = moveX * acceleration
PointsFore(0).x = PointsF(0).x + f1 - f2
PointsFore(0).y = PointsF(0).y + f3 - f4
PointsFore(1).x = PointsF(1).x - f1 - f2
PointsFore(1).y = PointsF(1).y - f3 - f4
PointsFore(2).x = PointsF(2).x - f1 - f2
PointsFore(2).y = PointsF(2).y - f3 - f4
PointsFore(3).x = PointsF(3).x + f1 - f2
PointsFore(3).y = PointsF(3).y + f3 - f4
For y As Ushort = 0 To ImgFHeight - 1
For x As Ushort = 0 To ImgFWidth - 1
iCol = PixelGetFore(x, y)
If iCol = &hFFFF0000 Then Continue For 'ignore red color as it is the transparent color and skip to next color
Trapezoid = Transform(x, y, ImgFWidth, ImgFHeight, PointsFore())
Trapezoid.x = Iif(Trapezoid.x < 1, 1, Iif(Trapezoid.x > scrw1, scrw1, Trapezoid.x))
Trapezoid.y = Iif(Trapezoid.y < 1, 1, Iif(Trapezoid.y > scrh1, scrh1, Trapezoid.y))
xx = Trapezoid.x
yy = Trapezoid.y
If scrw > ImgFWidth Or scrh > ImgFHeight Then
PixelSet(xx - 1, yy - 1, iCol)
PixelSet(xx, yy - 1, iCol)
PixelSet(xx + 1, yy - 1, iCol)
PixelSet(xx - 1, yy, iCol)
'PixelSet(xx + 1, yy, iCol)
'PixelSet(xx - 1, yy + 1, iCol)
'PixelSet(xx, yy + 1, iCol)
'PixelSet(xx + 1, yy + 1, iCol)
End If
PixelSet(xx, yy, iCol)
Next x
Next y
End Sub
Function Transform(x As Short, y As Short, ImgWidth As Ushort, ImgHeight As Ushort, Points() As DPOINT) As DPOINT
Dim As Ushort w = (ImgWidth - 1), h = (ImgHeight - 1)
Dim As Single a, b, c, d = w * h
Dim As DPOINT Result
'x
b = (Points(1).x - Points(0).x) / w
c = (Points(2).x - Points(0).x) / h
a = (Points(3).x - h * c - Points(0).x - w * b) / d
Result.x = x * (y * a + b) + y * c + Points(0).x
'y
b = (Points(2).y - Points(0).y) / h
c = (Points(1).y - Points(0).y) / w
a = (Points(3).y - h * b - w * c - Points(0).y) / d
Result.y = y * (x * a + b) + x * c + Points(0).y
Return Result
End Function
Sub ExtractImageBack()
Dim As Ulong iLines, iCompression, iFileSize, iCompressedSize
Dim As String sBaseType, sBase128, aB128(1)
Restore __Label1:
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 Ulong l
Dim As Ubyte Ptr aBinary = Base128Decode(sBase128, l)
? Len(sBase128)
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
End If
Dim As Integer hFile
hFile = Freefile()
Open "Sky.bmp" For Binary Access Write As #hFile
If iCompression Then
Dim as Ubyte Ptr aBinaryC = Allocate(iFileSize)
lzfx_decompress(aBinary, iCompressedSize, aBinaryC, iFileSize)
Put #hFile, 0, aBinaryC[0], iFileSize
Deallocate(aBinaryC)
Else
Put #hFile, 0, aBinary[0], iFileSize
Endif
Close #hFile
aBinary = 0
End Sub
Sub ExtractImageFore()
Dim As Ulong 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 Ulong 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
End If
Dim As Integer hFile
hFile = Freefile()
Open "Airplane.bmp" For Binary Access Write As #hFile
If iCompression Then
Dim as Ubyte Ptr aBinaryC = Allocate(iFileSize)
lzfx_decompress(aBinary, iCompressedSize, aBinaryC, iFileSize)
Put #hFile, 0, aBinaryC[0], iFileSize
Deallocate(aBinaryC)
Else
Put #hFile, 0, aBinary[0], iFileSize
Endif
Close #hFile
aBinary = 0
End Sub
Private Function lzfx_decompress(Byval ibuf As Ubyte Ptr , Byval ilen As Ulong , Byval obuf As Ubyte Ptr , Byref olen As Ulong) As Long
Dim As Ubyte Ptr ip = ibuf
Dim As Ubyte Ptr in_end = ip + ilen
Dim As Ubyte Ptr op = obuf
Dim As Ubyte Ptr out_end = op + olen
Dim As Ulong remain_len = 0
Dim As Long rc
If(olen = 0) Then Return LZFX_EARGS
If(ibuf = NULL) Then
If(ilen <> 0) Then Return LZFX_EARGS
olen = 0
Return 0
End If
If(obuf = NULL)Then
If(olen <> 0) Then Return LZFX_EARGS
Return lzfx_getsize(ibuf, ilen, olen)
End If
#Macro my_guess() 'used by lzfx_decompress (better than Gosub)
rc = lzfx_getsize(ip, ilen - (ip-ibuf), remain_len)
If rc>=0 Then olen = remain_len + (op - obuf)
Return rc
#Endmacro
Do
Dim As Ulong ctrl = *ip
ip+=1
/' Format 000LLLLL: a literal Byte String follows, of length L+1 '/
If(ctrl < (1 Shl 5)) Then
ctrl+=1
If(op + ctrl > out_end) Then
ip -=1 /' Rewind To control Byte '/
my_guess()
End If
If(ip + ctrl > in_end) Then Return LZFX_ECORRUPT
Do
*op= *ip : op+=1 : ip+=1
ctrl -= 1
Loop While(ctrl <> 0)
/' Format #1 [LLLooooo oooooooo]: backref of length L+1+2
^^^^^ ^^^^^^^^
A B
#2 [111ooooo LLLLLLLL oooooooo] backref of length L+7+2
^^^^^ ^^^^^^^^
A B
In both cases the location of the backref Is computed from the
remaining part of the Data As follows:
location = op - A*256 - B - 1
'/
Else
Dim As Ulong len1 = (ctrl Shr 5)
Dim As Ubyte Ptr ref = op - ((ctrl And &h1f) Shl 8) -1
If(len1=7) Then
len1 += *ip
ip+=1 /' i.e. Format #2 '/
End If
len1 += 2 /' Len Is Now #octets '/
If(op + len1 > out_end)Then
ip -= Iif(len1 >= 9, 2 , 1) /' Rewind To control Byte '/
my_guess()
End If
If(ip >= in_end) Then Return LZFX_ECORRUPT
ref -= *ip : ip += 1
If(ref < obuf) Then Return LZFX_ECORRUPT
Do
*op = *ref : op+= 1 : ref+=1
len1 -=1
Loop While (len1 <> 0 )
End If
Loop While (ip < in_end)
olen = op - obuf
Return 0
End Function
/'Get uncompressed size from compressed ibuf buffer '/
Private Function lzfx_getsize(Byval ibuf As Ubyte Ptr , Byval ilen As Ulong , Byref olen As Ulong ) As Long
If ( ibuf = NULL Or ilen = 0) Then
olen = 0
Return LZFX_EARGS
End If
Dim As Ubyte Ptr ip = ibuf
Dim As Ubyte Ptr in_end = ip + ilen
Dim As Ulong tot_len = 0
While(ip < in_end)
Dim As Ulong ctrl = *ip
ip += 1
If (ctrl < (1 Shl 5)) Then
ctrl += 1
If (ip + ctrl > in_end) Then Return LZFX_ECORRUPT
tot_len += ctrl
ip += ctrl
Else
Dim As Ulong len1 = (ctrl Shr 5)
If(len1=7) Then /' i.e. Format #2 '/
len1 += *ip
ip += 1
End If
len1 += 2 /' Len Is Now #octets '/
If (ip >= in_end) Then Return LZFX_ECORRUPT
ip+=1 /' skip the ref Byte '/
tot_len += len1
End If
Wend
olen = tot_len
Return 0
End Function
Function Base128Decode(sString As String, Byref iBase128Len as ULong) As Ubyte Ptr
If sString = "" Then
Error 1
Return 0
EndIf
Dim As String sB128, sDecoded
sB128 = "!#$%()*,.0123456789:;=@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎ"
Dim i As ULong
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
You will need "Images.bi" which is 241 kb and too large to post it here. You can download it here: <click me>. Images.bi was generated by my FB File2Bas Code Generator.
This version should be running on Linux, too but I cannot test it.
Thanks to marpon for the LZFX codec.
v0.70: added pseudo anti-aliasing (more a blur function).