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

User projects written in or related to FreeBASIC.
Post Reply
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:
Contact D.J.Peters

Post by D.J.Peters »

Hello Lachie Dazdarian feel free and write any tutorial if you like.
My written english are to bad to write readable tutorials and curently i open two business (one pc linux soft- and hardware shop and one IT-consulting) and in germany it consumed all my time and energie to cordinate new rooms new personal new hardware not to speak of the financing.

Joshy
Top
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:
Contact KristopherWindsor

Post by KristopherWindsor »

Hi Joshy. This is a great feature, but I cannot get it to work with

Code: Select all

screenres scr_w,scr_h,32
or 16 or 24 bit display modes. It only works with 8 bit display. Do I have to change other parts of the code, or is the program 'hack' not compatible with my computer?

I am using the second version of multiput you posted here.

_________________________
Recent CVS on Windows 2000
Top
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:
Contact D.J.Peters

Post by D.J.Peters »

KristopherWindsor wrote:Hi Joshy. This is a great feature, but I cannot get it to work...
Sorry thats are "normal" the code are older and lillo changed the Image header. If you can't fix it by your self i will do it on monday.

Joshy
Top
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:
Contact D.J.Peters

Post by D.J.Peters »

Get last version from first post.

Joshy
Top
TbbW
Posts: 348
Joined: Aug 19, 2005 10:08
Contact:
Contact TbbW

Post by TbbW »

D.J.Peters wrote:Get last version from first post.

Joshy
what's the last one of em?
it's like $%#@ of em xD
is it the first one in this topic? is it updated or is it one of the following?
Top
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:
Contact KristopherWindsor

Post by KristopherWindsor »

Goto page #1 of this thread and you will see Joshy's first post:
Last edited by D.J.Peters on Nov 21, 2006 7:32; edited 3 times in total
He put the new code in his first post recently. MultiPut is great! :-D
Top
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Post by counting_pine »

Here's a new (unofficial) version of the sub. The main change I've made is adding support for custom blenders, in the same format as Put Custom.
Two new optional parameters at the end: one is the address of a custom function, one is the Any Ptr that will get passed to it.

Code: Select all

' by D.J.Peters (Joshy)
' a put, scale, rotate hack for the new ImageHeader format.
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans],[Custom],[Param]
' Small changes/additions by counting_pine (2007/04/27)

#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 Trans    as integer= 0, _
             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

  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)

  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
            *t4=Custom(*s4, *t4, 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: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 *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

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

'
' 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
cls
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, @trans) ',1=trans
  sleep 20:Rotate+=0.01
wend

imagedestroy Sprite
If you have any problems, please let me know.
Top
Landeel
Posts: 777
Joined: Jan 25, 2007 10:32
Location: Brazil
Contact:
Contact Landeel

Post by Landeel »

I was wandering. MultiPut can rotate and scale images. But it can't mirror / flip them, can it?
How hard would be implementing MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Mirror],[Flip],[Trans],[Custom],[Param]?
Top
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:
Contact D.J.Peters

Post by D.J.Peters »

Landeel wrote:I was wandering. MultiPut can rotate and scale images. But it can't mirror / flip them, can it?
How hard would be implementing MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Mirror],[Flip],[Trans],[Custom],[Param]?
if any will do it:
IF mirror = TRUE THEN swap the X texture coords
IF flip = TRUE THEN swap the Y texture coords

Joshy
Top
Landeel
Posts: 777
Joined: Jan 25, 2007 10:32
Location: Brazil
Contact:
Contact Landeel

Post by Landeel »

MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Mirror],[Flip],[Trans],[Custom],[Param]

Code: Select all

' 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)

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

  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
            *t4=Custom(*s4, *t4, 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: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 *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

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

'
' 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,,0
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
Cls
'rotate=3.14
rotate=0
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,1,0,0, @trans) ',1=trans
  Sleep 20
  Rotate+=0.01
Wend

imagedestroy Sprite
Top
Stinktier
Posts: 26
Joined: Sep 04, 2008 10:53
Location: Sweden; Gothenburg

Post by Stinktier »

Is there a good, efficient way to smooth the pixels, and reduce that sawtooth effect, when resizing the object?
Top
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:
Contact KristopherWindsor

Post by KristopherWindsor »

Mysoft made a version that is slightly better quality for down-sizing images, but there is no real HQ solution in software / FBGFX. ;)
Top
Dr_D
Posts: 2451
Joined: May 27, 2005 4:59
Contact:
Contact Dr_D

Post by Dr_D »

Mysoft made a version that is slightly better quality for down-sizing images, but there is no real HQ solution in software / FBGFX. ;)
That is not accurate. Fbext has one that uses a different algorithm, which produces better end results, but it's also slower than multiput.
Top
Mysoft
Posts: 836
Joined: Jul 28, 2005 13:56
Location: Brazil, Santa Catarina, Indaial (ouch!)
Contact:
Contact Mysoft

Post by Mysoft »

but he's talking about Resample... (smooth) not resize... and my scaler is a resampler... and is accurate...

and in my opinion Multiput is accurate enough for everything that doesnt require resample...
Top
Stinktier
Posts: 26
Joined: Sep 04, 2008 10:53
Location: Sweden; Gothenburg

Post by Stinktier »

In my case, i could leave that as an option for the player to decide. It depends on what time penalties this would cause but in the end i don't want to cut off any improvement for those who have the possibility to view more smooth graphics without having the game running slower.
Top
Post Reply

Return to “Projects”