Nurmites et génétique

Télécharger le projet
Commenter

Description

Soit le Zip, soit vous copiez ce code. Il ne faut qu'une PictureBox.

Source / Exemple : 


'
' .: Genetic Hazard
'    --------------
'
'    Ce stupide programme ne simule en aucun cas de la vie mais simplement
'    l'évolution du patrimoine génétique d'individus soumis à la sélection
'    naturel.
'
'    Chaque nurm possède une chaine d'ADN contenant 5 branches. Lors de la
'    reproduction, les nurms  mélangent leur patrimoine génétique, le nurm
'    qui en résulte obtient la somme de l'intelligence de ses parents.
'
'    La  spécification  génétique de l'individus  joue directement sur son
'    intelligence et sa capacité à se déplacer.
'
'    Un Nurm meurt soit de faim, soit de viellesse.
'

' .: Da Nurm definition
Private Type Nurm
 GeneticCode As String
 State As Integer
 XNurm As Integer
 YNurm As Integer
 XTarget As Integer
 YTarget As Integer
 TargetNurm As Integer
 Faim As Long
 Age As Long
 Generation As Integer
End Type
 
' .: Da Path definition
Private Type Path
 Matrix(50, 50) As Integer
 Width As Integer
 Height As Integer
End Type
 
' .: Da Direction Matrix
Private Type Direction
 XWay As Integer
 YWay As Integer
End Type
 
' .: Da constantes
Private Const STATE_PENDING = 0
Private Const STATE_HUNGRY = 1
Private Const STATE_HUNGRY_LOCKED = 2
Private Const STATE_REPRODUCTION = 3
Private Const STATE_REPRODUCTION_LOCKED = 4
Private Const STATE_DEAD = 5

Private Const NURM_DRAW = 0
Private Const NURM_CLEAR = 1
Private Const FOOD = 2
 
' .: Global Vars
Dim GroupeOfNurms(100) As Nurm
Dim PathMatrix(50, 50) As Integer
Dim NbNurms As Integer
Dim Terrain As Path
Dim AdnMaxValue As Integer
Dim XStep, YStep As Integer

Private Sub Form_Load()
 ' .: Setting Up User Interface
 Me.Width = 4750: Me.Height = 3650
 Picture1.Top = 0: Picture1.Left = 0
 Picture1.Width = Me.Width: Picture1.Height = Me.Height
 Picture1.BorderStyle = 0: Picture1.BackColor = RGB(255, 255, 255)
 Picture1.AutoRedraw = True
 
 ' .: Nurms and Path Definition
 NbNurms = 10
 AdnMaxValue = 5
 Terrain.Width = 30
 Terrain.Height = 25
 
 ' .: Initialising Da World
 Randomize Timer
 Call InitGrid(Picture1)
 Call BuildInitialNurms
 Call PutRandomFood(10)
 Call DrawFood(Picture1)
 Call GoLife
End Sub

'
' .: Close Da Game
'
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 End
End Sub

'
' .: Initialising Main Graphic Grid
'
Private Sub InitGrid(PicHandle As PictureBox)
 ' .: Calculated one time to increase speed
 XStep = (PicHandle.Width - 80) / Terrain.Width
 YStep = (PicHandle.Height - 80) / Terrain.Height
 
 ' .: Cols drawing
 For i = 0 To PicHandle.Width Step XStep
  PicHandle.Line (i, 0)-(i, PicHandle.Height), RGB(0, 0, 0)
 Next i
 ' .: Lines Drawing
 For i = 0 To PicHandle.Height Step YStep
  PicHandle.Line (0, i)-(PicHandle.Width, i), RGB(0, 0, 0)
 Next i
End Sub

'
' .: Put Random Food
'
Private Sub PutRandomFood(ByVal Value)
 For i = 0 To Value
  Xpos = Int(Rnd * Terrain.Width)
  YPos = Int(Rnd * Terrain.Height)
  Terrain.Matrix(Xpos, YPos) = 1
 Next i
End Sub

'
' Building Initial nurms configuration [ Generation 0 ]
'
Private Sub BuildInitialNurms()
 For i = 0 To NbNurms
  Adn = ""
  For AdnIndex = 1 To 5
   Adn = Adn + Chr(Int(Rnd * AdnMaxValue))
  Next AdnIndex
  ' .: Building Initial Brain Connections ( Initial Values 0-AdnMaxValue )
  GroupeOfNurms(i).GeneticCode = Adn
  ' .: Positionning Nurm
  GroupeOfNurms(i).XNurm = Int(Rnd * Terrain.Width)
  GroupeOfNurms(i).YNurm = Int(Rnd * Terrain.Height)
  ' .: Initial State
  GroupeOfNurms(i).State = STATE_PENDING
  ' .: Hungry level
  GroupeOfNurms(i).Faim = 100
  ' .: Age
  GroupeOfNurms(i).Age = 0
 Next i
End Sub

'
' .: Make a new nurm by mixing parents ADN
'
Private Sub BabyNurmWillBorn(ByVal NurmID1, ByVal NurmID2)
 Dim Adn As String
 Generation = Max(GroupeOfNurms(NurmID1).Generation, GroupeOfNurms(NurmID2).Generation) + 1
 
 ' Flush Dead Nurms
 If NbNurms = 100 Then
  If CountNurmsAlive <> 100 Then
   Call FlushDeadNurms
  End If
 End If
 
 If NbNurms < 100 Then
  NbNurms = NbNurms + 1
  ' .: Nurm Generation
  GroupeOfNurms(NbNurms).Generation = Generation
  ' .: Positionning Nurm
  GroupeOfNurms(NbNurms).XNurm = Int(Rnd * Terrain.Width)
  GroupeOfNurms(NbNurms).YNurm = Int(Rnd * Terrain.Height)
  ' .: Initial State
  GroupeOfNurms(NbNurms).State = STATE_PENDING
  ' .: Hungry level
  GroupeOfNurms(NbNurms).Faim = 100
  ' .: Age
  GroupeOfNurms(NbNurms).Age = 0
  ' .: Building Initial Brain Connections ( Initial Values 0-AdnMaxValue )
  Adn = ""
  For AdnIndex = 1 To 5
   Value = Asc(Mid$(GroupeOfNurms(NurmID1).GeneticCode, AdnIndex, 1)) + Asc(Mid$(GroupeOfNurms(NurmID2).GeneticCode, AdnIndex, 1))
   If Value > 250 Then Value = 250
   Adn = Adn + Chr(Value)
  Next AdnIndex
  GroupeOfNurms(NbNurms).GeneticCode = Adn
 End If
End Sub

'
' .: Return the max of two values
'
Private Function Max(ByVal Value1, ByVal Value2)
 If Value1 >= Value2 Then
  Max = Value1
 Else
  Max = Value2
 End If
End Function

'
' Draw or free one nurm on the Graphical Grid
'
Private Sub DrawNurm(PicHandle As PictureBox, ByVal NurmID, ByVal Mode)
 ' .: Draw Nurms
 Da_X = GroupeOfNurms(NurmID).XNurm * XStep
 Da_Y = GroupeOfNurms(NurmID).YNurm * YStep
 ' .: Draw
 If Mode = NURM_DRAW Then PicHandle.Line (Da_X + 20, Da_Y + 20)-(Da_X + XStep - 20, Da_Y + YStep - 20), RGB(0, 0, 128), BF
 ' .: Free
 If Mode = NURM_CLEAR Then
  PicHandle.Line (Da_X + 20, Da_Y + 20)-(Da_X + XStep - 20, Da_Y + YStep - 20), RGB(255, 255, 255), BF
  If Terrain.Matrix(GroupeOfNurms(NurmID).XNurm, GroupeOfNurms(NurmID).YNurm) = 1 Then
   PicHandle.Line (Da_X + 20, Da_Y + 20)-(Da_X + XStep - 20, Da_Y + YStep - 20), RGB(128, 0, 128), BF
  End If
 End If
End Sub

'
' .: Draw food on the graphical grid
'
Private Sub DrawFood(PicHandle As PictureBox)
 ' .: Draw Food
 For Xpos = 0 To Terrain.Width
  For YPos = 0 To Terrain.Height
   If Terrain.Matrix(Xpos, YPos) = 1 Then
    Da_X = Xpos * XStep
    Da_Y = YPos * YStep
    PicHandle.Line (Da_X + 20, Da_Y + 20)-(Da_X + XStep - 20, Da_Y + YStep - 20), RGB(128, 0, 128), BF
   End If
  Next YPos
 Next Xpos
End Sub

'
' Draw or free each nurms of the groupe
'
Private Sub DrawGroupe(PicHandle As PictureBox, ByVal Mode)
 ' .: Draw Each Nurms
 For i = 0 To NbNurms
  If GroupeOfNurms(i).State <> STATE_DEAD Then
   Call DrawNurm(PicHandle, i, Mode)
  End If
 Next i
End Sub

'
' Use the adn portion of the genetic code to alter each move
'
Private Sub UseGeneticToAlterMove(ByVal NurmID, ByRef XMove, ByRef YMove)
 Dim XAllowed, YAllowed As Boolean
 
 ' .: Altering Nurm Xmove by using Genetic Code
 Select Case XMove
  Case -1
   XAllowed = GetGeneticProbability(1, NurmID)
  Case 1
   XAllowed = GetGeneticProbability(2, NurmID)
 End Select
 
 ' .: Altering Nurm Ymove by using Genetic Code
 Select Case YMove
  Case -1
   YAllowed = GetGeneticProbability(3, NurmID)
  Case 1
   YAllowed = GetGeneticProbability(4, NurmID)
 End Select

 ' .: Setting up the new direction
 If Not XAllowed Then XMove = 0
 If Not YAllowed Then YMove = 0
End Sub

'
' .: Retrieve Adn value and allow or not a decision
'
Private Function GetGeneticProbability(ByVal AdnIndex, ByVal NurmID)
 ' .: Retrieving Adn Information
 Value = Asc(Mid$(GroupeOfNurms(NurmID).GeneticCode, AdnIndex, 1))
 
 ' .: Calculating Probability and genetic Handicap
 Handicap = AdnMaxValue - Value
 If Handicap < 0 Then
  ' .: Let's rock, this is a genius!
  GetGeneticProbability = True
 Else
  RandomAlteration = Int(Rnd * Handicap)
  If RandomAlteration = 0 Then
   ' .: That's ok! The nurm is allowed to move
   GetGeneticProbability = True
  Else
   ' .: Bad, really bad... This is a very stupid nurm
   GetGeneticProbability = False
  End If
 End If
End Function

'
' .: Handle Nurms move
'
Private Sub NurmHandleMove(ByVal NurmID, ByVal XMove, ByVal YMove)
 ' .: Moving the nurm
 GroupeOfNurms(NurmID).XNurm = GroupeOfNurms(NurmID).XNurm + XMove
 GroupeOfNurms(NurmID).YNurm = GroupeOfNurms(NurmID).YNurm + YMove
 
 ' .: Altering out-of-path positions
 If GroupeOfNurms(NurmID).XNurm < 0 Then GroupeOfNurms(NurmID).XNurm = Terrain.Width
 If GroupeOfNurms(NurmID).XNurm > Terrain.Width Then GroupeOfNurms(NurmID).XNurm = 0
 If GroupeOfNurms(NurmID).YNurm < 0 Then GroupeOfNurms(NurmID).YNurm = Terrain.Height
 If GroupeOfNurms(NurmID).YNurm > Terrain.Height Then GroupeOfNurms(NurmID).YNurm = 0
End Sub

'
' .: Find The nurms Next move by using STATE value
'
Private Function FindNextMove(ByVal NurmID) As Direction
 ' .: Random Move
 If GroupeOfNurms(NurmID).State = STATE_PENDING Then
  FindNextMove.XWay = Int(Rnd * 2) - 1
  FindNextMove.YWay = Int(Rnd * 2) - 1
 End If
 
 ' .: Looking for the nearest food
 If GroupeOfNurms(NurmID).State = STATE_HUNGRY Then
  GroupeOfNurms(NurmID).State = STATE_HUNGRY_LOCKED
  DistanceMin = 100
  For Xpos = 0 To Terrain.Width
   For YPos = 0 To Terrain.Height
    If Terrain.Matrix(Xpos, YPos) = 1 Then
     If (GroupeOfNurms(NurmID).XNurm - Xpos) <> 0 And (GroupeOfNurms(NurmID).YNurm - YPos) <> 0 Then
      Distance = (GroupeOfNurms(NurmID).XNurm - Xpos) / (GroupeOfNurms(NurmID).YNurm - YPos)
      If Distance < DistanceMin Then
       GroupeOfNurms(NurmID).XTarget = Xpos: GroupeOfNurms(NurmID).YTarget = YPos
       DistanceMin = Distance
      End If
     End If
    End If
   Next YPos
  Next Xpos
 End If
 
 ' .: Looking for the nearest food
 If GroupeOfNurms(NurmID).State = STATE_REPRODUCTION Then
  GroupeOfNurms(NurmID).State = STATE_REPRODUCTION_LOCKED
  ' .: Looking for the nearest nurm
  DistanceMin = 100: TargetNurm = 0
  For i = 0 To NbNurms
   If GroupeOfNurms(i).State = STATE_PENDING And i < NurmID Then
    If (GroupeOfNurms(NurmID).XNurm - GroupeOfNurms(i).XNurm) <> 0 And (GroupeOfNurms(NurmID).YNurm - GroupeOfNurms(i).YNurm) <> 0 Then
     Distance = (GroupeOfNurms(NurmID).XNurm - GroupeOfNurms(i).XNurm) / (GroupeOfNurms(NurmID).YNurm - GroupeOfNurms(i).YNurm)
     If Distance < DistanceMin Then
      DistanceMin = Distance: TargetNurm = i
      GroupeOfNurms(NurmID).XTarget = GroupeOfNurms(i).XNurm: GroupeOfNurms(NurmID).YTarget = GroupeOfNurms(i).YNurm
      GroupeOfNurms(NurmID).TargetNurm = i
     End If
    End If
   End If
  Next i
  If Distance <> 100 Then
   GroupeOfNurms(TargetNurm).State = STATE_REPRODUCTION_LOCKED
   GroupeOfNurms(TargetNurm).XTarget = GroupeOfNurms(NurmID).XNurm: GroupeOfNurms(TargetNurm).YTarget = GroupeOfNurms(NurmID).YNurm
   GroupeOfNurms(TargetNurm).TargetNurm = GroupeOfNurms(NurmID).TargetNurm
  End If
 End If
 
 ' .: Moving to the target nurm
 If GroupeOfNurms(NurmID).State = STATE_REPRODUCTION_LOCKED Then
  If GroupeOfNurms(NurmID).XNurm < GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).XNurm Then FindNextMove.XWay = 1
  If GroupeOfNurms(NurmID).XNurm > GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).XNurm Then FindNextMove.XWay = -1
  If GroupeOfNurms(NurmID).YNurm < GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).YNurm Then FindNextMove.YWay = 1
  If GroupeOfNurms(NurmID).YNurm > GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).YNurm Then FindNextMove.YWay = -1
  If GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).State = STATE_DEAD Then GroupeOfNurms(NurmID).State = STATE_REPRODUCTION
 End If
 
 ' .: Moving to the target food
 If GroupeOfNurms(NurmID).State = STATE_HUNGRY_LOCKED Then
  If GroupeOfNurms(NurmID).XNurm < GroupeOfNurms(NurmID).XTarget Then FindNextMove.XWay = 1
  If GroupeOfNurms(NurmID).XNurm > GroupeOfNurms(NurmID).XTarget Then FindNextMove.XWay = -1
  If GroupeOfNurms(NurmID).YNurm < GroupeOfNurms(NurmID).YTarget Then FindNextMove.YWay = 1
  If GroupeOfNurms(NurmID).YNurm > GroupeOfNurms(NurmID).YTarget Then FindNextMove.YWay = -1
  If Terrain.Matrix(GroupeOfNurms(NurmID).XTarget, GroupeOfNurms(NurmID).YTarget) <> 1 Then GroupeOfNurms(NurmID).State = STATE_HUNGRY
 End If
End Function

'
' .: Check if the nurm is on some food
'
Private Sub CheckOnFoodEvent(ByVal NurmID)
 If Terrain.Matrix(GroupeOfNurms(NurmID).XNurm, GroupeOfNurms(NurmID).YNurm) = 1 Then
  Terrain.Matrix(GroupeOfNurms(NurmID).XNurm, GroupeOfNurms(NurmID).YNurm) = 0
  GroupeOfNurms(NurmID).Faim = GroupeOfNurms(NurmID).Faim + 100
 End If
End Sub

'
' Check if reproduction could be made
'
Private Sub CheckOnReproductionEvent(ByVal NurmID)
 If GroupeOfNurms(NurmID).State = STATE_REPRODUCTION_LOCKED Then
  If GroupeOfNurms(NurmID).XNurm = GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).XNurm Then
   If GroupeOfNurms(NurmID).YNurm = GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).YNurm Then
    GroupeOfNurms(NurmID).State = STATE_PENDING
    GroupeOfNurms(GroupeOfNurms(NurmID).TargetNurm).State = STATE_PENDING
    Call BabyNurmWillBorn(NurmID, GroupeOfNurms(NurmID).TargetNurm)
   End If
  End If
 End If
End Sub

'
' .: Count the number of nurms still alive
'
Private Function CountNurmsAlive()
 iCount = 0
 For i = 0 To NbNurms
  If GroupeOfNurms(i).State <> STATE_DEAD Then iCount = iCount + 1
 Next i
 CountNurmsAlive = iCount
End Function

'
' .: Find the hightest generation level
'
Private Function GenerationMax()
 GenerationMax = 0
 For i = 0 To NbNurms
  If GroupeOfNurms(i).Generation > GenerationMax Then GenerationMax = GroupeOfNurms(i).Generation
 Next i
End Function

'
' Find THE genius
'
Private Function Genius()
 Genius = 0
 For i = 0 To NbNurms
  Moyene = 0
  For j = 1 To 5
   Moyene = Moyene + Asc(Mid$(GroupeOfNurms(i).GeneticCode, j, 1))
  Next j
  Moyene = Moyene / 5
  If Moyene > Genius Then Genius = Moyene
 Next i
End Function

'
' .: Flush DeadNurms
'
Private Sub FlushDeadNurms()
 Dim TempGroupeOfNurms(100) As Nurm
 
 ' Looking for deads
 CurrentNurm = 0
 For i = 0 To NbNurms
  If GroupeOfNurms(i).State <> STATE_DEAD Then
   TempGroupeOfNurms(CurrentNurm).Age = GroupeOfNurms(i).Age
   TempGroupeOfNurms(CurrentNurm).Faim = GroupeOfNurms(i).Faim
   TempGroupeOfNurms(CurrentNurm).Generation = GroupeOfNurms(i).Generation
   TempGroupeOfNurms(CurrentNurm).GeneticCode = GroupeOfNurms(i).GeneticCode
   TempGroupeOfNurms(CurrentNurm).State = GroupeOfNurms(i).State
   TempGroupeOfNurms(CurrentNurm).TargetNurm = GroupeOfNurms(i).TargetNurm
   TempGroupeOfNurms(CurrentNurm).XNurm = GroupeOfNurms(i).XNurm
   TempGroupeOfNurms(CurrentNurm).XTarget = GroupeOfNurms(i).XTarget
   TempGroupeOfNurms(CurrentNurm).YNurm = GroupeOfNurms(i).YNurm
   TempGroupeOfNurms(CurrentNurm).YTarget = GroupeOfNurms(i).YTarget
   CurrentNurm = CurrentNurm + 1
  End If
 Next i
 
 ' .: Updating Nurms List
 For i = 0 To CurrentNurm - 1
  GroupeOfNurms(i).Age = TempGroupeOfNurms(i).Age
  GroupeOfNurms(i).Faim = TempGroupeOfNurms(i).Faim
  GroupeOfNurms(i).Generation = TempGroupeOfNurms(i).Generation
  GroupeOfNurms(i).GeneticCode = TempGroupeOfNurms(i).GeneticCode
  GroupeOfNurms(i).State = TempGroupeOfNurms(i).State
  GroupeOfNurms(i).TargetNurm = TempGroupeOfNurms(i).TargetNurm
  GroupeOfNurms(i).XNurm = TempGroupeOfNurms(i).XNurm
  GroupeOfNurms(i).XTarget = TempGroupeOfNurms(i).XTarget
  GroupeOfNurms(i).YNurm = TempGroupeOfNurms(i).YNurm
  GroupeOfNurms(i).YTarget = TempGroupeOfNurms(i).YTarget
 Next i
 ' .: Flushing deads
 For i = CurrentNurm To 100
  GroupeOfNurms(i).State = TempGroupeOfNurms(i).State
 Next i
 
 ' Setting Up Real Nurms Number
 NbNurms = CurrentNurm - 1
End Sub

'
' .: Start the simulation
'
Private Sub GoLife()
 Dim NextMove As Direction
 
 Me.Show
 Do
  DoEvents
  Call DrawGroupe(Picture1, NURM_CLEAR)
  
  ' .: Window's title
  Title$ = "Nurms : " + Str$(CountNurmsAlive) + " Génération :" + Str$(GenerationMax) + " Genius :" + Str$(Genius)
  If Me.Caption <> Title$ Then Me.Caption = Title$
  
  ' .: Put some found...somtimes :)
  Rounds = Rounds + 1
  If Rounds > 500 Then
   Rounds = 0
   Call PutRandomFood(10)
   Call DrawFood(Picture1)
  End If
  
  For i = 0 To NbNurms
   If GroupeOfNurms(i).State <> STATE_DEAD Then
    
    ' .: Use genetic to handle Hungry
    If GetGeneticProbability(5, i) Then
     GroupeOfNurms(i).Faim = GroupeOfNurms(i).Faim - 1
    End If
   
    ' .: Is the nurm hungry?
    If GroupeOfNurms(i).Faim < 50 And GroupeOfNurms(i).State <> STATE_HUNGRY Then
     GroupeOfNurms(i).State = STATE_HUNGRY
    End If
    
    ' .: Is the nurm not hungry but still looking for food?
    If GroupeOfNurms(i).Faim > 50 And GroupeOfNurms(i).State = STATE_HUNGRY Then
     GroupeOfNurms(i).State = STATE_PENDING
    End If
    
    ' .: Reproduction?
    If GroupeOfNurms(i).State = STATE_PENDING And (GroupeOfNurms(i).Age Mod 150) = 100 Then
     GroupeOfNurms(i).State = STATE_REPRODUCTION
    End If
    
    If GroupeOfNurms(i).Faim <= 0 Or GroupeOfNurms(i).Age > 400 Then
     GroupeOfNurms(i).State = STATE_DEAD
     Call DrawNurm(Picture1, i, NURM_CLEAR)
     Terrain.Matrix(GroupeOfNurms(i).XNurm, GroupeOfNurms(i).YNurm) = 1
    Else
     
     ' .: Incrementing nurms old
     GroupeOfNurms(i).Age = GroupeOfNurms(i).Age + 1
    
     ' .: Find Next Move
     NextMove = FindNextMove(i)
  
     ' .: Use Genetic to alter next move
     Call UseGeneticToAlterMove(i, NextMove.XWay, NextMove.YWay)
   
     ' .: Ease next move
     Call NurmHandleMove(i, NextMove.XWay, NextMove.YWay)
     
     ' .: Check on-food Event
     Call CheckOnFoodEvent(i)
     
     ' .: Check for reproduction targer
     Call CheckOnReproductionEvent(i)
     
    End If
   End If
  Next i
  Call DrawGroupe(Picture1, NURM_DRAW)
 Loop
End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_Mémère)