Leikkaavatko kaksi janaa?

Oletko tehnyt jotain, mistä muut voisivat hyötyä. Postita vinkit tänne.
Post Reply
SPuntte
Tech Developer
Tech Developer
Posts: 650
Joined: Mon Aug 27, 2007 9:51 pm
Location: Helsinki, Finland
Contact:

Leikkaavatko kaksi janaa?

Post by SPuntte »

Kehittelinpäs tarpeisiin SDK:n vastaavasta funktiosta optimoidumman version. Laitan vapaaseen jakoon, jos joku vaikka tarvitsisi. Parametrit ovat luonnollisesti janojen neljän päätepisteen x- ja y- koordinaatit.

Code: Select all

Function LineSegIsect(ax#, ay#, bx#, by#, cx#, cy#, dx#, dy#)
	Return (((bx-ax)*(cy-ay)-(by-ay)*(cx-ax))*((bx-ax)*(dy-ay)-(by-ay)*(dx-ax)) < 0)(((dy-cy)*(cx-ax)-(dx-cx)*(cy-ay))*((dx-cx)*(by-cy)-(dy-cy)*(bx-cx)) < 0)
EndFunction
Oman benchmarkkaukseni perusteella SDK:n funktio on lähes kolme kertaa hitaampi.

Pointtini ei ole, että SDK:n funktio olisi huono (päin vastoin!), vaan että kaikkia ongelmia ei kannata ampua tykillä, jos kevyemmälläkin kalustolla pärjää.

Seuraavassa syitä siihen, miksi SDK:n funktio on hidas:
Oma funktioni on optimoitu huippuunsa jättämällä siitä erinäisiä ominaisuuksia pois verrattuna SDK:n vastineeseen: ensinnäkin SDK:n funktio laskee leikkaustapauksessa leikkauspisteen ja palauttaa sen koordinaatit. Lisäksi se pystyy käsittelemään myös tapaukset, joissa toisen janan toinen päätepiste on tasan toisella janalla tai janat ovat yhdensuuntaisina päällekäin.

Käytännössä kumpikaan näistä kahdesta skenaariosta ei koskaan toteudu, kun janojen koordinaatit saavat reaalilukuarvoja (eli desimaalilukuja, kuten käytännössä kaikki data vaikkapa fysiikkasimulaatiossa). Niiden esiintymistodennäköisyys on huomattava ainoastaan silloin, kun koordinaatit ovat aina kokonaislukuja.

Tässä vielä testiohjelma. Janan pää on liimattu hiireen, ja avaruusnäppäin arpoo uudet arvot. LineSegIsect2() on käytännössä sama funktio kuin LineSegIsect1() mutta vaan huomattavasti selkeämpi lukea, mutta vie enemmän tilaa. Suorituskykyero oikeastaan marginaalinen.

Code: Select all

Const ITR = 10000

Dim ax#, ay#, bx#, by#, cx#, cy#, dx#, dy# As Float
Dim isect1, isect2, isect3, time1, time2, time3, i As Integer
Global IntersX, IntersY As Float
Global LinesOnTop As Integer

Gosub random

Repeat
	If KeyHit(cbKeySpace) Then Gosub Random
	
	ax = MouseX() : ay = MouseY()
	
	Wait 5
	
	time1 = Timer()
	For i = 1 To ITR
		isect1 = LineSegIsect1(ax, ay, bx, by, cx, cy, dx, dy)
	Next i
	time1 = Timer()-time1
	
	time2 = Timer()
	For i = 1 To ITR
		isect2 = LineSegIsect2(ax, ay, bx, by, cx, cy, dx, dy)
	Next i
	time2 = Timer()-time2
	
	time3 = Timer()
	For i = 1 To ITR
		isect3 = LinesIntersect(ax, ay, bx, by, cx, cy, dx, dy)
	Next i
	time3 = Timer()-time3
	
	Text 1, 1,  "Kustom1: " + time1
	Text 1, 14, "Kustom2: " + time2
	Text 1, 27, "SDK: " + time3
	
	If isect1 <> isect3 Then End
	
	Color 255*(1-isect3), 255*(1-isect1), 255
	
	Line ax, ay, bx, by
	Line cx, cy, dx, dy
	
	DrawScreen
Forever

End

Random:
	bx = Rnd(ScreenWidth())
	by = Rnd(ScreenHeight())
	cx = Rnd(ScreenWidth())
	cy = Rnd(ScreenHeight())
	dx = Rnd(ScreenWidth())
	dy = Rnd(ScreenHeight())
Return

Function LineSegIsect1(ax#, ay#, bx#, by#, cx#, cy#, dx#, dy#)
	Return (((bx-ax)*(cy-ay)-(by-ay)*(cx-ax))*((bx-ax)*(dy-ay)-(by-ay)*(dx-ax)) < 0)(((dy-cy)*(cx-ax)-(dx-cx)*(cy-ay))*((dx-cx)*(by-cy)-(dy-cy)*(bx-cx)) < 0)
EndFunction

Function LineSegIsect2(ax#, ay#, bx#, by#, cx#, cy#, dx#, dy#)
	Dim ABx#, ABy#, ACx#, ACy#, CDx#, CDy# As Float
	Dim ABxAC#, ABxAD#, CDxCA#, CDxCB# As Float

	ABx = bx-ax
	ABy = by-ay
	ACx = cx-ax
	ACy = cy-ay
	CDx = dx-cx
	CDy = dy-cy

	ABxAC = ABx*ACy-ABy*ACx
	ABxAD = ABx*(dy-ay)-ABy*(dx-ax)
	CDxCA = CDy*ACx-CDx*ACy
	CDxCB = CDx*(by-cy)-CDy*(bx-cx)
	
	If ABxAC*ABxAD < 0 And CDxCA*CDxCB < 0 Then Return True
	Return False
EndFunction

//© CBSDK
// Tarkastaa leikkavatko kaksi janaa ja paluttaa leikauspisteen
Function LinesIntersect(Ax#, Ay#, Bx#, By#, Cx#, Cy#, Dx#, Dy#)
	Dim Rn#, Rd#, Sn#, Intersection_AB#, Intersection_CD# As Float
    LinesOnTop = False
    // Tarkastetaan ovatko suorat toistensa päällä yhdensuuntaisina
    If Collinear(Ax#,Ay#,Bx#,By#,Cx#,Cy#) = True And Collinear(Ax#,Ay#,Bx#,By#,Dx#,Dy#) = True Then 'ovatko yhdensuuntaisia
        If Between(Ax#,Ay#,Bx#,By#,Cx#,Cy#) = True Or Between(Ax#,Ay#,Bx#,By#,Dx#,Dy#) = True Or Between(Cx#,Cy#,Dx#,Dy#,Ax#,Ay#) = True Or Between(Cx#,Cy#,Dx#,Dy#,Bx#,By#) = True Then  'ovatko sisäkkäin
            IntersX = 0
            IntersY = 0
            LinesOnTop = True
            Return True
        EndIf
    EndIf

    Rn# = (Ay#-Cy#)*(Dx#-Cx#) - (Ax#-Cx#)*(Dy#-Cy#)
    Rd# = (Bx#-Ax#)*(Dy#-Cy#) - (By#-Ay#)*(Dx#-Cx#)
    If Rd# = 0
        Return False
    Else
        Sn# = (Ay#-Cy#)*(Bx#-Ax#) - (Ax#-Cx#)*(By#-Ay#)
        Intersection_AB# = Rn# / Rd#
        Intersection_CD# = Sn# / Rd#
        If Intersection_AB# > 1 Or Intersection_CD# > 1 Or Intersection_AB# < 0 Or Intersection_CD# < 0 Then Return False
        IntersX = Ax# + Intersection_AB#*(Bx#-Ax#)
        IntersY = Ay# + Intersection_AB#*(By#-Ay#)
        Return True
    EndIf
End Function

//© CBSDK
// Tarkastaa onko jokin piste kahden pisteen määrittämällä suoralla
Function Collinear(x1#,y1#,x2#,y2#,x3#,y3#)
    If x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2) = 0 Then Return True Else Return False
End Function

//© CBSDK
// Tarkastaa onko jokin piste kahden pisteen määrittämällä janalla
Function Between(x1#,y1#,x2#,y2#,x3#,y3#)
    If Collinear(x1#,y1#,x2#,y2#,x3#,y3#) = False Then Return False
    If Distance(x1,y1,x3,y3) + Distance(x3,y3,x2,y2) = Distance(x1,y1,x2,y2) Then Return True Else Return False
End Function

CoolBasic henkilökuntaa
Tech-kehittäjä
CoolBasic Classic, Cool VES

CoolPhysicsEngine | MissileSystem | Jana-ympyrä -törmäys | cbSimpleTexture | CoolCPLX
Post Reply