10.03.2019 - Round 1 results of our "A Love Letter For FreeBASIC" game dev competition have been published. Please be sure to check the results thread: http://games.freebasic.net/forum/index.php?topic=629.0. Don't forget that the competition is continuing with a round 2, lasting till 29th of April, 300 USD first prize. Stay tuned!

Author Topic: Flicker Animation Class  (Read 5665 times)

rolliebollocks

  • Novice
  • ***
  • Posts: 75
    • View Profile
    • Email
Flicker Animation Class
« on: January 25, 2009, 10:23:25 AM »
A class to produce a flicker animation based on the modulus to counter. Quick and dirty with a couple of goodies.

Lemme know if it sucks. It was a board request.

RLUD arrows move animation around

R to rotate
+,- Zoom in/out

Code: [Select]
#include "fbgfx.bi"
#include "file.bi"

#DEFINE SCREEN_X 800
#DEFINE SCREEN_Y 600

screenres 800, 600, 32

type sprite
    img as fb.image ptr
    delay as double
   
    declare sub Init ( Filename as string, dly as double )
    declare sub MultiPut(Byval lpTarget As Any Ptr= 0, _
                        Byval xMidPos  As Integer= 0, _
                        Byval yMidPos  As Integer= 0, _
                        Byval lpSource As Any Ptr   , _
                        Byval xScale   As Single = 1, _
                        Byval yScale   As Single = 1, _
                        Byval Rotate   As Single = 0, _
                        Byval Trans    As Integer= 0)
    declare function LoadBitmap (ByVal filename As String) As any Ptr
                       
end type
   
sub Sprite.Init ( filename as string, dly as double )
   
    img = Loadbitmap ( filename )
    delay = dly
   
end sub

Sub sprite.MultiPut(Byval lpTarget As Any Ptr= 0, _
             Byval xMidPos  As Integer= 0, _
             Byval yMidPos  As Integer= 0, _
             Byval lpSource As Any Ptr   , _
             Byval xScale   As Single = 1, _
             Byval yScale   As Single = 1, _
             Byval Rotate   As Single = 0, _
             Byval Trans    As Integer= 0)

  If (screenptr=0) Or (lpSource=0) Then Exit Sub

  If xScale < 0.001 Then xScale=0.001
  If yScale < 0.001 Then yScale=0.001

  Dim As Integer MustLock,MustRotate

  If lpTarget= 0 Then MustLock  =1
  If Rotate  <>0 Then MustRotate=1

  Dim As Integer  TargetWidth,TargetHeight,TargetBytes,TargetPitch
  If MustLock Then
    ScreenInfo    _
    TargetWidth , _
    TargetHeight, _
    TargetBytes ,,_
    TargetPitch
    TargetBytes Shr=3

    lpTarget=ScreenPtr
  Else
    TargetBytes  = cptr(Uinteger Ptr,lpTarget)[1]
    TargetWidth  = cptr(Uinteger Ptr,lpTarget)[2]
    TargetHeight = cptr(Uinteger Ptr,lpTarget)[3]
    TargetPitch  = cptr(Uinteger Ptr,lpTarget)[4]
    lpTarget    += 32
  End If
  If (TargetWidth<4) Or (TargetHeight<4) Then Exit Sub

  Dim As Integer   SourceWidth,SourceHeight,SourceBytes,SourcePitch
  If cptr(Integer Ptr,lpSource)[0] = 7 Then
    SourceBytes  = cptr(Uinteger Ptr,lpSource)[1]
    SourceWidth  = cptr(Uinteger Ptr,lpSource)[2]
    SourceHeight = cptr(Uinteger Ptr,lpSource)[3]
    SourcePitch  = cptr(Uinteger Ptr,lpSource)[4]
    lpSource    += 32
  Else
    SourceBytes  = 1
    SourceWidth  = cptr(Ushort Ptr,lpSource)[0] Shr 3
    SourceHeight = cptr(Ushort Ptr,lpSource)[1]
    SourcePitch  = SourceWidth
    lpSource    += 4
  End If
#if 0
  ? TargetWidth & "x" & TargetHeight & "x" & TargetBytes,TargetPitch
  ? SourceWidth & "x" & SourceHeight & "x" & SourceBytes,SourcePitch
  ? MustLock,Trans
  Sleep:End
#endif

  If (SourceWidth<2) Or (SourceHeight<2) Then Exit Sub
  If (TargetBytes<>SourceBytes) Then Exit Sub

#define xs 0 'screen
#define ys 1
#define xt 2 'texture
#define yt 3
  Dim As Single Points(3,3)
  points(0,xs)=-SourceWidth/2 * xScale
  points(1,xs)= SourceWidth/2 * xScale
  points(2,xs)= points(1,xs)
  points(3,xs)= points(0,xs)

  points(0,ys)=-SourceHeight/2 * yScale
  points(1,ys)= points(0,ys)
  points(2,ys)= SourceHeight/2 * yScale
  points(3,ys)= points(2,ys)

  points(1,xt)= SourceWidth-1
  points(2,xt)= points(1,xt)
  points(2,yt)= SourceHeight-1
  points(3,yt)= points(2,yt)

  Dim As Uinteger i
  Dim As Single x,y
  If MustRotate Then
    #ifndef UseRad
    Rotate*=0.017453292 'degre 2 rad
    #endif
    While Rotate< 0        :rotate+=6.2831853:Wend
    While Rotate>=6.2831853:rotate-=6.2831853:Wend
    For i=0 To 3
      x=points(i,xs)*Cos(Rotate) - points(i,ys)*Sin(Rotate)
      y=points(i,xs)*Sin(Rotate) + points(i,ys)*Cos(Rotate)
      points(i,xs)=x:points(i,ys)=y
    Next
  End If

  Dim As Integer yStart,yEnd,xStart,xEnd
  yStart=100000:yEnd=-yStart:xStart=yStart:xEnd=yEnd

#define LI 0   'LeftIndex
#define RI 1   'RightIndex
#define  IND 0 'Index
#define NIND 1 'NextIndex
  Dim As Integer CNS(1,1) 'Counters

  For i=0 To 3
    points(i,xs)=Int(points(i,xs)+xMidPos)
    points(i,ys)=Int(points(i,ys)+yMidPos)
    If points(i,ys)<yStart Then yStart=points(i,ys):CNS(LI,IND)=i
    If points(i,ys)>yEnd   Then yEnd  =points(i,ys)
    If points(i,xs)<xStart Then xStart=points(i,xs)
    If points(i,xs)>xEnd   Then xEnd  =points(i,xs)
  Next
  If yStart =yEnd         Then Exit Sub
  If yStart>=TargetHeight Then Exit Sub
  If yEnd   <0            Then Exit Sub
  If xStart = xEnd        Then Exit Sub
  If xStart>=TargetWidth  Then Exit Sub
  If xEnd   <0            Then Exit Sub

  Dim As Ubyte    Ptr t1,s1
  Dim As Ushort   Ptr t2,s2
  Dim As Uinteger Ptr t4,s4


#define ADD 0
#define CMP 1
#define SET 2
  Dim As Integer ACS(1,2) 'add compare and set
  ACS(LI,ADD)=-1:ACS(LI,CMP)=-1:ACS(LI,SET)=3
  ACS(RI,ADD)= 1:ACS(RI,CMP)= 4:ACS(RI,SET)=0

