Word ladder - Rosetta Code

[bplus]

ref: http://rosettacode.org/wiki/Word_ladder

Oh this was a little more tricky!

Code: QB64: [Select]

1. _Title "Word ladder - Rosetta Code" 'b+ start 2021-09-03 ref: http://rosettacode.org/wiki/Word_ladder
2. Type connectType
3.     connect As String
4.     word As String
5. End Type
6.  
7. Dim Shared wordList$(2 To 7)
8. LoadWords 'build the strings for each word length the split them for that length
9. Print ladder$("boy", "man") '     quick
10. Print ladder$("girl", "lady") '   this takes awhile
11. Print ladder$("john", "jane") '   quick enough
12. Print ladder$("alien", "drool") ' cool but takes a long long time!
13. Print ladder$("child", "adult") ' and this takes awhile
14. Print ladder$("play", "ball") '   goes quick
15. Print ladder$("fun", "job") '     ditto
16.  
17. Sub LoadWords
18.     Open "unixdict.txt" For Input As #1
19.     While EOF(1) = 0
20.         Input #1, wd$
21.         If Len(wd$) > 1 And Len(wd$) < 8 Then
22.             ok = -1
23.             For m = 1 To Len(wd$)
24.                 If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
25.             Next
26.             If ok Then
27.                 If wordList$(Len(wd$)) = "" Then wordList$(Len(wd$)) = wd$ Else wordList$(Len(wd$)) = wordList$(Len(wd$)) + " " + wd$
28.             End If
29.         End If
30.     Wend
31.     Close #1
32. End Sub
33.  
34. Function ladder$ (w1$, w2$)
35.     If Len(w1$) <> Len(w2$) Then ladder$ = "": Exit Function
36.     ReDim TheList(1 To 1) As connectType, listPlace
37.     ReDim wl$(1 To 1)
38.     Split wordList$(Len(w1$)), " ", wl$()
39.     connect$ = w1$
40.  
41.     newConnect:
42.     'progress
43.     'Print "Connect word is "; connect$; UBound(wl$); listPlace;
44.     For i = 1 To UBound(wl$)
45.         If oneChange%(connect$, wl$(i)) Then
46.             If TheList(1).connect = "" Then
47.                 TheList(1).connect = connect$
48.                 TheList(1).word = wl$(i)
49.             Else ' add to list only if word isn't a connect
50.                 found = 0
51.                 For j = 1 To UBound(theList)
52.                     If wl$(i) = TheList(j).connect Then found = -1: Exit For
53.                 Next
54.                 If found = 0 Then
55.                     cAppend TheList(), connect$, wl$(i)
56.                 End If
57.             End If
58.             If wl$(i) = w2$ Then done = -1: Exit For
59.         End If
60.     Next
61.     If done = 0 Then
62.         listPlace = listPlace + 1
63.         If listPlace > UBound(TheList) Then
64.             ladder$ = "Could NOT connect " + w1$ + " to " + w2$
65.         Else
66.             connect$ = TheList(listPlace).word
67.             GoTo newConnect
68.         End If
69.     Else
70.         'should be able to backtrack our path?
71.         ladder$ = "Could connect " + w1$ + " to " + w2$
72.         target$ = w2$: trail$ = w2$
73.         again:
74.         For i = 1 To UBound(theList)
75.             If TheList(i).word = target$ Then target$ = TheList(i).connect: trail$ = target$ + " > " + trail$: GoTo again
76.         Next
77.         ladder$ = ladder$ + Chr$(10) + trail$
78.     End If
79. End Function
80.  
81. Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
82.     Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
83.     curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
84.     dpos = InStr(curpos, SplitMeString, delim)
85.     Do Until dpos = 0
86.         loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
87.         arrpos = arrpos + 1
88.         If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
89.         curpos = dpos + LD
90.         dpos = InStr(curpos, SplitMeString, delim)
91.     Loop
92.     loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
93.     ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
94. End Sub
95.  
96. Sub cAppend (arr() As connectType, cWrd$, w$)
97.     ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As connectType
98.     arr(UBound(arr)).connect = cWrd$
99.     arr(UBound(arr)).word = w$
100. End Sub
101.  
102. Function oneChange% (last$, test$)
103.     For i = 1 To Len(last$)
104.         If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
105.     Next
106.     If strike = 1 Then oneChange% = -1
107. End Function
108.  
109.  
110.  

Same unixdict.txt for words attached and screen shot of output.
 

All original in Basic!

[bplus]

There is an interesting structure here, like directories it's all down hill from one word to another for shortest path but! that can be reversed. I should try this tracking the whole path in the connect string of the ConnectType.

[david_uwi]

Interesting challenge. I haven't quite worked out a strategy yet, but I was tending towards a string to log the movement of the letters - as you seem to be suggesting. I notice you use quite a small dictionary which still contains a number of dubious words aaas, aaa, aarhus - just a few at the beginning. Are you just being lucky or do you filter out these wack words.

[bplus]

Hi @david_uwi

Yeah that dictionary is standard given for all Rosetta Code word challenges. The more words the better, goof ball or not, when trying to go from one word to another one letter change at a time. I do filter out digits and other words that don't have standard 26 English letters of alphabet. BTW I learned from Wordiff Challenge that the dictionary does not have "has"!? There are more common ones missing.

[SMcNeill]

Noticed it also doesn’t show multiple shortest paths.

For example, boy to man:

boy - bay - ban - man
boy - bay - may - man
boy - moy - may - man
boy - bon - ban - man
boy - bon - mon - man

Each of those are valid 4 word paths, and there’s probably more.  Those are just the ones I could come up with quickly off the top of my head.  ;D

[bplus]

Noticed it also doesn’t show multiple shortest paths.

For example, boy to man:

boy - bay - ban - man
boy - bay - may - man
boy - moy - may - man
boy - bon - ban - man
boy - bon - mon - man

Each of those are valid 4 word paths, and there’s probably more.  Those are just the ones I could come up with quickly off the top of my head.  ;D

Some of the PL's at RC were showing multiple paths of equal length but I say if equal in length then go alphabetic to settle differences, there can be only one shortest path ;-))
(I say that because that was the way they were coming up.)

[johnno56]

I checked out 'Rosetta Code', as per the above link, and noticed the absence of any version of Basic... This may be a discussion for another time, but I am eager to know, just how was the 'Word Ladder' converted to Basic? Someone must have a knowledge of any of those languages AND an understanding of QB64... Hmm... Did I just answer my own question? Never mind. At least someone knows how... lol

[bplus]

This may be a discussion for another time, but I am eager to know, just how was the 'Word Ladder' converted to Basic?

Hi @johnno56
Word Ladder wasn't converted, as I said "All original Basic!" Many of those languages I dont have a clue!
I do like to peek at FreeBASIC or BBC maybe or some other Basics even Python after I try my ideas out.


I have worked out an alternate version v2 that doesn't need to backtrack at the end to find the whole path. It tracks the path along with the connect (the last word in path before w2$), so when it finds the target word it's done you just pull the path from the last item loaded into TheList(). Too bad it runs 3 mins longer than the original version! I guess maintaining the path for every word in the list was very costly in processing time.

Here is what not to do to try to beat the first version in time:

Code: QB64: [Select]

1. _Title "Word ladder v2 - Rosetta Code" 'b+ start 2021-09-03 ref: http://rosettacode.org/wiki/Word_ladder
2. ' v2 2021-09-07 try building the whole path back to start word in the connect part of Connect Type
3. ' so far it does the short ones ok but hangs on longer ones (fixed)
4. ' adding path to connectType to avoid having to isolate last words in path
5. ' OK it works now for timed test to see if it is better than 1 version, hell no!
6.  
7. Type connectType
8.     path As String
9.     connect As String
10.     word As String
11. End Type
12.  
13. Dim Shared wordList$(2 To 7)
14. start! = Timer(.001)
15. LoadWords 'build the strings for each word length the split them for that length
16. Print ladder$("boy", "man") '     quick
17. Print ladder$("girl", "lady") '   this takes awhile
18. Print ladder$("john", "jane") '   quick enough
19. Print ladder$("alien", "drool") ' cool but takes a long long time!
20. Print ladder$("child", "adult") ' and this takes awhile
21. Print ladder$("play", "ball") '   goes quick
22. Print ladder$("fun", "job") '     ditto
23. Print Timer(.001) - start!
24.  
25. Sub LoadWords
26.     Open "unixdict.txt" For Input As #1
27.     While EOF(1) = 0
28.         Input #1, wd$
29.         If Len(wd$) > 1 And Len(wd$) < 8 Then
30.             ok = -1
31.             For m = 1 To Len(wd$)
32.                 If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
33.             Next
34.             If ok Then
35.                 If wordList$(Len(wd$)) = "" Then wordList$(Len(wd$)) = wd$ Else wordList$(Len(wd$)) = wordList$(Len(wd$)) + " " + wd$
36.             End If
37.         End If
38.     Wend
39.     Close #1
40. End Sub
41.  
42. Function ladder$ (w1$, w2$)
43.     If Len(w1$) <> Len(w2$) Then ladder$ = "": Exit Function
44.     ReDim TheList(1 To 1) As connectType, listPlace
45.     ReDim wl$(1 To 1)
46.     Split wordList$(Len(w1$)), " ", wl$()
47.     PathedConnect$ = ">>" + w1$ ' double >> signals root
48.     Connect$ = w1$
49.     newConnect:
50.     'progress
51.     'Print "Connect word is "; connect$; UBound(wl$); listPlace;
52.     For i = 1 To UBound(wl$)
53.         If oneChange%(Connect$, wl$(i)) Then
54.             If TheList(1).connect = "" Then
55.                 TheList(1).path = PathedConnect$
56.                 TheList(1).connect = Connect$
57.                 TheList(1).word = wl$(i)
58.             Else ' add to list only if word isn't a connect
59.                 found = 0
60.                 For j = 1 To UBound(theList) ' see if word is already on our list
61.                     If wl$(i) = TheList(j).connect Then found = -1: Exit For
62.                 Next
63.                 If found = 0 Then ' not in List so add it to list
64.                     cAppend TheList(), PathedConnect$, Connect$, wl$(i)
65.                 End If
66.             End If
67.             If wl$(i) = w2$ Then done = -1: Exit For
68.         End If
69.     Next
70.     If done = 0 Then
71.         listPlace = listPlace + 1
72.         If listPlace > UBound(TheList) Then
73.             ladder$ = "Could NOT connect " + w1$ + " to " + w2$
74.         Else
75.             PathedConnect$ = TheList(listPlace).path + ">" + TheList(listPlace).word
76.             Connect$ = TheList(listPlace).word
77.             GoTo newConnect
78.         End If
79.     Else
80.         'the very last item added to list had 2nd word connected to it, the .path has the first path (shortest) that got to it.
81.         ladder$ = "Could connect " + w1$ + " to " + w2$ + Chr$(10) + TheList(UBound(thelist)).path + ">" + w2$
82.     End If
83. End Function
84.  
85. Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
86.     Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
87.     curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
88.     dpos = InStr(curpos, SplitMeString, delim)
89.     Do Until dpos = 0
90.         loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
91.         arrpos = arrpos + 1
92.         If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
93.         curpos = dpos + LD
94.         dpos = InStr(curpos, SplitMeString, delim)
95.     Loop
96.     loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
97.     ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
98. End Sub
99.  
100. Sub cAppend (arr() As connectType, path$, cWrd$, w$)
101.     ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As connectType
102.     arr(UBound(arr)).path = path$
103.     arr(UBound(arr)).connect = cWrd$
104.     arr(UBound(arr)).word = w$
105. End Sub
106.  
107. Function oneChange% (last$, test$)
108.     For i = 1 To Len(last$)
109.         If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
110.     Next
111.     If strike = 1 Then oneChange% = -1
112. End Function
113.  
114. 'Function LastRightOf$ (source$, of$)   'abandoned to adding a path to ConnectType
115. '    For i = Len(source$) To 1 Step -1
116. '        If Mid$(source$, i, 1) = of$ Then LastRightOf$ = Mid$(source$, i + 1): Exit Function
117. '    Next
118. 'End Function
119.  
120.  

[johnno56]

I remember doing these in puzzle magazines. First word and Last word are shown but you could only make 3 changes by changing only one letter each turn. But the new word had to be a 'real' word. So much fun.

Ran the above... Could not connect child to adult and could not connect fun to job.
Ran for 496.0862...   Is that good? Do I get a prize? lol

Just had a weird thought... don't even think about it... The program uses a dictionary of 25k+ words.
Correct me if I'm wrong... The program looks like it is comparing words of equal length? Would it not make the search quicker if the dictionary was split up into files of equal word lengths? eg: if the first word was five characters long then only open the 5 character word file. Just a thought.

I now have my coffee and all the crazy ideas are abating....

[bplus]

Hi @johnno56

With first version my system ran code 403 and 416 secs, v2 ran 579 and 541 secs about 3 minutes difference.

You are not supposed to find a connect from child to adult but are supposed to connect fun to job and that goes fairly quick too.

Correct me if I'm wrong... The program looks like it is comparing words of equal length? Would it not make the search quicker if the dictionary was split up into files of equal word lengths? eg: if the first word was five characters long then only open the 5 character word file. Just a thought.

I did use that idea when loading the file, I loaded words of same length into very long strings. Then when Ladder sub gets 2 words to connect it checks their length, makes sure they are same and then splits the long string of words of that length into an array for connect words.

Just ran v2 again fun does connect to job ">>fun>bun>bon,bob,job total time 569 secs on my system.

What is bon? I can hear you asking.
According to Oxford Languages = a Japanese Buddhist festival held annually in August to honor the dead.

Dang just missed it.

[SMcNeill]

bon is also a type of bean, grass, and the name of a hindu based religion.

It’s also French for good, if my memory’s correct.  “Bon appetite.”

[david_uwi]

Well I've got something to work - it was tricky.
The number of words increases dramatically on each letter substitution - I'm sure that there is a lot of redundancy there.
Anyway fun --> job took 1.6 seconds. It found fun-bun-bon-bob-job and fun-bun-bub-bob-job and fun-fin-fib-fob-job (which I like the best).
I have two questions
How long did yours take from job to fun and how big was the word list on each step. For mine it was
13,117,1222,11092 (just to check I'm moving on the right path).

[bplus]

OK I am running v3 a revision of the original, now has timed each ladder call and also shows the ubound of The List array used to store all the word connections.

While we wait... oh dang, had I put sleep at end then wouldn't have scrolled, do over... dang didn't help:

How long did yours take from job to fun and how big was the word list on each step. For mine it was
13,117,1222,11092 (just to check I'm moving on the right path).

@david_uwi
11092 seems high, I am running through what I have in TheList so I don't add a duplicate connect, only add unique connects to avoid duplicate efforts. 

OK the results are in for:

Code: QB64: [Select]

1. _Title "Word ladder v3 - Rosetta Code" 'b+ start 2021-09-03 ref: http://rosettacode.org/wiki/Word_ladder
2. ' 2021-09-08  v3 is just v1 (original) plus times and TheList uBound added to the report
3.  
4. Type connectType
5.     connect As String
6.     word As String
7. End Type
8.  
9. Dim Shared wordList$(2 To 7)
10. start! = Timer(1)
11. LoadWords 'build the strings for each word length the split them for that length
12. Print ladder$("boy", "man") '     quick
13. Print ladder$("girl", "lady") '   this takes awhile
14. Print ladder$("john", "jane") '   quick enough
15. Print ladder$("alien", "drool") ' cool but takes a long long time!
16. Print ladder$("child", "adult") ' and this takes awhile
17. Print ladder$("play", "ball") '   goes quick
18. Print ladder$("fun", "job") '     ditto
19. Print Timer(.001) - start!
20. Sleep
21.  
22. Sub LoadWords
23.     Open "unixdict.txt" For Input As #1
24.     While EOF(1) = 0
25.         Input #1, wd$
26.         If Len(wd$) > 1 And Len(wd$) < 8 Then
27.             ok = -1
28.             For m = 1 To Len(wd$)
29.                 If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
30.             Next
31.             If ok Then
32.                 If wordList$(Len(wd$)) = "" Then wordList$(Len(wd$)) = wd$ Else wordList$(Len(wd$)) = wordList$(Len(wd$)) + " " + wd$
33.             End If
34.         End If
35.     Wend
36.     Close #1
37. End Sub
38.  
39. Function ladder$ (w1$, w2$)
40.     If Len(w1$) <> Len(w2$) Then ladder$ = "": Exit Function
41.     ReDim TheList(1 To 1) As connectType, listPlace
42.     ReDim wl$(1 To 1)
43.  
44.     start! = Timer(.001)
45.     Split wordList$(Len(w1$)), " ", wl$()
46.     connect$ = w1$
47.  
48.     newConnect:
49.     'progress
50.     'Print "Connect word is "; connect$; UBound(wl$); listPlace;
51.     For i = 1 To UBound(wl$)
52.         If oneChange%(connect$, wl$(i)) Then
53.             If TheList(1).connect = "" Then
54.                 TheList(1).connect = connect$
55.                 TheList(1).word = wl$(i)
56.             Else ' add to list only if word isn't a connect
57.                 found = 0
58.                 For j = 1 To UBound(theList)
59.                     If wl$(i) = TheList(j).connect Then found = -1: Exit For
60.                 Next
61.                 If found = 0 Then
62.                     cAppend TheList(), connect$, wl$(i)
63.                 End If
64.             End If
65.             If wl$(i) = w2$ Then done = -1: Exit For
66.         End If
67.     Next
68.     If done = 0 Then
69.         listPlace = listPlace + 1
70.         If listPlace > UBound(TheList) Then
71.             ladder$ = "Could NOT connect " + w1$ + " to " + w2$
72.         Else
73.             connect$ = TheList(listPlace).word
74.             GoTo newConnect
75.         End If
76.     Else
77.         'should be able to backtrack our path?
78.         ladder$ = "Could connect " + w1$ + " to " + w2$
79.         target$ = w2$: trail$ = w2$
80.         again:
81.         For i = 1 To UBound(theList)
82.             If TheList(i).word = target$ Then target$ = TheList(i).connect: trail$ = target$ + " > " + trail$: GoTo again
83.         Next
84.         ladder$ = ladder$ + Chr$(10) + trail$
85.     End If
86.     ladder$ = ladder$ + Chr$(10) + Str$(Timer(.001) - start!) + " secs, TheList() has" + Str$(UBound(theList)) + " items."
87. End Function
88.  
89. Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
90.     Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
91.     curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
92.     dpos = InStr(curpos, SplitMeString, delim)
93.     Do Until dpos = 0
94.         loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
95.         arrpos = arrpos + 1
96.         If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
97.         curpos = dpos + LD
98.         dpos = InStr(curpos, SplitMeString, delim)
99.     Loop
100.     loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
101.     ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
102. End Sub
103.  
104. Sub cAppend (arr() As connectType, cWrd$, w$)
105.     ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As connectType
106.     arr(UBound(arr)).connect = cWrd$
107.     arr(UBound(arr)).word = w$
108. End Sub
109.  
110. Function oneChange% (last$, test$)
111.     For i = 1 To Len(last$)
112.         If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
113.     Next
114.     If strike = 1 Then oneChange% = -1
115. End Function
116.  

The times for each ladder start and end inside the Ladder sub, the over all time for the set of ladder calls PLUS the time to load the words from file is listed at the very end:
 

[bplus]

You know checking for redundancies could be time consuming, if I just keep adding to TheList then v2 where I preserve the path may save time after all! Let's see...

[bplus]

No not going to work:
girl to lady took 45 secs with 25,369 items v3

v4 is v2 without redundancy checks now takes 601.85 secs with 3,251,469 items.
Remember processing paths took 3 mins longer when I did remove redundancies.

I am letting alien to drool run but it is going to take hours and that is if items does not exceed the limit of Longs.