Code-Beispiel

Rotation und Skalierung mit MultiPut

Lizenz:	Erster Autor:	Letzte Bearbeitung:
k. A.	MOD	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 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 MOD angelegt.
Die aktuellste Version wurde am 23.02.2012 von Sebastian gespeichert.

Bearbeiten

Versionen