Funktiota on väsätty ainakin viiteen eri otteeseen parin kuukauden aikana ja olen joutunut venyttämään taitoni äärirajoilleen erityisesti alkuvaiheessa, joten nyt kun vihdoinkin sain homman toimimaan niin en ymmärtänyt sen jokaista riviä täydellisesti(en jaksanut enää perehtyä), idean kumminkin. Tästä johtuen koodista voi löytyä optimoimisen varaa ja joitain kummallisuuksia, mutta se kumminkin toimii(omien testieni perusteella).
Jos kuitenkin löydät jonkin tapauksen, jossa funktio tuottaa virheellisen tuloksen, olisi kiva, jos viitsisit ilmoittaa(sähköposti, kommentit, jne.).
Painele enteriä testiohjelmassa.
Moduuliin
Option Explicit
Type Jana
P1x As Integer
P1y As Integer
P2x As Integer
P2y As Integer
End Type
Function CheckCutting(J1 As Jana, J2 As Jana) As Boolean
Dim A As Single 'jana1:n kulmakerroin
Dim B As Single 'jana1:n y-akselin leikkauskohta
Dim C As Single 'jana2:n kulmakerroin
Dim D As Single 'jana2:n y-akselin leikkauskohta
Dim px As Single 'leikkauspiste
Dim py As Single 'leikkauspiste
'Sitten seruaa "purkkaa"
'Simuloidaan sitä, että suorat olisivat pystysuoria
A = 100000
C = 100000
'Jos suora ei ole pystysuora, lasketaan sen kulmakerroin
'y1-y2=k(x1-x2) -> k=(y1-y2)/(x1-x2)
If J1.P1x <> J1.P2x Then A = (J1.P1y - J1.P2y) / (J1.P1x - J1.P2x)
If J2.P1x <> J2.P2x Then C = (J2.P1y - J2.P2y) / (J2.P1x - J2.P2x)
'jos suorat ovat yhdensuuntaiset, ne eivät leikkaa
If A = C Then
CheckCutting = False
Exit Function
End If
'lasketaan suorien y-akselileikkauskohdat
B = -A * J1.P1x + J1.P1y
D = -C * J2.P1x + J2.P1y
'lasketaan suorien leikkauspiste
px = (D - B) / (A - C)
py = A * px + B
'jos suorat ovat vaakasuoria
If J1.P1x = J1.P2x Then px = J1.P1x
If J2.P1x = J2.P2x Then px = J2.P1x
'Sitten seruaa pari "sekavaa" ehtolausetta
'Niillä tarkistetaan, onko leikkauspiste janoilla
If ((J1.P1x >= px And J1.P2x <= px) Or (J1.P1x <= px And J1.P2x >= px)) And _
((J1.P1y >= py And J1.P2y <= py) Or (J1.P1y <= py And J1.P2y >= py)) Then
'En osaa sanoa, miksi py:lle pitää lasketa uusi arvo toisen suoran avulla
'Tuli vain mieleeni kokeilla, kun funktio temppuili eräässä ääritapauksessa, ja se toimi!
py = C * px + D
If ((J2.P1x >= px And J2.P2x <= px) Or (J2.P1x <= px And J2.P2x >= px)) And _
((J2.P1y >= py And J2.P2y <= py) Or (J2.P1y <= py And J2.P2y >= py)) Then
CheckCutting = True
End If
End If
End FunctionFormiin(testi)
Option Explicit
Private Sub Form_Load()
Me.ScaleMode = 3
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim J1 As Jana
Dim J2 As Jana
If KeyAscii = 13 Then
Randomize Timer
J1.P1x = Rnd() * 150 + 50
J1.P1y = Rnd() * 150 + 50
J1.P2x = Rnd() * 150 + 50
J1.P2y = Rnd() * 150 + 50
J2.P1x = Rnd() * 150 + 50
J2.P1y = Rnd() * 150 + 50
J2.P2x = Rnd() * 150 + 50
J2.P2y = Rnd() * 150 + 50
Cls
Line (J1.P1x, J1.P1y)-(J1.P2x, J1.P2y)
Line (J2.P1x, J2.P1y)-(J2.P2x, J2.P2y)
If CheckCutting(J1, J2) Then MsgBox "Leikkaa!"
End If
End SubHieno :) joskaan vähän sekava.
toimii hyvin! :)
koodi on pikkasen purkkaa, mutta elämässähän pitää olla haasteita ;) vois kattoa jos ite osaisi tehdä vastaavan, kopioimatta tätä.
Aihe on jo aika vanha, joten et voi enää vastata siihen.