vb 2017 : AI : Genetic Programming

bluatigro

this is a try at GP i have this working in liberty/just basic GP what : from tabel or plot to formula GP how : 1 : write some random formula's 2 : calculate output of formula's 3 : sort formula's on error 4 : mix the best in child's 5 : mutate some child's 6 : if best.error > whised and generation < max then goto 2 i got so far as this : [code] '' bluatigro 4 sept 2017 '' genetic programming module Module Module1 Public Const gp_add As String = "[ + # # ]" Public Const gp_sub As String = "[ - # # ]" Public Const gp_mul As String = "[ * # # ]" Public Const gp_div As String = "[ / # # ]" Public Const gp_sqrt As String = "[ sqrt # # ]" Public Class GeneProg Private genes As Collection Private Enum numMode As Integer OnlyInputs = 0 AsDouble = 1 AsInteger = 2 End Enum Private gpstate As numMode Public Sub New() gpstate = numMode.OnlyInputs End Sub Public Sub use(gen As String) genes.Add(gen) End Sub Public Function run(prog As String) As String While InStr(prog, "]") <> 0 Dim eind As Int16 = InStr(prog, "]") Dim begin As Int16 = eind While Mid(prog, begin, 1) <> "[" begin -= 1 End While Dim part As String = Mid(prog _ , begin, eind - begin + 1) Dim q() As String = Split(part) Dim a As Double = Val(q(2)) Dim b As Double = Val(q(3)) Dim ab As Double Try Select Case q(1) Case "+" ab = a + b Case "-" ab = a - b Case "*" ab = a * b Case "/" If b = 0 Then Return "error" Else ab = a / b End If Case "sqrt" ab = Math.Sqrt(a) Case Else Return "error" End Select Catch ex As Exception Return "error" End Try Dim l As String = Left(prog, begin - 1) D

Arthur V Ratz

What you have tried is actually *NOT* a genetic algorithm (GA). :) Any genetic algorithm has the following formulation: 0. Generate random values (chromosomes) population; 1. Select a random pair of chromosomes; 2. Recombine chromosomes using cross-over genetic operator; 3. Check if the new child chromosomes are the fittest ones by using objective fitness function; 4. If at least one chromosome in a pair is the fittest, appended it to the array of valid solutions; 4. Mutate those new child chromosomes; 5. Go to step 1 until you've selected N / 2 - chromosomes, where N - the size of population; 6. Proceed with steps 1-5 until you've produced the desired number of fittest solutions; This is the easies variant of the a classical genetic algorithm. If you want implement a genetic algorithm, please rework it the way as just I have explained. :) And if you've got any questions about how to rework it, just write me in the reply to my post.

bluatigro

i aready knew that i wrote some GA's in the past GP is somthing else i already have GP/GA working in liberty/just basic i m just not knowing how to do it in vb2017 jet i have some detail's wrong

Arthur V Ratz

As far as I can understand you want just to migrate your code into VB.NET 2017 ? At the present time I'm just a bit busy, but will help you out later on. :) I'll post the ready code as the reply to your message today, but a little bit later.

Arthur V Ratz

'' bluatigro 4 sept 2017
'' genetic programming module

Module Module1
Public Const gp_add As String = "[ + # # ]"
Public Const gp_sub As String = "[ - # # ]"
Public Const gp_mul As String = "[ * # # ]"
Public Const gp_div As String = "[ / # # ]"
Public Const gp_sqrt As String = "[ sqrt # # ]"
Public Class GeneProg
Private genes As Collection
Private Enum numMode As Integer
OnlyInputs = 0
AsDouble = 1
AsInteger = 2
End Enum
Private gpstate As numMode
Public Sub New()
gpstate = numMode.OnlyInputs
End Sub
Public Sub use(gen As String)
genes.Add(gen)
End Sub
Public Function run(prog As String) As String
While InStr(prog, "]") <> 0
Dim eind As Int16 = InStr(prog, "]")
Dim begin As Int16 = eind
While Mid(prog, begin, 1) <> "["
begin -= 1
End While
Dim part As String = Mid(prog _
, begin, eind - begin + 1)
Dim q() As String = Split(part)
Dim a As Double = Val(q(2))
Dim b As Double = Val(q(3))
Dim ab As Double
Try
Select Case q(1)
Case "+"
ab = a + b
Case "-"
ab = a - b
Case "*"
ab = a * b
Case "/"
If b = 0 Then
Return "error"
Else
ab = a / b
End If
Case "sqrt"
ab = Math.Sqrt(a)
Case Else
Return "error"
End Select
Catch ex As Exception
Return "error"
End Try
Dim l As String = Left(prog, begin - 1)
Dim r As String = Right(prog _
, Len(prog) - eind)
prog = l + Str(ab) + r
End While
Return prog
End Function
Public Function mix(pa As String, pb As String) As String
Dim begina As Int16
Dim einda As Int16
Dim beginb As Int16

Arthur V Ratz

Here's the corrected code in VB.NET 2017. I've made some small improvements of code to avoid the number of runtime errors. I actually can't figure out what particular algorithm you're about to implement. So, if you want me to delve into your code more deep, please let me know about the algorithm. Are you actually trying to develop a code that performs a reverse 'polish notation' to parse math expressions ?

bluatigro

the 'language' i use is based on lisp the problem whit basic is that the operant is not on the same place every time parsing is a lot easyer that way do you have use for the liberty/just code than we wil have translated it earlyer ?

'' bluatigro 4 sept 2017
'' genetic programming module

Module Module1
Public Const gp_add As String = "[ + # # ]"
Public Const gp_sub As String = "[ - # # ]"
Public Const gp_mul As String = "[ * # # ]"
Public Const gp_div As String = "[ / # # ]"
Public Const gp_sqrt As String = "[ sqrt # # ]"
Public Class GeneProg
Private genes As Collection
Private Enum numMode As Integer
OnlyInputs = 0
AsDouble = 1
AsInteger = 2
End Enum
Private gpstate As numMode
Public Sub New()
gpstate = numMode.OnlyInputs
End Sub
Public Sub use(gen As String)
genes.Add(gen)
End Sub
Public Function run(prog As String) As String
While InStr(prog, "]") <> 0
Dim eind As Int16 = InStr(prog, "]")
Dim bgin As Int16 = eind
While Mid(prog, bgin, 1) <> "["
bgin -= 1
End While
Dim part As String = Mid(prog _
, bgin, eind - bgin + 1)
Dim q() As String = Split(part)
Dim a As Double = Val(q(2))
Dim b As Double = Val(q(3))
Dim ab As Double
Try
Select Case q(1)
Case "+"
ab = a + b
Case "-"
ab = a - b
Case "*"
ab = a * b
Case "/"
If b = 0 Then
Return "error"
Else
ab = a / b
End If
Case "sqrt"
ab = Math.Sqrt(a)
Case Else
Return "error"
End Select
Catch ex As Exception
Return "error"
End Try
Dim l As String = Left(prog, bgin - 1)
Dim r As String = Right(prog _
, Len(prog) - eind)
prog = l + Str(ab) + r
End Wh

bluatigro

i have used my liberty/just code to expand the code WARNING : i dont think i got it al right please look at it how do i do : wrd.count() [ see code ]

'' bluatigro 7 sept 2017
'' genetic programming module

Module Module1
'' function gene's
Public Const gp_add As String = "[ + # # ]"
Public Const gp_sub As String = "[ - # # ]"
Public Const gp_mul As String = "[ * # # ]"
Public Const gp_div As String = "[ / # # ]"
Public Const gp_sqrt As String = "[ sqrt # # ]"
public const vars as string = "xyzdefgh"
Public Class GeneProg
Private genes As Collection
Private Enum numMode As Integer
OnlyInputs = 0
AsDouble = 1
AsInteger = 2
End Enum
Private gpstate As numMode
private varMax as int16
private var(8) as double
private growthrate as double
private progLenMax as int16

    Public Sub New()
        gpstate = numMode.OnlyInputs
        varmax = 0
        growthrate = 0.2
        progLenMax = 200
    End Sub

    Public Sub use(gen As String)
    '' for activation of a functiongen or number 
        genes.Add(gen)
    End Sub

    public sub setVarMax( m as int16 )
    '' how many variables seting
        if m < 1 or m > len(vars) then exit sub
        dim i as int16
        for i = 1 to m
            use(mid(vars, i, 1))
        next i
    end sub
    
    public sub setVar(no as int16, q as double)
    '' set variable 
    '' only as set var max is set this is useful
        if no < 1 or no > len(vars) then exit sub
        var(no) = q
    end sub
    
    public sub useIntegers()
    '' create a set of integer gene's
    '' and set writing to integer's
        dim i as int16
        for i = 0 to 31
             use(str(2 ^ i))
             use(str(-(2 ^ i)))
        next i
        use("0")
        gpstate = numMode.asinteger
    end sub

    public sub useDoubles()
    '' create a set of double gene's
    '' and set writing to double's
        dim i as int16
        for i = -31 to 31
            use(str(2 ^ i))
            use(str(-(2 ^ i)))
        next i
        use("0")
        gpstate = numMode.asdouble
    end sub

    private function isVar(x as string)as bool
        return len(x) = 1 and instr(vars

Arthur V Ratz

Quote:

the 'language' i use is based on lisp

Unfortunately, I'm not familiar with LISP programming.

Quote:

the problem whit basic is that the operant is not on the same place every time parsing is a lot easyer that way

Quote:

do you have use for the liberty/just code than we wil have translated it earlyer ?

And yes, parsing is much easier in this particular case. Since that, just change the algorithm. Anyway, what you've implemented is *NOT* a genetic algorithm in whatever language you have used.

Quote:

do you have use for the liberty/just code than we wil have translated it earlyer ?

To parse math expressions I would recommend that reverse 'polish notation' algorithm is a good one. Just give a try to implement it by using LISP, or Liberty BASIC, or VB.NET 2017, or whatsoever. :) Also, I would recommend you to start the development using VB.NET 2017 right from the very beginning, so that there will be no need to rework the code from other languages such LISP or Liberty BASIC.

Arthur V Ratz

Here we go. Now, I'm ready to come up with the code in VB.NET 2017 you've been requesting for: Probably, this is a correct solution. Just check it:

Module Module1
Function Compute(expr As String)
Dim Result As Int32 = 0
Dim val As String = ""
Dim op() As String = {"+", "-", "*", "/"}
Dim strings As List(Of String) = New List(Of String)
For index = 0 To expr.Length() - 1 Step 1
If IsNumeric(expr(index)) Then
val = Nothing
Dim done As Boolean = False
While index < expr.Length() And done = False
If IsNumeric(expr(index)) Then
val += expr(index)
index = index + 1
Else done = True
End If
End While
strings.Add(val)
ElseIf expr(index) = op(0) Then
strings.Add(op(0))
ElseIf expr(index) = op(1) Then
strings.Add(op(1))
ElseIf expr(index) = op(2) Then
strings.Add(op(2))
ElseIf expr(index) = op(3) Then
strings.Add(op(3))
End If
Next

    Dim n As Int32 = 0
    While strings.Contains("\*") Or strings.Contains("/")
        Dim found As Boolean = False
        While n < strings.Count() And found = False
            If strings(n) = op(2) Then
                Dim op1 As Int32 = Integer.Parse(strings(n - 1))
                Dim op2 As Int32 = Integer.Parse(strings(n + 1))
                Dim Res = op1 \* op2
                strings.RemoveAt(n - 1)
                strings(n - 1) = Res
                strings.RemoveAt(n)
                Result = Res
                found = True
                n = 0
            End If

            If strings(n) = op(3) Then
                Dim op1 As Int32 = Integer.Parse(strings(n - 1))
                Dim op2 As Int32 = Integer.Parse(strings(n + 1))
                Dim Res = CInt(op1 / op2)
                strings.RemoveAt(n - 1)
                strings(n - 1) = Res
                strings.RemoveAt(n)
                Result = Res
                found = True
                n = 0
            End If
            n = n + 1
        End While
    End While

    n = 0
    While strings.Contains("+") Or strings.Contains("-")

bluatigro

@ arthur v raz : nice try how does parse report a iligal calulation ?

Arthur V Ratz

okey, I'll give a try it later on. :)