MultiPut V2.0 :-)

[D.J.Peters]

MultiPut V2.0 :-)
(with fixed point)

Joshy
file: MultiPut.bi

Code: Select all

#ifndef __MULTIPUT_BI__
#define __MULTIPUT_BI__

' 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

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

[D.J.Peters]

Test for 16/24/32 bit mode (pink=transparent)

Joshy

Code: Select all

#include "MultiPut.bi"
'
' main
'
dim as single rotation(5)
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
' some holes (in pink)
circle img,(12    ,12    ),8,RGB(255,0,255),,,,F
circle img,(127-12,12    ),8,RGB(255,0,255),,,,F
circle img,(12    ,127-12),8,RGB(255,0,255),,,,F
circle img,(127-12,127-12),8,RGB(255,0,255),,,,F
' yes baby version 2.0 :-)
draw string img,(24,9   ),"MultiPut2()",RGB(128,0,0)
draw string img,(24,9+32),"MultiPut2()",RGB(0,128,0)
draw string img,(24,9+64),"MultiPut2()",RGB(0,0,128)
draw string img,(24,9+96),"MultiPut2()",RGB(128,128,0)

dim as boolean transparent
dim as integer frames
while inkey()=""
  screenlock 
    line (0,0)-step(w-1,h-1),0,BF
    draw string (32,0),"Original"
    put  (0,8),img,PSET

    dim as single x
    for i as integer = 1 to 6
      dim as single scale = i*.5
      x+=scale*100
      MultiPut ,x,240,img,scale,scale,rotation(i-1),transparent
      rotation(6-i)+=i*.25
    next

  screenunlock
  frames+=1
  if frames mod 60=0 then transparent=not transparent
  sleep 10
wend

[D.J.Peters]

Test for palette mode (black = transparent)

Joshy

Code: Select all

#include "MultiPut.bi"
'
' main
'
dim as single rotation(5)

screenres 1024,480

dim as integer w,h
screeninfo w,h

var img=ImageCreate(128,128)
line img,(0,0)-step(127,127),15,BF
for i as integer = 0 to 127 step 32
  line img,(i ,0 )-step(0,127),7
  line img,(i+1,0)-step(0,127),7
  line img,(0 ,i )-step(127,0),7
  line img,(0,i+1)-step(127,0),7
next
for i as integer = 0 to 3
  line img,(i,i)-step(127-i*2,127-i*2),1,B
next
' some holes (in black)
circle img,(12    ,12    ),8,0,,,,F
circle img,(127-12,12    ),8,0,,,,F
circle img,(12    ,127-12),8,0,,,,F
circle img,(127-12,127-12),8,0,,,,F
' yes baby version 2.0 :-)
draw string img,(24,9   ),"MultiPut2()",4
draw string img,(24,9+32),"MultiPut2()",2
draw string img,(24,9+64),"MultiPut2()",1
draw string img,(24,9+96),"MultiPut2()",3


dim as boolean transparent
dim as integer frames
while inkey()=""
  screenlock 
    line (0,0)-step(w-1,h-1),0,BF
    draw string (32,0),"Original"
    put  (0,8),img,PSET

    dim as single x
    for i as integer = 1 to 6
      dim as single scale = i*.5
      x+=scale*100
      MultiPut ,x,240,img,scale,scale,rotation(i-1),transparent
      rotation(6-i)+=i*.25
    next

  screenunlock
  frames+=1
  if frames mod 60=0 then transparent=not transparent
  sleep 10
wend

[leopardpm]

once again... another sweet routine, Mr. Peters!

[D.J.Peters]

once again... another sweet routine, Mr. Peters!

once again... thank you :-)

[Dr_D]

Cool. It looks the edges have better quality than the original Multiput(). What did you do differently?

[leopardpm]

Cool. It looks the edges have better quality than the original Multiput(). What did you do differently?

Herr Peters just looks at code and it magically improves...

[D.J.Peters]

What did you do differently?

I use fixed point type FP16 in V2.0.
If you can't see it, you need glasses or you have to clean your glasses :-)

Joshy

[Dr_D]

lol... Well, it has been a while since I looked at it. How does the speed compare to the original?

[D.J.Peters]

How does the speed compare to the original?

I don't know but you can measure and compare it self if you like.
But what I know is you can't do it faster in BASIC without inline assembler.

Joshy

[D.J.Peters]

new version:
fixed: uninitialized array members found by fxm thank you :-)
deleted: the macros makes no sense
optimized: no more "if then" inside the pixel loop

In 256 color mode without transparent pixels I get ~1500 FPS on old P4 now.

Joshy

Code: Select all

#include "MultiPut.bi"

screenres 640,480
dim as integer w,h
screeninfo w,h
w shr=1
h shr=1
var img=ImageCreate(128,128,15)
for i as integer = 0 to 127 step 32
  line img,(i ,0 )-step(0,127),7
  line img,(i+1,0)-step(0,127),7
  line img,(0 ,i )-step(127,0),7
  line img,(0,i+1)-step(127,0),7
next
for i as integer = 0 to 3
  line img,(i,i)-step(127-i*2,127-i*2),1,B
next

draw string img,(24,9   ),"MultiPut2()",4
draw string img,(24,9+32),"MultiPut2()",2
draw string img,(24,9+64),"MultiPut2()",1
draw string img,(24,9+96),"MultiPut2()",3

dim as single  rot
dim as integer frames,fps
dim as double  tStart=Timer()
while inkey()=""
  ScreenLock
  line (0,0)-step(639,479),0,BF
  MultiPut ,w,h,img,2,2,rot
  draw string (0,0),"frame: " & frames & " fps: " & fps
  ScreenUnlock
  rot+=1
  frames+=1
  if frames mod 100=0 then
    dim as double tNow=Timer()
    fps=100/(tNow-tStart)
    tStart=tNow
  end if
wend

[leopardpm]

But what I know is you can't do it faster in BASIC without inline assembler....Joshy

That there is a dare, if I say so myself! Funny though, your very next post found ways to make it faster!!!

new version:
fixed: uninitialized array members found by fxm thank you :-)
deleted: the macros makes no sense
optimized: no more "if then" inside the pixel loop

LOL! I NEVER say something can't be faster... cuz it always can...

[bcohio2001]

Part of my code:

Code: Select all

	If ShowThis Then
		If Selected = 0 Then
			Put (XLoc, YLoc), ShowThis, Trans
		Else
			Put (XLoc, YLoc), ShowThis, PReset
		EndIf
	EndIf

Suggestions on how to use Multiput for both situations.

[leopardpm]

Part of my code:

Code: Select all

	If ShowThis Then
		If Selected = 0 Then
			Put (XLoc, YLoc), ShowThis, Trans
		Else
			Put (XLoc, YLoc), ShowThis, PReset
		EndIf
	EndIf

Suggestions on how to use Multiput for both situations.

as far as I understand, Multiput can't do PRESET... but I have question... why are you using PRESET in the first place? from your code and variable names it appears that you are highlighting an image if it is selected... why not just have showThis(0) and showThis(1).. a small image array of two images, ShowThis(0) for non-highlighted, and the highlighted version being ShowThis(1)?

Then your code becomes simpler:

Code: Select all

if ShowThis then put(xloc,yloc), ShowThis(Selected), trans 

just an idea... and if you happen to like the effect that PRESET gives you, the use PRESET to setup the ShowThis(1) image...

[bcohio2001]

Trying to just save memory. Here is the whole sub:

Code: Select all

'Rot value (Rotate) not used at the moment
Sub Card.DrawImg(ByVal XLoc As Integer, ByVal YLoc As Integer, GetCard As Integer, Selected As Integer, Rot As Single=0)
	Dim As Any Ptr ShowThis = 0
	'
	Select Case GetCard
		Case -1
			ShowThis = Backs(CurBackGr)
		Case 0 To 51
			ShowThis = Deck52(GetCard)
		Case 52
			If Jokers Then ShowThis = JokerBlack
		Case 53
			If Jokers Then ShowThis = JokerRed
		Case Else
			'54+
			'special image
			'As Integer Special
			'As Any Ptr SpecialRC(Any)
			If Special > GetCard - 54 Then ShowThis = SpecialRC(GetCard - 54)
	End Select
	'If Rot > 0 Then
	'	'insert rotation code or call a sub/function
	'EndIf
	If ShowThis Then
		If Selected = 0 Then
			Put (XLoc, YLoc), ShowThis, Trans
		Else
			Put (XLoc, YLoc), ShowThis, PReset
		EndIf
	EndIf
End Sub

I have a MINUMUM of 53 images, 52 'cards' and at least one 'back'. Maybe the two Jokers.
About the only thing that I could think of at the moment would be create another temp image, Put the 'ShowThis' in it using the PReset.
Then use Multiput to rotate and put it on screen.