MultiPut[DES],[x],[y],SRC,[xScale],[yScale],[Rotate],[Trans]
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Hello Lachie Dazdarian feel free and write any tutorial if you like.
My written english are to bad to write readable tutorials and curently i open two business (one pc linux soft- and hardware shop and one IT-consulting) and in germany it consumed all my time and energie to cordinate new rooms new personal new hardware not to speak of the financing.
Joshy
My written english are to bad to write readable tutorials and curently i open two business (one pc linux soft- and hardware shop and one IT-consulting) and in germany it consumed all my time and energie to cordinate new rooms new personal new hardware not to speak of the financing.
Joshy
-
- Posts: 2428
- Joined: Jul 19, 2006 19:17
- Location: Sunnyvale, CA
- Contact:
Hi Joshy. This is a great feature, but I cannot get it to work with
or 16 or 24 bit display modes. It only works with 8 bit display. Do I have to change other parts of the code, or is the program 'hack' not compatible with my computer?
I am using the second version of multiput you posted here.
_________________________
Recent CVS on Windows 2000
Code: Select all
screenres scr_w,scr_h,32
I am using the second version of multiput you posted here.
_________________________
Recent CVS on Windows 2000
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
-
- Posts: 2428
- Joined: Jul 19, 2006 19:17
- Location: Sunnyvale, CA
- Contact:
-
- Site Admin
- Posts: 6323
- Joined: Jul 05, 2005 17:32
- Location: Manchester, Lancs
Here's a new (unofficial) version of the sub. The main change I've made is adding support for custom blenders, in the same format as Put Custom.
Two new optional parameters at the end: one is the address of a custom function, one is the Any Ptr that will get passed to it.If you have any problems, please let me know.
Two new optional parameters at the end: one is the address of a custom function, one is the Any Ptr that will get passed to it.
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],[Trans],[Custom],[Param]
' Small changes/additions by counting_pine (2007/04/27)
#define UseRad 'if not then Rotate are in degrees
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 Trans as integer= 0, _
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
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)
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
*t4=Custom(*s4, *t4, 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:t4+=1
wend
elseif Trans=0 then
while xStart<xEnd
s4=cptr(integer ptr,lpSource)+V*(SourcePitch shr 2)+U
*t4=*s4
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 *t4=*s4
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 sub
function Trans(byval Src as uinteger, byval Dest as uinteger, byval Param as any ptr = 0) as uinteger
if (Src and &HFFFFFF) = &HFF00FF then return Dest else return Src
end function
'
' main
'
#define scr_w 320 'change it
#define scr_h 200
dim as any ptr Sprite
dim as single xZoom,yZoom,Rotate
dim as integer x,y,b,counter
#define wh scr_w\2
#define hh scr_h\2
'screenres scr_w,scr_h,8
'screenres scr_w,scr_h,15
screenres scr_w,scr_h,16
'screenres scr_w,scr_h,24
'screenres scr_w,scr_h,32
'create an sprite
screeninfo ,,b
if b=8 then
line (0,0)-(100,100),0,BF 'trans rectangle
circle (50,50),50,14,,,,F
circle (25,30),12,15,,,,F
circle (75,30),12,15,,,,F
circle (25,30), 7, 0,,,,F
circle (75,30), 7, 0,,,,F
circle (50,50),28, 0,1.57*2,1.57*4
else
line (0,0)-(100,100),rgb(255,0,255),BF 'trans rectangle
circle (50,50),50,rgb(255,255, 0),,,,F
circle (25,30),12,rgb(255,255,255),,,,F
circle (75,30),12,rgb(255,255,255),,,,F
circle (25,30), 7,rgb( 0, 0, 0),,,,F
circle (75,30), 7,rgb( 0, 0, 0),,,,F
circle (50,50),28,rgb( 0, 0, 0),1.57*2,1.57*4
end if
Sprite=ImageCreate(101,101)
locate 12,2:? "press a key"
getkey
get (0,0)-(100,100),Sprite
cls
rotate=3.14
while len(inkey)=0
cls
xZoom=cos(Rotate*2)*2+2.1
yZoom=sin(Rotate*3)*2+2.1
MultiPut(,wh,hh,Sprite,xZoom,yZoom,Rotate,0, @trans) ',1=trans
sleep 20:Rotate+=0.01
wend
imagedestroy Sprite
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
if any will do it:Landeel wrote:I was wandering. MultiPut can rotate and scale images. But it can't mirror / flip them, can it?
How hard would be implementing MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Mirror],[Flip],[Trans],[Custom],[Param]?
IF mirror = TRUE THEN swap the X texture coords
IF flip = TRUE THEN swap the Y texture coords
Joshy
MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Mirror],[Flip],[Trans],[Custom],[Param]
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)
#define UseRad 'if not then Rotate are in degrees
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 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
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
*t4=Custom(*s4, *t4, 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:t4+=1
Wend
Elseif Trans=0 Then
While xStart<xEnd
s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
*t4=*s4
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 *t4=*s4
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 Sub
Function Trans(Byval Src As Uinteger, Byval Dest As Uinteger, Byval Param As Any Ptr = 0) As Uinteger
If (Src And &HFFFFFF) = &HFF00FF Then Return Dest Else Return Src
End Function
'
' main
'
#define scr_w 320 'change it
#define scr_h 200
Dim As Any Ptr Sprite
Dim As Single xZoom,yZoom,Rotate
Dim As Integer x,y,b,counter
#define wh scr_w\2
#define hh scr_h\2
'screenres scr_w,scr_h,8
'screenres scr_w,scr_h,15
'screenres scr_w,scr_h,16
'screenres scr_w,scr_h,24
'screenres scr_w,scr_h,32,,0
screenres scr_w,scr_h,32
'create an sprite
screeninfo ,,b
If b=8 Then
Line (0,0)-(100,100),0,BF 'trans rectangle
Circle (50,50),50,14,,,,F
Circle (25,30),12,15,,,,F
Circle (75,30),12,15,,,,F
Circle (25,30), 7, 0,,,,F
Circle (75,30), 7, 0,,,,F
Circle (50,50),28, 0,1.57*2,1.57*4
Else
Line (0,0)-(100,100),rgb(255,0,255),BF 'trans rectangle
Circle (50,50),50,rgb(255,255, 0),,,,F
Circle (25,30),12,rgb(255,255,255),,,,F
Circle (75,30),12,rgb(255,255,255),,,,F
Circle (25,30), 7,rgb( 0, 0, 0),,,,F
Circle (75,30), 7,rgb( 0, 0, 0),,,,F
Circle (50,50),28,rgb( 0, 0, 0),1.57*2,1.57*4
End If
Sprite=ImageCreate(101,101)
Locate 12,2:? "press a key"
getkey
Get (0,0)-(100,100),Sprite
Cls
'rotate=3.14
rotate=0
While Len(Inkey)=0
Cls
xZoom=Cos(Rotate*2)*2+2.1
yZoom=Sin(Rotate*3)*2+2.1
MultiPut(,wh,hh,Sprite,xZoom,yZoom,Rotate,1,0,0, @trans) ',1=trans
Sleep 20
Rotate+=0.01
Wend
imagedestroy Sprite
-
- Posts: 2428
- Joined: Jul 19, 2006 19:17
- Location: Sunnyvale, CA
- Contact: