Code-Beispiel

Kaleidoskopeffekt mit Bitmaps

Lizenz:	Erster Autor:	Letzte Bearbeitung:
k. A.	pomme	30.04.2009
Das verwendete Bild (Andy.BMP) gibt es im Attachment (link unten). Bei Interesse, bitte auch den animierten Schredder-Effekt ausprobieren. Es können natürlich auch andere Bilder (*.BMP) verwendet werden.
'COPYRIGHT 2009 D.Pommerening

'Kaleidoscop-Effect

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

'Optimization is welcome !



'Kaleidoskop-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 bis zu 8 verschiedene kaleidoskopähnliche Effekte aus Bitmaps.

'Die erzeugten Bilder können überraschend, witzig und manchmal sogar wunderschön sein.



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

'Optimierungsvorschläge werden gern entgegengenommen!



 #Include "fbgfx.bi"



'{ FB-dialekt-handling

#If  __FB_VERSION__ < "0.20"

 #Error Please compile With FB version 0.20 Or above

#EndIf



#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__

'}



 #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



'{ DECLARE SUBS and FUNCTIONS

 Declare Function bmpload(file AS String) AS Any Ptr

 Declare Sub makekaleidoskop(kalbild AS UInteger Ptr,zbuff As UInteger Ptr,kal As Integer)

 Declare Sub message(text As String)

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

 Declare Sub setimageplanes(array_ptr As UInteger Ptr,planes As Integer)

'}



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

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



'{ Dims

 Dim Shared As UInteger  _deskb,_deskh



 Dim As UInteger Ptr  orgpic,minipic,srcpic,dstpic,orgdata

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

 Dim As Integer       kalei,minib,minih



 Dim As String  vz=ExePath

 Dim As String  file="\andy.bmp"

