#1 Tue 30 November 2010 13:12
- Sylvain PIERRE
- Participant assidu
- Lieu: Strasbourg
- Date d'inscription: 6 Sep 2005
- Messages: 170
Recherche algorithme définition boites englobantes
Bonjour,
Mes données de départ: ensemble d'ilots culturaux appartenant à un agriculteur répartis sur plusieurs communes.
Objectif: sortir des cartes à échelle fixe (1/5000) représentant les différents ilots, sans couper le moindre ilot, sans représenter plusieurs fois un même ilot sur plusieurs cartes
Question: quelle algo doit me permettre de définir le groupes d'ilots représentés sur chaque carte?
d'avance merci
Hors ligne
#2 Thu 02 December 2010 12:25
Re: Recherche algorithme définition boites englobantes
Bonjour,
L'ASP dispose de cet algo:
http://www.asp-public.fr/?q=node/856
Mais je doute qu'ils vous en fassent cadeau.
En revanche, pourquoi pas un deal pour disposer des cadres sur le 67?
Bruno
Dernière modification par Bruno (Thu 02 December 2010 12:49)
Hors ligne
#3 Thu 02 December 2010 15:13
- ChristopheV
- Membre
- Lieu: Ajaccio
- Date d'inscription: 7 Sep 2005
- Messages: 3185
- Site web
Re: Recherche algorithme définition boites englobantes
Bonjour,
Les conditions à l'origine de votre équation sont difficiles.
Une solution possible une fois connu le format d'impression.
Soit Ei l'encadrante d'un ilot ( ie le rectangle défini par xmin, ymin, xmax, ymax de la polyligne définissant l'ilot)
Quels sont les Ei inclus totalement dans un rectangle d'étendue le format de la carte ?
Puis ilot suivant ...
Un code VB6 définissant une classe (rectangle) que vous pourrez adapter il y a ce qu'il vous faut (union, intersection, est vide ...)
Code:
Option Explicit Private mLeft As Double Private mRight As Double Private mBottom As Double Private mTop As Double Private mColor As Long Public Property Get Color() As Long Color = mColor End Property Public Property Let Color(ByVal Color As Long) mColor = Color End Property Public Property Get Left() As Double Left = mLeft End Property Public Property Let Left(ByVal Left As Double) mLeft = Left End Property Public Property Get Right() As Double Right = mRight End Property Public Property Let Right(ByVal Right As Double) mRight = Right End Property Public Property Get Bottom() As Double Bottom = mBottom End Property Public Property Let Bottom(ByVal Bottom As Double) mBottom = Bottom End Property Public Property Get Top() As Double Top = mTop End Property Public Property Let Top(ByVal Top As Double) mTop = Top End Property Public Function PinRegion(p As Classpoint) As Boolean If p.x < mLeft Then PinRegion = False Exit Function Else If p.x > mRight Then PinRegion = False Exit Function Else If p.y < mBottom Then PinRegion = False Exit Function Else If p.y > mTop Then PinRegion = False Exit Function Else PinRegion = True End If End If End If End If End Function Public Function VertexInRegion(p As Vertex) As Boolean If p.x < mLeft Then VertexInRegion = False Exit Function Else If p.x > mRight Then VertexInRegion = False Exit Function Else If p.y < mBottom Then VertexInRegion = False Exit Function Else If p.y > mTop Then VertexInRegion = False Exit Function Else VertexInRegion = True End If End If End If End If End Function Public Function rotate(x As Double, y As Double, deltagis As Double) Dim p(3) As Classpoint Dim i& Dim Xmax As Double Dim Xmin As Double Dim Ymax As Double Dim Ymin As Double For i& = 0 To 3 Set p(i&) = New Classpoint Select Case i& Case 0 p(i&).x = mLeft p(i&).y = mBottom Case 1 p(i&).x = mLeft p(i&).y = mTop Case 2 p(i&).x = mRight p(i&).y = mTop Case 3 p(i&).x = mRight p(i&).y = mBottom End Select p(i&).rotate x, y, deltagis Next i& Xmin = p(0).x Ymin = p(0).y Xmax = p(2).x Ymax = p(2).y For i& = 0 To 3 If p(i&).x < Xmin Then Xmin = p(i&).x End If If p(i&).y < Ymin Then Ymin = p(i&).y End If If p(i&).x > Xmax Then Xmax = p(i&).x End If If p(i&).y > Ymax Then Ymax = p(i&).y End If Next i& mBottom = Ymin mTop = Ymax mLeft = Xmin mRight = Xmax End Function Public Function Intersection(r As RealRegion) As RealRegion Dim Inter As RealRegion Dim T As Double Set Inter = New RealRegion If mLeft < r.Left Then If mRight < r.Left Then Inter.Bottom = 0 Inter.Left = 0 Inter.Right = 0 Inter.Top = 0 Set Intersection = Inter Set Inter = Nothing Exit Function Else If mRight > r.Right Then Inter.Left = r.Left Inter.Right = r.Right Else Inter.Left = r.Left Inter.Right = mRight End If End If Else If mLeft > r.Right Then Inter.Bottom = 0 Inter.Left = 0 Inter.Right = 0 Inter.Top = 0 Set Intersection = Inter Set Inter = Nothing Exit Function Else If mRight > r.Right Then Inter.Left = mLeft Inter.Right = r.Right Else Inter.Left = mLeft Inter.Right = mRight End If End If End If If mBottom < r.Bottom Then If mTop < r.Bottom Then Inter.Bottom = 0 Inter.Left = 0 Inter.Right = 0 Inter.Top = 0 Set Intersection = Inter Set Inter = Nothing Exit Function Else If mTop > r.Top Then Inter.Bottom = r.Bottom Inter.Top = r.Top Else Inter.Bottom = r.Bottom Inter.Top = mTop End If End If Else If mBottom > r.Top Then Inter.Bottom = 0 Inter.Left = 0 Inter.Right = 0 Inter.Top = 0 Set Intersection = Inter Set Inter = Nothing Exit Function Else If mTop > r.Top Then Inter.Bottom = mBottom Inter.Top = r.Top Else Inter.Bottom = mBottom Inter.Top = mTop End If End If End If Set Intersection = Inter Set Inter = Nothing End Function Public Function clone(r As RealRegion) r.Bottom = mBottom r.Left = mLeft r.Right = mRight r.Top = mTop End Function Public Function EstVide() As Boolean If mBottom = mTop And mRight = mLeft Then EstVide = True Else EstVide = False End If End Function Public Sub ordonne() Dim x1 As Double If mBottom > mTop Then x1 = mTop mTop = mBottom mBottom = x1 End If If mLeft > mRight Then x1 = mRight mRight = mLeft mLeft = x1 End If End Sub Public Function Union(r As RealRegion) As RealRegion Dim un As RealRegion Set un = New RealRegion If mBottom = mTop And mLeft = mRight Then Set Union = r Set un = Nothing Exit Function End If If r.Left < mLeft Then un.Left = r.Left Else un.Left = mLeft End If If r.Right > mRight Then un.Right = r.Right Else un.Right = mRight End If If r.Bottom < mBottom Then un.Bottom = r.Bottom Else un.Bottom = mBottom End If If r.Top > mTop Then un.Top = r.Top Else un.Top = mTop End If Set Union = un Set un = Nothing End Function Public Function Egale(r As RealRegion) As Boolean If r.Bottom = mBottom And r.Top = mTop And r.Left = mLeft And r.Right = mRight Then Egale = True Else Egale = False End If End Function Public Function EnvironEgale(r As RealRegion, precision As Integer) As Boolean Dim i& i& = 0 If r.Bottom - mBottom < 10 ^ -precision Then i& = i& + 1 End If If r.Top - mTop < 10 ^ -precision Then i& = i& + 1 End If If r.Left - mLeft < 10 ^ -precision Then i& = i& + 1 End If If r.Right - mRight < 10 ^ -precision Then i& = i& + 1 End If If i& >= 3 Then EnvironEgale = True Else EnvironEgale = False End If End Function Public Function Milieu() As Classpoint Dim p As Classpoint Set p = New Classpoint p.x = (mRight - mLeft) / 2 + mLeft p.y = (mTop - mBottom) / 2 + mBottom Set Milieu = p Set p = Nothing End Function Public Function largeur() As Double largeur = mRight - mLeft End Function Public Function hauteur() As Double hauteur = mTop - mBottom End Function Public Sub Dessine(mdc As metricDC) mdc.CadreReal mLeft, mBottom, mRight, mTop, RGB(0, 0, 255) End Sub
Christophe
L'avantage d'être une île c'est d'être une terre topologiquement close
Hors ligne