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