Code-Beispiel

Animierter Schredder-Effekt

Lizenz:	Erster Autor:	Letzte Bearbeitung:
k. A.	pomme	23.04.2009
Das verwendete Bild (Andy.BMP) gibt es im Attachment zum Kaleidoskop-Effekt. Es können natürlich auch andere Bilder (*.BMP) verwendet werden.
'COPYRIGHT 2009 D.Pommerening

'Shredder-Effect

'THIS CODE HAS NO LICENSE, NO WARRANTY, USE IT AT YOUR OWN RISK; BUT DON´T CLAIM ISTS YOURS !

'Schredder-Effekt

'DIESER CODE DARF LIZENZFREI BENUTZT WERDEN; OHNE JEDE GEWÄHR UND HAFTUNG; BENUTZUNG AUF

'EIGENE GEFAHR; NICHT MIT EIGENEM COPYRIGHT VERSEHEN !



'Dieser Code erzeugt einen Schredder- bzw. Zerstäubungs-Effekt für ein Bitmap.

'Je kleiner die partikel sind, desto mehr Rechnerleistung wird benötigt.

'Die eingesetzten Werte und Formeln haben keinen wissenschaftlichen Hintergrund und sind rein willkürlich.

'Es werden nicht alle Fehlermöglichkeiten abgerüft.

'Verbesserungen und Erweiterungen sind willkommen.



'Hinweis: Die geschweiften Klammern helfen in FbEdit (ab Version 1.0.6.7) Codeteile einzuklappen.



'{ FB-dialekt-handling

#If  __FB_VERSION__ < "0.20"

 #Error Please compile With FB version 0.20 Or above

#EndIf



#Include "fbgfx.bi"



#lang "fb"

 Using FB



#Ifdef __FB_LANG__

   #If __FB_LANG__ <> "fb"

   #Error Please compile With -lang fb

#EndIf



#Print __FB_SIGNATURE__

#Print Dialekt:

#Print __FB_LANG__

'}



'{ Defines

 #Define  smalerval(val1,val2)  IIf(val1<val2,val1,val2) 'den kleineren zweier werte ermitteln

 #Define  bigerval(val1,val2)   IIf(val1>val2,val1,val2) 'den größeren zweier werte ermitteln



#Ifndef TRUE

 #Define  TRUE  1

#EndIf

#Ifndef FALSE

 #Define  FALSE 0

#EndIf



 #Define  col_transp      &HFFFF00FF

 #Define  col_weiss       &HFFFFFFFF

 #Define  col_hellgrau    &HFF999999

 #Define  col_dunkelgn    &HFF113311

 #Define  Bild_Pause      0.04         'maximal 25 bilder pro sekunde

 #Define  rnd_mth         4

'}



'{ DECLARE SUBS and FUNCTIONS

 Declare Function bmpload(file AS String) AS Any Ptr

 Declare Function shredder(modus  As Integer, dstpic As UInteger Ptr, srcpic As UInteger Ptr=0 _

                          ,deltax As Single=0, deltay As Single=0 _

                          ,startx As Single=0, starty As Single=0) As Integer

 Declare Sub massage(text As String)

 Declare Sub resizepic(ByVal quelle AS UInteger Ptr,ByVal ziel AS UInteger Ptr,ByVal methode AS Integer)

 Declare Sub ENDDESTRUCTOR() Destructor

'}



Enum bildanpassungs_methoden

   jerked_mth  'unbeschnitten, das quell-bild wird ggf. gezerrt oder gequetscht kopiert

   lopped_mth  'beschnitten, das quell-bild wird ggf. an den rändern zugeschnitten kopiert

End Enum



Type sand_type  Field=1

   sptr     As UInteger Ptr

   x        As Single

   y        As Single

   x2       As Single

   y2       As Single

   xdelta   As Single

   ydelta   As Single

   b        As UShort

   h        As UShort

   flag :2  As UByte

   xcalc:1  As UByte

   ycalc:1  As UByte

End Type



'{ Dims

 Dim Shared   As UInteger    _deskb,_deskh

 ReDim Shared As sand_type   sand(0)



 Dim As UInteger Ptr  orgpic,backpic,srcpic,orgdata

 Dim As UInteger      orgb,orgh,gr,bytpp,bitspp,orgpitch

 Dim As Integer       i,backb,backh,srcb,srch,count

 Dim As Integer       partb,parth,startx,starty,bilder

 Dim As Single        backx,backy,deltax,deltay

 Dim As Double        ti



 Dim As String        file,vz=ExePath

'}



   file="\andy.bmp"

   Randomize Timer,rnd_mth



'Informationen über Desktop abfragen

   SCREENINFO _deskb,_deskh,bitspp

    If bitspp<>32 Then massage("Der Desktop ist nicht im TrueColor-Mode (32 Bit)") : End



'vorerst unsichtbares fenster erstellen

   ScreenRes 64,480,32,,GFX_NULL



'einen zielpuffer als hintergrundbild erzeugen (in 66% desktopgröße)

   backb=(_deskb-128)*0.66

   backh=(_deskh-128)*0.66

    backpic=ImageCreate(backb,backh,col_dunkelgn)



'bild laden und größe auf 50% des hintergrundbildes einstellen

   orgpic=bmpload(vz+file) : If orgpic=0 Then End

    imageinfo(orgpic,orgb,orgh,bytpp,orgpitch,orgdata)

    srcb=backb*0.5

    srch=srcb*(orgh/orgb) 'möglichst im original seitenverhältnis

    srch=smalerval(backh,srch) 'quetschen falls zu hoch



'fb-fenster in hellgrau erstellen

    ScreenRes  backb+128,backh+128,32,,GFX_NO_FRAME

    ScreenLock

   Line (0,0)-(backb+127,backh+127),col_hellgrau,bf

    ScreenUnLock

    Locate 2,2: Print " Esc = Ende "



'quell-bildpuffer erstellen

    srcpic=ImageCreate(srcb,srch)

    resizepic(orgpic,srcpic,jerked_mth)

    ImageDestroy orgpic 'wird nicht mehr gebraucht



    backx=64 : backy=64



    Do

'initialisieren (partikel erzeugen) - jedes einzel-partikel soll partb mal parth pixel groß sein

       deltax=15-(Rnd*30) : deltay=25-(Rnd*50)

       partb=Int(Rnd*3)*10+1 : parth=Int(Rnd*3)*10+1

       Locate 4,2 : ? "Partikelgroesse:";partb;" x ";parth;"     "

       count=shredder(-1,backpic,srcpic,deltax,deltay,partb,parth)



'partikel ins bild fallen lassen

        startx=(backb-srcb)/4 : starty=20

       Do

          'bestimmt die geschwindigkeit mit der sich das bild zusammensetzt

          deltax=(Rnd*.95)+.05 : deltay=(Rnd*.95)+.05 'deltax und deltay müssen hier > 0 sein

          ti=Timer

          count=shredder(1,backpic,0,deltax,deltay,startx,starty)

           startx+=3

          starty+=2

           Put(backx,backy),backpic,trans 'zielpuffer im fb-fenster anzeigen

           Line backpic,(0,0)-(backb-1,backh-1),col_dunkelgn,bf 'zielpuffer restaurieren



          Do Until (Timer-ti)>Bild_Pause : Sleep 1 : Loop

          If MultiKey(SC_ESCAPE) Then End

       Loop While count



      Sleep 40



'partikel aus dem bild fallen lassen

       deltax=Int(Rnd*5)*.5 : deltay=Int(Rnd*5)*.5

       Locate 6,2 : ? "delta X / Y : ";deltax;" / ";deltay;"      "

       Do

          ti=Timer

          startx+=2 : starty-=1

          count=shredder(2+16,backpic,0,deltax,deltay,startx,starty)

          Put(backx,backy),backpic,trans 'zielpuffer im fb-fenster anzeigen

          Line backpic,(0,0)-(backb-1,backh-1),col_dunkelgn,bf  'zielpuffer restaurieren

          Do Until (Timer-ti)>Bild_Pause : Sleep 1 : Loop

          If MultiKey(SC_ESCAPE) Then End

       Loop While count



       If MultiKey(SC_ESCAPE) Then Exit Do



    Loop



End

'========================================================================================

Function bmpload(file AS String) AS Any Ptr

'{ Dims

 Dim As UInteger     b,h,bytpp,ff,result

 Dim As Any Ptr      sprite

'}



   ff=Freefile

   result=Open(file For Binary Access Read As #ff)

   If result=2 Then Close #ff : massage("Bild nicht gefunden.("+file+")") : Return 0

   If result   Then Close #ff : massage("Fehler beim Laden des Bildes.")  : Return 0

   Get #ff,19,b

   Get #ff,23,h

   Close #ff



'maximale bildgröße = 6 megapixel

   If (b>3000) Or (h>2000) Then

      massage("Das Bild ist zu gross ! ("+Str(b)+" x "+Str(h)+ " = "+Str(b*h)+" Bildpunkte)")

      Return 0

   End If



   sprite=ImageCreate(b,h,,32)

   result=BLoad(file,sprite)

    If imageinfo(sprite,,,bytpp) Then ImageDestroy sprite _

         : massage("Falscher Image-Header oder FB-Screen nicht initialisiert.") : Return 0



   If result Then ImageDestroy sprite : massage("Fehler beim Laden des Bildes.") : Return 0



    If bytpp<>4 Then ImageDestroy sprite : massage("Dieses Bild ist nicht in True-Color (32 Bit)") : Return 0



   Return sprite



End Function



Sub massage(text As String)

   ScreenRes 480,64,32

   Print text

   Beep

   GetKey

End Sub



Sub resizepic(ByVal qp As UInteger Ptr,ByVal zp As UInteger Ptr,ByVal methode As Integer)

'{ der zielpuffer muß bereits in der gewünschten größe vorhanden sein

'  methode: jerked_mth = nicht beschneiden, das quell-bild wird ggf. gezerrt oder gequetscht kopiert

'           lopped_mth = beschitten, das quell-bild wird ggf. an den rändern zugeschnitten kopiert

'}



'{ Dims

 Dim As UInteger Ptr  srcdata,dstdata

 Dim As Integer       srcb,srch,srcpitch,srcpad

 Dim As Integer       dstb,dsth,dstpitch,dstpad

 Dim As Integer       x,y,k,qlofs,boffs,hoffs,bytpp

 Dim As UInteger      punkt

 Dim As Double        brest,hrest

 Dim As Double        bv,hv,hv2,bv2

'}



'padding berechnen

    If imageinfo(qp,srcb,srch,bytpp,srcpitch,srcdata) Then Exit Sub

   srcpad=srcpitch/bytpp



    If imageinfo(zp,dstb,dsth,bytpp,dstpitch,dstdata) Then Exit Sub

   dstpad=dstpitch/bytpp



   If (srcb<2) Or (srch<2) Or (dstb<2) Or (dsth<2) Or (bytpp<4) Then Beep : Exit Sub



'breite und höhe anpassen

   Select Case methode

    Case jerked_mth

      bv=srcb/dstb : hv=srch/dsth 'größenverhältniss feststellen



    Case  lopped_mth

      If (srcb/srch)<=(dstb/dsth) Then 'das bild ist hoeher als breit oder gleich

         bv=(srcb/dstb) 'größenverhältnisse feststellen

         hv=bv

         hrest=((srch/bv)-dsth)

         hoffs=hrest/2

      Else 'das bild ist breiter als hoch

         hv=(srch/dsth) 'größenverhältnisse feststellen

         bv=hv

         brest=((srcb/hv)-dstb)

         boffs=brest/2

      End If



   Case Else

      Exit Sub

   End Select



   If (dsth<2) Or (dstb<2) Then Exit Sub



'kopieren

   hv2=hv/2 : bv2=bv/2

   For y=0 To dsth-1

      qlofs=(Fix(((y+hoffs)*hv)+hv2)*srcpad)

      For x=0 To dstb-1

         dstdata[k+x]=srcdata[qlofs+Fix(((x+boffs)*bv)+bv2)]

      Next x

      k+=dstpad

   Next y



End Sub



Function shredder(modus As Integer, dstpic As UInteger Ptr, srcpic As UInteger Ptr=0 _

                 ,deltax As Single=0, deltay As Single=0 _

                 ,ox As Single=0, oy As Single=0)   As Integer



'{ erläuterungen zu den parametern

'Aufrufparameter bei initialisierung (modus < 0):

'dstpic = zeiger auf den zielpuffer

'srcpic = zeiger auf zu zerschredderndes bild

'deltax,deltay  = x- und y- anfangszerstreuung des geschredderten bildes

'ox,oy  = breite und höhe der geschredderten partikel.

'RÜCKGABEWERT: Anzahl der erzeugten partikel

'

'AUFRUFPARAMETER bei abarbeitung (modus > 0):

'modus = 1 partikel ins bild fallen lassen (deltax und deltay müssen hier > 0 sein)

'modus = 2 oder 18 partikel aus dem bild fallen lassen

'       (wenn bit 4 gesetzt ist werden partikel die im himmel landeten ausgeschaltet)

'dstpic = zeiger auf den zielpuffer

'srcpic = 0

'deltax,deltay = x- und y- grad der zerstreuung

'ox,oy = x- y- grundposition innerhalb des zielpuffers für alle partikel

'

'RÜCKGABEWERT: Anzahl der gezeichneten partikel

'             (alle nicht mitgezählten partikel haben den sichtbaren bereich verlassen)

'}



'{ Dims

 Dim As Integer       i,ix,iy,bidx,kx,ky,skydeath,partb,parth

 Dim As Integer       dstb,dsth,bytpp,bitspp

 Dim As Integer       anzpart,count,anzsp,anzl,xrest,yrest,xstep,ystep,lsp,lzl



 Dim As UInteger Ptr  srcdata,dstdata

 Dim As UInteger      srcb,srch,srcpitch,dstpitch,srcpad,dstpad



 Dim As Single        ysum,ur,rr,mitte,diff



 CONST energieverlust As Single = -0.96

'}



   If imageinfo(dstpic,dstb,dsth,bytpp,dstpitch,dstdata) Then Return 0

   If bytpp<>4 Then massage("Das Hintergrundbild ist kein TrueColor-Bild (32 Bit)") : Return 0

   dstpad=dstpitch/bytpp

   rr=dstb-1 : ur=dsth-1



   count=0



'initialisieren

   If modus=-1 Then

      If imageinfo(srcpic,srcb,srch,bytpp,srcpitch,srcdata) Then Return 0

      If bytpp<>4 Then massage("Das Bild ist kein TrueColor-Bild (32 Bit)") : Return 0

      srcpad=srcpitch/bytpp



'{ partikelgröße begrenzen

      partb=ox : parth=oy

      If partb<1 Then partb=1

      If parth<1 Then parth=1

'}



'{ spalten- und zeilen-reste ermitteln

      xrest=srcb Mod partb : yrest=srch Mod parth



      anzsp=(srcb\partb)+IIf(xrest,1,0)

      anzl= (srch\parth)+IIf(yrest,1,0)

      anzpart=(anzsp*anzl)



      kx=0 : ky=0

      If xrest Then lsp=anzsp Else lsp=0

      If yrest Then lzl=anzl  Else lzl=0

'}



'{ partikel erzeugen

      ReDim As sand_type sand(anzpart)



      mitte=Sqr(((srcb Shr 1))^2+((srch Shr 1))^2)



      For iy=0 To anzl-1

         ystep=IIf(iy=lzl,yrest,parth)

         bidx=(iy*anzsp)

         For ix=0 To anzsp-1

           With sand(bidx+ix)

            xstep=IIf(ix=lsp,xrest,partb) 'letzte spalte ?

            .sptr=ImageCreate(xstep,ystep)

            Get srcpic,(kx,ky)-Step(xstep-1,ystep-1),.sptr

            .x=kx    : .y=ky

            .b=xstep : .h=ystep

            .x2=.x+srcb-((Rnd*srcb) * 2)

            .y2=.y-srch-((dsth-srch) Shr 1)-(Rnd*srch)

            kx+=xstep

            diff=Sqr((((srcb Shr 1)-.x)^2)+(((srch Shr 1)-.y)^2))/mitte

            .xdelta=diff*deltax

            .ydelta=diff*deltay

            .flag=2

            .xcalc=1

            .ycalc=1

           End With 'sand

           count+=1

         Next

         kx=0 : ky+=parth

      Next

'}



   EndIf



'{ shredder-effekt

    If UBound(sand)=0 Then massage("Function nicht initialsiert !") : Return 0



   If Bit(modus,4) Then skydeath=TRUE : modus=BitReset(modus,4)Else skydeath=FALSE



   If modus=1 Then

'{ partikel ins bild fallen lassen

      For i=LBound(sand) To UBound(sand)

         With sand(i)

          If .xcalc Then

             .x2+=(.x-.x2)*(Rnd*deltax) 'neue x-Position berechnen

             If Abs(.x-.x2)<deltax Then .x2=.x : .xcalc=0

           EndIf



          If .ycalc Then

             .y2+=(.y-.y2)*(Rnd*deltay)+1 'neue y-Position berechnen

             If .y2>.y Then .y2=.y : .ycalc=0

          EndIf



          If .xcalc Orelse .ycalc Then count+=1



          If (.x2+ox>=0) Andalso (.y2+oy>=0) Then

             Put dstpic,(.x2+ox,.y2+oy),.sptr,trans

          EndIf

         End With 'sand

       Next

'}

   ElseIf modus=2 Then

'{ partikel aus dem bild fallen lassen

       For i=LBound(sand) To UBound(sand)

         With sand(i)

          If .flag Then

              .xdelta+=deltax-(Rnd*(deltax*2)) 'x-energie berechnen

             .x+=.xdelta              'neue x-Position bestimmen



             'partikel die seitlich aus dem bild verschwinden werden ausgeschaltet

             If ((.x+ox+.b-1)<0) Orelse ((.x+ox)>rr) Then

                .flag=0

             Else

                 .ydelta+=(Rnd*deltay)+.5 'y-energie berechnen

                 .y+=.ydelta         'neue y-Position bestimmen



                 ysum=.y+oy+.h-1

                 If ysum>=ur Then    'untere rand erreicht

                    If .flag>1 Then  'erstmals untere rand erreicht

                       .ydelta*=energieverlust 'aus positiv wird negativ mit etwas verlust

                       .flag-=1

                    ElseIf ysum-.h+1>ur Then 'partikel, die zum zweiten mal den boden berühren, landen in der hölle

                       .flag=0

                    EndIf

                 ElseIf ysum<0 Andalso skydeath Then 'im himmel

                    .flag=0

                 EndIf



                 If .flag Then 'verbleibende partikel anzeigen

                    Put dstpic,(.x+ox,.y+oy),.sptr,trans

                    count+=1

                 EndIf

             EndIf

          EndIf

         End With 'sand

       Next

'}

    Else 'noch Ideen ?

       count=0

    EndIf

'}



   Return count



END Function



Sub ENDDESTRUCTOR() Destructor



   For i As Integer=UBound(sand) To UBound(sand)

      If sand(i).sptr Then ImageDestroy(sand(i).sptr) 'partikel löschen

   Next



   While InKey<>"" : Sleep 1 : Wend



End Sub
Zusätzliche Informationen und Funktionen
Das Code-Beispiel wurde am 23.04.2009 von pomme angelegt.
Die aktuellste Version wurde am 23.04.2009 von pomme gespeichert.
Bearbeiten
Versionen