home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Planet Source Code Jumbo …e CD Visual Basic 1 to 7
/
4_2005-2006.ISO
/
data
/
Zips
/
AntieLife_1976492262006.psc
/
AntieLife
/
LifeForm.bas
< prev
Wrap
BASIC Source File
|
2006-02-25
|
15KB
|
443 lines
Attribute VB_Name = "LifeForm"
Option Explicit
Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Type Creature
'attributes for life forms...
Alive As Boolean 'Initialize phenotype when Alive gets set to True.
Chromosome As String 'Genes are stored here.
activeGene As Long 'Gene number waiting to be processed next.
geneProcessAge As Long 'Earliest age at which next gene may be processed.
Age As Long 'Count of times this life form has been processed.
MaturityAge As Long 'Minimum age to produce offspring.
MatingAge As Long 'Minimum age to mate.
CloningAge As Long 'Minimum age to self reproduce.
CertainDeathAge As Long 'Absolute maximum life-span.
Health As Single 'Meant to be an indiator of wellness in the range of 0="critical" to 1="thriving".
Speed As Single 'Speed of motion expected
Velocity As Single 'Speed of motion in effect
Red As Integer 'Display this level of Red. (See Note.)
Green As Integer 'Display this level of Green. (See Note.)
Blue As Integer 'Display this level of Blue. (See Note.)
'Note... Adjusted automatically before use to ensure visibility.
RGB As Long 'Stores actual calculated DisplayColor.
Width As Single 'Pen width, or thinckness of creature.
Orientation As Single
minMates As Integer 'Minimum number of mates needed to reproduce. The default of 0 allows self reproduction.
NextX As Single
NextY As Single
NearSenseAngle As Single
FarSenseAngle As Single
'if speed is zero, nothing from here down is used.
length As Integer 'Additional length to be acquired before moving to NextX, NextY.
Energy As Double 'Energy available for use at this time.
Hungry As Double 'Below this level of energy, life form is hungry.
EnergyToMate As Double 'Mimimum Energy Needed Before Mating.
EnergyToClone As Double 'Mimimum Energy Needed Before Self Reproduction.
redEnergy As Double 'Energy from Red food, not yet ready for use.
greenEnergy As Double 'Energy from Green food, not yet ready for use.
blueEnergy As Double 'Energy from Blue food, not yet ready for use.
CloneCountDown As Integer ' off = 0. Clone now = 1. Higher numbers = counter.
mateRed As Integer 'Will see this level of Red as a potential mate.
mateGreen As Integer 'Will see this level of Green as a potential mate.
mateBlue As Integer 'Will see this level of Blue as a potential mate.
foodRed As Integer 'Will see this level of Red as potential food.
foodGreen As Integer 'Will see this level of Green as potential food.
foodBlue As Integer 'Will see this level of Blue as potential food.
End Type
'GridSizeX and GridSizeY define the dimensions of the grid on which the life forms live.
Public Const GridSizeX = 700
Public Const GridSizeY = 600
'used in positioning the display...
Public LowerX As Single
Public RangeX As Single
Public UpperX As Single
Public LowerY As Single
Public RangeY As Single
Public UpperY As Single
Public OffsetX As Single
Public OffsetY As Single
Public mulX As Double
Public mulY As Double
Public ZoomFactor As Single
Public Grid(GridSizeX - 1, GridSizeY - 1) As Creature
Public ListXY As String
Public lifeCount As Long
Public PlantCount As Long
Public AntCount As Long
Private itemPosition As Long
Function setBackgroundColor()
Dim R As Integer
Dim G As Integer
Dim b As Integer
Dim bColor As Long
Dim tColor As Long 'Label text color
R = IIf(formLife.mChkInvertRed.Checked, 255, 0)
G = IIf(formLife.mChkInvertGreen.Checked, 255, 0)
b = IIf(formLife.mChkInvertBlue.Checked, 255, 0)
bColor = RGB(R, G, b)
'PictureBox background...
formLife.picLife.BackColor = bColor
'Form and label colors...
tColor = RGB(255 - R, Abs(192 - G), Abs(192 - b))
formLife.BackColor = bColor
formLife.lblAntCountLbl.BackColor = bColor
formLife.lblPlantCountLbl.BackColor = bColor
formLife.lblAntCount.BackColor = bColor
formLife.lblPlantCount.BackColor = bColor
formLife.lblAntCountLbl.ForeColor = tColor
formLife.lblPlantCountLbl.ForeColor = tColor
formLife.lblAntCount.ForeColor = tColor
formLife.lblPlantCount.ForeColor = tColor
End Function
Function DisplayColor(X As Single, Y As Single) As Long
Dim R As Integer
Dim G As Integer
Dim b As Integer
With Grid(X, Y)
R = .Red
G = .Green
b = .Blue
End With
If (R = G) And (G = b) Then
R = R + 32
G = G + 32
b = b + 32
ElseIf (R < G) And (R < b) Then
G = G + 48
b = b + 48
ElseIf (G < R) And (G < b) Then
R = R + 48
b = b + 48
ElseIf (b < R) And (b < G) Then
R = R + 48
G = G + 48
ElseIf (R > G) And (R > b) Then
R = R + 64
ElseIf (G > R) And (G > b) Then
G = G + 64
ElseIf (b > R) And (b > G) Then
b = b + 64
End If
'Note: RGB values may be higher than 255. That's why Abs() is used here...
If formLife.mChkInvertRed.Checked Then R = Abs(255 - R)
If formLife.mChkInvertGreen.Checked Then G = Abs(255 - G)
If formLife.mChkInvertBlue.Checked Then b = Abs(255 - b)
DisplayColor = RGB(R, G, b)
End Function
Sub AddItemXY(X As Single, Y As Single)
Static entry As String
entry = makeEntryXY(X, Y)
If InStr(ListXY, entry) Then Exit Sub
ListXY = ListXY + entry
lifeCount = lifeCount + 1
If Grid(X, Y).Speed <= 0 Then
PlantCount = PlantCount + 1
Else
AntCount = AntCount + 1
End If
End Sub
Function makeEntryXY(X As Single, Y As Single)
makeEntryXY = "[" + Hex(inGridX(CLng(X))) + "," + Hex(inGridY(CLng(Y))) + "]"
End Function
Function RemoveItemEntry(entry) As Boolean
Static i As Long
If entry = "" Then
RemoveItemEntry = False
Exit Function
End If
i = InStr(ListXY, entry)
If i = 0 Then
RemoveItemEntry = False
Exit Function
End If
If itemPosition > i Then itemPosition = itemPosition - Len(entry)
ListXY = Left(ListXY, i - 1) + Mid(ListXY, i + Len(entry))
lifeCount = lifeCount - 1
RemoveItemEntry = True
If itemPosition > 1 Then itemPosition = itemPosition - 1
End Function
Sub RemoveItemXY(X As Single, Y As Single)
If RemoveItemEntry(makeEntryXY(X, Y)) Then
If Grid(X, Y).Speed <= 0 Then
PlantCount = PlantCount - 1
Else
AntCount = AntCount - 1
End If
End If
End Sub
Sub GetNextItemXY(ByRef X As Single, ByRef Y As Single)
Static ii As Long
Static entry
If ListXY < "[" Then Exit Sub
itemPosition = InStr(itemPosition + 1, ListXY, "[")
If itemPosition = 0 Then itemPosition = 1 'Return to first item
ii = InStr(itemPosition, ListXY, "]")
entry = Mid(ListXY, itemPosition, ii - itemPosition + 1)
ii = InStr(entry, ",")
X = Val("&h" + Mid(entry, 2))
Y = Val("&h" + Mid(entry, ii + 1))
End Sub
Sub ResetItemXY(X As Single, Y As Single)
Dim tmp As Creature
Grid(X, Y) = tmp
End Sub
Sub reBirthItemXY(X As Single, Y As Single)
Dim baby As Creature
baby = Grid(X, Y)
BirthItemXY X, Y
With Grid(X, Y)
.Energy = baby.Energy
.redEnergy = baby.redEnergy
.greenEnergy = baby.greenEnergy
.blueEnergy = baby.blueEnergy
.Orientation = baby.Orientation
End With
End Sub
Sub BirthItemXY(X As Single, Y As Single)
Dim Genes As String
Dim baby As Creature
Genes = Grid(X, Y).Chromosome
Grid(X, Y) = baby
With Grid(X, Y)
.Chromosome = Genes
.Alive = True
.Health = 1 'Thriving
'Set to default phenotype...
.Red = 77
.Green = 99
.Blue = 82
.mateRed = 77
.mateGreen = 99
.mateBlue = 82
.foodRed = 77
.foodGreen = 99
.foodBlue = 82
.CertainDeathAge = 23
.MatingAge = 0
.CloningAge = 0
.MaturityAge = 0
.Hungry = 0
.Orientation = Rnd * pi * 2 'random facing direction
.activeGene = 0 'Reset to default active gene.
'Process a few genes normally (if available) before birth...
processNextGeneXY X, Y
processNextGeneXY X, Y
processNextGeneXY X, Y
processNextGeneXY X, Y
processNextGeneXY X, Y
'Make sure item will display...
If .Width < 0.1 Then .Width = 1
.NextX = X + Cos(.Orientation) * .Width
.NextY = Y + Sin(.Orientation) * .Width
If .CertainDeathAge < 1 Then .CertainDeathAge = 1
If .Width > 33 Then .Width = 33
.RGB = DisplayColor(X, Y)
End With
AddItemXY X, Y 'Add coordinates of newborn to list
End Sub
Function biteItemXY(X As Single, Y As Single, Optional biteCount As Single = 1) As Boolean
' take a bite out of grid(x,y) and return a boolean indicating whether or not .health is still greater than 0.
Dim sTmp As Single
With Grid(X, Y)
'note: biteCount could also simulate mouth size.
sTmp = 1 / (2 + .Width + .length) * biteCount
.Health = .Health - sTmp
biteItemXY = (.Health > 0)
End With
End Function
Function healItemXY(X As Single, Y As Single) As Boolean
' Restore some health to grid(x,y) and return a boolean indicating whether or not .health has reached or exceded 1.
Dim sTmp As Single
If Grid(X, Y).Health >= 1 Then
healItemXY = True
Exit Function
Else
With Grid(X, Y)
sTmp = 1 / (3 + .Width + .length)
If sTmp >= .Energy / 2 Then sTmp = .Energy / 2 + 0.1
.Health = .Health + sTmp
.Energy = .Energy - sTmp 'Energy used to heal.
healItemXY = (.Health >= 1)
End With
End If
End Function
Function getNextGeneValueXY(X As Single, Y As Single)
Dim t() As Byte
With Grid(X, Y)
If .activeGene < 1 Then .activeGene = 1
If .activeGene > Len(.Chromosome) Then
getNextGeneValueXY = 0
Exit Function
End If
t() = Mid(.Chromosome, .activeGene, 1)
getNextGeneValueXY = PickGeneValue(t(0), t(1))
.activeGene = .activeGene + 1
'On Error GoTo 0
End With
Exit Function
End Function
Sub processNextGeneXY(X As Single, Y As Single)
Dim value As Integer
Dim mode As Integer
With Grid(X, Y)
If .Age < .geneProcessAge Then Exit Sub
If .activeGene > Len(.Chromosome) - 2 Then Exit Sub
mode = getNextGeneValueXY(X, Y)
' If mode > 32 Then mode = mode - 32 'Don't waste genes.
value = getNextGeneValueXY(X, Y)
Select Case mode
Case 1
.Red = Abs(.Red + value)
Case 2
.mateRed = Abs(.mateRed + value)
Case 3
.Green = Abs(.Green + value)
Case 4
.mateGreen = Abs(.mateGreen + value)
Case 5
.Blue = Abs(.Blue + value)
Case 6
.mateBlue = Abs(.mateBlue + value)
Case 7
.foodRed = Abs(.foodRed + value)
Case 8
.foodGreen = Abs(.foodGreen + value)
Case 9
.foodBlue = Abs(.foodBlue + value)
Case 10
.Speed = .Speed + 0.01 * value
Case 11
.MaturityAge = .MaturityAge + value
Case 12
.Hungry = .Hungry + value
Case 13
.CertainDeathAge = .CertainDeathAge + value * 3
Case 14
.CertainDeathAge = .CertainDeathAge + value
.Speed = .Speed + Log(value + 1) 'alternate animal gene
Case 15
.CloningAge = .CloningAge + value
Case 16
.MatingAge = .MatingAge + value
Case 17
.length = greaterOf(.length / 2 + value, .length + 1)
Case 18
.minMates = 1
Case 19
.activeGene = .activeGene + value
Case 20
.geneProcessAge = .Age + value + 2
Case 21
.NearSenseAngle = .NearSenseAngle + value / 8 - 1
Case 22
.FarSenseAngle = .FarSenseAngle + value / 8 - 1
Case 23
.Red = Abs(.Red + value * 2 - 16)
Case 24
.mateRed = Abs(.mateRed + value * 2 - 16)
Case 25
.Green = Abs(.Green + value * 2 - 16)
Case 26
.mateGreen = Abs(.mateGreen + value * 2 - 16)
Case 27
.Blue = Abs(.Blue + value * 2 - 16)
Case 28
.mateBlue = Abs(.mateBlue + value * 2 - 16)
Case 29
.foodRed = Abs(.foodRed + value * 2 - 16)
Case 30
.foodGreen = Abs(.foodGreen + value * 2 - 16)
Case 31
.foodBlue = Abs(.foodBlue + value * 2 - 16)
Case 32
.Width = .Width + 1
Case 33
.Red = Abs(.Red - value)
Case 34
.mateRed = Abs(.mateRed - value)
Case 35
.Green = Abs(.Green - value)
Case 36
.mateGreen = Abs(.mateGreen - value)
Case 37
.Blue = Abs(.Blue - value)
Case 38
.mateBlue = Abs(.mateBlue - value)
Case 39
.foodRed = Abs(.foodRed - value)
Case 40
.foodGreen = Abs(.foodGreen - value)
Case 41
.foodBlue = Abs(.foodBlue - value)
End Select
'On Error GoTo 0
End With
Exit Sub
End Sub
Function PickGeneValue(gM, gP) 'Decides which of two alleles to use.
PickGeneValue = IIf(gM And &H80, IIf(gP And &H80, (gM Or gP) And &H7F, gM And &H7F), IIf(gP And &H80, gP And &H7F, (gM And gP) And &H7F))
End Function
Function greaterOf(A, b)
greaterOf = IIf(A > b, A, b)
End Function
Function lesserOf(A, b)
lesserOf = IIf(A < b, A, b)
End Function
Sub firstLife(Optional ByVal number As Long = 1) '** NEVER use Variant
Dim baby As Creature
Dim X As Single
Dim Y As Single
Dim i As Long '** NEVER use Variant
Dim ii As Long '** NEVER use Variant
Dim t() As Byte
Dim s As String
Dim ct As String
Dim errorCount As Long
ReDim t(3)
t(0) = 10 'Speed adjust mode... to produce an animal.
t(1) = 10
t(2) = 3 'Adjustment value
t(3) = 3
ct = Left(t(), 1)
If number < 0 Then
baby.Chromosome = t()
End If
If (formLife.mChkQuickStart.Checked Xor breakRules) Then
'add some random genes...
s = Chr(Int(Rnd * 7lueDim errorCount As Long
errorCount As Long
errorCount As Long
of (y As Crel