01-02-2006, 12:45 AM
Thanx for testing and an happy new yeahr from germany.
Joshy
Joshy
Code:
' (c) D.J.Peters (Joshy)
' Source: http://Forum.FBPortal.de
' PUT with scale, rotate, colorkey und clipping in 8 BPP
' 16 and 32 BPP comes after tests in assembler.
' MultiPut [lpDes],[xmidpos],[ymidpos],lpSrc,[xScale],[yScale],[Rotate],[ColorKey]
option explicit
#define UseRad 'if not then Rotate are in degre
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 ColorKey as integer=-1)
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,MustKeying
if lpTarget= 0 then MustLock =1
if Rotate <>0 then MustRotate=1
if ColorKey>-1 then MustKeying=1
dim as byte ptr TargetPtr,SourcePtr
dim as short ptr ptr16
dim as short val16
dim as byte val8
dim as integer TargetWidth,TargetHeight,TargetBytes
if MustLock then
screeninfo TargetWidth,TargetHeight,TargetBytes
TargetPtr=screenptr:TargetBytes=TargetBytes shr 3
else
ptr16=cptr(short ptr,lpTarget):TargetPtr=cptr(byte ptr,lpTarget)
val16=ptr16[0]:TargetBytes =val16 and &H0007:TargetWidth=val16 shr 3
val16=ptr16[1]:TargetHeight=val16:TargetPtr+=4
end if
if (TargetWidth<4) or (TargetHeight<4) then exit sub
dim as integer SourceWidth,SourceHeight,SourceBytes
ptr16=cptr(short ptr,lpSource):SourcePtr=cptr(byte ptr,lpSource)
val16=ptr16[0]:SourceBytes =val16 and &H0007:SourceWidth=val16 shr 3
val16=ptr16[1]:SourceHeight=val16:SourcePtr+=4
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
#define xx 4 'integer part
#define yy 5
dim as single Points(4,5)
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)-1
dim as uinteger i
dim as single x,y
if MustRotate then
#ifndef UseRad
Rotate*=0.017453292 'degre 2 rad
#endif
while Rotate< 0 :rotate+=6.2831853:wend
while Rotate>=6.2831853:rotate-=6.2831853: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(2,2) 'Counters
for i=0 to 3
points(i,xs)+=xMidPos:points(i,ys)+=yMidPos
points(i,xx)=cint(points(i,xs)):points(i,yy)=cint(points(i,ys))
if points(i,yy)<yStart then yStart=points(i,yy):CNS(LI,IND)=i
if points(i,yy)>yEnd then yEnd =points(i,yy)
if points(i,xx)<xStart then xStart=points(i,xx)
if points(i,xx)>xEnd then xEnd =points(i,xx)
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 byte ptr t1,s1
dim as short ptr t2,s2
dim as integer ptr t4,s4
#define ADD 0
#define CMP 1
#define SET 2
dim as integer ACS(2,3) '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),yy) 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),yy) = points(CNS(i,NIND),yy)
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):if xStart>=TargetWidth then goto SkipScanLine
xEnd =E(RI,EX):if xEnd < 0 then goto SkipScanLine
if xStart=xEnd then goto SkipScanLine
'if xEnd <xStart then goto SkipScanLine
Length=E(RI,EX)-E(LI,EX)
uSlope=E(RI,EU)-E(LI,EU):uSlope/=Length
vSlope=E(RI,EV)-E(LI,EV):vSlope/=Length
Length=E(LI,EX)
If Length<0.0 Then
Length=-Length
U=(E(LI,EU)+uSlope*Length)
V=(E(LI,EV)+vSlope*Length)
xStart = 0
else
U=E(LI,EU):V=E(LI,EV)
End If
if xEnd>=TargetWidth then xEnd=TargetWidth-1
UV=int(uSlope):UA=(uSlope-UV)*10000:UN=0
VV=int(vSlope):VA=(vSlope-VV)*10000:VN=0
xEnd-=xStart
select case TargetBytes
case 1
t1=TargetPtr:t1+=yStart*TargetWidth:t1+=xStart:xStart=0
if MustKeying=0 then
while xStart<xEnd
s1=SourcePtr:s1+=V*SourceWidth:s1+=U
t1[xStart]=s1[0]
U+=UV:UN+=UA:if UN>10000 then U+=1:UN-=10000
V+=VV:VN+=VA:if VN>10000 then V+=1:VN-=10000
xStart+=1
wend
else
val8=ColorKey and &HFF
while xStart<xEnd
s1=SourcePtr:s1+=V*SourceWidth:s1+=U
if s1[0]<>val8 then t1[xStart]=s1[0]
U+=UV:UN+=UA:if UN>10000 then U+=1:UN-=10000
V+=VV:VN+=VA:if VN>10000 then V+=1:VN-=10000
xStart+=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
'
' main
'
#define scr_w 640 'change it
#define scr_h 480
dim as any ptr Sprite
dim as single xZoom,yZoom,Rotate
dim as integer x,y,counter
#define wh scr_w\2
#define hh scr_h\2
screenres scr_w,scr_h,8
'create an sprite
line (0,0)-(99,99),1,BF 'blue rectangle
circle (50,50),48,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
Sprite=ImageCreate(100,100)
get (0,0)-(99,99),Sprite
cls
for counter=0 to 200
xZoom=cos(Rotate)*10+10.1:Rotate+=0.05
MultiPut ,wh,hh,Sprite,xZoom,xZoom
sleep 50,1:cls
next
Rotate=0
while xZoom>1.0
MultiPut ,wh,hh,Sprite,xZoom,xZoom
sleep 50,1:cls:xZoom-=0.1
wend
for counter=0 to 200
MultiPut ,wh,hh,Sprite,,,Rotate
sleep 50,1:cls:Rotate+=0.1
next
for counter=0 to 500
xZoom=cos(Rotate)*2+2.1:yZoom=sin(Rotate)*2+2.1
MultiPut ,wh,hh,Sprite,xZoom,yZoom
sleep 50,1:cls:Rotate+=0.017453292
next
while len(inkey)=0
xZoom=rnd*3
MultiPut ,rnd*scr_w,rnd*scr_h,Sprite,xZoom,xZoom,rnd*6.28,1 'blue colorkey
'sleep 50,1
wend
end
sorry about my english