Thanks for your reply counting_pine.
I used your option 3 and have no problems at the present.
I will try option 2 when I get my head round what is needed.
Brains a bit slow these days.
Cheers
Bill.
MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]
Re: MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Tr
I did have that crashes due to division of 0.... here's a quick fix BUT doesn't compute for the right color -- currently defaults to Black.
~creek23
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)
' Alpha from D.J. Peters added by RayBritton (2008/11/07)
' Alpha Channel added by creek23 (Mj Mendoza IV) (2011/09/03)
'#define UseRad 'if not then Rotate are in degrees
Public 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 alphavalue As Integer = 255, _
Byval alphachannel As Integer = 1, _
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
'variables for the alpha blending
Dim As Uinteger srb = Any
Dim As Uinteger drb = Any
Dim As Uinteger rb = Any
Dim As Uinteger sr = Any, sg = Any, sb = Any, sa = Any, sa2 = Any
Dim As Uinteger dr = Any, dg = Any, db = Any, da = Any, da2 = Any
Dim As Uinteger r = Any, g = Any, b = Any, a = Any
Dim As Uinteger sc = Any 'source (alpha) channel
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
'***** start alpha blending
'this set of if...elseif...end if conditions applies alpha blending
'these 43 lines can be replaced with '*t4 = *s4' to remove blending
If alphavalue = 0 Then
'no change needed *t4 = *t4
Elseif alphavalue = 255 Then
*t4 = *s4
Elseif *t4 Shr 24 = 0 Then
*t4 = *s4
Elseif *t4 Shr 24 = 255 Then
srb = *s4 And &h00ff00ff
sg = *s4 Xor srb
sa = alphavalue
drb = *t4 And &h00ff00ff
dg = *t4 Xor drb
da = 256 - sa
rb = (drb * da + srb * sa) And &hff00ff00
g = (dg * da + sg * sa) And &h00ff0000
*t4 = (rb Or g) Shr 8 Or &hff000000
Else
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sa = (alphavalue)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
End If
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
'***** start alpha blending
'this set of if...elseif...end if conditions applies alpha blending
'these 43 lines can be replaced with '*t4 = *s4' to remove blending
If alphavalue = 0 Then
'no change needed *t4 = *t4
Elseif alphavalue = 255 And alphachannel = 0 Then
*t4 = *s4
Elseif alphavalue = 255 And alphachannel = 1 Then
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sa = (*s4 Shr 24)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
If (sa = 255) Then
*t4 = Rgba(sr, sg, sb, sa)
Else
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
If a > 0 Then
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
Else
*t4 = Rgba(dr, dg, db, da)
EndIf
EndIf'/'
ElseIf alphavalue > 0 And alphachannel = 1 Then
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sc = (*s4 Shr 24) And 255
sa = sc * (alphavalue / 255)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
If a > 0 Then
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
Else
*t4 = Rgba(dr, dg, db, da)
EndIf
Elseif *t4 Shr 24 = 0 Then'/
*t4 = *s4
Elseif *t4 Shr 24 = 255 Then
srb = *s4 And &h00ff00ff
sg = *s4 Xor srb
sa = alphavalue
drb = *t4 And &h00ff00ff
dg = *t4 Xor drb
da = 256 - sa
rb = (drb * da + srb * sa) And &hff00ff00
g = (dg * da + sg * sa) And &h00ff0000
*t4 = (rb Or g) Shr 8 Or &hff000000
Else
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sa = (alphavalue)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
End If
'***** end alpha blending
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
'***** start alpha blending
'this set of if...elseif...end if conditions applies alpha blending
'these 43 lines can be replaced with '*t4 = *s4' to remove blending
If alphavalue = 0 Then
'no change needed *t4 = *t4
Elseif alphavalue = 255 And alphachannel = 0 Then
*t4 = *s4
Elseif alphavalue = 255 And alphachannel = 1 Then
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sa = (*s4 Shr 24)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
' If (sa = 255) Then
' *t4 = Rgba(sr, sg, sb, sa)
' Else
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
If a > 0 Then
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
Else
*t4 = Rgba(dr, dg, db, da)
EndIf
' EndIf'/'
ElseIf alphavalue > 0 And alphachannel = 1 Then
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sc = (*s4 Shr 24)
sa = sc * (alphavalue / 255)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
If a > 0 Then
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
Else
*t4 = Rgba(dr, dg, db, da)
EndIf
Elseif *t4 Shr 24 = 0 Then'/
*t4 = *s4
Elseif *t4 Shr 24 = 255 Then
srb = *s4 And &h00ff00ff
sg = *s4 Xor srb
sa = alphavalue
drb = *t4 And &h00ff00ff
dg = *t4 Xor drb
da = 256 - sa
rb = (drb * da + srb * sa) And &hff00ff00
g = (dg * da + sg * sa) And &h00ff0000
*t4 = (rb Or g) Shr 8 Or &hff000000
Else
sr = (*s4 Shr 16) And 255
sg = (*s4 Shr 8) And 255
sb = (*s4 ) And 255
sa = (alphavalue)
dr = (*t4 Shr 16) And 255
dg = (*t4 Shr 8) And 255
db = (*t4 ) And 255
da = (*t4 Shr 24)
sa2 = sa Shl 8
da2 = da Shl 8 - da * sa
a = (sa2 + da2)
r = (dr * da2 + sr * sa2) \ a
g = (dg * da2 + sg * sa2) \ a
b = (db * da2 + sb * sa2) \ a
*t4 = Rgba(r, g, b, a Shr 8)
End If
'***** end alpha blending
End If
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 SubRe: MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]
This does not seem to work anymore in 1.10.0 (x64 Linux):
multiput_alpha.bas(24) error 4: Duplicated definition in 'Byval Param As Any Ptr = 0)'
-
D.J.Peters
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]
Don't use this old code from "2006" use MultiPut V2.0 instead from "2016" "10 years later" also a name of a band 
see at: viewtopic.php?t=24479
Joshy
see at: viewtopic.php?t=24479
Joshy