Buchempfehlung
Windows System Programming
Windows System Programming
Das Kompendium liefert viele interessante Informationen zur Windows-Programmierung auf Englisch. [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

Rotation und Skalierung mit MultiPut

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.RedakteurMOD 23.02.2012

MultiPut ist in FreeBASIC-Kreisen eine bekannte Funktion, um Grafiken zu drehen und zu zoomen. Der immer aktuellste MultiPut-Code lässt sich dem Externer Link!Originalthread im englischen Forum entnehmen.

multiput.bi

' by D.J.Peters (Joshy)
' a put, scale, rotate hack for the new ImageHeader format.
'MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Mirror],[Flip],[Trans],[Custom],[Param]
' Small changes/additions by counting_pine (2007/04/27)
' Mirror and Flip parameters added by Cleber de Mattos Casali (2008/08/18)
' Alpha from D.J. Peters added by RayBritton (2008/11/07)

'#define UseRad 'if not then Rotate are in degrees

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 Mirror   As Integer = 0, _
             Byval Flipp   As Integer = 0, _
             Byval Trans    As Integer= 0, _
             Byval alphavalue As Integer = 255, _
             Byval Custom As Function(Byval Src As Uinteger, Byval Dest As Uinteger, Byval Param As Any Ptr = 0) As Uinteger = 0, _
             Byval Param As Any Ptr = 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

   'variables for the alpha blending
     Dim As Uinteger srb = Any
     Dim As Uinteger drb = Any
     Dim As Uinteger  rb = Any
     Dim As Uinteger sr = Any, sg = Any, sb = Any, sa = Any, sa2 = Any
     Dim As Uinteger dr = Any, dg = Any, db = Any, da = Any, da2 = Any
     Dim As Uinteger  r = Any,  g = Any,  b = Any,  a = Any

  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  = cptr(Ushort Ptr,lpSource)[0] And 7
    SourceWidth  = cptr(Ushort Ptr,lpSource)[0] Shr 3
    SourceHeight = cptr(Ushort Ptr,lpSource)[1]
    SourcePitch  = SourceWidth * SourceBytes
    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)

If Mirror Then Swap points(0,xt),points(1,xt) :Swap points(2,xt),points(3,xt)
If Flipp Then Swap points(0,yt),points(3,yt) :Swap points(2,yt),points(1,yt)
'if Mirror then swap points(1,xt),points(2,xt)
'if Flipp then swap points(2,yt),points(3,yt)


  Dim As Uinteger i
  Dim As Single x,y
  If MustRotate Then
    #Ifndef UseRad
    Rotate*=Atn(1)/45 'degree 2 rad
    #EndIf
    While Rotate< 0     :rotate+=8*Atn(1):Wend
    While Rotate>=8*Atn(1):rotate-=8*Atn(1):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    t2c, s2c
  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 Custom Then
          While xStart<xEnd
            s1=lpSource+V*SourcePitch+U
            *t1=Custom(*s1,*t1,Param)
            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
        ElseIf 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 Custom Then
          While xStart<xEnd
            s2=cptr(Short Ptr,lpSource)+V*(SourcePitch Shr 1)+U
            s2c=*s2
            t2c=*t2
            s2c=(s2c And &H001F) Shl 3 Or (s2c Shr 2 And &H000007) Or _
                (s2c And &H07E0) Shl 5 Or (s2c Shr 1 And &H000300) Or _
                (s2c And &HF800) Shl 8 Or (s2c Shl 3 And &H070000) Or &HFF000000
            t2c=(t2c And &H001F) Shl 3 Or (s2c Shr 2 And &H000007) Or _
                (t2c And &H07E0) Shl 5 Or (s2c Shr 1 And &H000300) Or _
                (t2c And &HF800) Shl 8 Or (s2c Shl 3 And &H070000) Or &HFF000000
            t2c=Custom(s2c,t2c,Param)
            *t2=(t2c Shr 3 And &H001F) Or _
                (t2c Shr 5 And &H07E0) Or _
                (t2c Shr 8 And &HF800)
            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
        ElseIf 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 Custom Then
          While xStart<xEnd
            s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
            '***** start alpha blending
       'this set of if...elseif...end if conditions applies alpha blending
       'these 43 lines can be replaced with '*t4 = *s4' to remove blending
       If alphavalue = 0 Then
         'no change needed *t4 = *t4
       Elseif alphavalue = 255 Then
         *t4 = *s4
       Elseif *t4 Shr 24 = 0 Then
         *t4 = *s4
       Elseif *t4 Shr 24 = 255 Then
         srb = *s4 And &h00ff00ff
         sg  = *s4 Xor srb
         sa  = alphavalue

         drb = *t4 And &h00ff00ff
         dg  = *t4 Xor drb
         da  = 256 - sa

             rb = (drb * da + srb * sa) And &hff00ff00
         g  = (dg  * da + sg  * sa) And &h00ff0000

             *t4 = (rb Or g) Shr 8 Or &hff000000
       Else
         sr = (*s4 Shr 16) And 255
         sg = (*s4 Shr  8) And 255
         sb = (*s4     ) And 255
         sa = (alphavalue)

         dr = (*t4 Shr 16) And 255
         dg = (*t4 Shr  8) And 255
         db = (*t4     ) And 255
         da = (*t4 Shr 24)

         sa2 = sa Shl 8
         da2 = da Shl 8 - da * sa
         a = (sa2 + da2)

         r = (dr * da2 + sr * sa2) \ a
         g = (dg * da2 + sg * sa2) \ a
         b = (db * da2 + sb * sa2) \ a
         *t4 = Rgba(r, g, b, a Shr 8)
       End If
            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
        ElseIf 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 And &HFFFFFF)<>&HFF00FF Then
                '***** start alpha blending
         'this set of if...elseif...end if conditions applies alpha blending
         'these 43 lines can be replaced with '*t4 = *s4' to remove blending
         If alphavalue = 0 Then
           'no change needed *t4 = *t4
         Elseif alphavalue = 255 Then
           *t4 = *s4
         Elseif *t4 Shr 24 = 0 Then
           *t4 = *s4
         Elseif *t4 Shr 24 = 255 Then
           srb = *s4 And &h00ff00ff
           sg  = *s4 Xor srb
           sa  = alphavalue

           drb = *t4 And &h00ff00ff
           dg  = *t4 Xor drb
           da  = 256 - sa

           rb = (drb * da + srb * sa) And &hff00ff00
           g  = (dg  * da + sg  * sa) And &h00ff0000

           *t4 = (rb Or g) Shr 8 Or &hff000000
         Else
           sr = (*s4 Shr 16) And 255
           sg = (*s4 Shr  8) And 255
           sb = (*s4       ) And 255
           sa = (alphavalue)

           dr = (*t4 Shr 16) And 255
           dg = (*t4 Shr  8) And 255
           db = (*t4       ) And 255
           da = (*t4 Shr 24)

           sa2 = sa Shl 8
           da2 = da Shl 8 - da * sa
           a = (sa2 + da2)

           r = (dr * da2 + sr * sa2) \ a
           g = (dg * da2 + sg * sa2) \ a
           b = (db * da2 + sb * sa2) \ a
           *t4 = Rgba(r, g, b, a Shr 8)
         End If
         '***** end alpha blending
            End if
            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 Trans(Byval Src As Uinteger, Byval Dest As Uinteger, Byval Param As Any Ptr = 0) As Uinteger

    If (Src And &HFFFFFF) = &HFF00FF Then Return Dest Else Return Src

End Function

Anwendungsbeispiel (entnommen aus dem Projekt OpenBook: 2D-Spieleprogrammierung):

#INCLUDE "multiput.bi"
SCREENRES 400, 300, 32
DIM AS SINGLE rotation = 0, groesse = 1
DIM AS INTEGER mausX, mausY, mausR, mausB, rad

' Bild erstellen
DIM AS ANY PTR bild = IMAGECREATE(50, 50, 0)
LINE bild, (49, 49)-(0, 20), &h0000FF, BF
LINE bild, -(24, 0), &h0000FF
LINE bild, -(49, 20), &h0000FF
PAINT bild, (24, 10), &h00FFFF, &h0000FF

' Hauptprogramm
DO
  SETMOUSE 200, 150, 0, -1
  SLEEP 10
  GETMOUSE mausX, mausY, mausR, mausB
  IF mausX < 0 THEN CONTINUE DO           ' ausserhalb des Fensters
  rotation += (mausX-200)/50
  groesse += (rad-mausR)/10
  IF groesse < 0.1 THEN groesse = 0.1     ' minimale Groesse
  IF groesse > 4 THEN groesse = 4         ' maximale Groesse
  rad = mausR
  SCREENLOCK
  CLS
  MultiPut , 200, 150, bild, groesse, groesse, rotation
  SCREENUNLOCK
LOOP UNTIL mausB > 0 OR INKEY <> ""

' aufraeumen und beenden
IMAGEDESTROY bild

Durch Bewegen der Maus wird das Bild gedreht, durch drehen des Mausrades gezoomt.


Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 21.02.2012 von RedakteurMOD angelegt.
  • Die aktuellste Version wurde am 23.02.2012 von AdministratorSebastian gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen