MultiPut() for FreeBASIC >=1.0.4

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
D.J.Peters
Posts: 8631
Joined: May 28, 2005 3:28
Contact:
Contact D.J.Peters

MultiPut() for FreeBASIC >=1.0.4

Post by D.J.Peters »

Code: Select all

' Multiput by D.J.Peters (Joshy)
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]

type FP16 ' fixed point 16:16
  union
  type
    as ushort l
    as  short h
  end type
  as integer v
  end union
end type

#macro DrawSpawn(_type_)
  var t=cptr(_type_ ptr,pTarget)+yStart*TargetPitch+xStart
  xStart=0
  If Transparent=false Then
    While xStart<xEnd
      var s=cptr(_type_ ptr,pSource)+V.h*SourcePitch+U.h
      *t=*s
      U.v+=US.v : V.v+=VS.v : If v.v<0 Then v.v=0
      xStart+=1:t+=1
    Wend
  Else
    While xStart<xEnd
      var s=cptr(_type_ ptr,pSource)+V.h*SourcePitch+U.h
      If *s Then *t=*s
      U.v+=US.v : V.v+=VS.v : If v.v<0 Then v.v=0
      xStart+=1:t+=1
    Wend
  End If
#endmacro

#define _ADD_ 0 ' increment a value
#define _CMP_ 1 ' compare a values
#define _SET_ 2 ' set a value

#define _XScreen_  0
#define _YScreen_  1
#define _UTexture_ 2
#define _VTexture_ 3

#define _LeftIndex_    0
#define _RightIndex_   1

#define _CurrentIndex_ 0
#define _NextIndex_    1

#define _EdgeXStart_ 0
#define _EdgeUStart_ 1
#define _EdgeVStart_ 2
#define _EdgeXStep_  3
#define _EdgeUStep_  4
#define _EdgeVStep_  5

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

Sub MultiPut(Byval pTarget As Any Ptr= 0, _
             Byval xMidPos As Integer= 0, _
             Byval yMidPos As Integer= 0, _
             Byval pSource As Any Ptr   , _
             Byval xScale  As Single = 1, _
             Byval yScale  As Single = 1, _
             Byval Rotate  As Single = 0, _
             Byval Transparent As boolean = false)
  Dim As Integer SourceWidth=any,SourceHeight=any,SourceBytes=any,SourcePitch=any
  Dim as Integer TargetWidth=any,TargetHeight=any,TargetBytes=any,TargetPitch=any
  Dim As Integer i=any,yStart=any,yEnd=any,xStart=any,xEnd=any
  Dim As Integer CNS(1,1)=any 'Counters
  Dim As Integer ACS(1,2)=any '_ADD_ compare and _SET_
  Dim As Single fPoints(3,3)=any,fEdges(2,6)=any,fLength=any,fUSlope=any,fVSlope=any
  Dim As FP16 U=any,V=any,US=any,VS=any
  Dim As boolean MustRotate = iif(Rotate<>0,true,false)

  If (screenptr=0) Or (pSource=0) Then Exit Sub

  If xScale < 0.001 Then xScale=0.001
  If yScale < 0.001 Then yScale=0.001
 
  If pTarget=0 Then
    ScreenInfo    _
    TargetWidth  , _
    TargetHeight,, _
    TargetBytes  ,_
    TargetPitch
    pTarget=ScreenPtr
  Else
    TargetBytes  = cptr(uinteger Ptr,pTarget)[1]
    TargetWidth  = cptr(uinteger Ptr,pTarget)[2]
    TargetHeight = cptr(uinteger Ptr,pTarget)[3]
    TargetPitch  = cptr(uinteger Ptr,pTarget)[4]
    pTarget    += 32
  End If
  If (TargetWidth<4) Or (TargetHeight<4) Then Exit Sub

  SourceBytes  = cptr(uinteger Ptr,pSource)[1]
  If (TargetBytes<>SourceBytes) Then Exit Sub

  SourceWidth  = cptr(uinteger Ptr,pSource)[2]
  SourceHeight = cptr(uinteger Ptr,pSource)[3]
  If (SourceWidth<2) Or (SourceHeight<2) Then Exit Sub

  SourcePitch  = cptr(uinteger Ptr,pSource)[4]
  pSource    += 32


  Select Case as const TargetBytes
  case 1    ' TargetPitch shr=0 : SourcePitch shr=0
  case 2    : TargetPitch shr=1 : SourcePitch shr=1
  case 4    : TargetPitch shr=2 : SourcePitch shr=2
  case else : exit sub
  end select

  fPoints(0,_XScreen_)=-SourceWidth/2 * xScale
  fPoints(1,_XScreen_)= SourceWidth/2 * xScale
  fPoints(2,_XScreen_)= fPoints(1,_XScreen_)
  fPoints(3,_XScreen_)= fPoints(0,_XScreen_)

  fPoints(0,_YScreen_)=-SourceHeight/2 * yScale
  fPoints(1,_YScreen_)= fPoints(0,_YScreen_)
  fPoints(2,_YScreen_)= SourceHeight/2 * yScale
  fPoints(3,_YScreen_)= fPoints(2,_YScreen_)

  fPoints(1,_UTexture_)= SourceWidth
  fPoints(2,_UTexture_)= fPoints(1,_UTexture_)
  fPoints(2,_VTexture_)= SourceHeight
  fPoints(3,_VTexture_)= fPoints(2,_VTexture_)

  If MustRotate=true 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
      var x =fPoints(i,_XScreen_)*Cos(Rotate) - fPoints(i,_YScreen_)*Sin(Rotate)
      var y =fPoints(i,_XScreen_)*Sin(Rotate) + fPoints(i,_YScreen_)*Cos(Rotate)
      fPoints(i,_XScreen_)=x:fPoints(i,_YScreen_)=y
    Next
  End If
  yStart=30^2:yEnd=-yStart:xStart=yStart:xEnd=yEnd
  
  ' get min max
  For i=0 To 3
    fPoints(i,_XScreen_)=Int(fPoints(i,_XScreen_)+xMidPos)
    fPoints(i,_YScreen_)=Int(fPoints(i,_YScreen_)+yMidPos)
    If fPoints(i,_YScreen_)<yStart Then yStart=fPoints(i,_YScreen_):CNS(_LeftIndex_,_CurrentIndex_)=i
    If fPoints(i,_YScreen_)>yEnd   Then yEnd  =fPoints(i,_YScreen_)
    If fPoints(i,_XScreen_)<xStart Then xStart=fPoints(i,_XScreen_)
    If fPoints(i,_XScreen_)>xEnd   Then xEnd  =fPoints(i,_XScreen_)
  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
 
  ACS(_LeftIndex_ ,_ADD_)=-1:ACS(_LeftIndex_ ,_CMP_)=-1:ACS(_LeftIndex_ ,_SET_)=3
  ACS(_RightIndex_,_ADD_)= 1:ACS(_RightIndex_,_CMP_)= 4:ACS(_RightIndex_,_SET_)=0

  ' share the same highest point
  CNS(_RightIndex_,_CurrentIndex_)=CNS(_LeftIndex_,_CurrentIndex_)
 
  ' loop from Top to Bottom
  While yStart<yEnd
    'Scan Left and Right edges together
    For i=_LeftIndex_ To _RightIndex_
      ' bad to read but fast and short ;-)
      If yStart=fPoints(CNS(i,_CurrentIndex_),_YScreen_) Then
        CNS(i,_NextIndex_)=CNS(i,_CurrentIndex_)+ACS(i,_ADD_)
        If CNS(i,_NextIndex_)=ACS(i,_CMP_) Then CNS(i,_NextIndex_)=ACS(i,_SET_)
        While fPoints(CNS(i,_CurrentIndex_),_YScreen_) = fPoints(CNS(i,_NextIndex_),_YScreen_)
          CNS(i,_CurrentIndex_)=CNS(i,_NextIndex_)
          CNS(i,_NextIndex_   )=CNS(i,_CurrentIndex_)+ACS(i,_ADD_)
          If CNS(i,_NextIndex_)=ACS(i,_CMP_) Then CNS(i,_NextIndex_)=ACS(i,_SET_)
        Wend
        fEdges(i,_EdgeXStart_) = fPoints(CNS(i,_CurrentIndex_),_XScreen_)
        fEdges(i,_EdgeUStart_) = fPoints(CNS(i,_CurrentIndex_),_UTexture_)
        fEdges(i,_EdgeVStart_) = fPoints(CNS(i,_CurrentIndex_),_VTexture_)
        fLength  = fPoints(CNS(i,_NextIndex_),_YScreen_) - fPoints(CNS(i,_CurrentIndex_),_YScreen_)
        If fLength <> 0.0 Then
          fLength=1/fLength
          fEdges(i,_EdgeXStep_) = fPoints(CNS(i,_NextIndex_),_XScreen_ )-fEdges(i,_EdgeXStart_):fEdges(i,_EdgeXStep_)*=fLength
          fEdges(i,_EdgeUStep_) = fPoints(CNS(i,_NextIndex_),_UTexture_)-fEdges(i,_EdgeUStart_):fEdges(i,_EdgeUStep_)*=fLength
          fEdges(i,_EdgeVStep_) = fPoints(CNS(i,_NextIndex_),_VTexture_)-fEdges(i,_EdgeVStart_):fEdges(i,_EdgeVStep_)*=fLength
        End If
        CNS(i,_CurrentIndex_)=CNS(i,_NextIndex_)
      End If
    Next

    If (yStart<0)                                                    Then Goto SkipScanLine
    xStart=fEdges(_LeftIndex_ ,_EdgeXStart_) :If xStart>=TargetWidth Then Goto SkipScanLine
    xEnd  =fEdges(_RightIndex_,_EdgeXStart_):If xEnd  < 0            Then Goto SkipScanLine
    If (xStart=xEnd)                                                 Then Goto SkipScanLine
    if xEnd  <xStart                                                 Then goto SkipScanLine
    fLength=1/(xEnd-xStart)
    fUSlope=fEdges(_RightIndex_,_EdgeUStart_)-fEdges(_LeftIndex_,_EdgeUStart_):fUSlope*=fLength
    fVSlope=fEdges(_RightIndex_,_EdgeVStart_)-fEdges(_LeftIndex_,_EdgeVStart_):fVSlope*=fLength
    If xstart<0 Then
      fLength=Abs(xStart)
      U.v=(fEdges(_LeftIndex_,_EdgeUStart_)+fUSlope*fLength)*65536
      V.v=(fEdges(_LeftIndex_,_EdgeVStart_)+fVSlope*fLength)*65536
      xStart = 0
    Else
      U.v=fEdges(_LeftIndex_,_EdgeUStart_)*65536
      V.v=fEdges(_LeftIndex_,_EdgeVStart_)*65536
    End If
    If u.v<0 Then u.v=0
    If v.v<0 Then v.v=0
    US.v=fUSlope*65536
    VS.v=fVSlope*65536

    If xEnd>=TargetWidth Then xEnd=TargetWidth-1
    xEnd-=xStart

    Select Case as const TargetBytes
      Case 1
        DrawSpawn(ubyte)
      Case 2
        DrawSpawn(ushort)
      Case 4
        DrawSpawn(ulong)
    End Select

SkipScanLine:
    yStart+=1 : If yStart=TargetHeight Then exit while
    fEdges(_LeftIndex_ ,_EdgeXStart_)+=fEdges(_LeftIndex_ ,_EdgeXStep_)
    fEdges(_LeftIndex_ ,_EdgeUStart_)+=fEdges(_LeftIndex_ ,_EdgeUStep_)
    fEdges(_LeftIndex_ ,_EdgeVStart_)+=fEdges(_LeftIndex_ ,_EdgeVStep_)
    fEdges(_RightIndex_,_EdgeXStart_)+=fEdges(_RightIndex_,_EdgeXStep_)
    fEdges(_RightIndex_,_EdgeUStart_)+=fEdges(_RightIndex_,_EdgeUStep_)
    fEdges(_RightIndex_,_EdgeVStart_)+=fEdges(_RightIndex_,_EdgeVStep_)
  Wend
End Sub

screenres 1024,480,32
dim as integer w,h
screeninfo w,h

var img=ImageCreate(128,128,rgb(255,255,255))
line img,(0,0)-step(127,127),RGB(255,255,255),BF
for i as integer = 0 to 127 step 32
  line img,(i,0)-step(0,127),rgb(128,128,128)
  line img,(i+1,0)-step(0,127),rgb(128,128,128)
  line img,(0,i)-step(127,0),rgb(128,128,128)
  line img,(0,i+1)-step(127,0),rgb(128,128,128)
