Visual Basic için analitik geometri

by Oguz Koroglu 3. August 2011 13:38
AI4CAD-3D için Visual Basic ile yazmış olduğum analitik geometri kütüphanesini inceleyelim. Visual Basic ile ilgilenen arkadaşların işine yarayacağını düşünüyorum. Öncelikle analitikte bulunan basit tipleri (Nokta, çizgi, üçgen...) tanımlamak ile başlayalım. Bu tipler şu anda zaten XNA ve DirectX kütüphanelerinde (Vectors, Veritices, Tiriangles...) bulunmaktadır. Yanlız bunları bu şekilde kendimiz tanımlıyor olmamız DirectX ve OpenGL kütüphanlerini, dolayısıyla da Analitik Geometriyi daha iyi anlıyor olmamızı sağlayacaktır. NOKTA: Structure Nokta Implements ICloneable Implements IDisposable Public LocX As Single Public LocY As Single Public LocZ As Single Public Color As Color Public Property ColorArgb() As Integer Get Return Color.ToArgb() End Get Set(ByVal value As Integer) Color = Color.FromArgb(value) End Set End Property Public Property X() As Single Get Return LocX End Get Set(ByVal value As Single) LocX = value End Set End Property Public Property Y() As Single Get Return LocY End Get Set(ByVal value As Single) LocY = value End Set End Property Public Property Z() As Single Get Return LocZ End Get Set(ByVal value As Single) LocZ = value End Set End Property Public Sub New(ByVal lX As Single, ByVal lY As Single, ByVal lZ As Single) LocX = lX LocY = lY LocZ = lZ End Sub Public Sub New(ByVal lX As Single, ByVal lY As Single, ByVal lZ As Single, ByVal lColor As Color) LocX = lX LocY = lY LocZ = lZ Color = lColor End Sub Public ReadOnly Property ColorR() As Single Get Return Color.R / 255 End Get End Property Public ReadOnly Property ColorG() As Single Get Return Color.G / 255 End Get End Property Public ReadOnly Property ColorB() As Single Get Return Color.B / 255 End Get End Property Public Function IsEqualCoordinates(ByVal pNokta As Nokta) As Boolean If Math.Round(Me.LocX, 2) = Math.Round(pNokta.LocX, 2) And Math.Round(Me.LocY, 2) = Math.Round(pNokta.LocY, 2) And Math.Round(Me.LocZ, 2) = Math.Round(pNokta.LocZ, 2) Then Return True Else Return False End Function Public ReadOnly Property NoktaToString() As String Get With Me Dim MyStr As String = " X:" & .LocX.ToString("F") & ",Y:" & .LocY.ToString("F") & ",Z:" & .LocZ.ToString("F") Return MyStr End With End Get End Property Public ReadOnly Property Fark(ByVal pNokta As Nokta) As Nokta Get Return New Nokta(pNokta.LocX - Me.LocX, pNokta.LocY - Me.LocY, pNokta.LocZ - Me.LocZ) End Get End Property Public ReadOnly Property Toplam(ByVal pnokta As Nokta) As Nokta Get Return New Nokta(pnokta.LocX + Me.LocX, pnokta.LocY + Me.LocY, pnokta.LocZ + Me.LocZ) End Get End Property Public ReadOnly Property RotateAboutZ(ByVal pAngleInRadians As Single) As Nokta Get Dim Ang As Single = pAngleInRadians Return New Nokta((X * Cos(Ang) - Y * Sin(Ang)), (Y * Cos(Ang) + X * Sin(Ang)), LocZ) End Get End Property Public ReadOnly Property Normalize() As Nokta Get Dim t As Single = Sqrt(X * X + Y * Y + Z * Z) Return New Nokta(X / t, Y / t, Z / t, Me.Color) End Get End Property Public ReadOnly Property EksenAci_Radian(ByVal MyEksen As Eksen) Get Dim Ex As Nokta Select Case MyEksen Case Eksen.X Ex = New Nokta(1, 0, 0) Case Eksen.Y Ex = New Nokta(0, 1, 0) Case Eksen.Z Ex = New Nokta(0, 0, 1) End Select Dim v As Nokta = Me.Normalize Dim retVal As Single = VectorVectorAci_Radian(Ex, v, False) Return retVal End Get End Property Public ReadOnly Property ScaleLenXY(ByVal pAdd As Single) As Nokta Get Dim retVal As Nokta Dim XAci As Single = EksenAci_Radian(Eksen.X) Dim Yaci As Single = EksenAci_Radian(Eksen.Y) Dim Xadd As Single = pAdd * Cos(XAci) Dim Yadd As Single = pAdd * Cos(Yaci) retVal = New Nokta(X + Xadd, Y + Yadd, Z) Return retVal End Get End Property Public Function Clone() As Object Implements System.ICloneable.Clone Dim MyClone As New Nokta MyClone = Me.MemberwiseClone Return MyClone End Function Public Sub Dispose() Implements System.IDisposable.Dispose End Sub End Structure ÇİZGİ : Class Cizgi Implements ICloneable Implements IDisposable Public MyNokta(1) As Nokta Public Property Kose1() As Nokta Get Return MyNokta(0) End Get Set(ByVal value As Nokta) MyNokta(0) = value End Set End Property Public Property Kose2() As Nokta Get Return MyNokta(1) End Get Set(ByVal value As Nokta) MyNokta(1) = value End Set End Property Private MyColor As Color Public Property Rengi() As Color Get Return MyColor End Get Set(ByVal value As Color) MyColor = value For i = 0 To MyNokta.Length - 1 MyNokta(i).Color = MyColor Next i End Set End Property Public Property ColorArgb() As Integer Get Return MyColor.ToArgb() End Get Set(ByVal value As Integer) MyColor = Color.FromArgb(value) End Set End Property Sub New(ByVal p1 As Nokta, ByVal p2 As Nokta) MyNokta(0) = p1 MyNokta(1) = p2 End Sub Sub New(ByVal p1 As Nokta, ByVal p2 As Nokta, ByVal pColor As Color) MyNokta(0) = p1 MyNokta(1) = p2 MyColor = pColor End Sub Sub New() End Sub Public ReadOnly Property Uzunlugu() As Single Get Dim Xa As Single = MyNokta(0).LocX, Xb As Single = MyNokta(1).LocX Dim Ya As Single = MyNokta(0).LocY, Yb As Single = MyNokta(1).LocY Dim Za As Single = MyNokta(0).LocZ, Zb As Single = MyNokta(1).LocZ Dim Line1 As Single = Math.Sqrt((Xb - Xa) ^ 2 + (Yb - Ya) ^ 2 + (Zb - Za) ^ 2) Return Line1 End Get End Property Public Function HasSameCoordinates(ByVal pCizgi As Cizgi) As Boolean If Me.Kose1.IsEqualCoordinates(pCizgi.Kose1) And _ Me.Kose2.IsEqualCoordinates(pCizgi.Kose2) Then Return True ElseIf Me.Kose1.IsEqualCoordinates(pCizgi.Kose2) And _ Me.Kose2.IsEqualCoordinates(pCizgi.Kose1) Then Return True Else Return False End If End Function Public Function HasSameStartLocation(ByVal pCizgi As Cizgi) As Boolean Return Me.Kose1.IsEqualCoordinates(pCizgi.Kose1) End Function Public Function HasSameEndLocation(ByVal pCizgi As Cizgi) As Boolean Return Me.Kose2.IsEqualCoordinates(pCizgi.Kose2) End Function Public Function IsNoktaOnMe(ByVal pNokta As Nokta) As Boolean Try Dim Nok1 As Nokta = Me.Kose1, dNok1 As Nokta = Nok1 Dim Nok2 As Nokta = Me.Kose2, dNok2 As Nokta = Nok2 Dim mNok As Nokta = pNokta Dim x1 As Single = Nok1.LocX, x2 As Single = Nok2.LocX Dim y1 As Single = Nok1.LocY, y2 As Single = Nok2.LocY Dim GLy As Single = mNok.LocY, GLx As Single = mNok.LocX Dim m1 As Single If dNok1.LocZ <> mNok.LocZ Or dNok2.LocZ <> mNok.LocZ Then Return False If x1 = GLx And y1 = GLy Then Return True 'ilk noktada demektir If x2 = GLx And y2 = GLy Then Return True '2. noktada demektir If Math.Round(y2, 2) = Math.Round(y1, 2) And Math.Round(y1, 2) = Math.Round(GLy, 2) Then 'yatay bir doğrudur If GLx >= x1 And GLx < x2 Then Return True ElseIf GLx >= x2 And GLx < x1 Then Return True End If End If If Math.Round(x2, 2) = Math.Round(x1, 2) And Math.Round(x1, 2) = Math.Round(GLx, 2) Then 'dikey bir doğru demektir If GLy >= y1 And GLy < y2 Then Return True ElseIf GLy >= y2 And GLy < y1 Then Return True End If End If m1 = (y2 - y1) / (x2 - x1) If Math.Round(m1, 2) = Math.Round((GLy - y1) / (GLx - x1), 2) Then If Me.Uzunlugu >= New Cizgi(Nok1, mNok).Uzunlugu And Me.Uzunlugu >= New Cizgi(Nok2, mNok).Uzunlugu Then Return True End If End If Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function Public Function IsCizgiOnMe(ByVal pCizgi As Cizgi) As Boolean If HasSameCoordinates(pCizgi) = True Then Return True If Me.IsNoktaOnMe(pCizgi.Kose1) And Me.IsNoktaOnMe(pCizgi.Kose2) Then Return True ElseIf pCizgi.IsNoktaOnMe(Me.Kose1) And pCizgi.IsNoktaOnMe(Me.Kose2) Then Return True Else Return False End If End Function Public Sub ReverseMe() Dim NewNokta(1) As Nokta NewNokta(0) = Kose2 NewNokta(1) = Kose1 MyNokta = NewNokta End Sub Public Function Clone() As Object Implements System.ICloneable.Clone Dim MyClone As New Cizgi(MyNokta(0).Clone, MyNokta(1).Clone, MyColor) Return MyClone End Function Private disposedValue As Boolean = False ' To detect redundant calls ' IDisposable Protected Overridable Sub Dispose(ByVal disposing As Boolean) If Not Me.disposedValue Then If disposing Then ' TODO: free other state (managed objects). End If ' TODO: free your own state (unmanaged objects). ' TODO: set large fields to null. End If Me.disposedValue = True End Sub #Region " IDisposable Support " ' This code added by Visual Basic to correctly implement the disposable pattern. Public Sub Dispose() Implements IDisposable.Dispose ' Do not change this code. Put cleanup code in Dispose(ByVal disposing As Boolean) above. Dispose(True) GC.SuppressFinalize(Me) End Sub #End Region End Class ÜÇGEN: Class Ucgen Implements ICloneable Implements IDisposable Public ID As Integer Public Name As String Public MyNokta(2) As Nokta Public Property Kose1() As Nokta Get Return MyNokta(0) End Get Set(ByVal value As Nokta) MyNokta(0) = value End Set End Property Public Property Kose2() As Nokta Get Return MyNokta(1) End Get Set(ByVal value As Nokta) MyNokta(1) = value End Set End Property Public Property Kose3() As Nokta Get Return MyNokta(2) End Get Set(ByVal value As Nokta) MyNokta(2) = value End Set End Property Public ReadOnly Property Kenar1() As Cizgi Get Return New Cizgi(MyNokta(0), MyNokta(1)) End Get End Property Public ReadOnly Property Kenar2() As Cizgi Get Return New Cizgi(MyNokta(0), MyNokta(2)) End Get End Property Public ReadOnly Property Kenar3() As Cizgi Get Return New Cizgi(MyNokta(1), MyNokta(2)) End Get End Property Private MyColor As Color Public Property Rengi() As Color Get Return Me.MyColor End Get Set(ByVal value As Color) Me.MyColor = value MyNokta(0).Color = value MyNokta(1).Color = value MyNokta(2).Color = value End Set End Property Public Property ColorArgb() As Integer Get Return MyColor.ToArgb End Get Set(ByVal value As Integer) MyColor = Color.FromArgb(value) End Set End Property Public Sub New(ByVal pN1 As Nokta, ByVal pN2 As Nokta, ByVal pN3 As Nokta) MyNokta(0) = pN1 MyNokta(1) = pN2 MyNokta(2) = pN3 End Sub Public Sub New(ByVal pN1 As Nokta, ByVal pN2 As Nokta, ByVal pN3 As Nokta, ByVal pColor As Color) MyNokta(0) = pN1 MyNokta(1) = pN2 MyNokta(2) = pN3 MyColor = pColor MyNokta(0).Color = pColor MyNokta(1).Color = pColor MyNokta(2).Color = pColor End Sub Public Sub New() End Sub Public Function NoktaIcındemi(ByVal pNokta As Nokta) As Boolean Try If pNokta.LocZ <> Me.Kose1.LocZ Then Return False 'bu fonksiyon sadece düzlemsel çalışır Dim MyCalculus As New CalculusPRJ1.CalculusPRJ1class Dim A As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {2, 1}) Dim B As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {2, 1}) Dim C As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {2, 1}) Dim P As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {2, 1}) Dim retVal As MathWorks.MATLAB.NET.Arrays.MWLogicalArray P(1, 1) = pNokta.LocX : P(2, 1) = pNokta.LocY A(1, 1) = Me.Kose1.LocX : A(2, 1) = Me.Kose1.LocY B(1, 1) = Me.Kose2.LocX : B(2, 1) = Me.Kose2.LocY C(1, 1) = Me.Kose3.LocX : C(2, 1) = Me.Kose3.LocY retVal = MyCalculus.IsPinABC(P, A, B, C) Return retVal Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function Public ReadOnly Property Alani() As Single Get Try Dim MyCalculus As New CalculusPRJ1.CalculusPRJ1class Dim Xa As Single = MyNokta(0).LocX, Xb As Single = MyNokta(1).LocX, Xc As Single = MyNokta(2).LocX Dim Ya As Single = MyNokta(0).LocY, Yb As Single = MyNokta(1).LocY, Yc As Single = MyNokta(2).LocY Dim Za As Single = MyNokta(0).LocZ, Zb As Single = MyNokta(1).LocZ, Zc As Single = MyNokta(2).LocZ Dim Matris1 As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {3, 3}) Dim Matris2 As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {3, 3}) Dim Matris3 As New MathWorks.MATLAB.NET.Arrays.MWNumericArray(New Integer() {3, 3}) Dim Matris1Det As MathWorks.MATLAB.NET.Arrays.MWNumericArray Dim Matris2Det As MathWorks.MATLAB.NET.Arrays.MWNumericArray Dim Matris3Det As MathWorks.MATLAB.NET.Arrays.MWNumericArray 'Matris1 Matris1(1, 1) = Xa : Matris1(1, 2) = Xb : Matris1(1, 3) = Xc Matris1(2, 1) = Ya : Matris1(2, 2) = Yb : Matris1(2, 3) = Yc Matris1(3, 1) = 1 : Matris1(3, 2) = 1 : Matris1(3, 3) = 1 Matris1Det = MyCalculus.MDet(Matris1) 'Matris2 Matris2(1, 1) = Ya : Matris2(1, 2) = Yb : Matris2(1, 3) = Yc Matris2(2, 1) = Za : Matris2(2, 2) = Zb : Matris2(2, 3) = Zc Matris2(3, 1) = 1 : Matris2(3, 2) = 1 : Matris2(3, 3) = 1 Matris2Det = MyCalculus.MDet(Matris2) 'Matris3 Matris3(1, 1) = Za : Matris3(1, 2) = Zb : Matris3(1, 3) = Zc Matris3(2, 1) = Xa : Matris3(2, 2) = Xb : Matris3(2, 3) = Xc Matris3(3, 1) = 1 : Matris3(3, 2) = 1 : Matris3(3, 3) = 1 Matris3Det = MyCalculus.MDet(Matris3) Return 0.5 * Math.Sqrt(Matris1Det.ToString ^ 2 + Matris2Det.ToString ^ 2 + Matris3Det.ToString ^ 2) Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Get End Property Public ReadOnly Property Cevresi() As Single Get Try Dim Xa As Single = MyNokta(0).LocX, Xb As Single = MyNokta(1).LocX, Xc As Single = MyNokta(2).LocX Dim Ya As Single = MyNokta(0).LocY, Yb As Single = MyNokta(1).LocY, Yc As Single = MyNokta(2).LocY Dim Za As Single = MyNokta(0).LocZ, Zb As Single = MyNokta(1).LocZ, Zc As Single = MyNokta(2).LocZ Dim Line1 As Single = Math.Sqrt((Xb - Xa) ^ 2 + (Ya - Ya) ^ 2 + (Za - Za) ^ 2) Dim Line2 As Single = Math.Sqrt((Xc - Xa) ^ 2 + (Yc - Ya) ^ 2 + (Zc - Za) ^ 2) Dim Line3 As Single = Math.Sqrt((Xc - Xb) ^ 2 + (Yc - Yb) ^ 2 + (Zc - Zb) ^ 2) Return Line1 + Line2 + Line3 Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Get End Property Public Function Clone() As Object Implements System.ICloneable.Clone Dim MyClone = New Ucgen(Me.Kose1.Clone, Me.Kose2.Clone, Me.Kose3.Clone, Me.MyColor) Return MyClone End Function Private disposedValue As Boolean = False ' To detect redundant calls ' IDisposable Protected Overridable Sub Dispose(ByVal disposing As Boolean) If Not Me.disposedValue Then If disposing Then ' TODO: free other state (managed objects). End If ' TODO: free your own state (unmanaged objects). ' TODO: set large fields to null. End If Me.disposedValue = True End Sub #Region " IDisposable Support " ' This code added by Visual Basic to correctly implement the disposable pattern. Public Sub Dispose() Implements IDisposable.Dispose ' Do not change this code. Put cleanup code in Dispose(ByVal disposing As Boolean) above. Dispose(True) GC.SuppressFinalize(Me) End Sub #End Region End Class DÖRTGEN: Class Dortgen Implements ICloneable Implements IDisposable Public ID As Integer Public Name As String Public DrawLines As Boolean Public LineWidth As Integer Public LineColor As Color Public Property LineColorArgb() As Integer Get Return LineColor.ToArgb End Get Set(ByVal value As Integer) LineColor = Color.FromArgb(value) End Set End Property Public MyNokta(3) As Nokta Public Property Kose1() As Nokta Get Return MyNokta(0) End Get Set(ByVal value As Nokta) MyNokta(0) = value End Set End Property Public Property Kose2() As Nokta Get Return MyNokta(1) End Get Set(ByVal value As Nokta) MyNokta(1) = value End Set End Property Public Property Kose3() As Nokta Get Return MyNokta(2) End Get Set(ByVal value As Nokta) MyNokta(2) = value End Set End Property Public Property Kose4() As Nokta Get Return MyNokta(3) End Get Set(ByVal value As Nokta) MyNokta(3) = value End Set End Property Public ReadOnly Property Koseleri() As Nokta() Get Return MyNokta End Get End Property Public ReadOnly Property Kenar1() As Cizgi Get Return New Cizgi(MyNokta(0), MyNokta(1)) End Get End Property Public ReadOnly Property Kenar2() As Cizgi Get Return New Cizgi(MyNokta(1), MyNokta(2)) End Get End Property Public ReadOnly Property Kenar3() As Cizgi Get Return New Cizgi(MyNokta(2), MyNokta(3)) End Get End Property Public ReadOnly Property Kenar4() As Cizgi Get Return New Cizgi(MyNokta(3), MyNokta(0)) End Get End Property Public ReadOnly Property Kenarlari() As Cizgi() Get Dim Kenars(3) As Cizgi Kenars(0) = Kenar1 Kenars(1) = Kenar2 Kenars(2) = Kenar3 Kenars(3) = Kenar4 Return Kenars End Get End Property Public Triangles(1) As Ucgen Public ReadOnly Property Ucgeni1() As Ucgen Get Return Triangles(0) End Get End Property Public ReadOnly Property Ucgeni2() As Ucgen Get Return Triangles(1) End Get End Property Private MyColor As Color Public Property Rengi() As Color Get Return MyColor End Get Set(ByVal value As Color) MyColor = value MyNokta(0).Color = value MyNokta(1).Color = value MyNokta(2).Color = value MyNokta(3).Color = value For i = 0 To Triangles.Length - 1 Triangles(i).Rengi = MyColor Next i End Set End Property Public Property ColorArgb() As Integer Get Return MyColor.ToArgb End Get Set(ByVal value As Integer) MyColor = Color.FromArgb(value) End Set End Property Public Sub New(ByVal pN1 As Nokta, ByVal pN2 As Nokta, ByVal pN3 As Nokta, ByVal pN4 As Nokta) MyNokta(0) = pN1 MyNokta(1) = pN2 MyNokta(2) = pN3 MyNokta(3) = pN4 Triangles(0) = New Ucgen(MyNokta(0), MyNokta(1), MyNokta(2)) Triangles(1) = New Ucgen(MyNokta(2), MyNokta(3), MyNokta(0)) End Sub Public Sub New(ByVal pN1 As Nokta, ByVal pN2 As Nokta, ByVal pN3 As Nokta, ByVal pN4 As Nokta, ByVal pColor As Color) MyNokta(0) = pN1 MyNokta(1) = pN2 MyNokta(2) = pN3 MyNokta(3) = pN4 MyColor = pColor MyNokta(0).Color = pColor MyNokta(1).Color = pColor MyNokta(2).Color = pColor MyNokta(3).Color = pColor Triangles(0) = New Ucgen(MyNokta(0), MyNokta(1), MyNokta(2), MyColor) Triangles(1) = New Ucgen(MyNokta(2), MyNokta(3), MyNokta(0), MyColor) End Sub Public Sub New() Triangles(0) = New Ucgen(MyNokta(0), MyNokta(1), MyNokta(2), MyColor) Triangles(1) = New Ucgen(MyNokta(2), MyNokta(3), MyNokta(0), MyColor) End Sub Public Function NoktaIcindemi(ByVal pNokta As Nokta) As Boolean For i = 0 To Me.Triangles.Length - 1 If Me.Triangles(i).NoktaIcındemi(pNokta) = True Then Return True Next i Return False End Function Public ReadOnly Property Alani() Get Return Triangles(0).Alani + Triangles(1).Alani End Get End Property Public ReadOnly Property Cevresi() Get Return Kenar1.Uzunlugu + Kenar2.Uzunlugu + Kenar3.Uzunlugu + Kenar4.Uzunlugu End Get End Property Public Function Clone() As Object Implements System.ICloneable.Clone Dim MyClone As New Dortgen(MyNokta(0), MyNokta(1), MyNokta(2), MyNokta(3)) Return MyClone End Function Private disposedValue As Boolean = False ' To detect redundant calls ' IDisposable Protected Overridable Sub Dispose(ByVal disposing As Boolean) If Not Me.disposedValue Then If disposing Then ' TODO: free other state (managed objects). End If ' TODO: free your own state (unmanaged objects). ' TODO: set large fields to null. End If Me.disposedValue = True End Sub #Region " IDisposable Support " ' This code added by Visual Basic to correctly implement the disposable pattern. Public Sub Dispose() Implements IDisposable.Dispose ' Do not change this code. Put cleanup code in Dispose(ByVal disposing As Boolean) above. Dispose(True) GC.SuppressFinalize(Me) End Sub #End Region End Class Bu basit tipleri bu şekilde açıkca tanımladıktan sonra bazı analitik hesaplarına bu sınıflar üzerinden geçebiliriz. Bir noktanın diğer bir noktaya uzaklığı: Public Function NoktaNoktaUzaklik(ByVal pNok1 As Nokta, ByVal pNok2 As Nokta) As Single Dim MyCizgi As New Cizgi(pNok1, pNok2) Return MyCizgi.Uzunlugu End Function  Bir noktanın doğru üzerinde olup olmadığı kontrolü: Public Function NoktaDogruUzerindemi(ByVal dNok1 As Nokta, ByVal dNok2 As Nokta, ByVal mNok As Nokta) As Boolean Try Dim Nok1 As Nokta = dNok1 Dim Nok2 As Nokta = dNok2 Dim x1 As Single = Nok1.LocX, x2 As Single = Nok2.LocX Dim y1 As Single = Nok1.LocY, y2 As Single = Nok2.LocY Dim GLy As Single = mNok.LocY, GLx As Single = mNok.LocX Dim m1 As Single If dNok1.LocZ <> mNok.LocZ Or dNok2.LocZ <> mNok.LocZ Then Return False If x1 = GLx And y1 = GLy Then Return True 'ilk noktada demektir If x2 = GLx And y2 = GLy Then Return True '2. noktada demektir If Round(y2, 2) = Round(y1, 2) And Round(y1, 2) = Round(GLy, 2) Then 'yatay bir doğrudur If GLx >= x1 And GLx < x2 Then Return True ElseIf GLx >= x2 And GLx < x1 Then Return True End If End If If Round(x2, 2) = Round(x1, 2) And Round(x1, 2) = Round(GLx, 2) Then 'dikey bir doğru demektir If GLy >= y1 And GLy < y2 Then Return True ElseIf GLy >= y2 And GLy < y1 Then Return True End If End If m1 = (y2 - y1) / (x2 - x1) If Round(m1, 2) = Round((GLy - y1) / (GLx - x1), 2) Then If NoktaNoktaUzaklik(Nok1, Nok2) >= NoktaNoktaUzaklik(Nok1, mNok) And NoktaNoktaUzaklik(Nok1, Nok2) >= NoktaNoktaUzaklik(Nok2, mNok) Then Return True End If End If Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function Bir noktanın bir dörtgen içinde olup olmadığı kontrolü: Public Function NoktaDortgenIcindemi(ByVal pDortgen As Dortgen, ByVal mNok As Nokta) As Boolean Try If mNok.LocZ <> pDortgen.Kose1.LocZ Then Return False If mNok.LocX = pDortgen.Kose1.LocX And mNok.LocY = pDortgen.Kose1.LocY Then Return True If mNok.LocX = pDortgen.Kose2.LocX And mNok.LocY = pDortgen.Kose2.LocY Then Return True If mNok.LocX = pDortgen.Kose3.LocX And mNok.LocY = pDortgen.Kose3.LocY Then Return True If mNok.LocX = pDortgen.Kose4.LocX And mNok.LocY = pDortgen.Kose4.LocY Then Return True If NoktaDogruUzerindemi(pDortgen.Kose1, pDortgen.Kose2, mNok) Then Return True If NoktaDogruUzerindemi(pDortgen.Kose2, pDortgen.Kose3, mNok) Then Return True If NoktaDogruUzerindemi(pDortgen.Kose3, pDortgen.Kose4, mNok) Then Return True If NoktaDogruUzerindemi(pDortgen.Kose4, pDortgen.Kose1, mNok) Then Return True If mNok.LocY > pDortgen.Kose1.LocY And mNok.LocY < pDortgen.Kose4.LocY Or mNok.LocY < pDortgen.Kose1.LocY And mNok.LocY > pDortgen.Kose4.LocY Then If mNok.LocX > pDortgen.Kose1.LocX And mNok.LocX < pDortgen.Kose2.LocX Or mNok.LocX < pDortgen.Kose1.LocX And mNok.LocX > pDortgen.Kose2.LocX Then Return True End If End If Return False Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function Bir noktadan bir doğruya çizilebilen en kısa çizginin (dik doğru parçasının) doğruyu kestiği nokta: Public Function NoktaDogruyuDikKesenNokta(ByVal dNok1 As Nokta, ByVal dNok2 As Nokta, ByVal mNok As Nokta) As Nokta Try Dim Nok1 As Nokta = dNok1 Dim Nok2 As Nokta = dNok2 Dim x1 As Single = Nok1.LocX, x2 As Single = Nok2.LocX Dim y1 As Single = Nok1.LocY, y2 As Single = Nok2.LocY Dim GLy As Single = mNok.LocY, GLx As Single = mNok.LocX Dim m1 As Single, m2 As Single Dim x3 As Single, y3 As Single If x2 = x1 Then x3 = x1 y3 = GLy ElseIf y2 = y1 Then x3 = GLx y3 = y1 Else m1 = (y2 - y1) / (x2 - x1) m2 = -1 / m1 y3 = (y1 * m2 - (x1 - GLx) * m1 * m2 - GLy * m1) / (m2 - m1) x3 = (y3 - y1) / m1 + x1 End If Return New Nokta(x3, y3, mNok.LocZ) Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function  Bir noktanın bir doğruya olan dik uzaklığı: Public Function NoktaDogruyaDikUzaklik(ByVal dNok1 As Nokta, ByVal dNok2 As Nokta, ByVal mNok As Nokta) As Single Try Dim Nok1 As Nokta = dNok1 Dim Nok2 As Nokta = dNok2 Dim x1 As Single = Nok1.LocX, x2 As Single = Nok2.LocX Dim y1 As Single = Nok1.LocY, y2 As Single = Nok2.LocY Dim GLy As Single = mNok.LocY, GLx As Single = mNok.LocX If x2 - x1 = 0 Then Return GLy - y2 'eğimi 0 sa Dim m As Single = (y2 - y1) / (x2 - x1) Dim b As Single = 1, a As Single = -m, c As Single = -y1 + m * x1 Dim Ust As Single = Math.Abs(a * GLx + b * GLy + c) Dim Alt As Single = Sqrt(a ^ 2 + b ^ 2) Return Ust / Alt Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function  İki doğrunun kesişim noktası: Public Function DogruDogruKesisim(ByVal d1Nok1 As Nokta, ByVal d1Nok2 As Nokta, ByVal d2Nok1 As Nokta, ByVal d2Nok2 As Nokta) As Nokta Try Dim _x(5) As Single, _y(5) As Single Dim _m(2) As Single _x(1) = d1Nok1.LocX : _x(2) = d1Nok2.LocX : _x(4) = d2Nok1.LocX : _x(5) = d2Nok2.LocX _y(1) = d1Nok1.LocY : _y(2) = d1Nok2.LocY : _y(4) = d2Nok1.LocY : _y(5) = d2Nok2.LocY If _x(2) <> _x(1) And _x(5) <> _x(4) Then _m(1) = (_y(2) - _y(1)) / (_x(2) - _x(1)) _m(2) = (_y(5) - _y(4)) / (_x(5) - _x(4)) _x(3) = (_x(1) * _m(1) - _y(1) - _x(4) * _m(2) + _y(4)) / (_m(1) - _m(2)) _y(3) = (_x(3) - _x(1)) * _m(1) + _y(1) ElseIf _x(1) = _x(2) And _x(5) <> _x(4) Then _m(2) = (_y(5) - _y(4)) / (_x(5) - _x(4)) _x(3) = _x(1) _y(3) = (_x(3) - _x(4)) * _m(2) + _y(4) ElseIf _x(1) <> _x(2) And _x(5) = _x(4) Then _m(1) = (_y(2) - _y(1)) / (_x(2) - _x(1)) _x(3) = _x(5) _y(3) = (_x(3) - _x(1)) * _m(1) + _y(1) Else Return Nothing End If Return New Nokta(_x(3), _y(3), d1Nok1.LocZ) Catch ex As Exception Dim MyERR As New frmErrorReport(ex) MyERR.ShowDialog() End Try End Function Elips Y denklemi: Public Function Elips_Y_Equation(ByVal CenterX As Single, ByVal CenterY As Single, ByVal XLen As Single, ByVal YLen As Single, ByVal XCoord As Single) As Single Dim h As Single = CenterX Dim k As Single = CenterY Dim a As Single = XLen Dim b As Single = YLen Dim x As Single = XCoord Dim y As Single If x > h Then y = k + (Sqrt(4 / b ^ 2 - (4 * (x - h) ^ 2) / (a ^ 2 * b ^ 2)) * b ^ 2) / 2 Else y = k - (Sqrt(4 / b ^ 2 - (4 * (x - h) ^ 2) / (a ^ 2 * b ^ 2)) * b ^ 2) / 2 End If Return y End Function Bir vektörün diğer bir vektörle yaptığı açı (radyan cinsinden): Public Function VectorVectorAci_Radian(ByVal v1 As Nokta, ByVal v2 As Nokta, ByVal AlwaysPossitive As Boolean) As Single Dim v1n As Nokta = v1.Normalize Dim v2n As Nokta = v2.Normalize Dim retVal As Single Dim MyAtan = Atan2(v2n.LocY, v2n.LocX) - Atan2(v1n.LocY, v1n.LocX) If AlwaysPossitive Then If MyAtan < 0 Then retVal = ToRadians(360) + MyAtan Else retVal = MyAtan End If Else retVal = MyAtan End If 'Dim retVal As Single = Acos(v1n.LocX * v2n.LocX + v1n.LocY * v2n.LocY + v1n.LocZ * v2n.LocZ) Return retVal End Function  Kodların tamamını http://ai4cad3d.codeplex.com/ adresinde bulabilirsiniz. Umarım ilgilenen arkadaşların işine yarar.  

