fxm wrote:Roland Chastain wrote:Would it be possible to change the title of the discussion ?
The author of a topic can change the title editing his first post (field: 'Subject').
Thank you, fxm. I didn't know.
fxm wrote:Roland Chastain wrote:Would it be possible to change the title of the discussion ?
The author of a topic can change the title editing his first post (field: 'Subject').
Code: Select all
'*******************************************************************************
#Define Vide 0
#Define Pion 1
#Define Cavalier 2
#Define Fou 3
#Define Tour 4
#Define Dame 5
#Define Roi 6
#Define Noir -1
#Define Blanc 1
#Define Vrai -1
#Define Faux 0
#Define e8c8 0
#Define e8g8 1
#Define e1c1 2
#Define e1g1 3
'*******************************************************************************
Type Coup
x1 as Byte
y1 as Byte
x2 as Byte
y2 as Byte
End Type
Function CoupStr(c as Coup) as String
Return Chr(c.x1+97)+Chr(c.y1+49)+Chr(c.x2+97)+Chr(c.y2+49)
End Function
Sub StrCoup(s as String, byref c as Coup)
c.x1=s[0]-97
c.y1=s[1]-49
c.x2=s[2]-97
c.y2=s[3]-49
End Sub
'*******************************************************************************
Type Position
Damier(7,7) as Byte
Trait as Byte
Roque(3) as Byte
Passant as Byte
DemiCoups as Byte
Pli as Short
Valeur as Short
End Type
'*******************************************************************************
Data -4,-2,-3,-5,-6,-3,-2,-4
Data -1,-1,-1,-1,-1,-1,-1,-1
Data 0, 0, 0, 0, 0, 0, 0, 0
Data 0, 0, 0, 0, 0, 0, 0, 0
Data 0, 0, 0, 0, 0, 0, 0, 0
Data 0, 0, 0, 0, 0, 0, 0, 0
Data 1, 1, 1, 1, 1, 1, 1, 1
Data 4, 2, 3, 5, 6, 3, 2, 4
'*******************************************************************************
Dim shared Courante as Position
'*******************************************************************************
Sub Initialise
Restore
For y as Byte=7 to 0 step -1
For x as Byte=0 to 7
Read Courante.Damier(x,y)
Next x
Next y
Courante.Trait=Blanc
Courante.Roque(e8c8)=Vrai
Courante.Roque(e8g8)=Vrai
Courante.Roque(e1c1)=Vrai
Courante.Roque(e1g1)=Vrai
Courante.Passant=8
Courante.DemiCoups=0
Courante.Pli=1
End Sub
'*******************************************************************************
Function Passage(c as const Coup, p as const Position) as Byte
Dim x as Byte=c.x1
Dim y as Byte=c.y1
Dim vx as Byte=Sgn(c.x2-c.x1)
Dim vy as Byte=Sgn(c.y2-c.y1)
Dim Obstacle as Byte=Faux
Dim Arrivee as Byte=Faux
Do
x+=vx
y+=vy
If not(p.Damier(x,y)=Vide) then Obstacle=Vrai
If (x=c.x2) and (y=c.y2) then Arrivee=Vrai
Loop until (Obstacle or Arrivee)
Return Arrivee
End Function
'*******************************************************************************
Function Geometrie(c as const Coup, p as const Position) as Byte
If (c.x1=c.x2) andalso (c.y1=c.y2) then Return Faux
If Sgn(p.Damier(c.x2,c.y2))=Sgn(p.Damier(c.x1,c.y1)) then Return Faux
Select Case as const Abs(p.Damier(c.x1,c.y1))
Case Pion
If Sgn(c.y2-c.y1)=p.Damier(c.x1,c.y1) then
If (Abs(c.x2-c.x1)=1) andalso (c.y2-c.y1=p.Damier(c.x1,c.y1)) then
If p.Damier(c.x2,c.y2)=Vide then
If p.Passant=8 then
Return Faux
Else
If c.x2=p.Passant then
If (p.Damier(c.x1,c.y1)=Blanc) and (c.y1=4) then Return Vrai
If (p.Damier(c.x1,c.y1)=Noir) and (c.y1=3) then Return Vrai
End If
End If
Else
Return Vrai
End If
End If
If (c.x2=c.x1) andalso (p.Damier(c.x2,c.y2)=Vide) then
If (c.y2-c.y1=p.Damier(c.x1,c.y1)) then Return Vrai
If (c.y2-c.y1=2*p.Damier(c.x1,c.y1)) then
If p.Damier(c.x1,c.y1+p.Damier(c.x1,c.y1))=Vide then
If (p.Damier(c.x1,c.y1)=Blanc) andalso (c.y1=1) then Return Vrai
If (p.Damier(c.x1,c.y1)=Noir) andalso (c.y1=6) then Return Vrai
End If
End If
End If
End if
Case Cavalier
If (c.x2-c.x1)*(c.x2-c.x1)+(c.y2-c.y1)*(c.y2-c.y1)=5 then Return Vrai
Case Fou
If (c.x2-c.x1)*(c.x2-c.x1)=(c.y2-c.y1)*(c.y2-c.y1) then
If Passage(c,p) then Return Vrai
End If
Case Tour
If (c.x2-c.x1)*(c.x2-c.x1)*(c.y2-c.y1)*(c.y2-c.y1)=0 then
If Passage(c,p) then Return Vrai
End If
Case Dame
If (c.x2-c.x1)*(c.x2-c.x1)=(c.y2-c.y1)*(c.y2-c.y1) then
If Passage(c,p) then Return Vrai
End If
If (c.x2-c.x1)*(c.x2-c.x1)*(c.y2-c.y1)*(c.y2-c.y1)=0 then
If Passage(c,p) then Return Vrai
End If
Case Roi
If (c.x2-c.x1)*(c.x2-c.x1)+(c.y2-c.y1)*(c.y2-c.y1)<=2 then Return Vrai
If (c.y2=c.y1) and (Abs(c.x2-c.x1)=2) then
If c.x2=2 then
If p.Damier(1,c.y1)=Vide then
If p.Damier(2,c.y1)=Vide then
If p.Damier(3,c.y1)=Vide then
If (p.Damier(c.x1,c.y1)=Roi*Blanc) and p.Roque(e1c1) then Return Vrai
If (p.Damier(c.x1,c.y1)=Roi*Noir) and p.Roque(e8c8) then Return Vrai
End If
End If
End If
End If
If c.x2=6 then
If p.Damier(5,c.y1)=Vide then
If p.Damier(6,c.y1)=Vide then
If (p.Damier(c.x1,c.y1)=Roi*Blanc) and p.Roque(e1g1) then Return Vrai
If (p.Damier(c.x1,c.y1)=Roi*Noir) and p.Roque(e8g8) then Return Vrai
End If
End If
End If
End If
End Select
Return Faux
End Function
'*******************************************************************************
Function Echec(p as const Position) as Byte
Dim as Byte x1,y1,x2,y2
y2=7
x2=0
While not(p.Damier(x2,y2)=Roi*p.Trait)
x2+=1
If x2=8 then
x2=0
y2-=1
End If
Wend
Dim c as Coup
c.x2=x2
c.y2=y2
For x1=0 to 7
For y1=0 to 7
If Sgn(p.Damier(x1,y1))=-1*p.Trait then
c.x1=x1
c.y1=y1
If Geometrie(c,p) then Return Vrai
End If
Next y1
Next x1
Return Faux
End Function
'*******************************************************************************
Function Empechement(p as Position, r as Byte) as Byte
Dim as Byte x1,y1,x2,y2
Dim as Byte a,b
Select Case as const r
Case e8c8
y2=7
a=0
b=4
Case e8g8
y2=7
a=4
b=7
Case e1c1
y2=0
a=0
b=4
Case e1g1
y2=0
a=4
b=7
End Select
Dim c as Coup
c.y2=y2
For x2=a to b
c.x2=x2
For x1=0 to 7
For y1=0 to 7
If Sgn(p.Damier(x1,y1))=-1*p.Trait then
c.x1=x1
c.y1=y1
If Geometrie(c,p) then Return Vrai
End If
Next y1
Next x1
Next x2
Return Faux
End Function
'*******************************************************************************
Sub Mouvement(c as const Coup, byref p as Position)
If (Abs(p.Damier(c.x1,c.y1))=Pion) and ((c.y2=7) or (c.y2=0)) then
p.Damier(c.x1,c.y1)*=Dame
End If
If (Abs(p.Damier(c.x1,c.y1))=Roi) and (Abs(c.x2-c.x1)=2) then
If c.x2=2 then
p.Damier(3,c.y1)=p.Damier(0,c.y1)
p.Damier(0,c.y1)=Vide
Else
p.Damier(5,c.y1)=p.Damier(7,c.y1)
p.Damier(7,c.y1)=Vide
End If
End If
If (Abs(p.Damier(c.x1,c.y1))=Pion) andalso (Abs(c.x2-c.x1)=1) then
If p.Damier(c.x2,c.y2)=Vide then
p.Damier(c.x1,c.y2)=Vide
End If
End If
If (Abs(p.Damier(c.x1,c.y1))=Roi) then
If p.Trait=Blanc then
p.Roque(e1c1)=Faux
p.Roque(e1g1)=Faux
Else
p.Roque(e8c8)=Faux
p.Roque(e8g8)=Faux
End If
End If
If (Abs(p.Damier(c.x1,c.y1))=Tour) then
If (c.x1=0) andalso (c.y1=7) then p.Roque(e8c8)=Faux
If (c.x1=7) andalso (c.y1=7) then p.Roque(e8g8)=Faux
If (c.x1=0) andalso (c.y1=0) then p.Roque(e1c1)=Faux
If (c.x1=7) andalso (c.y1=0) then p.Roque(e1g1)=Faux
End If
If (Abs(p.Damier(c.x2,c.y2))=Tour) then
If (c.x2=0) andalso (c.y2=7) then p.Roque(e8c8)=Faux
If (c.x2=7) andalso (c.y2=7) then p.Roque(e8g8)=Faux
If (c.x2=0) andalso (c.y2=0) then p.Roque(e1c1)=Faux
If (c.x2=7) andalso (c.y2=0) then p.Roque(e1g1)=Faux
End If
If (Abs(p.Damier(c.x1,c.y1))=Pion) and (Abs(c.y2-c.y1)=2) then
p.Passant=c.x1
Else
p.Passant=8
End If
If (Abs(p.Damier(c.x1,c.y1))=Pion) or (p.Damier(c.x2,c.y2)<>Vide) then
p.DemiCoups=0
Else
p.DemiCoups+=1
End If
If p.Trait=Noir then p.Pli+=1
p.Damier(c.x2,c.y2)=p.Damier(c.x1,c.y1)
p.Damier(c.x1,c.y1)=Vide
p.Trait*=-1
End Sub
'*******************************************************************************
Function Possibles(p as Position) as String
Dim s as String=""
Dim as Byte x1,y1,x2,y2
Dim c as Coup
Dim cs as String
Dim fictive as Position
For x1=0 to 7
c.x1=x1
For y1=0 to 7
c.y1=y1
If Sgn(p.Damier(x1,y1))=p.Trait then
For x2=0 to 7
c.x2=x2
For y2=0 to 7
c.y2=y2
If Geometrie(c,p) then
cs=CoupStr(c)
fictive=p
Mouvement(c,fictive)
fictive.Trait*=-1
If Echec(fictive) then cs=""
If Abs(p.Damier(x1,y1))=Roi then
If Abs(c.x2-c.x1)=2 then
Select Case cs
Case "e8c8"
If not(Empechement(p,e8c8)) then
s+=cs
End If
Case "e8g8"
If not(Empechement(p,e8c8)) then
s+=cs
End If
Case "e1c1"
If not(Empechement(p,e8c8)) then
s+=cs
End If
Case "e1g1"
If not(Empechement(p,e8c8)) then
s+=cs
End If
End Select
End If
Else
s+=cs
End If
End If
Next y2
Next x2
End If
Next y1
Next x1
Possibles=s
End Function
'*******************************************************************************
Dim shared Prix (Roi*Noir to Roi*Blanc) as Byte
Prix(Roi*Noir) = 0
Prix(Dame*Noir) = -80
Prix(Tour*Noir) = -50
Prix(Fou*Noir) = -30
Prix(Cavalier*Noir) = -30
Prix(Pion*Noir) = -10
Prix(Vide) = 0
Prix(Pion*Blanc) = 10
Prix(Cavalier*Blanc) = 30
Prix(Fou*Blanc) = 30
Prix(Tour*Blanc) = 50
Prix(Dame*Blanc) = 80
Prix(Roi*Blanc) = 0
'*******************************************************************************
Sub Evaluation(byref p as Position)
Dim as Byte x,y
p.Valeur=0
For x=0 to 7
For y=0 to 7
p.Valeur+=Prix(p.Damier(x,y))*p.Trait
Next y
Next x
End Sub
'*******************************************************************************
Sub Variantes
Dim as Ubyte ff=freefile
Dim erreur as Integer=Open("Variantes.txt" for output as #ff)
Dim as String pss0,pss1,pss2,pss3
Dim as Coup c0,c1,c2,c3
Dim as String*4 cs0,cs1,cs2,cs3
Dim as Position Fictive,F1,F2,F3
Dim as Byte i,j,k,l
pss0=Possibles(Courante)
For i=1 to len(pss0)\4
cs0=Mid(pss0,4*i-3,4)
StrCoup(cs0,c0)
Fictive=Courante
Mouvement(c0,Fictive)
pss1=Possibles(Fictive)
For j=1 to len(pss1)\4
cs1=Mid(pss1,4*j-3,4)
StrCoup(cs1,c1)
F1=Fictive
Mouvement(c1,F1)
pss2=Possibles(F1)
For k=1 to len(pss2)\4
cs2=Mid(pss2,4*k-3,4)
StrCoup(cs2,c2)
F2=F1
Mouvement(c2,F2)
pss3=Possibles(F2)
For l=1 to len(pss3)\4
cs3=Mid(pss3,4*l-3,4)
StrCoup(cs3,c3)
F3=F2
Mouvement(c3,F3)
Evaluation(F3)
Print #ff,cs0+cs1+cs2+cs3+String(1,32)+Str(F3.Valeur)
Next l
Next k
Next j
Next i
Close #ff
End Sub
'*******************************************************************************
' PROGRAMME PRINCIPAL
Initialise
Variantes
' FIN DU PROGRAMME PRINCIPAL
'*******************************************************************************
Code: Select all
'Colors.bas
BackgroundColor = &H9F9F8F
TextColor = &H000088
GadgetColor = &H4F8F3F
GadgetTextColor = &HFFDF00
CursorColor = GadgetColor
MenuColor = &HD0D0D0
MenuTextColor = black
MenuHiliteColor = &H80D0FF
MenuGhostedColor = &H808080
const customWhite as uInteger = rgb(248, 252, 248)
const customGray as uInteger = rgb(200, 200, 184)
const customBlack as uInteger = rgb(24, 28, 8)
const chessBoardForeground as uInteger = &H000088
const chessBoardBackground as uInteger = customWhite
TESLACOIL wrote:ps i tried to compile your code Eschecs 0.8.2 but got zillions of errors everywhere, at some point you will need to write an installer / zip that includes all the files, i think several dependent files where missing from that zip
Code: Select all
'Colors.bas
Couleurs = 0
Users browsing this forum: No registered users and 5 guests