Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
evolu.bas
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 27.06.2009 23:47:59 |
'#########################################################################################################################
'Analytische Grundparameter
Dim Shared G_Conf_MaxParamVal as UInteger = 10000
'#########################################################################################################################
'Parameter Typ
Type Param_Type
V_Next as Param_Type Ptr
V_Data as UInteger
End Type
'-------------------------------------------------------------------------------------------------------------------------
'GENOM Typ (Bildet ein genetischen code durch abstraktion definierter Parameter)
Type GENOM_Type
V_Next as GENOM_Type Ptr
V_Prev as GENOM_Type Ptr
V_ParamF as Param_Type Ptr
V_ParamL as Param_Type Ptr
V_TargetV as UInteger
End Type
'#########################################################################################################################
'Ziel GENOM variablen
Dim Shared G_TargetGenom as GENOM_Type
Dim Shared G_TargetGenomPC as UInteger
'Hilfsvariablen für GENOM Optimirung beim "Build" Prozess
Dim Shared G_GenomOptF as GENOM_Type Ptr
Dim Shared G_GenomOptL as GENOM_Type Ptr
Dim Shared G_GenomOptC as UInteger
'#########################################################################################################################
'== Parameter zu einem GENOM hinzufügen ==
Sub GENOM_ParamAdd(ByRef V_GENOM as GENOM_Type, V_Number as UInteger)
With V_GENOM
If .V_ParamL <> 0 Then
.V_ParamL->V_Next = CAllocate(SizeOf(Param_Type))
.V_ParamL = .V_ParamL->V_Next
Else
.V_ParamL = CAllocate(SizeOf(Param_Type))
.V_ParamF = .V_ParamL
End If
.V_ParamL->V_Data = V_Number
End With
End Sub
'-------------------------------------------------------------------------------------------------------------------------
'== Kopiert Genetische Parameter ==
Sub GENOM_ParamCopy(V_TargetGENOM as GENOM_Type Ptr, V_SourceGenom as GENOM_Type)
Dim TPtr as Param_Type Ptr = V_SourceGenom.V_ParamF
Do Until TPtr = 0
With *V_TargetGENOM
If .V_ParamL <> 0 Then
.V_ParamL->V_Next = CAllocate(SizeOf(Param_Type))
.V_ParamL = .V_ParamL->V_Next
Else
.V_ParamL = CAllocate(SizeOf(Param_Type))
.V_ParamF = .V_ParamL
End If
.V_ParamL->V_Data = TPtr->V_Data
End With
TPtr = TPtr->V_Next
Loop
End Sub
'-------------------------------------------------------------------------------------------------------------------------
'Zufall GENOM erzeugen
Function GENOM_BuildRandom() as GENOM_Type
Dim TGenom as GENOM_Type
For X as UInteger = 1 to Int((Rnd * G_Conf_MaxParamVal) + 1)
GENOM_ParamAdd(TGenom, Int((Rnd * G_Conf_MaxParamVal) + 1))
Next
Return TGenom
End Function
'-------------------------------------------------------------------------------------------------------------------------
'Erzeugen eines Mutierten GENOMs
Function GENOM_Build() as GENOM_Type
'(Function kann optimiert werden, um Optimierungsverhalten >MASSIV< zu steigern)
'/= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =\
' S E L E K T I O N
Dim TPtr as GENOM_Type Ptr = G_GenomOptF
Dim PPtr as Param_Type Ptr
Dim CMax as Integer = 0
Dim CMin as Integer = G_Conf_MaxParamVal
Dim C as UInteger
Dim ParamC as UInteger
'Anzahl Optimierter Zellen ermitteln
Do Until TPtr = 0
C = 0
PPtr = TPtr->V_ParamF
Do Until PPtr = 0
C += 1
PPtr = PPtr->V_Next
Loop
If ParamC < C Then ParamC = C
TPtr = TPtr->V_Next
Loop
If ParamC < 1 Then ParamC = 1
'Maximalwerte für Anzahl Parameter und Parameterbereiche ermitteln
Dim ParamMin() as Integer
Dim ParamMax() as Integer
ReDim ParamMin(ParamC) as Integer
ReDim ParamMax(ParamC) as Integer
For X as UInteger = 1 to ParamC
ParamMax(X) = G_Conf_MaxParamVal
Next
TPtr = G_GenomOptF
Do Until TPtr = 0
C = 0
PPtr = TPtr->V_ParamF
'Wertebereich erfassen
Do Until PPtr = 0
C += 1
If ParamMin(C) > PPtr->V_Data Then ParamMin(C) = PPtr->V_Data
If ParamMax(C) < PPtr->V_Data Then ParamMax(C) = PPtr->V_Data
PPtr = PPtr->V_Next
Loop
'Wertebereich erweitern und auf maximalgrenze beschränken
If CMin > C Then CMin = C
If CMax < C Then CMax = C
TPtr = TPtr->V_Next
Loop
'Mutationsbereich erweitern und auf maximalgrenze beschränken
CMin -= 20
CMax += 20
If CMin < 1 Then CMin = 1
If CMax > G_Conf_MaxParamVal Then CMax = G_Conf_MaxParamVal
ReDim ParamMin(ParamC + 40) as Integer
ReDim ParamMax(ParamC + 40) as Integer
For X as UInteger = 1 to ParamC
ParamMin(X) -= 20
ParamMax(X) += 20
If ParamMin(X) < 1 Then ParamMin(X) = 1
If ParamMax(X) > G_Conf_MaxParamVal Then ParamMax(X) = G_Conf_MaxParamVal
Next
'\= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =/
'/= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =\
' M U T A T I O N
'GENOM aufbauen
Dim TGenom as GENOM_Type
'Optimierter GENOM Aufbau (Evolutionäres Prinzip)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
C = 0
For X as UInteger = 1 to CMin + Int(Rnd * (CMax - CMin))
C += 1
'Evolotionärere Version
' GENOM_ParamAdd(TGenom, ParamMin(C) + Int((Rnd * (ParamMax(C) - ParamMin(C))) + 1))
'Effektivere Version
GENOM_ParamAdd(TGenom, Int((Rnd * G_Conf_MaxParamVal) + 1))
Next
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'NICHT Optimierter GENOM Aufbau (Zufallsprinzip)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'For X as UInteger = 1 to Int((Rnd * G_Conf_MaxParamVal) + 1)
' GENOM_ParamAdd(TGenom, Int((Rnd * G_Conf_MaxParamVal) + 1))
'Next
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'\= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =/
Return TGenom
End Function
'-------------------------------------------------------------------------------------------------------------------------
Sub GENOM_Clear(ByRef V_GENOM as GENOM_Type)
'== Hilfsfunktion == Leert eine Genom sequenzliste
With V_GENOM
Do Until .V_ParamF = 0
.V_ParamL = .V_ParamF->V_Next
DeAllocate(.V_ParamF)
.V_ParamF = .V_ParamL
Loop
End With
End Sub
'-------------------------------------------------------------------------------------------------------------------------
Sub GENOM_Insert(V_GENOM as GENOM_Type)
'== Hilfsfunktion == Fügt ein Genom zu einer Optimierungsliste hinzu ==
'/= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =\
' O P T I M I R U N G
'(Sub kann optimiert werden, um Geschwindigkeit >MASSIV< zu steigern)
Dim TPtr as GENOM_Type Ptr = G_GenomOptF
'Prüfen ob Annäherungswert des gegebenen GENOMs besser ist als bereits bekannte Optimale GENOMe
Do Until TPtr = 0
If TPtr->V_TargetV > V_GENOM.V_TargetV Then Exit Do
TPtr = TPtr->V_Next
Loop
'Neues OptimalGenom erzeugen
Dim NPtr as GENOM_Type Ptr = CAllocate(SizeOf(GENOM_Type))
'GENOM Informationen Kopieren
NPtr->V_TargetV = V_GENOM.V_TargetV
GENOM_ParamCopy(NPtr, V_GENOM)
'GENOM in Optimierungsliste einfügen
If TPtr <> 0 Then
If TPtr->V_Prev <> 0 Then
TPtr->V_Prev->V_Next = NPtr
Else: G_GenomOptF = NPtr
End If
NPtr->V_Prev = TPtr->V_Prev
TPtr->V_Prev = NPtr
NPtr->V_Next = TPtr
Else
If G_GenomOptL <> 0 Then G_GenomOptL->V_Next = NPtr
NPtr->V_Prev = G_GenomOptL
G_GenomOptL = NPtr
End If
If G_GenomOptF = 0 Then G_GenomOptF = NPtr
If G_GenomOptL = 0 Then G_GenomOptL = NPtr
'Übersteigt die Anzahl Optimaler Genome das Maximum der Liste, dann letzten Eintrag entfernen
If G_GenomOptC >= 25 Then
TPtr = G_GenomOptL->V_Prev
DeAllocate(G_GenomOptL)
G_GenomOptL = TPtr
If G_GenomOptL <> 0 Then G_GenomOptL->V_Next = 0
Else: G_GenomOptC += 1
End If
'\= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =/
End Sub
'#########################################################################################################################
Function Target(V_GENOM as GENOM_Type) as UInteger
'== Zielfunktion == Überprüft die Annäherung zum Ziel-GENOM udn liefert den Annäherungswert zurück ==
Dim TC as UInteger
Dim RVC as UInteger
Dim TPtr1 as Param_Type Ptr = G_TargetGenom.V_ParamF
'Anzahl Parameter im GENOM ermitteln
Do Until TPtr1 = 0
TC += 1
TPtr1 = TPtr1->V_Next
Loop
'Parameterdiferenz auf Wertebereich vergrössern
RVC += (Abs(G_TargetGenomPC - TC) * G_Conf_MaxParamVal)
'abstand vom sollwert zum gegebenen wert jedes parameters ermitteln und dem Annäherungswert hinzufügen
TPtr1 = G_TargetGenom.V_ParamF
Dim TPtr2 as Param_Type Ptr = V_GENOM.V_ParamF
Do
If TPtr1 = 0 Then Exit Do
If TPtr2 = 0 Then Exit Do
RVC += (Abs(TPtr1->V_Data - TPtr2->V_Data) * 3)
TC += 1
TPtr1 = TPtr1->V_Next
TPtr2 = TPtr2->V_Next
Loop
'Annäherung zurückliefern
Return RVC
End Function
'#########################################################################################################################
'Zelle = Thread. Eine Zelle speichert Informationen über sich in vorn einer genetischen Sequenz sowie Ausführungsparameter
Type Zelle_Type
V_InUse as UByte
V_Thread as Any Ptr
V_CreateTime as Double
V_RunTime as Double
V_GENOM as GENOM_Type
End Type
'#########################################################################################################################
'Variablen zur Zellenverwaltung udn Statistik ermittlung
Dim Shared ZelleD() as Zelle_Type
Dim Shared ZelleC as UInteger
Dim Shared ZelleTime() as Double
Dim Shared ZelleMutex as Any Ptr
'#########################################################################################################################
'Constant variablen für dynamische Zellablauf optimierung
Dim Shared ZellLifeTime as Double
'#########################################################################################################################
'Statistikvariablen
Dim Shared G_Stat_TimeStart as Double
Dim Shared G_Stat_Mutation as UInteger
Dim Shared G_Stat_ZellRunTime as Double
Dim Shared G_Stat_NearestValue as UInteger
'#########################################################################################################################
'Thread funktion zur simulation eines Zellprozesses
Sub Zelle_Thread(V_Data as Any Ptr)
'Informationen der Zelle zwischenspeichern
MutexLock(ZelleMutex)
Dim TZelleP as Zelle_Type Ptr = Cast(Zelle_Type Ptr, V_Data)
Dim TZelleD as Zelle_Type = *TZelleP
MutexUnLock(ZelleMutex)
'GENOM annäherung testen
Dim TRV as UInteger = Target(TZelleD.V_GENOM)
MutexLock(ZelleMutex)
'Annäherungswert des Genoms in Zellenstruktur speichern
TZelleP->V_GENOM.V_TargetV = TRV
TZelleP->V_Runtime = Timer() - TZelleD.V_CreateTime
MutexUnLock(ZelleMutex)
End Sub
'#########################################################################################################################
'Daten für Textuelle Statistik aufbereiten
Sub StatsCalc()
G_Stat_ZellRunTime = 0
For X as UInteger = 1 to ZelleC
G_Stat_ZellRunTime += ZelleTime(X)
Next
G_Stat_ZellRunTime /= ZelleC
'If G_Stat_ZellRunTime < (ZellLifeTime / 2) Then
' ZelleC -= 1
' If ZelleC <= 0 Then ZelleC = 1
'ElseIf G_Stat_ZellRunTime > (ZellLifeTime / 2) Then
' ZelleC += 1
' If ZelleC > 1000 Then ZelleC = 1000
' If UBound(ZelleD) < ZelleC Then
' Redim Preserve ZelleD(ZelleC) as Zelle_Type
' Redim Preserve ZelleTime(ZelleC) as Double
' End If
'End If
End Sub
'#########################################################################################################################
'Statistikdaten ausgeben
Sub StatsDraw()
Locate 1, 15: Print G_Stat_Mutation; String(10, 32)
Locate 2, 15: Print ZelleC; String(10, 32)
Locate 3, 15: Print G_Stat_ZellRunTime; String(10, 32)
Locate 4, 15: Print G_Stat_NearestValue; String(10, 32)
Locate 5, 15
MutexLock(ZelleMutex)
Dim C as UInteger
Dim TPtr as GENOM_Type Ptr = G_GenomOptF
Do Until TPtr = 0
C += 1
Print C; ":"; TPtr->V_TargetV; " ";
TPtr = TPtr->V_Next
Loop
MutexLock(ZelleMutex)
Print String(100, 32)
End Sub
'#########################################################################################################################
'Hauptprogramm
Sub Main()
'Zufallswerte erzeugen
Randomize Timer()
'Startzeitpunkt festlegen
G_Stat_TimeStart = Timer()
'(Optional) Maximaler Lebenszyklus einer Zelle
ZellLifeTime = 4
'Ein zufälliges Ziel GENOM erzeugen
G_TargetGenom = GENOM_BuildRandom()
'Anzahl Parameter zur beschleunigten Mutation erfassen
Dim TPtr as Param_Type Ptr = G_TargetGenom.V_ParamF
Do Until TPtr = 0
G_TargetGenomPC += 1
TPtr = TPtr->V_Next
Loop
'Cursor abschalten
Locate , , 0
'Textbereich vorbereiten
Cls
Print "Mutationen: 0"
Print "Zellen: 0"
Print "/-Runtime: 0"
Print "NearestValue: 0"
Print "MutationVals: 0"
'Anzahl Zellen für inizialisierung festlegen
ZelleC = 100
Redim Preserve ZelleD(ZelleC) as Zelle_Type
Redim Preserve ZelleTime(ZelleC) as Double
'Annäherungswert maximieren
G_Stat_NearestValue = 999999999
'Hauptschleife beginnen
Dim X as UInteger
Dim Y as UInteger
Dim XTot as Double
Do
'Pro durchlauf jeweils eine Zelle verarbeiten
X += 1
If X > ZelleC Then X = 1
MutexLock(ZelleMutex)
With ZelleD(X)
'Zelle in nutzung?
If .V_InUse = 0 Then
'Thread vorhanden?
If .V_Thread <> 0 Then
'Threadende abwarten
ThreadWait(.V_Thread)
'Für durchschnittliche Laufzeitermittlugn Laufzeit der Zelle erfassen
ZelleTime(X) = .V_Runtime
'minimalster Annäherungswert erfassen
If .V_GENOM.V_TargetV < G_Stat_NearestValue Then G_Stat_NearestValue = .V_GENOM.V_TargetV
'GENOM in Optimierungstabelle einfügen
GENOM_Insert(.V_GENOM)
'Hat die Annäherung 0 erreicht, wurde das entsprechende GENOM gefunden.
If G_Stat_NearestValue = 0 Then
MutexUnLock(ZelleMutex)
StatsCalc()
StatsDraw()
Print
Print "Optimale GENOM-Sequenz entdeckt!"
Print "Gesammtlaufzeit: " & Str(Fix(Timer() - G_Stat_TimeStart)) & " Sek."
End
End If
'Andernfalls Zell GENOM säubern
GENOM_Clear(.V_GENOM)
End If
'Statistischen Mutationszähler erhöhen
G_Stat_Mutation += 1
'Neues GENOM erzeugen
.V_GENOM = GENOM_Build()
.V_CreateTime = Timer()
'Zellen ausführung einleiten
.V_Thread = ThreadCreate(Cast(Any Ptr, @Zelle_Thread), Cast(Any Ptr, @ZelleD(X)))
End If
End With
MutexUnLock(ZelleMutex)
'Ausführungsoptimierung durch zyklische Textaktualisierung
If XTot < Timer() Then
StatsCalc()
StatsDraw()
Sleep 1, 1
XTot = Timer() + 0.1
End If
Loop until InKey() = Chr(27)
'Cursor wieder aktivieren
Locate , , 1
End Sub
'#########################################################################################################################
'Hauptprogramm starten
Main()
End 0