Layered Parallax Effect v0.70

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Layered Parallax Effect v0.70

Post by UEZ »

I was inspired by this web version and tried to convert it to FB. It doesn't run as smooth as the web version...

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
Image

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).
Last edited by UEZ on Mar 19, 2019 9:20, edited 7 times in total.
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: Layered Parallax Effect

Post by jj2007 »

Very cute!
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Layered Parallax Effect

Post by srvaldez »

compiles and runs ok on my Mac :-)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Layered Parallax Effect

Post by dodicat »

Hi UEZ.
my 7-zip cannot open the .rar file, although it should.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Layered Parallax Effect

Post by UEZ »

dodicat wrote:Hi UEZ.
my 7-zip cannot open the .rar file, although it should.
I've tested the RAR v5 file with 7-Zip v19.00 and it works properly. Maybe you have to update 7-Zip to latest version.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Layered Parallax Effect

Post by badidea »

Yep, runs fine on linux and no trouble with the .rar file :-p

On linux, changing Sleep (10, 1) to Sleep (1, 1) brings fps from 25 to 30 here.

There seems room for speed improvement in the Transform() function (which is called often). 'w', 'h' and 'd' are calculated many times, but the result be will the same every time I think. Also, if 'w', 'h' and 'd' are often the same, multiplication with a precalculated (e.g. '1/w') is probably faster then division by 'w'.

There seems to be some small error with the plane image. The wing tip shows some artifacts, especially visible at the start of the demo. Also, the generated 'Airplane.bmp' is corrupt according to my computer.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Layered Parallax Effect

Post by UEZ »

I have changed the archive format to ZIP.

I've update the code to v0.6 with some small code optimization which increases the FPS a little bit.

I have deliberately avoided that the code only works with Windows, but the disadvantage for me is that I can not use directly transparent images (PNG) with on-board resources, so I had to convert the image to BMP and the background red to subsequently to create the transparency.

Anti aliasing is not implemented yet. If you have a fast code, please share.
Pim Scheffers
Posts: 54
Joined: Jun 29, 2014 17:15

Re: Layered Parallax Effect

Post by Pim Scheffers »

Very nicely done!
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Layered Parallax Effect v0.6

Post by counting_pine »

Nice, although is it just me, or is there something off about the way the background image is transformed?

Also, as with most mouse interaction demos, this is one of those cases where it would be great to allow the user to exit with the 'X' button on the title bar. (For many user setups, Esc is the furthest key away from the mouse.)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Layered Parallax Effect v0.6

Post by dodicat »

Thanks UEZ, the .zip is good.
My computer has been playing up of late, probably why 7-zip was not working.
I have lost the start menu and most file associations (including .bas). I am going to upgrade soon.
That looks like a 737!

Fb 1.06 has zlib1.dll as a gift in bin/win32, for general use I presume.
I don't see it in the 64 bit version.

But Marpon's compressor/decompressor is excellent anyway, I tried it out a few months ago.
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Layered Parallax Effect v0.6

Post by srvaldez »

@dodicat
if nothing else works, I suggest factory reset, not sure that's the right phrase but you get the idea
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Layered Parallax Effect v0.65

Post by UEZ »

@jj2007, srvaldez, dodicat, badidea, Pim Scheffers and counting_pine: thank you all for your feedback. :-)
counting_pine wrote:Nice, although is it just me, or is there something off about the way the background image is transformed?

Also, as with most mouse interaction demos, this is one of those cases where it would be great to allow the user to exit with the 'X' button on the title bar. (For many user setups, Esc is the furthest key away from the mouse.)
"something off" means what exactly? ^^ The trapezoid transformation code is not the best.¯\_(ツ)_/¯

I updated the code to 0.65:
-added X button close code
-the background image position will also slightly move now
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Layered Parallax Effect v0.65

Post by counting_pine »

UEZ wrote:"something off" means what exactly? ^^ The trapezoid transformation code is not the best.¯\_(ツ)_/¯
Thanks for adding the 'X' close ability.

I guess "something off" is just the first impression I get when looking at it. It's difficult to be precise how, but decades of looking at three-dimensional objects tells me it doesn't move in the right way.

I think what I'd expect to happen is that as you move the mouse right, the left hand side should get "closer to the screen", but in the program itself, it just gets "taller".

When something gets closer, it should expand at the same rate in the horizontal and vertical axes. But the image here just expands in one direction.

Try mentally superimposing a grid on the image. If you move one edge closer to the viewer, you'd expect the gridlines around that edge to move further apart - both horizontally and vertically, and for the distances to decrease on points further from that edge.

But with the code used here, I suspect that the gridlines remain equidistant from each other. They'll move further and closer as the image is stretched and squashed, but all the gridlines will start the same distance apart, and end the same distance apart, evenly spaced along the start/end edges.

EDIT: I guess you've managed an "affine" transformation, but with a quad instead of two triangles.

See this picture, where you can see on the left the gridlines are evenly spaced, while on the right, the gridlines change distance.
Image[1]
The main difference on the left is there is clearly a seam where two affine-rendered triangles are joined, while yours doesn't have the seam.

EDIT: A better example can be found at https://stackoverflow.com/a/534433/446106:
Image
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Layered Parallax Effect v0.65

Post by UEZ »

counting_pine wrote:
UEZ wrote:"something off" means what exactly? ^^ The trapezoid transformation code is not the best.¯\_(ツ)_/¯
EDIT: I guess you've managed an "affine" transformation, but with a quad instead of two triangles.
I think you are right.

Here the same code where you can see that it generates an affine transformation.

Code: Select all

'Coded by UEZ build 2019-02-22
#Include "fbgfx.bi"

Using FB

'Original affine transformation code by Ben321 @ http://www.vbforums.com/showthread.php?700187-Code-for-a-four-point-transformation-of-an-image


#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_s + (_y) * pitch_s + (_x) Shl 2)
#Define IsInCircle(cx, cy, radius, x, y) (cx-x) * (cx - x) + (cy - y) * (cy - y) <= radius * radius 'thx to dodicat
#Define Floor(x) (((x) * 2.0 - 0.5) Shr 1)

Type DPOINT
	x As Single
	y As Single
End Type

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



Function Checkerboard(iSizeX as uShort, iSizeY as uShort, iAmount  as UShort, iColor1 as ULong = &h303080, iColor2 as ULong = &h909090) as any Pointer
   #Define SetPixelCb(_x, _y, _color)  *cptr(ulong ptr, imgData_cb + _y * pitch_cb + _x Shl 2) = _color
   Dim as any Pointer pImage_cb = ImageCreate(iSizeY * iAmount, iSizeY * iAmount): Dim As Integer w, h, pitch_cb: Dim As Any Pointer imgData_cb: ImageInfo(pImage_cb, w, h, , pitch_cb, imgData_cb)
   For y as UShort = 0 to h - 1: For x as UShort = 0 to w - 1
         SetPixelCb(x, y, Iif(Floor(y / iSizeY) mod 2, Iif(Floor(x / iSizeX) Mod 2 = 0, iColor1, iColor2), Iif(Floor(x / iSizeX) Mod 2 = 0, iColor2, iColor1)))
      Next: Next: Return pImage_cb
End Function


Dim As Integer ImgWidth = 800, ImgHeight = 800, scrw = 1200, scrh = 800

Screenres (scrw, scrh, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_HIGH_PRIORITY Or GFX_NO_SWITCH)
Screenset 1, 0

Dim As Image Ptr Img_Source = Imagecreate(ImgWidth, ImgHeight, 32), Img_Dest = Imagecreate(scrw, scrh, 32)
Img_Source = Checkerboard(80, 80, 10)

Dim As Integer pitch_s, pitch_d
Dim As Any Ptr imgData_s, imgData_d
Imageinfo(Img_Source, , , , pitch_s, imgData_s)
Imageinfo(Img_Dest, , , , pitch_d, imgData_d)

Randomize , 2
Dim Points(3) As DPOINT
Points(0).x = Rnd() * scrw / 2 		: Points(0).y = Rnd() * scrh / 2 'left upper corner
Points(1).x = scrw / 2 + Rnd() * scrw / 2	: Points(1).y = Rnd() * scrh / 2 'right upper corner
Points(2).x = Rnd() * scrw / 2 		: Points(2).y = scrh / 2 + Rnd() * scrh / 2 'left lower corner
Points(3).x = scrw / 2 + Rnd() * scrw / 2 : Points(3).y = scrh / 2 + Rnd() * scrh / 2 'right lower corner


Dim As Ushort x, y, xx, yy
Dim As Byte iPoint = -1
Dim As DPOINT Trapezoid
Dim As Ulong iCol

#Macro Update()
	Line Img_Dest, (0, 0) - (scrw - 1, scrh - 1), Rgb(64, 64, 64), BF
	For y = 0 To ImgHeight - 1
		For x = 0 To ImgWidth - 1
			Trapezoid = Transform(x, y, ImgWidth, ImgHeight, Points())
			Trapezoid.x = Iif(Trapezoid.x < 1, 1, Iif(Trapezoid.x > scrw - 1, scrw - 1, Trapezoid.x))
			Trapezoid.y = Iif(Trapezoid.y < 1, 1, Iif(Trapezoid.y > scrh - 1, scrh - 1, Trapezoid.y))
			xx = Trapezoid.x
			yy = Trapezoid.y
			iCol =  PixelGet(x, y)
			If scrw > ImgWidth Or scrh > ImgHeight 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, yy, iCol)
				PixelSet(xx + 1, yy, iCol)
				PixelSet(xx - 1, yy + 1, iCol)
				PixelSet(xx, yy + 1, iCol)
				PixelSet(xx + 1, yy + 1, iCol)	
			Else
				PixelSet(xx, yy, iCol)
			End If

		Next x
	Next y	

	For i As Ubyte = 0 To 3
		Circle Img_Dest, (Points(i).x, Points(i).y), 5, Rgb(255, 0, 0), , , , F
		Circle Img_Dest, (Points(i).x, Points(i).y), 5, Rgb(128, 0, 0)
	Next
	
	Put (0, 0), Img_Dest, PSet
	Flip
#Endmacro


Dim As Integer mx, mxo, my, myo, mb
Update()

Dim As Double fTimer = Timer

Do
	Getmouse mx, my, , mb
	If mb = 1 Then
		For i As Ubyte = 0 To 3
			If IsInCircle(mx, my, 5, Points(i).x, Points(i).y) Then
				iPoint = i
				Exit For
			End If
		Next
		If iPoint > -1 Then
			While mb = 1
				Getmouse mx, my, , mb
				mxo = Iif(mx < 0, mxo, mx)
				myo = Iif(my < 0, myo, my)
				Points(iPoint).x = mxo
				Points(iPoint).y = myo
				Update()
				Sleep(1, 1)
			Wend
			iPoint = -1
		Endif
	End If
	Sleep (10, 1)
Loop Until Inkey = Chr(27)

Imagedestroy(Img_Source)
Imagedestroy(Img_Dest)
Just move the corners.


Hmm, I don't want to reinvent the wheel again...Let me try to find a better solution.
Coolman
Posts: 294
Joined: Nov 05, 2010 15:09

Re: Layered Parallax Effect v0.65

Post by Coolman »

amazing. 39-40 fps. under linux with wine. with Sleep (1, 1).
Post Reply