I have tried to design a genetic algorithm in Freebasic.
Problem: Knight's tour
https://en.wikipedia.org/wiki/Knight's_tour
Using brute force requires about 2M attempts. With this algorithm it needs about 100K of attempts.
First it makes the first moves and then tries to find a good strategy. The best strokes are fixed (red marked). If they do not result in a longer period of time, they will make a mutation.
Certainly it can be optimized. But I wanted him not to know anything in advance to teach himself during the attempts.
I hope you like it! ;-)
YT preview:
https://youtu.be/jiTPvltZ8Ys
Code: Select all
Dim shared as ubyte i,j
Dim shared as ubyte x,y
Dim shared as ubyte tah_x,tah_y
Dim shared as ubyte tah_vyber
Dim shared as single sc
Dim shared as single zbytek
Dim shared as double pokus,pokus_test,pokus_def
Dim shared as single prumer,zbytek_prumer
Dim shared as single max_pokusy
Dim shared as single poradi
Dim shared as single nejlepsi_vysledek
Dim shared as ubyte n
Dim shared as ubyte ctrl
Dim shared as single max_prumer
Dim shared as single sc_draw
Dim shared as single x_draw,y_draw
Dim shared as single a(8,8)
Dim shared as single r(64) 'řešení
Dim shared as single g(64) 'genetika
Declare Sub zobrazeni
Declare Sub vynulovani
Declare Sub sachovnice
Declare Sub prevod
Randomize
Screen 19,32,,0
max_pokusy=200e3 'maximální počet pokusů v cyklu
zbytek=0
zbytek_prumer=0
prumer=0
max_prumer=25.6
pokus=1
nejlepsi_vysledek=64
n=1
poradi=1
pokus_test=1
pokus_def=1
Color rgb(100,100,100)
For i=1 To 32
Locate i,27:Print i;"."
Next i
For i=33 To 64
Locate i-32,36:Print i;"."
Next i
start:
g(1)=1 'výchozí pole na šachovnici číslo
Color rgb(100,100,100)
Line(365,50)-(365,460)
Line(365,460)-(778,460)
Locate 2,50:Print "Good strategy"
Locate 31,50:Print "Bad strategy"
Color rgb(255,255,255)
'graf
sc_draw+=1
If sc_draw>150 Then
If x_draw>410 Then x_draw=0
x_draw+=1
y_draw=prumer
If y_draw>=22 And y_draw<=25 Then
Pset(x_draw+370,y_draw*133-2883)
End If
sc_draw=0
End If
i=1
prevod()
a(tah_x,tah_y)=1
x=tah_x
y=tah_y
n=1
For i=1 To poradi
r(i)=g(i)
Next i
If poradi>2 Then
n=poradi-1
i=1
Do
prevod()
a(tah_x,tah_y)=1
i+=1
Loop Until i>poradi-1
x=tah_x
y=tah_y
End If
zobrazeni()
provedeni_tahu:
'vyhodnocení
If sc>100 Then
pokus+=1
pokus_test+=1
pokus_def+=1
If pokus>max_pokusy And poradi>4 Then
poradi-=1
pokus=1
For i=1 To 32
Locate i,20:Print " "
ctrl=1
If i<=poradi And zbytek<>0 Then Color rgb(220,0,0) Else Color rgb(255,255,255)
sachovnice()
Next i
For i=33 To 64
Locate i-32,24:Print " "
ctrl=2
If i<=poradi And zbytek<>0 Then Color rgb(220,0,0) Else Color rgb(255,255,255)
sachovnice()
Next i
i=poradi
Do
r(i)=0
g(i)=0
prevod()
a(tah_x,tah_y)=0
i+=1
Loop Until i>64
x=tah_x
y=tah_y
GoTo start
End If
sc=0
zbytek=0
For i=1 To 8
For j=1 To 8
If a(i,j)=0 Then zbytek+=1
Next j
Next i
If zbytek<nejlepsi_vysledek Then
g(poradi)=r(poradi)
poradi+=1
nejlepsi_vysledek=zbytek
For i=1 To 32
Locate i,20:Print " "
ctrl=1
If i<=poradi And zbytek<>0 Then Color rgb(220,0,0) Else Color rgb(255,255,255)
sachovnice()
Next i
For i=33 To 64
Locate i-32,24:Print " "
If i<=poradi And zbytek<>0 Then Color rgb(220,0,0) Else Color rgb(255,255,255)
ctrl=2
sachovnice()
Next i
End If
zbytek_prumer+=zbytek
prumer=zbytek_prumer/pokus_test
Locate 10,2:Print "Zbylo: ";zbytek;" "
Locate 11,2:Print "Pokus: ";pokus_def;" "
Locate 12,2:Print "Nejlepsi: ";nejlepsi_vysledek;" "
Locate 14,2:Print "Pozice: ";poradi;" "
Locate 15,2:Print "Prumer: ";prumer;" "
If zbytek=0 Then
Locate 17,2:Print "Vyreseno! "
sleep:sleep:End
End If
'korekce průměrného zbytku
If prumer>max_prumer Then
zbytek=0
zbytek_prumer=0
prumer=0
pokus=1
nejlepsi_vysledek=64
n=1
poradi=1
pokus_test=1
sc=0
vynulovani()
GoTo start
End If
n=1
'sleep 200
vynulovani()
GoTo start
End If
'výběr 1 z 8 možných tahů
tah_vyber=Int(Rnd*8)+1
tah_x=x
tah_y=y
Select Case tah_vyber
Case 1
tah_x+=1
tah_y-=2
Case 2
tah_x-=1
tah_y-=2
Case 3
tah_x+=2
tah_y-=1
Case 4
tah_x+=2
tah_y+=1
Case 5
tah_x-=2
tah_y-=1
Case 6
tah_x-=2
tah_y+=1
Case 7
tah_x+=1
tah_y+=2
Case 8
tah_x-=1
tah_y+=2
End Select
If tah_x>8 Or tah_x<=0 Or tah_y>8 Or tah_y<=0 Then
sc+=1
GoTo provedeni_tahu
End If
If a(tah_x,tah_y)=1 Then
sc+=1
GoTo provedeni_tahu
End If
x=tah_x
y=tah_y
a(x,y)=1
n+=1
r(n)=x+(y-1)*8
'zobrazeni()
sc=0
GoTo provedeni_tahu
'zobrazení šachovnice
Sub zobrazeni()
For i=1 To 8
For j=1 To 8
If a(j,i)=0 Then
Locate i,j:Print(".")
Else
Locate i,j:Print("X")
End If
Next j
Next i
'sleep 150
End Sub
Sub vynulovani()
For i=1 To 8
For j=1 To 8
a(i,j)=0
Next j
Next i
End Sub
'převod čísla na souřadnice
Sub sachovnice()
If ctrl=1 Then
Locate i,30
Else
Locate i-32,39
End If
Select Case r(i)
Case 1
Print "A8"
Case 2
Print "B8"
Case 3
Print "C8"
Case 4
Print "D8"
Case 5
Print "E8"
Case 6
Print "F8"
Case 7
Print "G8"
Case 8
Print "H8"
Case 9
Print "A7"
Case 10
Print "B7"
Case 11
Print "C7"
Case 12
Print "D7"
Case 13
Print "E7"
Case 14
Print "F7"
Case 15
Print "G7"
Case 16
Print "H7"
Case 17
Print "A6"
Case 18
Print "B6"
Case 19
Print "C6"
Case 20
Print "D6"
Case 21
Print "E6"
Case 22
Print "F6"
Case 23
Print "G6"
Case 24
Print "H6"
Case 25
Print "A5"
Case 26
Print "B5"
Case 27
Print "C5"
Case 28
Print "D5"
Case 29
Print "E5"
Case 30
Print "F5"
Case 31
Print "G5"
Case 32
Print "H5"
Case 33
Print "A4"
Case 34
Print "B4"
Case 35
Print "C4"
Case 36
Print "D4"
Case 37
Print "E4"
Case 38
Print "F4"
Case 39
Print "G4"
Case 40
Print "H4"
Case 41
Print "A3"
Case 42
Print "B3"
Case 43
Print "C3"
Case 44
Print "D3"
Case 45
Print "E3"
Case 46
Print "F3"
Case 47
Print "G3"
Case 48
Print "H3"
Case 49
Print "A2"
Case 50
Print "B2"
Case 51
Print "C2"
Case 52
Print "D2"
Case 53
Print "E2"
Case 54
Print "F2"
Case 55
Print "G2"
Case 56
Print "H2"
Case 57
Print "A1"
Case 58
Print "B1"
Case 59
Print "C1"
Case 60
Print "D1"
Case 61
Print "E1"
Case 62
Print "F1"
Case 63
Print "G1"
Case 64
Print "H1"
End Select
End Sub
'převod čísla na souřadnice
Sub prevod()
Select Case g(i)
Case 1
tah_x=1
tah_y=1
Case 2
tah_x=2
tah_y=1
Case 3
tah_x=3
tah_y=1
Case 4
tah_x=4
tah_y=1
Case 5
tah_x=5
tah_y=1
Case 6
tah_x=6
tah_y=1
Case 7
tah_x=7
tah_y=1
Case 8
tah_x=8
tah_y=1
Case 9
tah_x=1
tah_y=2
Case 10
tah_x=2
tah_y=2
Case 11
tah_x=3
tah_y=2
Case 12
tah_x=4
tah_y=2
Case 13
tah_x=5
tah_y=2
Case 14
tah_x=6
tah_y=2
Case 15
tah_x=7
tah_y=2
Case 16
tah_x=8
tah_y=2
Case 17
tah_x=1
tah_y=3
Case 18
tah_x=2
tah_y=3
Case 19
tah_x=3
tah_y=3
Case 20
tah_x=4
tah_y=3
Case 21
tah_x=5
tah_y=3
Case 22
tah_x=6
tah_y=3
Case 23
tah_x=7
tah_y=3
Case 24
tah_x=8
tah_y=3
Case 25
tah_x=1
tah_y=4
Case 26
tah_x=2
tah_y=4
Case 27
tah_x=3
tah_y=4
Case 28
tah_x=4
tah_y=4
Case 29
tah_x=5
tah_y=4
Case 30
tah_x=6
tah_y=4
Case 31
tah_x=7
tah_y=4
Case 32
tah_x=8
tah_y=4
Case 33
tah_x=1
tah_y=5
Case 34
tah_x=2
tah_y=5
Case 35
tah_x=3
tah_y=5
Case 36
tah_x=4
tah_y=5
Case 37
tah_x=5
tah_y=5
Case 38
tah_x=6
tah_y=5
Case 39
tah_x=7
tah_y=5
Case 40
tah_x=8
tah_y=5
Case 41
tah_x=1
tah_y=6
Case 42
tah_x=2
tah_y=6
Case 43
tah_x=3
tah_y=6
Case 44
tah_x=4
tah_y=6
Case 45
tah_x=5
tah_y=6
Case 46
tah_x=6
tah_y=6
Case 47
tah_x=7
tah_y=6
Case 48
tah_x=8
tah_y=6
Case 49
tah_x=1
tah_y=7
Case 50
tah_x=2
tah_y=7
Case 51
tah_x=3
tah_y=7
Case 52
tah_x=4
tah_y=7
Case 53
tah_x=5
tah_y=7
Case 54
tah_x=6
tah_y=7
Case 55
tah_x=7
tah_y=7
Case 56
tah_x=8
tah_y=7
Case 57
tah_x=1
tah_y=8
Case 58
tah_x=2
tah_y=8
Case 59
tah_x=3
tah_y=8
Case 60
tah_x=4
tah_y=8
Case 61
tah_x=5
tah_y=8
Case 62
tah_x=6
tah_y=8
Case 63
tah_x=7
tah_y=8
Case 64
tah_x=8
tah_y=8
End Select
End Sub
https://www.brainbashers.com/knight.asp
