 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
qbasicfan
gesperrt (Wird das nicht langweilig?)
Anmeldungsdatum: 29.07.2009
Beiträge: 45
|
 Verfasst am: 02.08.2009, 09:30 Titel: Rechteckcollision und Pixelcollision, klappt jetzt |
 |
|
So jetzt klappt es mit dem Sprite drehen, Rechteckcollision und die Pixelcollision . Danke an alle, die geholfen haben mit ihren Ideen.
Nach der Rechteckcollision wird die Pixelcollision angesprungen.
mfg
Steuern mit denTasten "QWSE"
| Code: |
#include "fbgfx.bi"
Const As Double pi = 3.1415926, pi_180 = pi / 180
Declare Sub rotozoom( Byref dst As FB.IMAGE Ptr = 0, Byref src As Const FB.IMAGE Ptr, Byval positx As Integer, Byval posity As Integer, Byref angle As Integer, Byref zoomx As Single, Byref zoomy As Single, Byval transcol As Uinteger = &hffff00ff, Byval offsetx As Integer = 0, Byref offsety As Integer = 0 )
Declare Sub pixelcollisionspruefung(cnr As Integer)
Declare Sub rectcollisionspruefung(xx1 As Integer,yy1 As Integer,ww1 As Integer,hh1 As Integer _
,xx2 As Integer,yy2 As Integer,ww2 As Integer,hh2 As Integer,cnr As Integer)
Dim Shared As integer iw, ih, siw,sih,siwh,xspr,yspr,sw,angle,zz,xx,yy,w,h,daten,zaehler
Dim Shared As Single x1,y1,dx,dy,zoomx,zoomy
DIM Shared AS uinteger PTR image,spritegr
Dim Shared As UInteger Ptr hdnviereck,hdnkreis,pzviereck,pzkreis
Dim Shared As UInteger Ptr hdnviereck1,hdnkreis1,pzviereck1,pzkreis1
Dim Shared As Integer rectcolli
Dim As integer cw1,ch1,cx2,cy2,cw2,ch2,cx3,cy3,cw3,ch3,cnr
Open Cons FOR Output AS #1
Screen 19,32,2
hdnviereck=ImageCreate(101,101)
ImageInfo hdnviereck, w, h,,, pzviereck
hdnkreis=ImageCreate(101,101)
ImageInfo hdnkreis, w, h,,, pzkreis
daten=w*h-1
hdnviereck1=ImageCreate(101,101)
ImageInfo hdnviereck1, w, h,,, pzviereck1
hdnkreis1=ImageCreate(101,101)
ImageInfo hdnkreis1, w, h,,, pzkreis1
iw=64
ih=64
zoomx = 1
zoomy = 1
siw=iw*Sqr(2)
sih=ih*Sqr(2)
siwh=siw/2
sw=2
ScreenSet 1,0
Cls
'Line image,(200,200)-(300,300), RGB(255,255,255), BF
Circle (250, 250), 40,RGB(255,255,0), ,,,F
Get (200,200)-(300,300),hdnkreis
'Line image,(450,200)-(550,300), RGB(255,255,255), BF
Circle (500,250), 40,RGB(0,255,255), ,,,F
Get (450,200)-(550,300),hdnkreis1
ScreenSet 0,0
dx+=100
dy+=100
image = ImageCreate(iw, ih)
Line image,(12, 2)-(48,62), RGB(0,197,0), BF
spritegr=imagecreate(siw,sih)
rotozoom( spritegr, image, siwh,siwh, angle+90, zoomx, zoomy )
put(dx,dy), spritegr, PSet
cw1=siw
ch1=sih
cx2=200
cy2=200
cw2=101
ch2=101
cx3=450
cy3=200
cw3=101
ch3=101
Do
If multikey( FB.SC_S ) Then
x1=Sin(angle*pi_180)*sw
y1=Cos(angle*pi_180)*sw
dx+=x1
dy+=y1
rectcollisionspruefung(dx,dy,cw1,ch1,cx2,cy2,cw2,ch2,1)
rectcollisionspruefung(dx,dy,cw1,ch1,cx3,cy3,cw3,ch3,2)
End If
If multikey( FB.SC_W ) Then
x1=Sin(angle*pi_180)*sw
y1=Cos(angle*pi_180)*sw
dx-=x1
dy-=y1
rectcollisionspruefung(dx,dy,cw1,ch1,cx2,cy2,cw2,ch2,1)
rectcollisionspruefung(dx,dy,cw1,ch1,cx3,cy3,cw3,ch3,2)
End If
If multikey(FB.SC_E) Then
angle -=1
If angle<0 Then angle = 360
ImageDestroy spritegr
spritegr=imagecreate(siw,sih)
rotozoom( spritegr, image, siwh,siwh, angle+90, zoomx, zoomy )
rectcollisionspruefung(dx,dy,cw1,ch1,cx2,cy2,cw2,ch2,1)
rectcollisionspruefung(dx,dy,cw1,ch1,cx3,cy3,cw3,ch3,2)
End If
If multikey(FB.SC_Q) Then
angle +=1
If angle>360 Then angle = 0
ImageDestroy spritegr
spritegr=imagecreate(siw,sih)
rotozoom( spritegr, image, siwh,siwh, angle+90, zoomx, zoomy )
rectcollisionspruefung(dx,dy,cw1,ch1,cx2,cy2,cw2,ch2,1)
rectcollisionspruefung(dx,dy,cw1,ch1,cx3,cy3,cw3,ch3,2)
End If
ScreenLock
ScreenCopy 1,0
put(dx,dy), spritegr, Trans
Get (200,200)-(300,300),hdnviereck
Get (450,200)-(550,300),hdnviereck1
ScreenSync
ScreenUnLock
Sleep 1
Loop Until multikey(FB.SC_ESCAPE)
Sub rectcollisionspruefung(xx1 As Integer,yy1 As Integer,ww1 As Integer,hh1 As Integer _
,xx2 As Integer,yy2 As Integer,ww2 As Integer,hh2 As Integer, cnr As Integer)
Dim As Integer xxl,xxr,yyo,yyu
xxl=xx1
yyo=yy1
xxr=xx2+ww2
yyu=yy2+hh2
If xx2 < xx1 Then xxl=xx2
If yy2 < yy1 Then yyo=yy2
If (xx1+ww1) > (xx2 + ww2) Then xxr=xx1+ww1
If (yy1+hh1) > (yy2 + hh2) Then yyu=yy1+hh1
If ((ww1+ww2) > (xxr-xxl)) And ((hh1+hh2) > (yyu - yyo)) Then
zaehler+=1
Print #1,cnr;zaehler
pixelcollisionspruefung(cnr)
End If
End Sub
Sub pixelcollisionspruefung(cnr As Integer)
If cnr =1 Then
For zz = 0 To daten
IF (pzviereck[zz] AND &Hffffff) = &H00c500 THEN
IF (pzkreis[zz] AND &Hffffff) = &Hffff00 THEN
zaehler+=1
Print #1, "pixel";zaehler
Exit Sub
End If
EndIf
Next
End If
If cnr=2 Then
For zz = 0 To daten
IF (pzviereck1[zz] AND &Hffffff) = &H00c500 THEN
IF (pzkreis1[zz] AND &Hffffff) = &H00ffff THEN
zaehler+=1
Print #1, "pixel";zaehler
Exit Sub
End If
EndIf
Next
End If
End Sub
Sub rotozoom( Byref dst As FB.IMAGE Ptr = 0, Byref src As Const FB.IMAGE Ptr, Byval positx As Integer, Byval posity As Integer, Byref angle As Integer, Byref zoomx As Single, Byref zoomy As Single = 0, Byval transcol As Uinteger = &hffff00ff, Byval offsetx As Integer = 0, Byref offsety As Integer = 0 )
Static As Integer mx, my, col, nx, ny
Static As Single nxtc, nxts, nytc, nyts
Static As Single tcdzx, tcdzy, tsdzx, tsdzy
Static As Integer sw2, sh2, dw, dh
Static As Single tc, ts, _mx, _my
Static As Uinteger Ptr dstptr, srcptr, odstptr
Static As Integer xput, yput, startx, endx, starty, endy
Static As Integer x(3), y(3), xa, xb, ya, yb, lx, ly
Static As Ubyte Ptr srcbyteptr, dstbyteptr
Static As Integer dstpitch, srcpitch, srcbpp, dstbpp, srcwidth, srcheight
If zoomx = 0 Then Exit Sub
If zoomy = 0 Then zoomy = zoomx
If src = 0 Then Exit Sub
If dst = 0 Then
dstptr = screenptr
odstptr = dstptr
screeninfo dw,dh,,,dstpitch
Else
dstptr = cast( Uinteger Ptr, dst + 1 )
odstptr = cast( Uinteger Ptr, dst + 1 )
dw = dst->width
dh = dst->height
dstbpp = dst->bpp
dstpitch = dst->pitch
End If
srcptr = cast( Uinteger Ptr, src + 1 )
srcbyteptr = cast( Ubyte Ptr, srcptr )
dstbyteptr = cast( Ubyte Ptr, dstptr )
sw2 = src->width\2
sh2 = src->height\2
srcbpp = src->bpp
srcpitch = src->pitch
srcwidth = src->width
srcheight = src->height
tc = Cos( angle * pi_180 )
ts = Sin( angle * pi_180 )
tcdzx = tc/zoomx
tcdzy = tc/zoomy
tsdzx = ts/zoomx
tsdzy = ts/zoomy
xa = sw2 * tc * zoomx + sh2 * ts * zoomx
ya = sh2 * tc * zoomy - sw2 * ts * zoomy
xb = sh2 * ts * zoomx - sw2 * tc * zoomx
yb = sw2 * ts * zoomy + sh2 * tc * zoomy
Dim As Integer centerx = -(offsetx*(tc*zoomx) + offsety*(ts*zoomx)) + offsetx
Dim As Integer centery = -(offsety*(tc*zoomy) - offsetx*(ts*zoomy)) + offsety
x(0) = sw2-xa
x(1) = sw2+xa
x(2) = sw2-xb
x(3) = sw2+xb
y(0) = sh2-ya
y(1) = sh2+ya
y(2) = sh2-yb
y(3) = sh2+yb
For i As Integer = 0 To 3
For j As Integer = i To 3
If x(i)>=x(j) Then
Swap x(i), x(j)
End If
Next
Next
startx = x(0)
endx = x(3)
For i As Integer = 0 To 3
For j As Integer = i To 3
If y(i)>=y(j) Then
Swap y(i), y(j)
End If
Next
Next
starty = y(0)
endy = y(3)
positx-=sw2
posity-=sh2
positx+=centerx
posity+=centery
If posity+starty<0 Then starty = -posity
If positx+startx<0 Then startx = -positx
If posity+endy<0 Then endy = -posity
If positx+endx<0 Then endx = -positx
If positx+startx>(dw-1) Then startx = (dw-1)-positx
If posity+starty>(dh-1) Then starty = (dh-1)-posity
If positx+endx>(dw-1) Then endx = (dw-1)-positx
If posity+endy>(dh-1) Then endy = (dh-1)-posity
If startx = endx Or starty = endy Then Exit Sub
xput = (startx + positx) * 4
yput = starty + posity
ny = starty - sh2
nx = startx - sw2
nxtc = (nx * tcdzx)
nxts = (nx * tsdzx)
nytc = (ny * tcdzy)
nyts = (ny * tsdzy)
dstptr += dstpitch * yput \ 4
Dim As Integer y_draw_len = (endy - starty) + 1
Dim As Integer x_draw_len = (endx - startx) + 1
'and we're off!
asm
mov edx, dword Ptr [y_draw_len]
test edx, edx ' 0?
jz y_end ' nothing to do here
fld dword Ptr[tcdzy]
fld dword Ptr[tsdzy]
fld dword Ptr [tcdzx]
fld dword Ptr [tsdzx]
y_inner:
fld dword Ptr[nxtc] 'st(0) = nxtc, st(1) = tsdzx, st(2) = tcdzx, st(3) = tsdzy, st(4) = tcdzy
fsub dword Ptr[nyts] 'nxtc-nyts
fiadd dword Ptr[sw2] 'nxtc-nyts+sw2
fld dword Ptr[nxts] 'st(0) = nxts, st(1) = tsdzx, st(2) = tcdzx, st(3) = tsdzy, st(4) = tcdzy
fadd dword Ptr[nytc] 'nytc+nxts
fiadd dword Ptr[sh2] 'nxts+nytc+sh2
'fpu stack returns to: st(0) = tsdzx, st(1) = tcdzx, st(2) = tsdzy, st(3) = tcdzy
mov ebx, [xput]
add ebx, [dstptr]
mov ecx, dword Ptr [x_draw_len]
test ecx, ecx ' 0?
jz x_end ' nothing to do here
x_inner:
fist dword Ptr [my] ' my = _my
fld st(1) ' mx = _mx
fistp dword Ptr [mx]
mov esi, dword Ptr [mx] ' esi = mx
mov edi, dword Ptr [my] ' edi = my
' bounds checking
test esi, esi 'mx<0?
js no_draw
'mov esi, 0
test edi, edi
'mov edi, 0
js no_draw 'my<0?
cmp esi, dword Ptr [srcwidth] ' mx >= width?
jge no_draw
cmp edi, dword Ptr [srcheight] ' my >= height?
jge no_draw
' calculate position in src buffer
mov eax, dword Ptr [srcbyteptr] ' eax = srcbyteptr
imul edi, dword Ptr [srcpitch] ' edi = my * srcpitch
add eax, edi
Shl esi, 2
' eax becomes src pixel color
mov eax, dword Ptr [eax+esi]
cmp eax, [transcol]
je no_draw
' draw pixel
mov dword Ptr [ebx], eax
no_draw:
fld st(3)
faddp st(2), st(0) ' _mx += tcdzx
fadd st(0), st(2) ' _my += tsdzx
' increment the output pointer
add ebx, 4
' increment the x loop
dec ecx
jnz x_inner
x_end:
fstp dword Ptr [_my]
fstp dword Ptr [_mx]
'st(0) = tsdzx, st(1) = tcdzx, st(2) = tsdzy, st(3) = tcdzy
'nytc += tcdzy
fld dword Ptr[nytc]
fadd st(0), st(4)
fstp dword Ptr[nytc]
'st(0) = tsdzx, st(1) = tcdzx, st(2) = tsdzy, st(3) = tcdzy
'nyts+=tsdzy
fld dword Ptr[nyts]
fadd st(0), st(3)
fstp dword Ptr[nyts]
'dstptr += dst->pitch
mov eax, dword Ptr [dstpitch]
add dword Ptr [dstptr], eax
dec edx
jnz y_inner
y_end:
finit
End asm
End Sub
|
Zuletzt bearbeitet von qbasicfan am 03.08.2009, 19:44, insgesamt 2-mal bearbeitet |
|
| Nach oben |
|
 |