#define EX  0
#define EU  1
#define EV  2
#define EXS 3
#define EUS 4
#define EVS 5
  Dim As Single E(2,6),S(6),Length,uSlope,vSlope
  Dim As Integer U,UV,UA,UN,V,VV,VA,VN

  ' share the same highest point
  CNS(RI,IND)=CNS(LI,IND)
  If MustLock Then ScreenLock
  ' loop from Top to Bottom
  While yStart<yEnd
    'Scan Left and Right sides together
    For i=LI To RI
      ' bad to read but fast and short ;-)
      If yStart=points(CNS(i,IND),ys) Then
        CNS(i,NIND)=CNS(i,IND)+ACS(i,Add)
        If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
        While points(CNS(i,IND),ys) = points(CNS(i,NIND),ys)
          CNS(i, IND)=CNS(i,NIND)
          CNS(i,NIND)=CNS(i, IND)+ACS(i,Add)
          If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
        Wend
        E(i,EX) = points(CNS(i, IND),xs)
        E(i,EU) = points(CNS(i, IND),xt)
        E(i,EV) = points(CNS(i, IND),yt)
        Length  = points(CNS(i,NIND),ys)
        Length -= points(CNS(i, IND),ys)
        If Length <> 0.0 Then
          E(i,EXS) = points(CNS(i, NIND),xs)-E(i,EX):E(i,EXS)/=Length
          E(i,EUS) = points(CNS(i, NIND),xt)-E(i,EU):E(i,EUS)/=Length
          E(i,EVS) = points(CNS(i, NIND),yt)-E(i,EV):E(i,EVS)/=Length
        End If
        CNS(i,IND)=CNS(i,NIND)
      End If
    Next

    If (yStart<0)                              Then Goto SkipScanLine
    xStart=E(LI,EX)+0.5:If xStart>=TargetWidth Then Goto SkipScanLine
    xEnd  =E(RI,EX)-0.5:If xEnd  < 0           Then Goto SkipScanLine
    If (xStart=xEnd)                           Then Goto SkipScanLine
    'if xEnd  <xStart                           then goto SkipScanLine
    Length=xEnd-xStart
    uSlope=E(RI,EU)-E(LI,EU):uSlope/=Length
    vSlope=E(RI,EV)-E(LI,EV):vSlope/=Length
    If xstart<0 Then
      Length=Abs(xStart)
      U=Int(E(LI,EU)+uSlope*Length)
      V=Int(E(LI,EV)+vSlope*Length)
      xStart = 0
    Else
      U=Int(E(LI,EU)):V=Int(E(LI,EV))
    End If
    If xEnd>=TargetWidth Then xEnd=TargetWidth-1
    UV=Int(uSlope):UA=(uSlope-UV)*100000:UN=0
    VV=Int(vSlope):VA=(vSlope-VV)*100000:VN=0
    xEnd-=xStart
    Select Case TargetBytes
      Case 1
        t1=cptr(Ubyte Ptr,lpTarget)
        t1+=yStart*TargetPitch+xStart:xStart=0
        If Trans=0 Then
          While xStart<xEnd
            s1=lpSource+V*SourcePitch+U
            *t1=*s1
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t1+=1
          Wend
        Else
          While xStart<xEnd
            s1=lpSource+V*SourcePitch+U
            If *s1 Then *t1=*s1
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t1+=1
          Wend
        End If
      Case 2
        t2=cptr(Short Ptr,lpTarget)
        t2+=yStart*(TargetPitch Shr 1)+xStart:xStart=0
        If Trans=0 Then
          While xStart<xEnd
            s2=cptr(Short Ptr,lpSource)+V*(SourcePitch Shr 1)+U
            *t2=*s2
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t2+=1
          Wend
        Else
          While xStart<xEnd
            s2=cptr(Short Ptr,lpSource)+V*(SourcePitch Shr 1)+U
            If *s2<>&HF81F Then *t2=*s2
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t2+=1
          Wend
        End If
      Case 4
        t4=cptr(Integer Ptr,lpTarget)+yStart*(TargetPitch Shr 2)+xStart:xStart=0
        If Trans=0 Then
          While xStart<xEnd
            s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
            *t4=*s4
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t4+=1
          Wend
        Else
          While xStart<xEnd
            's4=cptr(Integer Ptr,lpSource):s4+=V*(SourcePitch shr 2):s4+=U
            s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
            If *s4<>&HFFFF00FF Then *t4=*s4
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t4+=1
          Wend
        End If
    End Select

SkipScanLine:
    E(LI,EX)+=E(LI,EXS):E(LI,EU)+=E(LI,EUS):E(LI,EV)+=E(LI,EVS)
    E(RI,EX)+=E(RI,EXS):E(RI,EU)+=E(RI,EUS):E(RI,EV)+=E(RI,EVS)
    yStart+=1:If yStart=TargetHeight Then yStart=yEnd 'exit loop
  Wend
If MustLock Then ScreenUnlock
End Sub


Function Sprite.LoadBitmap (ByVal filename As String) As any Ptr
Dim As Integer h,w,hf
Dim As Byte    head(1)
Dim As Any Ptr img

   Do
      If FileExists(filename) Then
         hf=FreeFile
         Open filename For Binary As #hf
            Get #hf,,head()
            If head(0)=&h42 And head(1)=&h4d Then 'BM header
               Seek #hf,&h13
               Get  #hf,,w   'get width
               
               Seek #hf,&h17
               Get  #hf,,h   'get height
            Else
               Close #hf
               Exit Do
            End If           
         Close #hf
         img = ImageCreate(w,h)
         BLoad filename,img
         Return img           
      EndIf
   Loop   
     
End Function


#DEFINE SPRITE_MAX 10

type Animation
   
    as integer numpics
    as integer counter
   
    as double posX, posY
   
    rotangle as single
    zX as single
    zY as single
   
   
    as sprite  sprites(SPRITE_MAX)
   
    declare sub Init ( numpix as integer )
   
    declare sub Display ( num as integer )
    declare sub Process ()
   
end type

sub Animation.Init ( numpix as integer )

    numpics = numpix
   
    sprites(1).Init ( "Human/FF01.bmp", 10 )
    sprites(2).Init ( "Human/FF02.bmp", 50 )
   
    posX = SCREEN_X / 2
    posY = SCREEN_Y / 2
   
    zX = 1
    zY = 1
    rotangle = 0
   
end sub

sub Animation.Process ()
   
    counter += 1
   
    for i as integer = 1 to this.numpics
        if counter mod sprites(i).delay = 0 then Display ( i )
    next
   
    if counter > 5000 then counter = 0

end sub

sub Animation.Display ( num as integer )
   
        screenlock
        cls
            sprites(num).Multiput ( , posX, posY, sprites ( num ).img, zX, zY, Rotangle, 1)
           
        screenunlock
   
end sub
'///////////////////////////////////////////////////////////////////////////////

dim as Animation myAnim

myAnim.Init ( 2 )

do
    sleep 3
    myAnim.Process

    if multikey ( fb.sc_right ) then myAnim.posX += 1 : myAnim.Display ( 1 )
    if multikey ( fb.sc_left ) then myAnim.posX -= 1 : myAnim.Display ( 1 )
    if multikey ( fb.sc_up ) then myAnim.posY -= 1 : myAnim.Display ( 1 )
    if multikey ( fb.sc_down ) then myAnim.posY += 1 : myAnim.Display ( 1 )
   
    if multikey ( fb.sc_R ) then myAnim.Rotangle += 1
    if multikey ( fb.sc_plus ) then myAnim.zX += 1: myanim.zY += 1
    if multikey ( fb.sc_minus ) then myAnim.zX -= 1: myanim.zY -= 1
   
   
   
loop until multikey(fb.sc_escape)
       

KristopherWindsor

  • Forum Sage
  • *****
  • Posts: 363
  • The Thirsty Smiley
    • View Profile
    • Reddit/r/pics
    • Email
Re: Flicker Animation Class
« Reply #1 on: January 25, 2009, 05:05:52 PM »
I don't know... I'd just getting a black screen, 100% CPU usage, and an app that won't quit when I press escape. :P :o

rolliebollocks

  • Novice
  • ***
  • Posts: 75
    • View Profile
    • Email
Re: Flicker Animation Class
« Reply #2 on: January 25, 2009, 05:15:39 PM »
I don't know... I'd just getting a black screen, 100% CPU usage, and an app that won't quit when I press escape. :P :o

Well you have to supply your own files...

There might be something wiggy with the bmp loader though crashing or hanging when the file doesn't exist.

Maybe I'll just write my own. Or go back to XPM's or something. Direct complaints to Vince. If the file exists it should work.

Anyways I need a decent way to handle animation for my engine so I'll be updating.

rb

rolliebollocks

  • Novice
  • ***
  • Posts: 75
    • View Profile
    • Email
Re: Flicker Animation Class
« Reply #3 on: February 23, 2009, 05:25:41 AM »
Update!

Flickers now flick on timer. Much nicer. Added multiput w/ Alphablending.

http://freefile.kristopherw.us/uploads/rolliebollocks/sprite_engine_v1.20.zip
« Last Edit: February 23, 2009, 05:28:13 AM by rolliebollocks »