next
for i as integer = 0 to 3
  line img,(i,i)-step(127-i*2,127-i*2),RGB(0,0,255),B
next
draw string img,(24,9),"MultiPut()",RGB(0,0,0)

dim as single rot
while inkey()=""
  screenlock : line (0,0)-step(w-1,h-1),0,BF
    dim as single x
    for i as integer = 1 to 7
      dim as single scale = i*.25
      x+=scale*128
      multiPut ,x,240,img,scale,scale,rot
    next
    put (2,2),img,PSET
  screenunlock
  rot+=.5
  sleep 10
wend
Last edited by D.J.Peters on Oct 25, 2015 9:54, edited 4 times in total.
Top
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: MultiPut() for FreeBASIC >=1.0.4

Post by sean_vn »

I'm not sure it really worked on my system, depending on what it was supposed to do. Likely a misunderstanding on my part.
Last edited by sean_vn on Oct 27, 2015 0:51, edited 1 time in total.
Top
BasicCoder2
Posts: 3954
Joined: Jan 01, 2009 7:03
Location: Australia

Re: MultiPut() for FreeBASIC >=1.0.4

Post by BasicCoder2 »

@Joshy,
So is this version faster than the other version?
If so are there any other differences in behaviour to the other version?
Is the put commmand faster than multiput when there is no scaling or rotation involved?

The fast scaling was useful when auto fitting a large bitmap into a smaller picture box. The fast rotation would also be useful on large images to rotate an image 90 degrees as can be done with Microsoft Photo Viewer to adjust pictures taken with the camera held side ways.

This is a little demo program I wrote in which I have replaced my own rotateImage routine with multiput.
Note I have changed your multiput code to compile with the FreeBASIC Compiler - Version 0.24.0 that I use.

multiput.bi (compiles with FreeBASIC Compiler - Version 0.24.0)

Code: Select all

' Multiput by D.J.Peters (Joshy)
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]
const TRUE = -1
const FALSE = 0

type FP16 ' fixed point 16:16
  union
  type
    as ushort l
    as  short h
  end type
  as integer v
  end union
end type

#macro DrawSpawn(_type_)
  var t=cptr(_type_ ptr,pTarget)+yStart*TargetPitch+xStart
  xStart=0
  If Transparent=false Then
    While xStart<xEnd
      var s=cptr(_type_ ptr,pSource)+V.h*SourcePitch+U.h
      *t=*s
      U.v+=US.v : V.v+=VS.v : If v.v<0 Then v.v=0
      xStart+=1:t+=1
    Wend
  Else
    While xStart<xEnd
      var s=cptr(_type_ ptr,pSource)+V.h*SourcePitch+U.h
      If *s Then *t=*s
      U.v+=US.v : V.v+=VS.v : If v.v<0 Then v.v=0
      xStart+=1:t+=1
    Wend
  End If
#endmacro

#define _ADD_ 0 ' increment a value
#define _CMP_ 1 ' compare a values
#define _SET_ 2 ' set a value

#define _XScreen_  0
#define _YScreen_  1
#define _UTexture_ 2
#define _VTexture_ 3

#define _LeftIndex_    0
#define _RightIndex_   1

#define _CurrentIndex_ 0
#define _NextIndex_    1

#define _EdgeXStart_ 0
#define _EdgeUStart_ 1
#define _EdgeVStart_ 2
#define _EdgeXStep_  3
#define _EdgeUStep_  4
#define _EdgeVStep_  5

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

Sub MultiPut(Byval pTarget As Any Ptr= 0, _
             Byval xMidPos As Integer= 0, _
             Byval yMidPos As Integer= 0, _
             Byval pSource As Any Ptr   , _
             Byval xScale  As Single = 1, _
             Byval yScale  As Single = 1, _
             Byval Rotate  As Single = 0, _
             Byval Transparent As integer = false)
  Dim As Integer SourceWidth=any,SourceHeight=any,SourceBytes=any,SourcePitch=any
  Dim as Integer TargetWidth=any,TargetHeight=any,TargetBytes=any,TargetPitch=any
  Dim As Integer i=any,yStart=any,yEnd=any,xStart=any,xEnd=any
  Dim As Integer CNS(1,1)=any 'Counters
  Dim As Integer ACS(1,2)=any '_ADD_ compare and _SET_
  Dim As Single fPoints(3,3)=any,fEdges(2,6)=any,fLength=any,fUSlope=any,fVSlope=any
  Dim As FP16 U=any,V=any,US=any,VS=any
  Dim As integer MustRotate = iif(Rotate<>0,true,false)

  If (screenptr=0) Or (pSource=0) Then Exit Sub

  If xScale < 0.001 Then xScale=0.001
  If yScale < 0.001 Then yScale=0.001
 
  If pTarget=0 Then
    ScreenInfo    _
    TargetWidth  , _
    TargetHeight,, _
    TargetBytes  ,_
    TargetPitch
    pTarget=ScreenPtr
  Else
    TargetBytes  = cptr(uinteger Ptr,pTarget)[1]
    TargetWidth  = cptr(uinteger Ptr,pTarget)[2]
    TargetHeight = cptr(uinteger Ptr,pTarget)[3]
    TargetPitch  = cptr(uinteger Ptr,pTarget)[4]
    pTarget    += 32
  End If
  If (TargetWidth<4) Or (TargetHeight<4) Then Exit Sub

  SourceBytes  = cptr(uinteger Ptr,pSource)[1]
  If (TargetBytes<>SourceBytes) Then Exit Sub

  SourceWidth  = cptr(uinteger Ptr,pSource)[2]
  SourceHeight = cptr(uinteger Ptr,pSource)[3]
  If (SourceWidth<2) Or (SourceHeight<2) Then Exit Sub

  SourcePitch  = cptr(uinteger Ptr,pSource)[4]
  pSource    += 32


  Select Case as const TargetBytes
  case 1    ' TargetPitch shr=0 : SourcePitch shr=0
  case 2    : TargetPitch shr=1 : SourcePitch shr=1
  case 4    : TargetPitch shr=2 : SourcePitch shr=2
  case else : exit sub
  end select

  fPoints(0,_XScreen_)=-SourceWidth/2 * xScale
  fPoints(1,_XScreen_)= SourceWidth/2 * xScale
  fPoints(2,_XScreen_)= fPoints(1,_XScreen_)
  fPoints(3,_XScreen_)= fPoints(0,_XScreen_)

  fPoints(0,_YScreen_)=-SourceHeight/2 * yScale
  fPoints(1,_YScreen_)= fPoints(0,_YScreen_)
  fPoints(2,_YScreen_)= SourceHeight/2 * yScale
  fPoints(3,_YScreen_)= fPoints(2,_YScreen_)

  fPoints(1,_UTexture_)= SourceWidth
  fPoints(2,_UTexture_)= fPoints(1,_UTexture_)
  fPoints(2,_VTexture_)= SourceHeight
  fPoints(3,_VTexture_)= fPoints(2,_VTexture_)

  If MustRotate=true 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
      var x =fPoints(i,_XScreen_)*Cos(Rotate) - fPoints(i,_YScreen_)*Sin(Rotate)
      var y =fPoints(i,_XScreen_)*Sin(Rotate) + fPoints(i,_YScreen_)*Cos(Rotate)
      fPoints(i,_XScreen_)=x:fPoints(i,_YScreen_)=y
    Next
  End If
  yStart=30^2:yEnd=-yStart:xStart=yStart:xEnd=yEnd
  
  ' get min max
  For i=0 To 3
    fPoints(i,_XScreen_)=Int(fPoints(i,_XScreen_)+xMidPos)
    fPoints(i,_YScreen_)=Int(fPoints(i,_YScreen_)+yMidPos)
    If fPoints(i,_YScreen_)<yStart Then yStart=fPoints(i,_YScreen_):CNS(_LeftIndex_,_CurrentIndex_)=i
    If fPoints(i,_YScreen_)>yEnd   Then yEnd  =fPoints(i,_YScreen_)
    If fPoints(i,_XScreen_)<xStart Then xStart=fPoints(i,_XScreen_)
    If fPoints(i,_XScreen_)>xEnd   Then xEnd  =fPoints(i,_XScreen_)
  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
 
  ACS(_LeftIndex_ ,_ADD_)=-1:ACS(_LeftIndex_ ,_CMP_)=-1:ACS(_LeftIndex_ ,_SET_)=3
  ACS(_RightIndex_,_ADD_)= 1:ACS(_RightIndex_,_CMP_)= 4:ACS(_RightIndex_,_SET_)=0

  ' share the same highest point
  CNS(_RightIndex_,_CurrentIndex_)=CNS(_LeftIndex_,_CurrentIndex_)
 
  ' loop from Top to Bottom
  While yStart<yEnd
    'Scan Left and Right edges together
    For i=_LeftIndex_ To _RightIndex_
      ' bad to read but fast and short ;-)
      If yStart=fPoints(CNS(i,_CurrentIndex_),_YScreen_) Then
        CNS(i,_NextIndex_)=CNS(i,_CurrentIndex_)+ACS(i,_ADD_)
        If CNS(i,_NextIndex_)=ACS(i,_CMP_) Then CNS(i,_NextIndex_)=ACS(i,_SET_)
        While fPoints(CNS(i,_CurrentIndex_),_YScreen_) = fPoints(CNS(i,_NextIndex_),_YScreen_)
          CNS(i,_CurrentIndex_)=CNS(i,_NextIndex_)
          CNS(i,_NextIndex_   )=CNS(i,_CurrentIndex_)+ACS(i,_ADD_)
          If CNS(i,_NextIndex_)=ACS(i,_CMP_) Then CNS(i,_NextIndex_)=ACS(i,_SET_)
        Wend
        fEdges(i,_EdgeXStart_) = fPoints(CNS(i,_CurrentIndex_),_XScreen_)
        fEdges(i,_EdgeUStart_) = fPoints(CNS(i,_CurrentIndex_),_UTexture_)
        fEdges(i,_EdgeVStart_) = fPoints(CNS(i,_CurrentIndex_),_VTexture_)
        fLength  = fPoints(CNS(i,_NextIndex_),_YScreen_) - fPoints(CNS(i,_CurrentIndex_),_YScreen_)
        If fLength <> 0.0 Then
          fLength=1/fLength
          fEdges(i,_EdgeXStep_) = fPoints(CNS(i,_NextIndex_),_XScreen_ )-fEdges(i,_EdgeXStart_):fEdges(i,_EdgeXStep_)*=fLength
          fEdges(i,_EdgeUStep_) = fPoints(CNS(i,_NextIndex_),_UTexture_)-fEdges(i,_EdgeUStart_):fEdges(i,_EdgeUStep_)*=fLength
          fEdges(i,_EdgeVStep_) = fPoints(CNS(i,_NextIndex_),_VTexture_)-fEdges(i,_EdgeVStart_):fEdges(i,_EdgeVStep_)*=fLength
        End If
        CNS(i,_CurrentIndex_)=CNS(i,_NextIndex_)
      End If
    Next

    If (yStart<0)                                                    Then Goto SkipScanLine
    xStart=fEdges(_LeftIndex_ ,_EdgeXStart_) :If xStart>=TargetWidth Then Goto SkipScanLine
    xEnd  =fEdges(_RightIndex_,_EdgeXStart_):If xEnd  < 0            Then Goto SkipScanLine
    If (xStart=xEnd)                                                 Then Goto SkipScanLine
    if xEnd  <xStart                                                 Then goto SkipScanLine
    fLength=1/(xEnd-xStart)
    fUSlope=fEdges(_RightIndex_,_EdgeUStart_)-fEdges(_LeftIndex_,_EdgeUStart_):fUSlope*=fLength
    fVSlope=fEdges(_RightIndex_,_EdgeVStart_)-fEdges(_LeftIndex_,_EdgeVStart_):fVSlope*=fLength
    If xstart<0 Then
      fLength=Abs(xStart)
      U.v=(fEdges(_LeftIndex_,_EdgeUStart_)+fUSlope*fLength)*65536
      V.v=(fEdges(_LeftIndex_,_EdgeVStart_)+fVSlope*fLength)*65536
      xStart = 0
    Else
      U.v=fEdges(_LeftIndex_,_EdgeUStart_)*65536
      V.v=fEdges(_LeftIndex_,_EdgeVStart_)*65536
    End If
    If u.v<0 Then u.v=0
    If v.v<0 Then v.v=0
    US.v=fUSlope*65536
    VS.v=fVSlope*65536

    If xEnd>=TargetWidth Then xEnd=TargetWidth-1
    xEnd-=xStart

    Select Case as const TargetBytes
      Case 1
        DrawSpawn(ubyte)
      Case 2
        DrawSpawn(ushort)
      Case 4
        DrawSpawn(ulong)
    End Select

SkipScanLine:
    yStart+=1 : If yStart=TargetHeight Then exit while
    fEdges(_LeftIndex_ ,_EdgeXStart_)+=fEdges(_LeftIndex_ ,_EdgeXStep_)
    fEdges(_LeftIndex_ ,_EdgeUStart_)+=fEdges(_LeftIndex_ ,_EdgeUStep_)
    fEdges(_LeftIndex_ ,_EdgeVStart_)+=fEdges(_LeftIndex_ ,_EdgeVStep_)
    fEdges(_RightIndex_,_EdgeXStart_)+=fEdges(_RightIndex_,_EdgeXStep_)
    fEdges(_RightIndex_,_EdgeUStart_)+=fEdges(_RightIndex_,_EdgeUStep_)
    fEdges(_RightIndex_,_EdgeVStart_)+=fEdges(_RightIndex_,_EdgeVStep_)
  Wend
End Sub
SineWaveBird.bas

Code: Select all

#include "multiput.bi"

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32
color rgb(0,0,0),rgb(255,255,255):cls         
dim as any ptr extraScreen
extraScreen = imagecreate(640,480,rgb(255,0,255))

dim as uinteger c
 'cycle through 360 degrees in steps of 10 degrees
dim shared as any ptr bird,rotBird
bird    = imagecreate(64,64,rgb(255,0,255))
rotBird = imagecreate(64,64,rgb(255,0,255))

'bload "C:\FreeBasic\BirdGame\rotBird1.bmp",bird
dim as string datum,char
for j as integer = 0 to 18
    read datum
    for i as integer = 0 to 31
        char = mid(datum,i+1,1)
        if char = "$" then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(239,228,176),bf
        end if
        if char = "*" then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(153,217,234),bf
        end if
        if char = "&" then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(255,127,39),bf
        end if
        if char = "@" then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(185,122,87),bf
        end if
        if char = "+" then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(255,201,14),bf
        end if
        if char = "#" then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(64,64,64),bf
        end if
        if char = "." then
            line bird,(i*2,j*2+13)-(i*2+1,j*2+14),rgb(255,0,255),bf
        end if
    next i
next j

sub rotateImage(img as any ptr,ww as double)
    dim as double tx,ty,nx,ny,vx,vy,angle
    angle = (ww+180)*DtoR    
    dim as uinteger c
    for yp as double = 0 to 63 step .5
        for xp as double = 0 to 63 step .5      
            c = point(xp,yp,bird):'get color
            'select centre of image as centre of rotation
            vx = xp-32
            vy = yp-32      
            'equations to compute new x,y coordinates for rotation of ww degrees
            tx = cos(angle) * vx - sin(angle) * vy
            ty = cos(angle) * vy + sin(angle) * vx      
            nx = tx+32
            ny = ty+32
            pset rotBird,(nx,ny),c      
         next xp
    next yp
end sub

dim as double dx1,dy1,dx2,dy2,px1,py1,px2,py2,newAngle
line (0,100)-(640,100),rgb(255,0,0)
for ww as double = 0 to 639
    dx1 = Cos((ww-5)*DtoR)*50
    dy1 = Sin((ww-5)*DtoR)*50
    px1 = ww
    py1 = 100 + dx1
    dx2 = Cos((ww+5)*DtoR)*50
    dy2 = Sin((ww+5)*DtoR)*50
    px2 = ww+10
    py2 = 100 + dx2    
 
    screenlock()
    cls
    line (0,100)-(640,100),rgb(255,0,0)
    newAngle = atan2((py1-py2),(px1-px2))*RtoD
    
    'rotateImage(bird,newAngle)
    multiput rotBird,31,31,bird,1,1,newAngle+180,1

    'rotateImage(bird,newAngle)
    circle extraScreen,(ww,py1),3,rgb(0,0,255),,,,f

    put (0,0),extraScreen,trans
    put  (ww-32,py1-32),rotBird,trans
    
   
    screenunlock()
    sleep 10
next ww
sleep

data "............##########.........."
data "..........##@@@@@@@@###........."
data "........##@@@@@@@@@#***#........"
data ".......#@@@@@@@@@@#*****#......."
data "......#@@@@@@@@@@@#**##*#......."
data ".....#@@@@@@@@@@@@#**##*#......."
data ".....#@@##@@@@@@@@#****##......."
data ".....###$$##@@@@@@@####&&##....."
data "....##$$$$$$#@@@@@@@##&&&&&##..."
data "...##$$$$$$$$#@@@@@@##&&&&#&&#.."
data ".##$$$$$$$$$$#@@@@@###&&&&&&&&#."
data "#$$$$$$$$$$$$#@@@@@###&&&&&&&&&#"
data ".#$$$$$$$$$$$#@@@@#++##########."
data "..#$$$$$$$$$$#@@@#+++#&&&&&#...."
data "...#$$$$$$$$#+++++++++#####....."
data "....###$$###+++++++++#.........."
data ".......####+++++++++#..........."
data "...........#+++++++#............"
data "............#######............."
Top
Post Reply

Return to “Sources, Examples, Tips and Tricks”