28398
Anmeldungsdatum: 25.04.2008
Beiträge: 1917
|
| Verfasst am: 03.08.2009, 18:05 Titel: |
|
|
| Toll, dein zusammengestohlener Quelltext interessiert bloß niemanden, weil er vermutlich haufenweise Urheberrechte verletzt. |
|
| Nach oben |
|
|
qbasicfan
gesperrt (Wird das nicht langweilig?)
Anmeldungsdatum: 29.07.2009
Beiträge: 45
|
| Verfasst am: 03.08.2009, 19:32 Titel: |
|
|
Danke für dein kompliment. Könntest ruhig höflicher sein.
Habe jetzt etwas verbessert.
Konnte es mit dem Sub-aufrufen noch nicht so.
Ist etwas schneller geworden.
mfg |
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
| Verfasst am: 04.08.2009, 17:28 Titel: |
|
|
| Zitat: | | vermutlich haufenweise Urheberrechte verletzt |
na, das sehe ich hier aber nicht,
obwohl, es ist natürlich geschickter und höflicher seine Quellen zu nennen!
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater. |
|
| Nach oben |
|
|
qbasicfan
gesperrt (Wird das nicht langweilig?)
Anmeldungsdatum: 29.07.2009
Beiträge: 45
|
| Verfasst am: 09.08.2009, 21:37 Titel: |
|
|
IF (pzviereck[zz] AND &Hffffff) = &H00c500 THEN
Warum muss dieses AND &Hffffff gesetzt werden?
Ist doch eigentlich ersichtlich, das hier die Farbdaten drin liegen.
Wenn ich das And rausnehme, wird der If-Zweig nicht richtig beantwortet.
Ist das eine Freebasic-Spezialität?
Wenn ich die Pixelabfrage so wie hier mit Zeiger bei GFA32 mache, brauche ich kein "And",....hm...
mfg |
|
| Nach oben |
|
|
Jojo
alter Rang
Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte
|
| Verfasst am: 09.08.2009, 22:42 Titel: |
|
|
Hallo pebi,
Farbdaten haben auch einen Alphakanal.
_________________
» Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.
 |
|
| Nach oben |
|
|
qbasicfan
gesperrt (Wird das nicht langweilig?)
Anmeldungsdatum: 29.07.2009
Beiträge: 45
|
| Verfasst am: 09.08.2009, 23:09 Titel: |
|
|
Jup,danke.
mfg |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
