Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
MultiPut (verbessert)
| Uploader: |  Jojo |
| Datum/Zeit: | 11.05.2008 14:47:00 |
' #define UseRad
'(c) by D.J. Peters, modified by Saga-Games (added "center" parameter and deleted some "mustlock" stuff...)
'wenn du mit X und Y die linke obere Ecke verwenden willst, muss Center auf 0 bleiben,
'ansonsten einfach 1 als Parameter übergeben!
'da die erste zeile (#define useread) auskommentiert ist, wird bei Rotate eine Grad-
'zahl erwartet, also 0 bis 360 grad. Du willst ja, so weit ich weiß, nur 90,180 und 270 ;)
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 Center As Integer= 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 Byte val8
Dim As Short Ptr ptr16
Dim As Short val16
Dim As Integer val32,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
mustlock = 0
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
If Center = 0 Then
xMidPos+=SourceWidth/(2/xScale)
yMidPos+=SourceHeight/(2/yScale)
End If
#define xs 0 'screen
#define ys 1
#define xt 2 'texture
#define yt 3
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)
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)=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 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),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)*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
If u<0 Then u=0
If v<0 Then v=0
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
If u<0 Then u=0
If v<0 Then v=0
xStart+=1
Wend
End If
Case 2
t2=Cptr(Short Ptr,TargetPtr)
t2+=yStart*TargetWidth:t2+=xStart:xStart=0
If MustKeying=0 Then
While xStart<xEnd
s2=Cptr(Short Ptr,SourcePtr):s2+=V*SourceWidth:s2+=U
t2[xStart]=s2[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
If u<0 Then u=0
If v<0 Then v=0
xStart+=1
Wend
Else
val16=ColorKey And &HFFFF
While xStart<xEnd
s2=Cptr(Short Ptr,SourcePtr):s2+=V*SourceWidth:s2+=U
If s2[0]<>val16 Then t2[xStart]=s2[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
If u<0 Then u=0
If v<0 Then v=0
xStart+=1
Wend
End If
Case 4
t4=Cptr(Integer Ptr,TargetPtr)
t4+=yStart*TargetWidth:t4+=xStart:xStart=0
If MustKeying=0 Then
While xStart<xEnd
s4=Cptr(Integer Ptr,SourcePtr):s4+=V*SourceWidth:s4+=U
t4[xStart]=s4[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
If u<0 Then u=0
If v<0 Then v=0
xStart+=1
Wend
Else
val32=ColorKey And &HFFFFFF
While xStart<xEnd
s4=Cptr(Integer Ptr,SourcePtr):s4+=V*SourceWidth:s4+=U
If s4[0]<>val32 Then t4[xStart]=s4[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
If u<0 Then u=0
If v<0 Then v=0
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