Creating a Crossword Puzzle in Visual Basic

WEBINAR: On-demand webcast

How to Boost Database Development Productivity on Linux, Docker, and Kubernetes with Microsoft SQL Server 2017 REGISTER >

Introduction

Having an over-active brain and over-active imagination can sometimes be a blessing, but mostly it is a curse—especially for me, especially when I am thinking up wonderful ideas to write about. A topic that seems too complicated can end up being a gremlin of a project, whereas a topic that seems complicated up front can be a breeze.

Today's project ended up being much bigger than what I initially thought, and there is still so much more potential that this project can end up huge! This is why I love developing: You never know what a project might become.

Today you will create a Crossword puzzle generator in Visual Basic. Hold on tight; it's going to be an interesting ride!

Our Project

Open Visual Studio and create a new Visual Basic WPF application. The main reason I made this project in WPF form is because it has a handy little grid control that eases the design for the crossword. More on this a bit later.

Add the following controls to your WPF Form:

Three ListViews and a label for each, as shown in Figure 1:

ListViews
Figure 1: ListViews

A Grid control, as shown in Figure 2:

Grid
Figure 2: Grid

A Textbox and two buttons, as shown in Figure 3:

Buttons and TextBox
Figure 3: Buttons and TextBox

Add six more buttons to your Form. Set their background colors to any color of your choice. These buttons will be used to fill the crossword grid. After you have formatted them, make all.

You already can shape an idea of what you will be doing, based on the preceding pictures. Just in case, let me explain it:

  • You will type a word in the TextBox and click Add. All the words will be added like this.
  • Once you click Generate the Puzzle, the words will be displayed in the grid as well as which words are shown Vertically and which are shown Horizontally.

You are welcome to name and format and rearrange all your objects as you please.

Add a Class to your project and name it clsCrossword.

Add the following Members to it:

   Shared rndRandom As Random

   Private Shared strWordList As IList(Of String)

   Const strLetters As String = "abcdefghijklmnopqrstuvwxyz"

   Private intHWords As Integer(,)
   Private intVWords As Integer(,)
   Private intX As Integer() = {0, 1}
   Private intY As Integer() = {1, 0}
   Private intDirX As Integer
   Private intDirY As Integer
   Private intHWordsCount As Integer
   Private intVWordsCount As Integer
   Private Shared intSol As Integer

   Private chrGameBoard As Char(,)
   Private Shared chrTempGameBoard As Char(,)

   Private dtTime As DateTime

These variables control the direction in which the word should be displayed on the board as well as setting up the game board and word structure. You will make use of strLetters, which will get split into either the Horizontal words or Vertical words arrays.

Add the Constructor:

   Public Sub New(X As Integer, Y As Integer)

      intDirX = X
      intDirY = Y

      rndRandom = New Random()

      chrGameBoard = New Char(X - 1, Y - 1) {}

      intHWords = New Integer(X - 1, Y - 1) {}
      intVWords = New Integer(X - 1, Y - 1) {}

      For i As Integer = 0 To intDirX - 1

         For j As Integer = 0 To intDirY - 1

            chrGameBoard(i, j) = " "c

         Next
      Next

   End Sub

The Constructor simply initializes all the objects. It sets up the game board and creates a new Random object. Add the next two Properties for this class:

   Public ReadOnly Property X() As Integer

      Get

         Return intDirX

      End Get

   End Property

   Public ReadOnly Property Y() As Integer

      Get

         Return intDirY

      End Get

   End Property

   Public ReadOnly Property GetBoard() As Char(,)

      Get

         Return chrGameBoard

      End Get

   End Property

As you can probably deduce, these will be used to determine in which direction a word should be placed.

Now the fun begins…

Probably the most important thing to remember here is that we are only dealing with so many blocks. The total amount of blocks is 252. Now, with every word, the empty blocks should become fewer and the occupied blocks greater—that seems obvious, but achieving this in code needs a lot of effort. Another thing to consider is where a previous character was placed. Add the following functions to determine the best position for a desired letter:

   Private Function BestPos(strWord As String) As _
      Tuple(Of Integer, Integer, Integer)

      Dim lstPos = FindPos(strWord)

      If lstPos.Count > 0 Then

         Dim intIndex As Integer = _
            rndRandom.[Next](lstPos.Count)

         Return lstPos(intIndex)

      End If

      Return Nothing

   End Function

   Private Function FindPos(strWord As String) As _
      List(Of Tuple(Of Integer, Integer, Integer))

      Dim intMaxWordCount As Integer = 0

      Dim lstPos = New List(Of Tuple(Of Integer, _
         Integer, Integer))()

      For x As Integer = 0 To intDirX - 1

         For y As Integer = 0 To intDirY - 1

            For i As Integer = 0 To intX.Length - 1

               Dim intDirection As Integer = i

               Dim strWordToInsert As String = strWord

               Dim intCount = DetermineSpace(strWordToInsert, _
                  x, y, intDirection)

               If intCount < intMaxWordCount Then

                  Continue For

               End If

               If intCount > intMaxWordCount Then

                  lstPos.Clear()

               End If

               intMaxWordCount = intCount

               lstPos.Add(New Tuple(Of Integer, Integer, _
                  Integer)(x, y, intDirection))

            Next
         Next
      Next

      Return lstPos

   End Function

   Private Function PosValid(intX As Integer, _
      intY As Integer) As Boolean

      Return intX >= 0 AndAlso intY >= 0 AndAlso intX < _
         intDirX AndAlso intY < intDirY

   End Function

BestPos and FindPos determine the best place to insert the next letter of a word in a sequence whereas PosValid ensures it is a legal block for the desired character.

Add the following code to identify the space in and around each inserted letter and word:

   Private Function intSpace() As Integer

      Dim intCount As Integer = 0

      For i As Integer = 0 To X - 1

         For j As Integer = 0 To Y - 1

            If chrGameBoard(i, j) = " "c OrElse chrGameBoard(i, j) = _
               "*"c Then

               intCount += 1

            End If

         Next

      Next

      Return intCount

   End Function

   Private Function DetermineSpace(strWord As String, intxX As Integer, _
         intyY As Integer, intDirection As Integer) As Integer

      Dim intResult As Integer = 0

      If intDirection = 0 Then

         For i As Integer = 0 To strWord.Length - 1

            Dim xX As Integer = intxX, yY As Integer = intyY + i

            If Not (PosValid(xX, yY) AndAlso (chrGameBoard(xX, yY) = _
                  " "c OrElse chrGameBoard(xX, yY) = _
                  strWord(i))) Then

               Return -1
            End If

            If PosValid(xX - 1, yY) Then

               If intHWords(xX - 1, yY) > 0 Then

                  Return -1

               End If

            End If

            If PosValid(xX + 1, yY) Then

               If intHWords(xX + 1, yY) > 0 Then

                  Return -1

               End If

            End If

            If chrGameBoard(xX, yY) = strWord(i) Then

               intResult += 1

            End If

         Next

      Else

         For i As Integer = 0 To strWord.Length - 1

            Dim xX As Integer = intxX + i, yY As Integer = intyY

            If Not (PosValid(xX, yY) AndAlso (chrGameBoard(xX, yY) = _
                  " "c OrElse chrGameBoard(xX, yY) = _
                  strWord(i))) Then

               Return -1

            End If

            If PosValid(xX, yY - 1) Then

               If intVWords(xX, yY - 1) > 0 Then

                  Return -1

               End If

            End If

            If PosValid(xX, yY + 1) Then

               If intVWords(xX, yY + 1) > 0 Then

                  Return -1

               End If

            End If

            If chrGameBoard(xX, yY) = strWord(i) Then

               intResult += 1

            End If

         Next

      End If

      Dim xPos As Integer = intxX - intX(intDirection)
      Dim yPos As Integer = intyY - intY(intDirection)

      If PosValid(xPos, yPos) Then

         If Not (chrGameBoard(xPos, yPos) = " "c _
               OrElse chrGameBoard(xPos, yPos) = "*"c) Then

            Return -1

         End If

      End If

      xPos = intxX + intX(intDirection) * strWord.Length
      yPos = intyY + intY(intDirection) * strWord.Length

      If PosValid(xPos, yPos) Then

         If Not (chrGameBoard(xPos, yPos) = " "c OrElse _
               chrGameBoard(xPos, yPos) = "*"c) Then

            Return -1

         End If

      End If

      Return If(intResult = strWord.Length, -1, intResult)

   End Function

Add the logic to add the Current word to a Grid:

   Private Sub AddToGrid(strWord As String, intxX As Integer, _
         intyY As Integer, intDirection As Integer, intVal As Integer)

      Dim intDir = If(intDirection = 0, intHWords, intVWords)

      For i As Integer = 0 To strWord.Length - 1

         Dim x As Integer = intxX + intX(intDirection) * i
         Dim y As Integer = intyY + intY(intDirection) * i

         chrGameBoard(x, y) = strWord(i)

         intDir(x, y) = intVal

      Next

      Dim xPos As Integer = intxX - intX(intDirection)
      Dim yPos As Integer = intyY - intY(intDirection)

      If PosValid(xPos, yPos) Then

         chrGameBoard(xPos, yPos) = "*"c

      End If

      xPos = intxX + intX(intDirection) * strWord.Length
      yPos = intyY + intY(intDirection) * strWord.Length

      If PosValid(xPos, yPos) Then

         chrGameBoard(xPos, yPos) = "*"c

      End If

   End Sub

   Public Function Add(strWord As String) As Integer

      Dim strNextWord As String = strWord

      Dim tplWordInfo = BestPos(strNextWord)

      If tplWordInfo IsNot Nothing Then

         If tplWordInfo.Item3 = 0 Then

            intHWordsCount += 1

         Else

            intVWordsCount += 1

         End If

         Dim intValue As Integer = If(tplWordInfo.Item3 = _
               0, intHWordsCount, intVWordsCount)

            AddToGrid(strNextWord, tplWordInfo.Item1, _
               tplWordInfo.Item2, tplWordInfo.Item3, intValue)

            Return tplWordInfo.Item3

      End If

      Return -1

   End Function

Add the rest of the class to clean up the class and ensure we are dealing with only text characters:

   Public Function IsCharacter(cA As Char) As Boolean

      Return strLetters.Contains(cA.ToString())

   End Function

   Private Shared Function Helper(Of T)(ByRef tTarget As T, _
         ByVal tValue As T) As T

      tTarget = tValue

      Return tValue

   End Function

   Public Sub Reset()

      For i As Integer = 0 To intDirX - 1

         For j As Integer = 0 To intDirY - 1

            chrGameBoard(i, j) = " "c

            intVWords(i, j) = 0
            intHWords(i, j) = 0

            intHWordsCount = Helper(intVWordsCount, 0)

         Next

      Next

   End Sub

   Public Sub GenWords(strWords As IList(Of String))

      strWordList = strWords

      intSol = X * Y

      dtTime = DateTime.Now
      Generate(0)

      chrGameBoard = chrTempGameBoard

   End Sub

   Private Sub Generate(intPos As Integer)

      If intPos >= strWordList.Count OrElse (DateTime.Now - _
            dtTime).Minutes > 1 Then

         Return

      End If

      For i As Integer = intPos To strWordList.Count - 1

         Dim tBestPos = BestPos(strWordList(i))

         If tBestPos IsNot Nothing Then

            Dim strWord As String = strWordList(i)

            Dim intVal As Integer = If(tBestPos.Item3 = 0, _
               intHWordsCount, intVWordsCount)

            AddToGrid(strWord, tBestPos.Item1, tBestPos.Item2, _
               tBestPos.Item3, intVal)

            Generate(intPos + 1)

            RemoveWord(strWord, tBestPos.Item1, tBestPos.Item2, _
               tBestPos.Item3)

         Else

            Generate(intPos + 1)

         End If

      Next

      Dim iSpace As Integer = intSpace()

      If iSpace >= intSol Then

         Return

      End If

      intSol = iSpace

      chrTempGameBoard = TryCast(chrGameBoard.Clone(), Char(,))

   End Sub

   Private Sub RemoveWord(strWord As String, intxX As Integer, _
         intyY As Integer, intDirection As Integer)

      Dim HWordLoc = If(intDirection = 0, intHWords, intVWords)
      Dim VWordLoc = If(intDirection = 0, intVWords, intHWords)

      For i As Integer = 0 To strWord.Length - 1

         Dim x As Integer = intxX + intX(intDirection) * i
         Dim y As Integer = intyY + intY(intDirection) * i

         If VWordLoc(x, y) = 0 Then

            chrGameBoard(x, y) = " "c

         End If

         HWordLoc(x, y) = 0

      Next

      Dim xPos As Integer = intxX - intX(intDirection)
      Dim yPos As Integer = intyY - intY(intDirection)

      If PosValid(xPos, yPos) AndAlso FactibleValue(xPos, yPos) Then

         chrGameBoard(xPos, yPos) = " "c

      End If

      xPos = intxX + intX(intDirection) * strWord.Length
      yPos = intyY + intY(intDirection) * strWord.Length

      If PosValid(xPos, yPos) AndAlso FactibleValue(xPos, yPos) Then

         chrGameBoard(xPos, yPos) = " "c

      End If

   End Sub

   Private Function FactibleValue(intxX As Integer, _
         intyY As Integer) As Boolean

      For i As Integer = 0 To intX.Length - 1

         Dim x As Integer = intxX + intX(i)
         Dim y As Integer = intyY + intY(i)

         If PosValid(x, y) AndAlso (chrGameBoard(x, y) <> _
               " "c OrElse chrGameBoard(x, y) = "*"c) Then

            Return True

         End If

         x = intxX - intX(i)
         y = intyY - intY(i)

         If PosValid(x, y) AndAlso (chrGameBoard(x, y) <> _
               " "c OrElse chrGameBoard(x, y) = "*"c) Then

            Return True

         End If

      Next

      Return False

   End Function

Open the MainWindow.xaml.vb file (the code file for your main Window) and add the following member objects:

   Private ReadOnly lWords As New List(Of String)()
   Private lstOrder As List(Of String)

   Private ReadOnly lstButtons As List(Of Button)

   Dim cwBoard As New clsCrossword(14, 18)

Here we instantiate a new game board object, the button colors, and the word list objects.

Add the Constructor:

   Public Sub New()

      InitializeComponent()

      lstButtons = New List(Of Button)() From { _
         bcolor2, _
         bcolor1, _
         bcolor3, _
         btn1, _
         btn2, _
         btn3 _
      }

      For i As Integer = 0 To cwBoard.X - 1

         For j As Integer = 0 To cwBoard.Y - 1

            Dim bButton = New Button() With { _
               .Background = lstButtons(0).Background, _
               .Content = "" _
            }

            Grid.SetRow(bButton, i)
            Grid.SetColumn(bButton, j)

            grdCrossword.Children.Add(bButton)

         Next

      Next

   End Sub

This sets up our game.

Add the following code to add the entered words into the list for the Crossword:

   Private Sub txtWordToAdd_KeyDown(sender As Object, e As KeyEventArgs) _
         Handles txtWordToAdd.KeyDown

      If e.Key = Key.Return Then

         btnAddWord_Click_1(Nothing, Nothing)

      End If

   End Sub

   Private Sub btnAddWord_Click(sender As Object, e As RoutedEventArgs) _
         Handles btnAddWord.Click

      Dim strWord As String = txtWordToAdd.Text.Trim()

      If strWord.Length <> 0 Then

         If lWords.Contains(strWord) Then

            MessageBox.Show("Word Already Exists.", "Attention", _
               MessageBoxButton.OK, MessageBoxImage.Information)

            Return

         End If

         lWords.Add(strWord)
         lstWords.Items.Add(strWord)

      End If

      txtWordToAdd.Text = ""
      txtWordToAdd.Focus()

   End Sub

Generate the Crossword:

   Private Sub btnGenerate_Click(sender As Object, e As RoutedEventArgs) _
         Handles btnGenerate.Click

      lWords.Reverse()

      lstOrder = lWords

      GenerateCrossword()

      txtWordToAdd.Focus()

   End Sub

   Private Sub GenerateCrossword()

      lstHorizontal.Items.Clear()
      lstVertical.Items.Clear()

      cwBoard.Reset()
      Clear()

      For Each strWord As String In lstOrder

         Select Case cwBoard.Add(strWord)

            Case 0

               lstHorizontal.Items.Add(strWord)

               Exit Select

            Case 1

               lstVertical.Items.Add(strWord)

               Exit Select

            Case Else

               Exit Select

         End Select

      Next

      ShowWords()

   End Sub

   Private Sub ShowWords()

      Dim cBoard = cwBoard.GetBoard

      Dim intCurrChild As Integer = 0

      For i As Integer = 0 To cwBoard.X - 1

         For j As Integer = 0 To cwBoard.Y - 1

            Dim cLetter As Char = If(cBoard(i, j) = "*"c, _
               " "c, cBoard(i, j))

            DirectCast(grdCrossword.Children(intCurrChild), _
               Button).Content = cLetter.ToString()
            DirectCast(grdCrossword.Children(intCurrChild), _
               Button).Background = If(cLetter <> " "c, _
               lstButtons(4).Background, lstButtons(0).Background)

            intCurrChild += 1

         Next

      Next

End Sub

Clear the Crossword:

   Private Sub Clear()

      Dim intCountChildren As Integer = 0

      For i As Integer = 0 To cwBoard.X - 1

         For j As Integer = 0 To cwBoard.Y - 1

            DirectCast(grdCrossword.Children(intCountChildren), _
               Button).Content = ""
            DirectCast(grdCrossword.Children(intCountChildren), _
               Button).Background = lstButtons(0).Background

            intCountChildren += 1

         Next

      Next

   End Sub

Running
Figure 4: Running

Conclusion

You can do anything with Visual Basic! As you can see, all you need is logic. The crossword you have helped me create today can be expanded greatly. You could add a word list for Hints. You could add a word list that lists the unused words, and you could add export functions to Excel, for example, and even printing capabilities. I'll let you play further.



About the Author

Hannes DuPreez

Hannes du Preez has been a Microsoft MVP for Visual Basic from 2008 to 2017. He loves technology and loves Visual Basic. He loves writing articles and proving that Visual Basic is more powerful than what most believe. You are most welcome to reach him at: ojdupreez1978@gmail.com

Related Articles

Comments

  • There are no comments yet. Be the first to comment!

Leave a Comment
  • Your email address will not be published. All fields are required.

Top White Papers and Webcasts

  • As all sorts of data becomes available for storage, analysis and retrieval - so called 'Big Data' - there are potentially huge benefits, but equally huge challenges...
  • The agile organization needs knowledge to act on, quickly and effectively. Though many organizations are clamouring for "Big Data", not nearly as many know what to do with it...
  • Cloud-based integration solutions can be confusing. Adding to the confusion are the multiple ways IT departments can deliver such integration...

Most Popular Programming Stories

More for Developers

RSS Feeds

Thanks for your registration, follow us on our social networks to keep up-to-date