Liberty BASIC Community Forum
« Genetic Programming »

Welcome Guest. Please Login or Register.
Nov 24th, 2017, 10:51am


Rules|Home|Help|Search|Recent Posts|Notification


« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: Genetic Programming  (Read 962 times)
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Genetic Programming
« Thread started on: Apr 9th, 2014, 08:37am »

this is a try to get GP in LB

GP wat :
- trying to get a function out of a grafic

GP how :
- 1 : create a set of functions [ write ]
- 2 : calculate output [ gprun ]
- 3 : sort functions on fitness
- 4 : get child functions from the best [ mix ]
- 5 : mutate childs [ mutate ]
- 6 : goto 2 if generation < max
and best.fitness > whised_fitness

error :
- mutate() somitmes freezes

Code:
dim gene$( 200 ) , prog$( 200 ) , fout(200)
global genetel , numberMode , pi _
, true , false
pi = atn( 1 ) * 4
true = not( false )
call test
''call calculatePI
end
sub test
  a$ = "[ + 1 [ - 2 3 4 ] 5 ]"
  b$ = "[ * 6 [ / 7 8 9 ] 10 ]"
  print "a = " ; a$
  print "b = " ; b$
  print "run a = " ; gprun$( a$ )
  print "run b = " ; gprun$( b$ )
  for i = 0 to 5
  print "mix a b = " ; mix$( a$ , b$ )
  print "mutate a = " ; mutate$( a$ )
  next i
end sub
sub calculatePI
''try to get a pi function
  ''first activate genes out of gene pool
  call intarray
  call use add$()
  call use sub$()
  call use div$()
  call use multi$()
  ''then write programs
  for i = 0 to 200
    prog$( i ) = write$( 4 )
  next i
  pi = atn( 1 ) * 4
  ''then loop thou generations
  max = 20
  for generation = 0 to max
    ''generate fitnes of every prog$
    for i = 0 to 200
      q$ = gprun$( prog$( i ) )
      if q$ = "error!!" then
        fout( i ) = 1e14
      else
        fout( i ) = abs( pi - val( q$ ) )
      end if
    next i
    call evaluate
  next generation
end sub
sub evaluate
''sort programs on fitnes
  for h = 1 to 200
    for l = 0 to h
      if fout( l ) > fout( h ) then
        a = fout( h )
        fout( h ) = fout( l )
        fout( l ) = a
        a$ = prog$( h )
        prog$( h ) = prog$( l )
        prog$( l ) = a$
      end if
    next l
  next h
  ''print best program and its fit ness
    print prog$( 0 )
    print fout( 0 )
  ''get childern
  for i = 10 to 200
    a = int( rnd( 0 ) * 10 )
    b = int( rnd( 0 ) * 10 )
    prog$( i ) = mix$( prog$( a ) , prog$( b ) )
    prog$( i ) = mutate$( prog$( i ) )
  next i
end sub
function isNumber( x$ )
  l$ = left$( x$ , 1 )
  i = instr( "0123456789" , l$ )
  if i <> 0 then
    uit = true
  else
    uit = false
  end if
  isNumber = uit
end function
function gprun$( prog$ )
''eval function for lisp functions
  if prog$ = "" then gprun$ = "error!!"
  while instr( prog$ , "]" ) <> 0 _
  and prog$ <> "error!!"
    einde = instr( prog$ , "]" )
    begin = einde
    while mid$( prog$ , begin , 1 ) <> "[" and begin > 1
      begin = begin - 1
    wend
    part$ = mid$( prog$ , begin , einde - begin + 1 )
    f$ = word$( part$ , 2 )
    a$ = word$( part$ , 3 )
    b$ = word$( part$ , 4 )
    c$ = word$( part$ , 5 )
    if isNumber( a$ ) then
      a = val( word$( part$ , 3 ) )
    else
        prog$ = "error!!"
    end if
    if isNumber( b$ ) then
      b = val( word$( part$ , 4 ) )
    else
        prog$ = "error!!"
    end if
    if isNumber( c$ ) then
      c = val( word$( part$ , 5 ) )
    else
        prog$ = "error!!"
    end if
    select case f$
      case "+"
        ab = a + b
      case "-"
        ab = a - b
      case "*"
        ab = a * b
      case "/"
        if b = 0 then
          prog$ = "error!!"
        else
          ab = a / b
        end if
      case else
        prog$ = "error!!"
    end select
    l$ = left$( prog$ , begin - 1 )
    r$ = mid$( prog$ , einde + 1, len( prog$ ) - einde + 1)
    prog$ = l$ + str$( ab ) + r$
  wend
  gprun$ = prog$
end function
function write$( hookmax )
''write a program whit the activated genes
  ''get a function gene for seed
  dice = int( rnd( 0 ) * genetel )
  while left$( gene$( dice ) , 1 ) <> "["
    dice = int( rnd( 0 ) * genetel )
  wend
  uit$ = gene$( dice )
  while instr( uit$, "#" ) <> 0 _
  and hook < hookmax
    p = instr( uit$ , "#" )
    dice = int( rnd( 0 ) * genetel )
    l$ = left$( uit$ , p - 1 )
    r$ = right$( uit$ , len( uit$ ) - p )
    uit$ = l$ +" "+ gene$( dice ) + r$
    if left$( gene$( dice ) , 1 ) = "[" then
      hook = hook + 1
    end if
  wend
  while instr( uit$, "#" ) <> 0
    p = instr( uit$ , "#" )
    dice = int( rnd( 0 ) * genetel )
    while left$( gene$( dice ) , 1 ) = "["
      dice = int( rnd( 0 ) * genetel )
    wend
    l$ = left$( uit$ , p - 1 )
    r$ = right$( uit$ , len( uit$ ) - p )
    uit$ = l$ +" "+ gene$( dice ) + r$
  wend
  write$ = uit$
end function
sub use gen$
''activate gen$ for use in writing and mutation
  gene$( genetel ) = gen$
  genetel = genetel + 1
end sub
sub intarray
''create a array of integer genes
  for i = 0 to 31
    call use str$( 2 ^ i )
    call use str$( 2 ^ i )
  next i
  numberMode = 1
end sub
sub dblarray
''create a array of double genes
  for i = -31 to 31
    call use str$( 2 ^ i )
  next i
  numberMode = 2
end sub
function mix$( a$ , b$ )
''take a random part of a prog
''and put it a random place
''of another prog
  if rnd( 0 ) < .5 then
    h$ = a$
    a$ = b$
    b$ = h$
  end if
  for i = 1 to len( a$ )
    if mid$( a$ , i , 1 ) = "[" then
      qa$ = qa$ + str$( i ) + " "
      at = at + 1
    end if
  next i
  for i = 1 to len( b$ )
    if mid$( b$ , i , 1 ) = "[" then
      qb$ = qb$ + str$( i ) + " "
      bt = bt + 1
    end if
  next i
  begina = val( word$( qa$ , int( rnd(0) * at + 1 ) ) )
  eindea = begina
  fl = 0
  while fl >= 0
    eindea = eindea + 1
    if mid$( a$ , eindea , 1 ) = "[" then fl=fl+1
    if mid$( a$ , eindea , 1 ) = "]" then fl=fl-1
  wend
  beginb = val( word$( qb$ , int( rnd(0) * bt + 1 ) ) )
  eindeb = beginb
  fl = 0
  while fl >= 0
    eindeb = eindeb + 1
    if mid$( b$ , eindeb , 1 ) = "[" then fl=fl+1
    if mid$( b$ , eindeb , 1 ) = "]" then fl=fl-1
  wend
  l$ = left$( b$ , beginb - 1 )
  r$ = right$( b$ , len( b$ ) - eindeb + 1 )
  mix$ = l$ _
  + mid$( a$ , begina , eindea - begina ) _
  + r$
end function
function mutate$( a$ )
''mutate prog a$
  ''find complexity
  tel = 0
  for i = 1 to len( a$ )
    if mid$( a$ , i , 1 ) = " " then
    tel = tel + 1
    end if
  next i
  ''take a atom that isnt a hook or empty
  dice = int( rnd( 0 ) * tel + 1 )
  while word$( a$ , dice ) = "[" _
  or    word$( a$ , dice ) = "]" _
  or    word$( a$ , dice ) = ""
    dice = int( rnd( 0 ) * tel + 1 )
  wend
  atom$ = word$( a$ , dice )
    if isNumber( atom$ ) then
      ''atom is a number
      select case numberMode
        case 1 ''integers
          x = val( atom$ )
          atom$ = str$( x _
          xor 2 ^ int( rnd(0) * 31 ) )
        case else ''doubles
          x = val( atom$ )
          q = 2 ^ int( rnd(0) * 63 - 31 )
          if rnd(0) < .5 then
            atom$ = str$( x - q )
          else
            atom$ = str$( x + q )
          end if
      end select
    else
      ''atom is a function
      q = 0
      while left$( gene$( q ) , 1 ) <> "["
        q = int( rnd( 0 ) * genetel )
      wend
      atom$ = word$( gene$( q ) , 2 )
    end if
  uit$ = ""
  for i = 1 to tel + 2
    if i = dice then
      uit$ = uit$ + atom$ + " "
    else
      uit$ = uit$ + word$( a$ , i ) + " "
    end if
  next i
  mutate$ = uit$
end function

''gene pool
''feel free to extemd
''if you extend this you have
''to alter run$() to

function add$()
  add$ = "[ + # # # ]"
end function
function sub$()
  sub$ = "[ - # # # ]"
end function
function div$()
  div$ = "[ / # # # ]"
end function
function multi$()
  multi$ = "[ * # # # ]"
end function
 
User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #1 on: Apr 14th, 2014, 04:38am »

update :
- proof of cocept is now working

i forgot that for mutate() the code needs
a set of active genes

Code:
dim gene$( 200 ) , prog$( 200 ) , fout(200)
global genetel , numberMode , pi _
, true , false
pi = atn( 1 ) * 4
true = not( false )
''both subs need activated genes
call intarray
call use add$()
call use sub$()
call use div$()
call use multi$()

call test
input "[ push return ]" ; a$
call calculatePI
end
sub test
''test all the subs
  a$ = "[ + 1 [ - 2 3 4 ] 5 ]"
  b$ = "[ * 6 [ / 7 8 9 ] 10 ]"
  print "a = " ; a$
  print "b = " ; b$
  print "run a = " ; gprun$( a$ )
  print "run b = " ; gprun$( b$ )
  for i = 0 to 5
    print "mix a b = " ; mix$( a$ , b$ )
    print "mutate a = " ; mutate$( a$ )
  next i
end sub
sub calculatePI
''try to get a pi function
  ''then write programs
  for i = 0 to 200
    prog$( i ) = write$( 4 )
  next i
  pi = atn( 1 ) * 4
  ''then loop thou generations
  max = 20
  for generation = 0 to max
    ''generate fitnes of every prog$
    for i = 0 to 200
      q$ = gprun$( prog$( i ) )
      if q$ = "error!!" then
        fout( i ) = 1e14
      else
        fout( i ) = abs( pi - val( q$ ) )
      end if
    next i
    call evaluate
  next generation
end sub
sub evaluate
''sort programs on fitnes
  for h = 1 to 200
    for l = 0 to h
      if fout( l ) > fout( h ) then
        a = fout( h )
        fout( h ) = fout( l )
        fout( l ) = a
        a$ = prog$( h )
        prog$( h ) = prog$( l )
        prog$( l ) = a$
      end if
    next l
  next h
  ''print best program and its fit ness
    print prog$( 0 )
    print fout( 0 )
  ''get childern
  for i = 10 to 200
    a = int( rnd( 0 ) * 10 )
    b = int( rnd( 0 ) * 10 )
    prog$( i ) = mix$( prog$( a ) , prog$( b ) )
    prog$( i ) = mutate$( prog$( i ) )
  next i
end sub
function isNumber( x$ )
  isNumber = val( x$ ) <> 0 _
             or x$ = "0"
end function
function gprun$( prog$ )
''eval function for lisp functions
  if prog$ = "" then gprun$ = "error!!"
  while instr( prog$ , "]" ) <> 0 _
  and prog$ <> "error!!"
    einde = instr( prog$ , "]" )
    begin = einde
    while mid$( prog$ , begin , 1 ) <> "[" and begin > 1
      begin = begin - 1
    wend
    part$ = mid$( prog$ , begin , einde - begin + 1 )
    f$ = word$( part$ , 2 )
    a$ = word$( part$ , 3 )
    b$ = word$( part$ , 4 )
    c$ = word$( part$ , 5 )
    if isNumber( a$ ) then
      a = val( word$( part$ , 3 ) )
    else
        prog$ = "error!!"
    end if
    if isNumber( b$ ) then
      b = val( word$( part$ , 4 ) )
    else
        prog$ = "error!!"
    end if
    if isNumber( c$ ) then
      c = val( word$( part$ , 5 ) )
    else
        prog$ = "error!!"
    end if
    select case f$
      case "+"
        ab = a + b
      case "-"
        ab = a - b
      case "*"
        ab = a * b
      case "/"
        if b = 0 then
          prog$ = "error!!"
        else
          ab = a / b
        end if
      case else
        prog$ = "error!!"
    end select
    l$ = left$( prog$ , begin - 1 )
    r$ = mid$( prog$ , einde + 1, len( prog$ ) - einde + 1)
    prog$ = l$ + str$( ab ) + r$
  wend
  gprun$ = prog$
end function
function write$( hookmax )
''write a program whit the activated genes
  ''get a function gene for seed
  dice = int( rnd( 0 ) * genetel )
  while left$( gene$( dice ) , 1 ) <> "["
    dice = int( rnd( 0 ) * genetel )
  wend
  uit$ = gene$( dice )
  while instr( uit$, "#" ) <> 0 _
  and hook < hookmax
    p = instr( uit$ , "#" )
    dice = int( rnd( 0 ) * genetel )
    l$ = left$( uit$ , p - 1 )
    r$ = right$( uit$ , len( uit$ ) - p )
    uit$ = l$ +" "+ gene$( dice ) + r$
    if left$( gene$( dice ) , 1 ) = "[" then
      hook = hook + 1
    end if
  wend
  while instr( uit$, "#" ) <> 0
    p = instr( uit$ , "#" )
    dice = int( rnd( 0 ) * genetel )
    while left$( gene$( dice ) , 1 ) = "["
      dice = int( rnd( 0 ) * genetel )
    wend
    l$ = left$( uit$ , p - 1 )
    r$ = right$( uit$ , len( uit$ ) - p )
    uit$ = l$ +" "+ gene$( dice ) + r$
  wend
  write$ = uit$
end function
sub use gen$
''activate gen$ for use in writing and mutation
  gene$( genetel ) = gen$
  genetel = genetel + 1
end sub
sub intarray
''create a array of integer genes
  for i = 0 to 31
    call use str$( 2 ^ i )
    call use str$( 2 ^ i )
  next i
  numberMode = 1
end sub
sub dblarray
''create a array of double genes
  for i = -31 to 31
    call use str$( 2 ^ i )
  next i
  numberMode = 2
end sub
function mix$( a$ , b$ )
''take a random part of a prog
''and put it a random place
''of another prog
  if rnd( 0 ) < .5 then
    h$ = a$
    a$ = b$
    b$ = h$
  end if
  for i = 1 to len( a$ )
    if mid$( a$ , i , 1 ) = "[" then
      qa$ = qa$ + str$( i ) + " "
      at = at + 1
    end if
  next i
  for i = 1 to len( b$ )
    if mid$( b$ , i , 1 ) = "[" then
      qb$ = qb$ + str$( i ) + " "
      bt = bt + 1
    end if
  next i
  begina = val( word$( qa$ , int( rnd(0) * at + 1 ) ) )
  eindea = begina
  fl = 0
  while fl >= 0
    eindea = eindea + 1
    if mid$( a$ , eindea , 1 ) = "[" then fl=fl+1
    if mid$( a$ , eindea , 1 ) = "]" then fl=fl-1
  wend
  beginb = val( word$( qb$ , int( rnd(0) * bt + 1 ) ) )
  eindeb = beginb
  fl = 0
  while fl >= 0
    eindeb = eindeb + 1
    if mid$( b$ , eindeb , 1 ) = "[" then fl=fl+1
    if mid$( b$ , eindeb , 1 ) = "]" then fl=fl-1
  wend
  l$ = left$( b$ , beginb - 1 )
  r$ = right$( b$ , len( b$ ) - eindeb + 1 )
  mix$ = l$ _
  + mid$( a$ , begina , eindea - begina ) _
  + r$
end function
function mutate$( a$ )
''mutate prog a$
  ''find complexity
  tel = 0
  for i = 1 to len( a$ )
    if mid$( a$ , i , 1 ) = " " then
    tel = tel + 1
    end if
  next i
  ''take a atom that isnt a hook or empty
  dice = int( rnd( 0 ) * tel + 1 )
  while word$( a$ , dice ) = "[" _
  or    word$( a$ , dice ) = "]" _
  or    word$( a$ , dice ) = ""
    dice = int( rnd( 0 ) * tel + 1 )
  wend
  atom$ = word$( a$ , dice )
    if isNumber( atom$ ) then
      ''atom is a number
      select case numberMode
        case 1 ''integers
          x = val( atom$ )
          atom$ = str$( x _
          xor 2 ^ int( rnd(0) * 31 ) )
        case else ''doubles
          x = val( atom$ )
          q = 2 ^ int( rnd(0) * 63 - 31 )
          if rnd(0) < .5 then
            atom$ = str$( x - q )
          else
            atom$ = str$( x + q )
          end if
      end select
    else
      ''atom is a function
      q = 0
      while left$( gene$( q ) , 1 ) <> "["
        q = int( rnd( 0 ) * genetel )
      wend
      atom$ = word$( gene$( q ) , 2 )
    end if
  uit$ = ""
  for i = 1 to tel + 2
    if i = dice then
      uit$ = uit$ + atom$ + " "
    else
      uit$ = uit$ + word$( a$ , i ) + " "
    end if
  next i
  mutate$ = uit$
end function

''gene pool
''feel free to extemd
''if you extend this you have
''to alter run$() to

function add$()
  add$ = "[ + # # # ]"
end function
function sub$()
  sub$ = "[ - # # # ]"
end function
function div$()
  div$ = "[ / # # # ]"
end function
function multi$()
  multi$ = "[ * # # # ]"
end function
 
« Last Edit: Apr 14th, 2014, 04:38am by bluatigro » User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #2 on: Apr 16th, 2014, 04:07am »

update :
- now whit var's

the code eats now 10 dimensional problems
i cant think of a >10 dimensional problem jet

i wil expand this whit more genes in the gene pool

when done that
i wil look into controling 'robots'

code at :
http://www.ai-forum.org/forum.asp?forum_id=1
User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #3 on: Jun 19th, 2014, 05:02am »

update :
- now whit example problems
--- find a function for PI
--- find the pytagoras formula

this is now a proof of concept

i REMed some things that use mutch time
feel free to unREM those lines

code at :
http://libertybasic.nl/viewtopic.php?f=4&t=649
User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #4 on: Oct 11th, 2015, 11:01am »

update :
- now al is in englsh
- added aprox gene
- added more remarks

if you need more remarks ask

i need help :
- in gprun() the code does not catch al errors that can ocure

code at :
http://libertybasic.nl/viewtopic.php?f=4&t=649
« Last Edit: Oct 11th, 2015, 11:06am by bluatigro » User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #5 on: Apr 24th, 2017, 04:25am »

update :
now whit iif() function

not all is in english but it works
[ proof of concept ]

i dont know for sure if gprun$() catches all error's
please report them if you see them

code at :
http://libertybasic.nl/viewtopic.php?f=4&t=649&p=2566#p2566
User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #6 on: Apr 27th, 2017, 08:49am »

update :
the "error' had extentions .
i removed that
more genes to choise from

i m not sure that i got al the catch i need in gprun()
please report them if you see them

code at :
http://libertybasic.nl/viewtopic.php?f=4&t=649
User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
bluatigro
Guru
ImageImageImageImageImage


member is offline

Avatar

cxiu diversas el tio respondas cxiu samvaloras [ thats esperanto for : we are al different therefore we are al equal ]


PM

Gender: Male
Posts: 922
xx Re: Genetic Programming
« Reply #7 on: Jul 25th, 2017, 04:53am »

update :
i tryed to catch ALL "error"s in gprun
i got them all now but i think i made some mistakes
[ see REM ]

please look in gprun if i got them rigth
and report mistakes and forgotten ones

code at :
http://libertybasic.nl/viewtopic.php?f=4&t=649&p=2571#p2571
User IP Logged

basic's : C64 Simons C128 Amiga Amos quick4.5 Visual5 Visual6 Visual2005 Visual2008 just and last but not least liberty
Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

Rules|Home|Help|Search|Recent Posts|Notification

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls