Die Struktur kann sich auf bereits gesetzten Feldern in die Höhe entwickeln, wobei die Anzahl der 'Geschosse' vorgeschrieben ist.

Durch weitere Optimierungsmethoden könnte die Struktur z.B. auf ausreichende Belichtung oder Möglichkeiten der Erschließung und andere funktionale Aspekte hin untersucht werden.

<< Inhaltsverzeichnis

 

 

''**********************Das Skript erzeugt eine Wachstumsstruktur durch Recursion******************
'---weitere Bearbeitung

Private loser() As Long
Private koord(0 To 2) As Double
Private oneSlice
Private f As Integer, u As Integer
Private etage As Double
Private durchlauf As Integer
Private max As Double
Private startpoint(2) As Double
Private endpoint(2) As Double
Private mengeWuerfel As Integer
Private astZahl As Integer
Private num As Integer
Private checkList() As Variant
Private Ktod As Double
Private KtodGesamt As Double
Private KtodAlt As Double

Sub main() '---Initialisierung
Dim amount As Integer, default As Variant, messagge As Variant
Dim startTrip(0 To 2) As Double
num = 4
max = 1

'---InputBox für die Anzahl der Würfel
messagge = "geben Sie die Anzahl der Würfel an"
default = "300"
mengeWuerfel = InputBox(messagge, , default)

'---InputBox für die Zahl der Verzweigungen
messagge = "geben Sie die Anzahl der Verzweigungen an"
default = "2"
astZahl = InputBox(messagge, , default)

ReDim checkList(mengeWuerfel) As Variant '---Liste mit den besetzten Positionen
ReDim loser(mengeWuerfel) As Long '---Die Indevariable zur bestimmung des vorhergehenden Astes
checkList(0) = startTrip
checkList(0)(0) = 1

startTrip(0) = 0
startTrip(1) = 0
startTrip(2) = 0
oneSlice = pi * 2 / num
durchlauf = 0
ThisDrawing.SendCommand "_erase" & vbCr & "all" & vbCr
ThisDrawing.SendCommand vbCr
setzeQuad startTrip 'Der Samen

create 0 '---Die Iteration wird gestartet und läft bis mengeWürfel erreicht ist
End Sub

Sub create(i As Integer) '---Berechnung der Postion der jeweiligen Würfel
Dim m As Integer, s As Integer, geschoss As Integer
Dim angle As Double
Dim mitte(0 To 2) As Double
geschoss = 4

For m = 0 To astZahl - 1 '---Anzahl der Verästelung
Dim Centroid As Variant, besetzt As Boolean, rauf As Boolean, runter As Boolean
Dim baddy As AcadObject

Set baddy = ThisDrawing.ObjectIdToObject(loser(i)) '---Der Basisast wird durch die Indexvariable i aufgerufen und die Koordinaten an baddy übergeben
Centroid = baddy.Centroid
koord(0) = Centroid(0)
koord(1) = Centroid(1)
koord(2) = Centroid(2)
Randomize

'---Richtung des nächsten Würfels berechnen
angle = Round((Rnd() * num + 1)) * oneSlice
' Koordinaten berechnen
koord(0) = Round(koord(0) + Cos(angle) * 11, 0)
koord(1) = Round(koord(1) + Sin(angle) * 11, 0)
mitte(0) = koord(0): mitte(1) = koord(1): mitte(2) = koord(2)

besetzt = check(mitte)

If besetzt Then '---Wenn Positione noch frei, setze Würfel und zeichne Linie
If mitte(2) = 0 Then
setzeQuad mitte
Else
mitte(2) = mitte(2) - 11
runter = check(mitte)
If runter = False Then
mitte(2) = mitte(2) + 11
setzeQuad mitte
Else
Ktod = Ktod + 1
End If
End If

Else '---Wenn Position besetzt erhöhe den Zähler Ktod um die nichtbesetzten Felder zu speichern
mitte(2) = mitte(2) + 11
rauf = check(mitte)
If rauf And mitte(2) < geschoss * 11 Then
setzeQuad mitte
Else
Ktod = Ktod + 1
End If
End If
'---Bestimmt den Start- und Endpunkt der Verbindungslinien
'startpoint(0) = Centroid(0): startpoint(1) = Centroid(1): startpoint(2) = Centroid(2)
'endpoint(0) = mitte(0): endpoint(1) = mitte(1): endpoint(2) = mitte(2)
'draw_line startpoint, endpoint, durchlauf
Next m

'---Berechnung der Indexvariablen des Basisastes
If u >= max - 1 Then
u = 0: durchlauf = durchlauf + 1: '---durchlauf zählt die Iterationsschritte
KtodGesamt = (KtodGesamt + KtodAlt) * astZahl '---errechnet die Zahl aller nicht gesetzter Würfel
max = (astZahl ^ durchlauf) - Ktod - KtodGesamt '---um den richtigen Basisast zu finden wird die Anzahl der nichtgesetzten Würfel von der Anzahl aller möglichen abgezogen
KtodAlt = Ktod
Ktod = 0
ThisDrawing.Regen acActiveViewport
Else
u = u + 1
End If

create (f - (u * astZahl - Ktod) + u - max) '---der entsprechende Index des Basisastes wird an create übergeben, Prozedur ruft sich selbst auf

End Sub

Sub draw_line(here() As Double, there() As Double, segment As Integer) '---zeichnen der Verbindungslinie

Dim begin(2) As Double, finish(2) As Double
Dim path As AcadLine

'---Linie zeichnen
Set path = ThisDrawing.ModelSpace.AddLine(here, there)
path.color = segment + 1
path.Update

End Sub

Sub setzeQuad(mittelPunkt() As Double) 'zeichnen der Würfel
Dim wuerfel As Acad3DSolid
Dim length As Double, width As Double, height As Double
Dim center(0 To 2) As Double
Dim cont As Long

' Angaben für den wuerfel
center(0) = mittelPunkt(0): center(1) = mittelPunkt(1): center(2) = mittelPunkt(2)
height = 10
length = 10
width = 10

' Würfel erstellen
Set wuerfel = ThisDrawing.ModelSpace.AddBox(center, length, width, height)

wuerfel.color = 151 'durchlauf + 1
'wuerfel.ScaleEntity center, 1 / (durchlauf / 4 + 1)
'wuerfel.Rotate center, u
loser(f) = wuerfel.ObjectID

f = f + 1 '---Zählt und indexiert Würfel
checkList(f) = center

If f = mengeWuerfel Then End '---Wenn die maximale Anzahl an Würfel = menge Würfel, erreicht ist wird das Programm abgebrochen
ZoomAll

End Sub
Function check(pos() As Double) '---Prüft, ob eine Position bereits mit einem Würfel besetzt ist
Dim position(0 To 2) As Double
position(0) = pos(0)
position(1) = pos(1)
position(2) = pos(2)
check = True

For s = 1 To f '---Würfelposition wird anhand des checkList-Arrays auf Doppelbelegung überprüft
If position(0) = checkList(s)(0) And position(1) = checkList(s)(1) And position(2) = checkList(s)(2) Then
check = False
End If
Next s
End Function

Function random(lower As Double, upper As Double) '---Erzeugen eines Zufallswertes
random = Int((upper - lower + 1) * Rnd + lower)
End Function

Function pi() '---Berechnung der Zahl Pi
pi = (Atn(1) * 4)
End Function

 
 
\\ Entwurfsforschung \ Strukturexperimente \ autoCAD_VBA experimente