How to use Multiput without erosion?

New to FreeBASIC? Post your questions here.
Tourist Trap
Posts: 2282
Joined: Jun 02, 2015 16:24

How to use Multiput without erosion?

Postby Tourist Trap » Jan 30, 2018 19:44

Hi,

I'm trying to use Multiput after I have seen the nice tetris variation from badidea at game section.

I certainly should have used it before, but I didn't and unfortunately I fail in something in my trials. My square is being eroded while rotating continuously. It's more a geology simulation than what I would like to do.

Is someone able to show me what I'm doing wrong here?

Code: Select all

 'simulation of erosion with multiput!?                                           

#include "fbgfx.bi"
screenRes 800, 600, 32

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

   #ifndef __MULTIPUT_BI__
   #define __MULTIPUT_BI__
   type FP16 ' fixed point 16:16
     union
     type
       as ushort l
       as  short h
     end type
     as integer v
     end union
   end type
   #define _ADD_ 0 ' increment a value
   #define _CMP_ 1 ' compare 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
         ImageInfo     _
               pTarget     , _
               TargetWidth , _
               TargetHeight, _
               TargetBytes , _
               TargetPitch , _
               pTarget
      End If
         If (TargetWidth<4) Or (TargetHeight<4) Then Exit Sub
      
         ImageInfo     _
               pSource     , _
               SourceWidth , _
               SourceHeight, _
               SourceBytes , _
               SourcePitch , _
               pSource
   
      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(0,_UTexture_)=0
      fPoints(1,_UTexture_)= SourceWidth
      fPoints(2,_UTexture_)= fPoints(1,_UTexture_)
      fPoints(3,_UTexture_)=0
      
      fPoints(0,_VTexture_)=0
      fPoints(1,_VTexture_)=0
      fPoints(2,_VTexture_)= SourceHeight
      fPoints(3,_VTexture_)= fPoints(2,_VTexture_)
   
      If MustRotate=true Then
         #ifndef UseRad
            Rotate*=0.017453292   'deg 2 rad
         #endif
         var co = cos(rotate)
         var si = sin(rotate)
         For i=0 To 3
           var x = fPoints(i,_XScreen_)*co - fPoints(i,_YScreen_)*si
           var y = fPoints(i,_XScreen_)*si + fPoints(i,_YScreen_)*co
           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 xStart = xEnd        Then Exit Sub
      If yEnd   < 0           Then Exit Sub
      If xEnd   < 0           Then Exit Sub
      If yStart>=TargetHeight Then Exit Sub
      If xStart>=TargetWidth  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 NextScanLine
         xStart=fEdges(_LeftIndex_ ,_EdgeXStart_):If xStart>=TargetWidth Then Goto NextScanLine
         xEnd  =fEdges(_RightIndex_,_EdgeXStart_):If xEnd  < 0           Then Goto NextScanLine
         If (xStart=xEnd)                                                Then Goto NextScanLine
         if xEnd  <xStart                                                Then goto NextScanLine
         
         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=-xStart
            U.v=(fEdges(_LeftIndex_,_EdgeUStart_)+fUSlope*fLength)*&HFFFF
            V.v=(fEdges(_LeftIndex_,_EdgeVStart_)+fVSlope*fLength)*&HFFFF
            xStart = 0
         Else
            U.v=fEdges(_LeftIndex_,_EdgeUStart_)*&HFFFF
            V.v=fEdges(_LeftIndex_,_EdgeVStart_)*&HFFFF
         End If
         If u.v<0 Then u.v=0
         If v.v<0 Then v.v=0
         US.v=fUSlope*&HFFFF
         VS.v=fVSlope*&HFFFF
         
         If xEnd>=TargetWidth Then xEnd=TargetWidth-1
         
         Select Case as const TargetBytes
            Case 1
               var s=cptr(ubyte ptr,pSource)
               var t=cptr(ubyte ptr,pTarget)+yStart*TargetPitch+xStart
               var e=t+(xEnd-xStart)
               If Transparent=false Then
                  While t<e
                     *t=*(s+V.h*SourcePitch+U.h)
                     V.v+=VS.v : U.v+=US.v : t+=1
                  Wend
               Else
                  While t<e
                     dim as ubyte c=*(s+V.h*SourcePitch+U.h)
                     If c Then *t=c
                     V.v+=VS.v : U.v+=US.v : t+=1
                  Wend
               End If
            Case 2
               var s=cptr(ushort ptr,pSource)
               var t=cptr(ushort ptr,pTarget)+yStart*TargetPitch+xStart
               var e=t+(xEnd-xStart)
               If Transparent=false Then
                  While t<e
                     *t=*(s+V.h*SourcePitch+U.h)
                     V.v+=VS.v : U.v+=US.v : t+=1
                  Wend
               Else
                  While t<e
                     dim as ushort c=*(s+V.h*SourcePitch+U.h)
                     If c<>&HF81F Then *t=c
                     V.v+=VS.v : U.v+=US.v : t+=1
                  Wend
               End If
            Case 4
               var s=cptr(ulong ptr,pSource)
               var t=cptr(ulong ptr,pTarget)+yStart*TargetPitch+xStart
               var e=t+(xEnd-xStart)
               If Transparent=false Then
                  While t<e
                     *t=*(s+V.h*SourcePitch+U.h)
                     V.v+=VS.v : U.v+=US.v : t+=1
                  Wend
               Else
                  While t<e
                     dim as ulong c=*(s+V.h*SourcePitch+U.h)
                     If c<>&HFFFF00FF Then *t=c
                     V.v+=VS.v : U.v+=US.v : t+=1
                  Wend
               End If
         End Select
         
         NextScanLine:
            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
   #endif ' __MULTIPUT_BI__
end namespace

dim as fb.IMAGE ptr   pImage
scope
   dim as integer   scrW, scrH
   screenInfo   scrW, scrH
   pImage = imagecreate(scrW, scrH)
   line   (200,200)-(scrW - 101, scrH - 101), rgb(100,100,200) , bf
end scope


do
   scope
      '
      dim as integer   scrW, scrH
      screenInfo   scrW, scrH
      get(0, 0)-(scrW - 1, scrH - 1), pImage
      
      for angle as integer = 0 to 89 step 2
         screenlock
            cls
            DJP.MultiPut(0, scrW\2, scrH\2, pImage, 1, 1, angle, true)
         screenunlock
         sleep 10, 1
      next angle
      '
   end scope
loop until chr(27)=inkey()

'(eof)                                                                             


Thanks.
BasicCoder2
Posts: 3087
Joined: Jan 01, 2009 7:03

Re: How to use Multiput without erosion?

Postby BasicCoder2 » Jan 30, 2018 20:52

You get the image when it has rotated outside boundary. Place get outside the loop.

Code: Select all

dim as integer   scrW, scrH
screenInfo   scrW, scrH
get(0, 0)-(scrW - 1, scrH - 1), pImage

do
   scope
      'for angle as integer = 0 to 89 step 2
      for angle as single = 0 to 359 step 2
         screenlock
            cls
            DJP.MultiPut(0, scrW\2, scrH\2, pImage, 1, 1, angle, true)
         screenunlock
         sleep 10, 1
      next angle
      '
   end scope
loop until chr(27)=inkey()
badidea
Posts: 653
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: How to use Multiput without erosion?

Postby badidea » Jan 30, 2018 22:24

Tourist Trap wrote:I'm trying to use Multiput after I have seen the nice tetris variation from badidea at game section.

:-) My plan continue improving the 'twisted' Tetris variant, but a bit busy at the moment with my house. I have already a different Tetris variation in mind. Tetris is complex enough to be a challenge, but not too complex or large to end in stagnation (I hope), as happened with my previous game attempts.
dodicat
Posts: 4764
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: How to use Multiput without erosion?

Postby dodicat » Jan 31, 2018 1:33

angles by radian.
different rotation fulcrum.
Simple image rotator.
-gen gas for more speed.

Code: Select all


Sub rotate(im As Any Ptr,angle As single,shiftx As long=0,shifty As long=0,sc As Single=1)
    static As Integer pitch,pitchs,xres,yres,runflag
    static As Any Ptr row
    static As integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
   if runflag=0 then Screeninfo xres,yres,,,pitchS:runflag=1
    Dim As Any Ptr rowS=Screenptr
    Dim As long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
    For y As long=centrey-fx*mx+1 To centrey+ fx*mx
        dim as single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As long=centrex-mx*fx To centrex+mx*fx
             'on screen
                 if x+shiftx >=0 then
                    if x+shiftx <xres then
                        if shfty >=0 then
                            if shfty<yres then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                'on image
                if resultx >=0 then
                    if resultx<ddx then
                        if resulty>=0 then
                            if resulty<ddy then
    *cast(ulong ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= _
    *cast(ulong ptr,row+pitch*((resultY))+((resultX)) Shl 2 )
                End If:end if:end if:end if
                End If:end if:end if:end if
        Next x
    Next y
End Sub

#include "fbgfx.bi"
screenRes 800, 600, 32
dim as fb.IMAGE ptr   pImage
scope
   dim as integer   scrW, scrH
   screenInfo   scrW, scrH
   pImage = imagecreate(scrW, scrH)
   line   (200,200)-(scrW - 101, scrH - 101), rgb(100,100,200) , bf
end scope
dim as double pi=4*atn(1)

do
   scope
      '
      dim as integer   scrW, scrH
      screenInfo   scrW, scrH
      get(0, 0)-(scrW - 1, scrH - 1), pImage
     
      for angle as double = 0 to 2*pi step .05
         screenlock
            cls
            rotate(pimage,angle,scrW\2-400, scrH\2-300,1)
         screenunlock
         sleep 10, 1
      next angle
      '
   end scope
loop until chr(27)=inkey()
 

Return to “Beginners”

Who is online

Users browsing this forum: No registered users and 2 guests