Tags: , , , , ,

VB.NET

AI4CAD M&M1 Metraj ve Maliyet Programı

by Oguz Koroglu 7. July 2011 15:17
Zamanında ticari açamla yazmış olduğum AI4CAD M&M1 Metraj ve Maliyet proramını http://ai4cadm1.codeplex.com/ adresinde vb.net kaynak kodlarıyla birlikte yayınlıyorum. Program İnşaat metrajı ve nakliye maliyetleri üzerine raporlama yapmaktadır. Yazılım geliştiren arkadaşlar için faydalı olacağını umarım. Emeği geçen herkese teşekkürler.

Tags: , , , ,

VB.NET | Software

AI4CAD 3D

by Oguz Koroglu 27. June 2011 16:28
I have published a new open source project called AI4CAD-3D in codeplex. This project is good for architectural design with OpenGL. To download : http://ai4cad3d.codeplex.com/ .

Tags: , , ,

VB.NET | Software

Powered by BlogEngine.NET 2.0.0.36
Theme by Mads Kristensen | Modified by Mooglegiant | Some Development Modifications by Oðuz Köroðlu

codeplex projects

VMBase WinRT
vmbase.codeplex.com/

Real Square
realsquare.codeplex.com/

Silver Designer
silverdesigner.codeplex.com/ 

WPF Multitouch CMS
wpfmultitouchcms.codeplex.com/

MongoDB Backup and Restore Manager
mongobackup.codeplex.com/

Bounce Ball
bounceball.codeplex.com/

Cloud Wallet
cloudwallet.codeplex.com/

Windows Mobile 6 Calculator
wm6calculator.codeplex.com/

AI4CAD-3D
ai4cad3d.codeplex.com/

LAM-Local Area Messaging
lam.codeplex.com/

Right Click Calculator
rightclickcalculator.codeplex.com/

WPF Hex Editor
wpfhexeditor.codeplex.com/

Get Paint.NET!

Month List