MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]

D.J.Peters · Post by **D.J.Peters** » Jan 01, 2006 19:00

Now for 8,15,16,24 and 32 BPP with clipping and new header support.

Joshy

' by D.J.Peters (Joshy)
' an put, scale, rotate hackfor the new ImageHeader format.
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Rotate],[Trans]

#define UseRad 'if not then Rotate are in degres

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 Trans    As Integer= 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

  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  = 1
    SourceWidth  = cptr(ushort Ptr,lpSource)[0] shr 3
    SourceHeight = cptr(ushort Ptr,lpSource)[1]
    SourcePitch  = SourceWidth
    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)

  Dim As Uinteger i
  Dim As Single x,y
  If MustRotate Then
    #ifndef UseRad
    Rotate*=0.017453292 'degre 2 rad
    #endif
    While Rotate< 0        :rotate+=6.2831853:Wend
    While Rotate>=6.2831853:rotate-=6.2831853: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 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 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 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 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<>&HFFFF00FF Then *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
        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



'
' main
'
#define scr_w 320 'change it
#define scr_h 200

Dim As Any Ptr Sprite
Dim As Single xZoom,yZoom,Rotate
Dim As Integer x,y,b,counter
#define wh scr_w\2
#define hh scr_h\2

screenres scr_w,scr_h,8
'screenres scr_w,scr_h,15
'screenres scr_w,scr_h,16
'screenres scr_w,scr_h,24
'screenres scr_w,scr_h,32

'create an sprite
screeninfo ,,b
If b=8 Then
  Line (0,0)-(100,100),0,BF 'trans rectangle
  Circle (50,50),50,14,,,,F
  Circle (25,30),12,15,,,,F
  Circle (75,30),12,15,,,,F
  Circle (25,30), 7, 0,,,,F
  Circle (75,30), 7, 0,,,,F
  Circle (50,50),28, 0,1.57*2,1.57*4
Else
  Line (0,0)-(100,100),rgb(255,0,255),BF 'trans rectangle
  Circle (50,50),50,rgb(255,255,  0),,,,F
  Circle (25,30),12,rgb(255,255,255),,,,F
  Circle (75,30),12,rgb(255,255,255),,,,F
  Circle (25,30), 7,rgb(  0,  0,  0),,,,F
  Circle (75,30), 7,rgb(  0,  0,  0),,,,F
  Circle (50,50),28,rgb(  0,  0,  0),1.57*2,1.57*4
End If
Sprite=ImageCreate(101,101)
locate 12,2:? "press a key"
getkey
Get (0,0)-(100,100),Sprite
rotate=3.14
While Len(Inkey)=0
  cls
  xZoom=Cos(Rotate*2)*2+2.1
  yZoom=Sin(Rotate*3)*2+2.1
  MultiPut(,wh,hh,Sprite,xZoom,yZoom,Rotate,0) ',1=trans
  Sleep 20:Rotate+=0.01
Wend
End

Adigun A. Polack · Post by **Adigun A. Polack** » Jan 01, 2006 21:25

D.J.Peters, you are THE man!!! I have tested this code out just now and I am so happy to announce that it is flawlessly awesome in any 8-bit graphics mode, plus the fact that it actually supports custom color transparency and screen clipping...... JUST PERFECT for AFlib2, you know? No errors here! :D

Well, catch you later, and I thank you so much for your most excellently executed sprite scaling/rotation routine, my good man!!! You are free to do your 16-/24-/32-bit versions of this, too! ^-^=b !!

Andrew Collins · Post by **Andrew Collins** » Jan 01, 2006 21:27

Error num 57 at line 10

Illegal specification, at parameter 2 ( ) of ()
BYVAL xMidPos AS INTEGER = 0, _

Same error on .15b and .16

EDIT:

I reinstalled FB and it works fine....

Dr_D · Post by **Dr_D** » Jan 02, 2006 3:10

Looks good man. I did notice something though... When it's rotating, I could see some of the yellow pixels out on the edge of the sprite. It looked like they weren't supposed to be there. ;)

axipher · Post by **axipher** » Jan 02, 2006 3:33

I got the same as Dr_D, the yellow pixels and all. Also, in the last part where it keeps placing them over and over again, the outline box of the sprite can be seen in black pixels randomly, I'm thinking it's linked to the yellow pixels.

D.J.Peters · Post by **D.J.Peters** » Jan 02, 2006 19:51

Hallo all,
thank you for the info i will see what it is.
It seams to be a problem with float<->int rounding.

for example:
intY=int(singleY)
must / can be
intY=int(singleY+0.5)

Joshy

SotSvart · Post by **SotSvart** » Jan 02, 2006 23:42

Exellent work! Iv been looking for something like this for awhile. Please keep updateing this, also a 16 and 32bit version would be very usefull.

axipher · Post by **axipher** » Jan 03, 2006 1:29

D.J.Peters wrote:Hallo all,
thank you for the info i will see what it is.
It seams to be a problem with float<->int rounding.

for example:
intY=int(singleY)
must / can be
intY=int(singleY+0.5)

Joshy

I couldn't find that line. Maybe you can tell me about where it is so I can fix it.

D.J.Peters · Post by **D.J.Peters** » Jan 03, 2006 4:51

Hello axipher,
this was only an example what can be wrong.

If i find the wrong part i will fix it.

Joshy

axipher · Post by **axipher** » Jan 03, 2006 15:23

D.J.Peters wrote:Hello axipher,
this was only an example what can be wrong.

If i find the wrong part i will fix it.

Joshy

Sorry, I forgot it was only an example, it was "constructive" critism... Well It works good so far and looks promising, keep up the good work.

D.J.Peters · Post by **D.J.Peters** » Jan 05, 2006 7:33

Use code of the first post now.

Joshy

Adigun A. Polack · Post by **Adigun A. Polack** » Jan 05, 2006 18:33

D.J.Peters, I tested out your newly revised sprite scaling/rotation routine on the 8-, 16-, 24-, and 32-bit color depths, and CAME OUT SO MARVELOUSLY IMPRESSED!!! d=^-^=b !

Also, I found out that there were no loose pixels at all from during your test as well, which I must say is quite an improvement, my man!!

You got yourself a TRUE winner right there with this well-working routine all along, and so I deeply congratulate you on an awesome job well done!!! (^_-)//

See you again, and you are a great FB programmer!!!

Antoni · Post by **Antoni** » Jan 05, 2006 20:14

It's a great job, Joshy!

Dr_D · Post by **Dr_D** » Jan 05, 2006 21:52

Yeah, I didn't see the rogue pixels this time either. Everything seems to work the way it should. Good job. :)

SotSvart · Post by **SotSvart** » Jan 05, 2006 23:15

Works great! =) Ill sure be using this(with propper credits ofcourse..)

One small thing though, using rgb(255,0,255) as colorkey in 16bit mode wont work, but Im not sure if its supposed to be compatible with the color value that rgb returns. Using &b1111100000011111 works though.

MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]

MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]

You rock, D.J.Peters!!! (^-^)//

A most splendid improvement if I do say so myself!!