Option Explicit

Rem =============================================================
Rem     External user defined types for Solver arguments.
Rem =============================================================

Rem Array element structure of Solution() argument (returned from Solver):
    Type typeSolution
        AcrossWord As Integer   ' Index in Word() if across word starts at Col/Row.
        DownWord As Integer     ' Index in Word() if down word starts at Col/Row.
        Col As Integer          ' Starting column for word.
        Row As Integer          ' Starting row for word.
    End Type

Rem Structure of Args argument (some elements passed and some returned):
Rem
Rem FirstWord   (passed to Solver) - The Word array index of the
Rem             first word to be placed into the grid. If FirstWord is
Rem             less than the lower bound of Word, then the first word
Rem             is selected in the same way as the rest of the words.
Rem FirstAcross (passed to Solver) - If set to true, the first word
Rem             placed into the grid will appear as an Across word in
Rem             the solution. Otherwise, the first word will appear as a
Rem             Down word.
Rem MaxSize     (passed to Solver) - The maximum permissible size, in
Rem             letters, of the grid occupied by words in the solution.
Rem             The grid is always square, so MaxSize limits both the
Rem             number of letters across as well as down. If MaxSize is
Rem             zero, no size limit is imposed on the solution.
Rem RandomWord  (passed to Solver) - If set to true, words are selected
Rem             at random from the Word array for testing. Otherwise, words
Rem             are selected sequentially.
Rem RandomMatch (passed to Solver) - If set to true, letter matches
Rem             within a word are tested in a random order. Otherwise,
Rem             letter matches are tested in the order in which they occur
Rem             in each word.
Rem Recalled    (passed to Solver) - If set to true, Solver will use
Rem             the Match array from the last time Solver was run.
Rem             The Match array is always the same for a given list of
Rem             words, so it’s a waste of time to recreate it each
Rem             time Solver is run with the same list of words. After
Rem             running Solver once for a list of words, Recalled should
Rem             be set to true.
Rem PlacedCnt   (returned from Solver) - The number of words included in
Rem             the solution.
Rem Size        (returned from Solver) - The minimum size, in letters,
Rem             of a square grid capable of containing the solution.
Rem ErrorMsg    (returned from Solver) - Contains any error messages.

    Type typeArgs
        FirstWord As Integer
        FirstAcross As Integer
        MaxSize As Integer
        RandomWord As Integer
        RandomMatch As Integer
        Recalled As Integer
        PlacedCnt As Integer
        Size As Integer
        ErrorMsg As String
    End Type

Rem ====================================================================
Rem     Internally used types, module level variables and constants.
Rem ====================================================================

Rem Used to indicate direction in Vector().
    Const ACROSS = 1
    Const DOWN = 2

Rem Intermediate solution vector.
    Type typeWordVector
        Col As Integer      ' Starting column index in Grid() for word.
        Row As Integer      ' Starting row index in Grid() for word.
        Direction As Integer' Direction of word in Grid() - across/down.
        Link As Integer     ' Index to next Vector() element in row/col sort.
    End Type

Rem Array with one vector for each word in Word().
    Dim Vector() As typeWordVector

Rem Range of indices in Match().
    Type typeWordMatch
        FirstMatch As Integer   ' Index of first Match() element for Word1.
        LastMatch As Integer    ' Index of last Match() element for Word1.
    End Type

Rem Array with one range of indices for each word in Word().
    Dim WordMatch() As typeWordMatch

Rem One letter match between a pair of words.
    Type typeMatch
        Ltr1Posn As Integer     ' Position of matching letter in Word1
        Word2Idx As Integer    ' Index of Word2 in Word().
        Ltr2Posn As Integer     ' Position of matching letter in Word2.
    End Type

Rem Array of all letter matches between every pair of words.
    Dim Match() As typeMatch
    Dim UMatch As Integer   ' Upper bound of Match() - lower is 1.
    Dim MatchCnt As Integer ' Highest index used in Match().
    
Rem Array with one tested flag for each element in Match().
    Dim MatchTested() As Integer

Rem Array of letters as they placed in the puzzle.
    Dim Grid() As String * 1
    Dim UGrid As Integer    ' Upper bound of Grid().
    Dim LGrid As Integer    ' Lower bound of Grid().
    
Rem Miscellaneous module level variables.
    Dim LWord As Integer    ' Lower bound of Word().
    Dim UWord As Integer    ' Upper bound of Word().
    Dim MaxSize As Integer  ' Maximum size of solution grid.
    Dim MinRowPzl As Integer    ' Lowest row index used in Grid().
    Dim MaxRowPzl As Integer    ' Highest row index used in Grid().
    Dim MinColPzl As Integer    ' Lowest column index used in Grid().
    Dim MaxColPzl As Integer    ' Highest column index used in Grid().
    Dim MaxWordLength As Integer' Maximum word length found in Word().
    Dim WordCnt As Integer  ' Number of words in Word().
    Dim PlacedCnt As Integer' Number of words successfully placed in Grid().
    Dim LinkEnd As Integer  ' Index of Vector element at end of linked list.

Private Function MakeMatch (Word() As String) As Integer
Rem Put letter matches into Match() and indices into WordMatch().

    Dim Word1 As String
    Dim Word1Idx As Integer
    Dim Ltr1Posn As Integer
    Dim Length1 As Integer
    Dim Ltr1 As String * 1
    Dim Word2 As String
    Dim Word2Idx As Integer
    Dim Ltr2Posn As Integer
    Dim Prev2Posn As Integer
    Dim MatchIdx As Integer

    Rem Clear Match() and dimension to reasonable size.
    ReDim Match(1 To UWord)
    UMatch = UWord
    MaxWordLength = 0
    MatchIdx = 0
    
    Rem Check each word in Word().
    For Word1Idx = LWord To UWord
        Word1 = Word(Word1Idx)
        Length1 = Len(Word1)
        
        Rem Word can't be longer than the maximum grid size.
        If (MaxSize = 0) Or (Length1 <= MaxSize) Then
            If Length1 > MaxWordLength Then
                Rem Keep track of maximum word length for sizing Grid().
                MaxWordLength = Length1
            End If

            GoSub FindMatches
        End If
    Next Word1Idx
    
    MakeMatch = (MatchIdx > 0)
    
    Exit Function

FindMatches:
    Rem Match each letter of each word against each other.
    For Word2Idx = LWord To UWord
        DoEvents
        
        If Word2Idx <> Word1Idx Then
            Word2 = Word(Word2Idx)
            For Ltr1Posn = 1 To Length1
                Ltr1 = Mid$(Word1, Ltr1Posn, 1)
                Prev2Posn = 1
                Do
                    Ltr2Posn = InStr(Prev2Posn, Word2, Ltr1)
                    If Ltr2Posn Then
                        Rem Redim Match() if necessary.
                        If MatchIdx + 1 > UMatch Then
                            UMatch = UMatch + Int(UWord / 2) + 1
                            ReDim Preserve Match(1 To UMatch)
                        End If
                        
                        Rem Define letter match in Match().
                        MatchIdx = MatchIdx + 1
                        Match(MatchIdx).Ltr1Posn = Ltr1Posn
                        Match(MatchIdx).Word2Idx = Word2Idx
                        Match(MatchIdx).Ltr2Posn = Ltr2Posn

                        Rem Put Match() indices into WordMatch().
                        If WordMatch(Word1Idx).FirstMatch = 0 Then
                            WordMatch(Word1Idx).FirstMatch = MatchIdx
                        End If
                        WordMatch(Word1Idx).LastMatch = MatchIdx

                        Prev2Posn = Ltr2Posn + 1
                    Else
                        Exit Do
                    End If
                Loop
            Next Ltr1Posn
        End If
    Next Word2Idx
    Return

End Function

Function MakeSolution (Solution() As typeSolution)
Rem Generate Solution() with column and row adjusted to base of 1.
    
    Dim Col1 As Integer
    Dim Row1 As Integer
    Dim SolutionIdx As Integer
    Dim Link As Integer

    ReDim Solution(1 To PlacedCnt)
    
    Col1 = -1   ' Trigger SolutionIdx increment first time round.
    SolutionIdx = 0
    Link = LinkEnd
    Do Until Link < LWord
        DoEvents

        Rem Only Vectors with same col/row share same Solution element.
        If (Vector(Link).Col - MinColPzl + 1 <> Col1) Or (Vector(Link).Row - MinRowPzl + 1 <> Row1) Then
            Rem Initialize next position in Solution().
            SolutionIdx = SolutionIdx + 1
            Solution(SolutionIdx).AcrossWord = LWord - 1
            Solution(SolutionIdx).DownWord = LWord - 1
        End If

        Col1 = Vector(Link).Col - MinColPzl + 1
        Row1 = Vector(Link).Row - MinRowPzl + 1
        Solution(SolutionIdx).Col = Col1
        Solution(SolutionIdx).Row = Row1
        If Vector(Link).Direction = ACROSS Then
            Solution(SolutionIdx).AcrossWord = Link
        Else
            Solution(SolutionIdx).DownWord = Link
        End If
        Link = Vector(Link).Link
    Loop

    Rem Reduce size of array to number of elements actually used.
    ReDim Preserve Solution(1 To SolutionIdx)

    MakeSolution = True

End Function

Private Function MakeVectors (Word() As String, Args As typeArgs) As Integer
Rem Generate Vector() word vectors.

    Dim Vector1 As typeWordVector
    Dim Vector2 As typeWordVector
    Dim Word1Idx As Integer
    Dim Word2Idx As Integer
    Dim Col1 As Integer
    Dim Row1 As Integer
    Dim Direction1 As Integer
    Dim WordsTried() As Integer
    Dim WordsToTry As Integer
    Dim PlacingWords As Integer
    Dim MatchIdx As Integer
    Dim FirstMatch As Integer
    Dim LastMatch As Integer
    Dim MatchCnt As Integer
    Dim MatchTried() As Integer
    Dim MatchToTry As Integer
    Dim NoValidMatch As Integer
    Dim Rtn As Integer

    Rem Initialize number of words placed in Grid.
    PlacedCnt = 0
    
    Rem Dimension Grid() to a reasonable size.
    If MaxSize > 0 Then
        UGrid = MaxSize * 4
    ElseIf MaxWordLength > WordCnt Then
        UGrid = MaxWordLength * 4
    Else
        UGrid = WordCnt * 4
    End If
    LGrid = 0
    ReDim Grid(LGrid - 1 To UGrid + 1, LGrid - 1 To UGrid + 1)
    
    Rem Initialize markers to test for exceeding maximum size.
    MinRowPzl = UGrid
    MaxRowPzl = LGrid
    MinColPzl = UGrid
    MaxColPzl = LGrid

    Rem Initialize marker to end of linked list.
    LinkEnd = LWord - 1

    GoSub PlaceFirstWord
    GoSub PlaceRestOfWords
    
    Rem Return size of Grid and number of words in it.
    Col1 = MaxColPzl - MinColPzl + 1
    Row1 = MaxRowPzl - MinRowPzl + 1
    If Col1 > Row1 Then
        Args.Size = Col1
    Else
        Args.Size = Row1
    End If
    Args.PlacedCnt = PlacedCnt

    Rem Done with these arrays.
    Erase WordsTried
    Erase MatchTried
    Erase Grid

    MakeVectors = (PlacedCnt > 1)
    Exit Function

PlaceFirstWord:
Rem Place first word with a letter match into the Grid.
    ReDim WordsTried(LWord To UWord)
    WordsToTry = WordCnt
    Word1Idx = Args.FirstWord
    If Args.FirstAcross Then
        Direction1 = ACROSS
    Else
        Direction1 = DOWN
    End If

    PlacingWords = True
    Do  ' While PlacingWords
        DoEvents
        If Word1Idx >= LWord Then
            If WordMatch(Word1Idx).FirstMatch > 0 Then
                Rem Position word near the center of Grid().
                Vector(Word1Idx).Col = Int((UGrid - Len(Word(Word1Idx))) / 2)
                Vector(Word1Idx).Row = Int(UGrid / 2)
                Vector(Word1Idx).Direction = Direction1
                Rtn = PlaceWord(Word(Word1Idx), Word1Idx)
                PlacingWords = False
            End If
        End If

        If PlacingWords Then
            PlacingWords = NextIdx(Word1Idx, WordsTried(), WordsToTry, Args.RandomWord)
        End If
    Loop While PlacingWords
    Return

PlaceRestOfWords:
Rem Test successive words at crosspoints and place into Grid() if valid.
    ReDim WordsTried(LWord To UWord)
    ReDim MatchTried(1 To 1)
    WordsToTry = WordCnt
    Do  ' While PlacingWords
        PlacingWords = False
        Do  ' Until no more words to try.
            If Vector(Word1Idx).Direction = 0 Then
                Rem Word1 hasn't been put into the Grid() yet.
                NoValidMatch = True
                FirstMatch = WordMatch(Word1Idx).FirstMatch
                If FirstMatch > 0 Then
                    LastMatch = WordMatch(Word1Idx).LastMatch
                    MatchCnt = LastMatch - FirstMatch + 1
                    MatchToTry = MatchCnt
                    ReDim MatchTried(FirstMatch To LastMatch)
                    MatchIdx = FirstMatch - 1
                Else
                    MatchToTry = 0
                End If
                MatchIdx = FirstMatch - 1   ' MatchIdx hasn't been tried.
                
                Do While NextIdx(MatchIdx, MatchTried(), MatchToTry, Args.RandomMatch)
                    DoEvents
                    If Not MatchTested(MatchIdx) Then
                        Rem We didn't fail this letter match yet.
                        Word2Idx = Match(MatchIdx).Word2Idx
                        If Vector(Word2Idx).Direction Then
                            Rem Test match on Word2 already in Grid().
                            Vector1 = Vector(Word1Idx)
                            Vector2 = Vector(Word2Idx)
                            If TestMatch(Word(Word1Idx), MatchIdx, Vector1, Vector2) Then
                                Vector(Word1Idx) = Vector1
                                Rtn = PlaceWord(Word(Word1Idx), Word1Idx)

                                NoValidMatch = False

                                Rem Word1 may provide crosses for other words.
                                PlacingWords = True

                                Rem Force end of MatchIdx loop for Word1.
                                MatchToTry = 0
                            Else
                                MatchTested(MatchIdx) = True
                            End If
                        Else
                            Rem Word2 may get put into Grid() before Word1.
                            NoValidMatch = False
                        End If
                    End If
                Loop ' Do while NextIdx

                If NoValidMatch Then
                    Rem Stop testing Word1 since all letter matches failed.
                    Vector(Word1Idx).Direction = -1
                End If
            End If
        Loop While NextIdx(Word1Idx, WordsTried(), WordsToTry, Args.RandomWord)
    Loop While PlacingWords
    Return

End Function

Private Function NextIdx (Idx As Integer, Tried() As Integer, ToTry As Integer, Randum As Integer) As Integer
Rem Handle random selection of the next index in array to try.
    
    Dim LTried As Integer
    Dim UTried As Integer
    Dim CurrIdx As Integer
    Dim Cnt As Integer

    LTried = LBound(Tried)
    UTried = UBound(Tried)
    Cnt = UTried - LTried + 1
    If (Idx >= LTried) And (Idx <= UTried) Then
        Tried(Idx) = True
        ToTry = ToTry - 1
    End If

    If ToTry > 0 Then
        CurrIdx = Idx
        Do
            If Randum Then
                Rem Set random index between LTried and UTried.
                Idx = Int((Cnt * Rnd) + LTried)
            Else
                Rem Increment index.
                Idx = Idx + 1
                If Idx > UTried Then
                    Rem Wrap around to front of array.
                    Idx = LTried
                End If
            End If
        Loop While Tried(Idx) Or (Idx = CurrIdx)
    End If

    NextIdx = (ToTry > 0)

End Function

Private Function PlaceWord (Word1 As String, WordIdx As Integer) As Integer
Rem Place word into Grid().

    Dim Col1 As Integer
    Dim Row1 As Integer
    Dim Direction1 As Integer
    Dim Word1Across As Integer
    Dim Word1Len As Integer
    Dim Col As Integer
    Dim Row As Integer
    Dim LtrPosn As Integer
    Dim Link As Integer
    Dim PrevLink As Integer

    Col1 = Vector(WordIdx).Col
    Row1 = Vector(WordIdx).Row
    Direction1 = Vector(WordIdx).Direction
    Word1Across = (Direction1 = ACROSS)

    Rem Place each character into Grid().
    Col = Col1
    Row = Row1
    Word1Len = Len(Word1)
    For LtrPosn = 1 To Word1Len
        Grid(Col, Row) = Mid$(Word1, LtrPosn, 1)
        
        If Word1Across Then
            Col = Col + 1
        Else
            Row = Row + 1
        End If
    Next LtrPosn
    PlacedCnt = PlacedCnt + 1

    Rem Update outer boundaries of words actually placed in Grid.
    If Word1Across Then
        If Col1 < MinColPzl Then MinColPzl = Col1
        Col = Col1 + Word1Len - 1
        If Col > MaxColPzl Then MaxColPzl = Col
    Else
        If Row1 < MinRowPzl Then MinRowPzl = Row1
        Row = Row1 + Word1Len - 1
        If Row > MaxRowPzl Then MaxRowPzl = Row
    End If

    Rem Maintain list links in Vector().Link sorted by row/col/direction.
    Link = LinkEnd
    Do Until Link < LWord
        Rem Link to vector with next higher row/col/direction.
        Select Case Vector(Link).Row
            Case Is < Row1

            Case Row1
                Select Case Vector(Link).Col
                    Case Is < Col1

                    Case Col1
                        If Vector(Link).Direction > Direction1 Then Exit Do

                    Case Else
                        Exit Do
                End Select
            
            Case Else
                Exit Do
        End Select
        
        PrevLink = Link
        Link = Vector(Link).Link
    Loop
    Vector(WordIdx).Link = Link
    If Link = LinkEnd Then
        LinkEnd = WordIdx
    Else
        Vector(PrevLink).Link = WordIdx
    End If
    
    PlaceWord = True

End Function

Function Solver (Word() As String, Solution() As typeSolution, Args As typeArgs) As Integer
Rem Main routine called to create Solution() from Word().

   Randomize

    Solver = False  ' Default

    On Error GoTo SolverFailure

    Args.ErrorMsg = ""
    LWord = LBound(Word)
    UWord = UBound(Word)
    WordCnt = UWord - LWord + 1
    MaxSize = Args.MaxSize
    If MaxSize < 0 Then MaxSize = 0

    If WordCnt <= 1 Then
        Args.ErrorMsg = "Word array must contain at least 2 words."
    Else
        If Not Args.Recalled Then
            Rem Find letter matches if not being recalled.
            ReDim WordMatch(LWord To UWord)
            MatchCnt = MakeMatch(Word())
        End If
        ReDim MatchTested(1 To UMatch)
        
        If MatchCnt Then
            Rem Dimension Vector() for 1 to 1 relation with Word().
            ReDim Vector(LWord To UWord)

            If MakeVectors(Word(), Args) Then
                Solver = MakeSolution(Solution())
            Else
                Args.ErrorMsg = "Unable to develop a solution."
            End If

            Erase Vector
        Else
            Args.ErrorMsg = "No letter matches between words."
        End If

        Erase MatchTested
    End If

    Exit Function

SolverFailure:
    MsgBox "Unexpected fatal error in Solver: " & Error$
    Exit Function
    
End Function

Private Function TestMatch (Text1 As String, MatchIdx As Integer, Vector1 As typeWordVector, Vector2 As typeWordVector)
Rem Determine if Word1 can be placed in Grid() crossing Word2 already in Grid().
Rem Return Vector1 if valid.

    Dim ValidMatch As Integer
    Dim Text As String
    Dim Ltr As String * 1
    Dim LtrPosn As Integer
    Dim Length As Integer
    Dim ColPzl As Integer
    Dim ColInc As Integer
    Dim ColSide As Integer
    Dim RowPzl As Integer
    Dim RowInc As Integer
    Dim RowSide As Integer
    Dim zero As String * 1
    Dim PosnEnd As Integer
    Dim TmpGrid() As String * 1

    ValidMatch = True
    Length = Len(Text1)

    Rem Set variables so that testing logic is independent of direction.
    If Vector2.Direction = ACROSS Then
        Vector1.Col = Vector2.Col + Match(MatchIdx).Ltr2Posn - 1
        Vector1.Row = Vector2.Row - (Match(MatchIdx).Ltr1Posn - 1)
        ColInc = 0
        RowInc = 1
        ColSide = 1
        RowSide = 0
        Vector1.Direction = DOWN
        PosnEnd = Vector1.Row + Length - 1
        If MaxSize > 0 Then
            Rem Test for word extending beyond maximum grid size.
            If Vector1.Row < MinRowPzl Then
                If (MaxRowPzl - Vector1.Row + 1) > MaxSize Then
                    ValidMatch = False
                End If
            ElseIf PosnEnd > MaxRowPzl Then
                If (PosnEnd - MinRowPzl + 1) > MaxSize Then
                    ValidMatch = False
                End If
            End If
        End If
        If ValidMatch And (Vector1.Row < LGrid) Or (PosnEnd > UGrid) Then
            GoSub GrowGrid
        End If
    Else
        Vector1.Col = Vector2.Col - (Match(MatchIdx).Ltr1Posn - 1)
        Vector1.Row = Vector2.Row + Match(MatchIdx).Ltr2Posn - 1
        ColInc = 1
        RowInc = 0
        ColSide = 0
        RowSide = 1
        Vector1.Direction = ACROSS
        PosnEnd = Vector1.Col + Length - 1
        If MaxSize > 0 Then
            Rem Test for word extending beyond maximum grid size.
            If Vector1.Col < MinColPzl Then
                If (MaxColPzl - Vector1.Col + 1) > MaxSize Then
                    ValidMatch = False
                End If
            ElseIf PosnEnd > MaxColPzl Then
                If (PosnEnd - MinColPzl + 1) > MaxSize Then
                    ValidMatch = False
                End If
            End If
        End If
        If ValidMatch And (Vector1.Col < LGrid) Or (PosnEnd > UGrid) Then
            GoSub GrowGrid
        End If
    End If
    
    If ValidMatch Then
        Rem Prevent butting into other words.
        zero = Chr$(0)
        Text = zero & Text1 & zero
        Length = Length + 2

        ColPzl = Vector1.Col - ColInc
        RowPzl = Vector1.Row - RowInc
        LtrPosn = 1
        Do
            Ltr = Grid(ColPzl, RowPzl)
            Select Case Ltr
                Case Is = Mid$(Text, LtrPosn, 1)
                    Rem Matches letter in Text.
                    If Ltr <> zero Then
                        If Grid(ColPzl + ColInc, RowPzl + RowInc) <> zero Then
                            Rem Prevent running into start of another word.
                            ValidMatch = False
                        End If
                    End If

                Case Is = zero
                    Rem Cell is empty. Check adjoining cells.
                    If Grid(ColPzl + ColSide, RowPzl + RowSide) = zero Then
                        If Grid(ColPzl - ColSide, RowPzl - RowSide) <> zero Then
                            ValidMatch = False
                        End If
                    Else
                        ValidMatch = False
                    End If

                Case Else
                    Rem Cell already has another letter.
                    ValidMatch = False
            End Select
            
            LtrPosn = LtrPosn + 1
            ColPzl = ColPzl + ColInc
            RowPzl = RowPzl + RowInc
        Loop Until Not ValidMatch Or (LtrPosn > Length)
    End If

    TestMatch = ValidMatch
    Exit Function

GrowGrid:
Rem VB can't preserve contents of array when both dimensions are ReDim'd.
    
    Rem Copy Grid() to temporary array.
    ReDim TmpGrid(MinColPzl To MaxColPzl, MinRowPzl To MaxRowPzl)
    For ColPzl = MinColPzl To MaxColPzl
        For RowPzl = MinRowPzl To MaxRowPzl
            TmpGrid(ColPzl, RowPzl) = Grid(ColPzl, RowPzl)
        Next RowPzl
    Next ColPzl

    Rem Redimension Grid() and recopy contents to original positions.
    UGrid = UGrid + Int(UGrid / 4)
    LGrid = LGrid - Int(UGrid / 4)
    ReDim Grid(LGrid - 1 To UGrid + 1, LGrid - 1 To UGrid + 1)
    For ColPzl = MinColPzl To MaxColPzl
        For RowPzl = MinRowPzl To MaxRowPzl
            Grid(ColPzl, RowPzl) = TmpGrid(ColPzl, RowPzl)
        Next RowPzl
    Next ColPzl
    Return

End Function