How to use Multiput without erosion?

[Tourist Trap]

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]

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]

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]

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