'}



   SCREENINFO _deskb,_deskh,bitspp 'Informationen über Desktop abfragen

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



   'vorerst unsichtbares fenster erstellen

   ScreenRes 320,240,32,,GFX_NULL



   'bild laden

   orgpic=bmpload(vz+file)

    If orgpic=0 Then End



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

    gr=smalerval(_deskb,_deskh)*0.5



    ScreenRes gr,gr,32,,GFX_NO_FRAME



    'quell-bildpuffer erstellen (muß immer quadratisch sein)

    srcpic=ImageCreate(gr,gr)

    resizepic(orgpic,srcpic,lopped_mth)



   'größe des mini-bildes festlegen

   minib=gr*0.33

   minih=minib*(orgh/orgb) 'möglichst nahe am original seitenverhältnis

   If minih>gr/2 Then minih=gr/2 'falls das bild zu hoch ist - kürzen



    'mini-bildpuffer erstellen

    minipic=ImageCreate(minib,minih)

    resizepic(orgpic,minipic,jerked_mth) 'vollständig hineinkopieren



    ImageDestroy orgpic 'wird nicht mehr gebraucht



    'ziel-bildpuffer erstellen (muß immer quadratisch sein)

    dstpic=ImageCreate(gr,gr)



    For kalei=0 To 8

        makekaleidoskop(srcpic,dstpic,kalei)

        ScreenLock

      Put(0,0),dstpic,trans

      Put(0,0),minipic,trans

      If gr>104 Then Locate (gr Shr 4)-1,2 : Print "Variante ";kalei;

      ScreenUnLock

      If MultiKey(SC_ESCAPE) Then Exit For

      Sleep 1200

    Next



   ImageDestroy dstpic

    ImageDestroy srcpic

    ImageDestroy minipic



   While InKey<>"" : Sleep 50 : Wend



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 : message("Bild nicht gefunden.("+file+")") : Return 0

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

   Get #ff,19,b

   Get #ff,23,h

   Close #ff



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

      message("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 _

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

   If result Then ImageDestroy sprite _

      : message("Fehler beim Laden des Bildes.") : Return 0



    If bytpp<>4 Then ImageDestroy sprite _

       : message("Dieses Bild ist nicht in True-Color (32 Bit)") : Return 0



   Return sprite



End Function



Sub makekaleidoskop(srcpic As UInteger Ptr,dstpic As UInteger Ptr,kalei As Integer)

'beide bildpuffer müssen existieren, gleich groß und quadratisch sein

'{ Dims

 Dim As UInteger Ptr    tdata,dstdata,srcdata

 Dim As UInteger        x,y,srcb,srch,dstb,dsth,srcofs

 Dim As UInteger        srcb1,srch1,dsth1,dstb1,bytpp

 Dim As UInteger        srcpitch,srcpad,dstpad,dstpitch

 Dim As UInteger        pf 'pixelfarbe

'}



   If (kalei<0) Or (kalei>8) Then Exit Sub



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

   srcpad=srcpitch/bytpp

   srcb1=srcb-1 : srch1=srch-1



   'prüfen, ob das bild in 32bit-farben ist

   If bytpp<>4 Then Exit Sub



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

   dstpad=dstpitch/bytpp

   dstb1=dstb-1 : dsth1=dsth-1



   'prüfen, ob beide bilder quadratisch und in 32bit-farben sind

   If (dstb<>srcb) Or (dsth<>srch) Or (dstb<>srch) Or (dsth<>srcb) Or (bytpp<>4) Then Exit Sub



    If kalei=0 Then resizepic(srcpic,dstpic,jerked_mth) : Exit Sub 'das bild wird nur kopiert



   For y=0 To dsth1 Shr 1

      'zur optimierung ließen sich noch einige multiplikationen, additionen und subtraktionen einsparen !

      For x=y To dstb1 Shr 1

           Select Case kalei

           Case 1 'normales bild   vertikalspiegelnsp

              pf=srcdata[(y*srcpad)+x]

           Case 2 'nur gespiegelt   vertikalspiegeln

              pf=srcdata[(y*srcpad)+srcb1-x]

           Case 3 '90 nach links gedreht   linksdrehen

              pf=srcdata[(x*srcpad)+srcb1-y]

           Case 4 '90 nach rechts gedreht und gespiegelt   rechtsdrehensp

              pf=srcdata[((srch1-x)*srcpad)+srcb1-y]

           Case 5 '180 gedreht   kopfstand

              pf=srcdata[((srch1-y)*srcpad)+srcb1-x]

           Case 6 '180 gedreht und gespiegelt   kopfstandsp

              pf=srcdata[((srch1-y)*srcpad)+x]

           Case 7 '90 nach rechts gedreht   rechtsdrehen

              pf=srcdata[((srch1-x)*srcpad)+y]

           Case 8 '90 nach links gedreht und gespiegelt   linksdrehensp

              pf=srcdata[(x*srcpad)+y]



           End Select



         dstdata[(y*dstpad)+x]               = pf   'vertikalspiegelnsp

         dstdata[(y*dstpad)+dstb1-x]         = pf   'vertikalspiegeln

         dstdata[(x*dstpad)+dstb1-y]         = pf   'linksdrehen

         dstdata[((dsth1-x)*dstpad)+dstb1-y] = pf   'rechtsdrehensp



         dstdata[((dsth1-y)*dstpad)+dstb1-x] = pf   'horizontalspiegeln

         dstdata[((dsth1-y)*dstpad)+x]       = pf   'horizontalspiegelnsp

         dstdata[((dsth1-x)*dstpad)+y]       = pf   'rechtsdrehen

         dstdata[(x*dstpad)+y]               = pf   'linksdrehensp

      Next

   Next



End Sub

Sub message(text As String)

   Screen 14

   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,xend,k,qlofs,boffs,hoffs,bytpp

 Dim As UInteger      punkt

 Dim As Double        brest,hrest

 Dim As Double        bv,hv,hv2,bv2

'}



'padding berechnen

    imageinfo(qp,srcb,srch,bytpp,srcpitch,srcdata)

   srcpad=srcpitch/bytpp



    imageinfo(zp,dstb,dsth,bytpp,dstpitch,dstdata)

   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

   xend=dstb-1

   For y=0 To dsth-1

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

      For x=0 To xend

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

      Next x

      k+=dstpad

   Next y



End Sub

'=================================================
Attachments zum Code-Beispiel
Andy.bmp
Beispielbild für Kaleidoskopeffekt.
pomme
28.03.09
Zusätzliche Informationen und Funktionen
Das Code-Beispiel wurde am 28.03.2009 von pomme angelegt.
Die aktuellste Version wurde am 30.04.2009 von pomme gespeichert.
Bearbeiten
Versionen