Planet Source Code Jumbo …e CD Visual Basic 1 to 7/4_2005-2006.ISO/data/Zips/AntieLife_1976492262006.psc/AntieLife/LifeForm.bas

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