Attribute VB_Name = "Module2" '************************************************************** '* Chess: Problem of the Eight Queens * '* ---------------------------------------------------------- * '* Description: * '* This famous problem consists in finding locations of eight * '* queens on a chess board, such as no one can be taken by * '* another one. After Arthur Engel Cedic (1979), this problem * '* was posed for the first time in 1848 by Max Bezzel in a * '* Chess Journal. This publication gave way to an extraordi- * '* nary passion and on sept. 21th, 1850 a certain Dr Nauck * '* gave all the solutions when the famous mathematician Gauss * '* had only found 72 out of 92. But it is true that he had * '* better to attend to... This small program gives all the * '* solutions from n=4 to n=8 (size of board) by using the so * '* called "backtracking method". * '* ---------------------------------------------------------- * '* REFERENCE: * '* "Graphisme dans le plan et dans l'espace avec Turbo Pascal * '* 4.0 By R. Dony - MASSON, Paris 1990". * '* * '* Graphic Visual Basic Release By J-P Moreau, Paris. * '************************************************************** DefInt I-N Option Base 0 Const iblue = 9 Const iwhite = 15 Dim R(8) As Integer Dim S(92, 8) As Integer 'maximum 92 solutions Dim Xr(8) As Integer Dim Yr(8) As Integer Dim order As Integer Dim ok, fin As Boolean Dim x As Integer Dim y As Integer Dim i As Integer Dim k As Integer Dim l As Integer Dim num As Integer Dim num1 As Integer Dim old As Integer Dim Numsol(8) As Integer Sub ReadOrder() order = Val(Form1.Text1.Text) End Sub Sub DrawQueen(x As Integer, y As Integer) 225 Dim xc As Integer Dim yc As Integer Dim xp As Integer Dim yp As Integer xc = x + 225: yc = y + 525: xp = xc: yp = yc 'Form1.MoveTo xp, yp xc = xc + 450: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc yc = yc - 45: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc - 450: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc yc = yc + 45: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 75: yc = yc - 75: xp = xc: yp = yc 'Form1.MoveTo xc, yc yc = yc + 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 300: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc yc = yc - 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc - 300: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc - 75: yc = yc - 75: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc - 75: yc = yc - 120: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 30: yc = yc - 15: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 45: yc = yc + 60: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 75: yc = yc - 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc yc = yc - 60: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 15: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 15: yc = yc + 45: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 90: yc = yc - 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 15: yc = yc - 45: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 15: yc = yc + 45: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 90: yc = yc + 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 15: yc = yc - 45: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 15: xp = xc: yp = yc 'Form1.MoveTo xc, yc yc = yc + 60: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 75: yc = yc + 30: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 45: yc = yc - 60: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc + 30: yc = yc + 15: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc - 75: yc = yc + 120: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc xc = xc - 75: yc = yc + 75: Form1.Line (xp, yp)-(xc, yc): xp = xc: yp = yc Form1.Circle (x + 150, y + 225), 30 Form1.Circle (x + 300, y + 180), 30 Form1.Circle (x + 450, y + 150), 40 Form1.Circle (x + 600, y + 180), 30 Form1.Circle (x + 750, y + 225), 30 End Sub Sub Init() Xr(1) = 425: Yr(1) = 6300 For ii = 2 To order Xr(ii) = Xr(ii - 1) + 750 Next ii For ii = 2 To order Yr(ii) = Yr(ii - 1) - 750 Next ii fin = False i = 0: num = 0: k = -1 l = 500 Numsol(4) = 2 Numsol(5) = 10 Numsol(6) = 4 Numsol(7) = 40 Numsol(8) = 92 Display 8000, 200, "TABLE OF SOLUTIONS" End Sub 'print string S at location (x,y) Sub Display(x As Integer, y As Integer, S As String) Form1.CurrentX = x Form1.CurrentY = y Form1.Print S End Sub Sub DrawBoard() M1 = 7000: N1 = 750 For ii = 0 To order Form1.Line (500, M1 - ii * N1)-(500 + N1 * order, M1 - ii * N1) Next ii For ii = 0 To order Form1.Line (500 + ii * N1, M1)-(500 + ii * N1, M1 - N1 * order) Next ii End Sub Sub TestPreviousQueens() ok = True j = 1 While j <= i - 1 And (ok) If R(i) = R(j) Or Abs(R(i) - R(j)) = i - j Then ok = False j = j + 1 Wend End Sub Sub ColumnDown() R(i) = 0 i = i - 1 If i = 0 Then fin = True Else i = i - 1 End If End Sub Sub DrawSolution(NN As Integer, coul As Integer) If coul = iblue Then 'blue pen Form1.ForeColor = RGB(0, 0, 255) Else 'white pen Form1.ForeColor = RGB(255, 255, 255) End If For ii = 1 To order DrawQueen Xr(ii), Yr(S(NN, ii)) Next ii End Sub Sub DisplaySolution() Dim ch As String Dim chaine As String chaine = "" num = num + 1 For j = 1 To order S(num, j) = R(j) ch = Str\$(R(j)) chaine = chaine + ch Next j k = k + 1 k3 = k Mod 3 If k3 = 0 Then l = l + 200 Display 7000, l, chaine ElseIf k3 = 1 Then Display 8300, l, chaine ElseIf k3 = 2 Then Display 9600, l, chaine End If End Sub Sub SeekSolution() Dim S As String While Not fin i = i + 1 While i <= order And Not fin ok = False While R(i) < order And Not ok R(i) = R(i) + 1 Call TestPreviousQueens Wend If Not ok Then Call ColumnDown End If i = i + 1 Wend If Not fin Then Call DisplaySolution R(order) = 0 i = order - 2 End If Wend S = Str\$(num) Form1.Text2.Text = S End Sub 'seek the num solutions for given board size Sub Exec_Queens() Form1.Cls Call ReadOrder Call Init Call DrawBoard Call SeekSolution num1 = Val(Form1.Text3.Text) DrawSolution num1, iblue End Sub 'draw the solution #num1 Sub Draw() old = num1 num1 = Val(Form1.Text3.Text) DrawSolution old, iwhite 'erase DrawSolution num1, iblue End Sub