Layered Parallax Effect v0.70

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

Layered Parallax Effect v0.70

Postby UEZ » Mar 14, 2019 19:52

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: 1263
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: Layered Parallax Effect

Postby jj2007 » Mar 14, 2019 20:11

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

Re: Layered Parallax Effect

Postby srvaldez » Mar 14, 2019 20:11

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

Re: Layered Parallax Effect

Postby dodicat » Mar 14, 2019 21:56

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

Re: Layered Parallax Effect

Postby UEZ » Mar 14, 2019 22:24

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: 1624
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Layered Parallax Effect

Postby badidea » Mar 14, 2019 22:35

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: 346
Joined: May 05, 2017 19:59
Location: Germany

Re: Layered Parallax Effect

Postby UEZ » Mar 15, 2019 12:06

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: 45
Joined: Jun 29, 2014 17:15

Re: Layered Parallax Effect

Postby Pim Scheffers » Mar 15, 2019 12:37

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

Re: Layered Parallax Effect v0.6

Postby counting_pine » Mar 15, 2019 15:35

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: 6030
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Layered Parallax Effect v0.6

Postby dodicat » Mar 15, 2019 16:27

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: 2160
Joined: Sep 25, 2005 21:54

Re: Layered Parallax Effect v0.6

Postby srvaldez » Mar 15, 2019 16:56

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

Re: Layered Parallax Effect v0.65

Postby UEZ » Mar 15, 2019 17:45

@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: 6174
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Layered Parallax Effect v0.65

Postby counting_pine » Mar 15, 2019 21:16

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: 346
Joined: May 05, 2017 19:59
Location: Germany

Re: Layered Parallax Effect v0.65

Postby UEZ » Mar 15, 2019 21:53

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: 211
Joined: Nov 05, 2010 15:09

Re: Layered Parallax Effect v0.65

Postby Coolman » Mar 16, 2019 19:07

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

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest