Buchempfehlung
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Umfassend, aber leicht verständlich führt dieses Buch in die Programmierung von ATMEL AVR Mikrocontrollern ein. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Grafik und Fonts

Animierter Schredder-Effekt

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.Mitgliedpomme 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 Mitgliedpomme angelegt.
  • Die aktuellste Version wurde am 23.04.2009 von Mitgliedpomme gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen