_Title "Word ladder v 2021-09-16" '2021-09-10 david has already improved his first version! ' ref: https://www.qb64.org/forum/index.php?topic=4157.msg135293#msg135293
' get original version above, I am modifying below to study
' 2021-09-11 in v3 b+ mod david_uwi I modify to compare whole set to my orignal whole set
' 2021-09-11 in v4 I think I can load the words faster
' 2021-09-12 in v5 lets just call the external file once, use david's idea instead of _continue,
' I think it looks cleaner without _continue which tool out skipping a For loop by a THEN (GOTO) line #.
' Ave of 5 runs before this (mod 4) was 11.27.. see if we improve still more, also DefLng A-Z oh wow.
' Ave of 5 runs now 8.74 another 2.5 secs shaved off
' 2021-09-12 in v6 though using asc instead of mid$ might go faster.
' Ave of 5 runs now is 4.45 secs another 4.29 sec off!
' 2021-09-13 v7 b+ mod david_uwi = v6 b+ mod but I will attempt to translate letter variables into
' more meaningful in attempts to understand what is being done in his code.
' Shaved significant time by making store$ (used to be q4) not fixed!
' Yes run a quick check that target word connects to something does save us so much time that
' we get a better overall time for the whole set even though we added a tiny bit of time to
' the ones that do connect.
' Ave of 5 runs is now 2.57 sec another 1.88 secs shaved off.
' Steve's mods, mainy with $checking:off saves about .3 sec for me with ave 2.27
' v david_uwi 2021-09-14 tried to work in Steves mods with david_uwi's latest improvement
' plus I insist the shortest path is the one that sorts out first alphabetically :)
' Running an average of 2.01 secs for my (bplus) system.
' v 2021-09-16 can we get 6 letters going? I can't seem to get more that a 3 word connect by eye
' ah goot! seaman to skater works Hurray! with the added 6 letter words to ladder it is taking even
' less time than before I generalized to do more than 5 letter words. This is because w() array no
' longer is fixed String * 5 but now variable length. Also reason #3 why we have to load the n letter
' words every time is because we change w(i) with starUsed$ signal as we go through it to
' indicate we've processed this word already. Average 1.49 secs per run!!!
' Holy moley! another 2 huge cuts in time!!! both storage and changes arrays don't have to be 10000 long!
' Now .67 secs average on my (b+) older laptop
' v 2021-09-16 fix Dang something happened when I cut the arrays to 100 instead of 10000??? girl to lady
' got 2 words longer and alien to drool picked up a word and an alternate path.
' Cause: when $checking:off No error when subscript goes out of range in both changes and store arrays.
' So found minimum that lets our set work 615. OK now my (b+) average is .74 secs.
DefLng A
-Z
' 2 secs off from old Single default!
' do just once for all ladder calls, Fwords$() contain the entire list of dictionary
Split buf$
, Chr$(10), Fwords$
()UBF
= UBound(fwords$
) ' track the ubound of Fwords$
' gets some intell on the word file
'Print UBF ' 25,105 words
'Dim lcount(3 To 10) ' what is largest word list I need?
'For i = 1 To UBF
' lw = Len(Fwords$(i))
' If lw > 2 And lw <= 10 Then lcount(lw) = lcount(lw) + 1
'Next
'For i = 3 To 10
' Print i, lcount(i) ' 4060 is maximum words for a letter
'Next
'End
' test set of ladder calls
ladder "boy", "man" ' quick
ladder "girl", "lady" ' this takes awhile
ladder "john", "jane" ' quick enough
ladder "alien", "drool" ' cool but takes a long long time!
ladder "child", "adult" ' and this takes awhile
ladder "play", "ball" ' goes quick
ladder "fun", "job" ' ditto
' These 6 letter words added to our test set to show it has been generalized past 5 letter words.
ladder "cheese", "butter" ' Steve challnges to do more than 5 letter words not going to connect
ladder "seaman", "skater" ' I think this will connect
Print:
Print "Total time including one disk file access:";
Timer(.001) - start!
tt!
= Timer(.001) ' time each ladder call, doesn't include one time download of words to Fwords$() Dim w
(4060) As String '* 5 <<< no fixed string huge time savings!!!! w() contains all words of Len(q1$) max words = 4060 for 7 letters Dim store$
(615, 100) ' wow went from fixed string storing connect words to not fixed string and shaved a sec off time!!! Dim storeIndexs
(100) ' tracking indexes to changes Dim changes
(615, 100) As String ' tracking the change letter and position going from one word to next ' does changes have to be 10000? no! and another huge time cut!!! but more than 100
' does store$ have to be 10000? no! and another huge time cut!!!
FI = 1
'If wordLength < 5 Then q1$ = q1$ + Space$(5 - wordLength): q2$ = q2$ + Space$(5 - wordLength)
starUsed$
= String$(wordLength
, "*") ' this is signal that word is used maxWordIndex = maxWordIndex + 1
If Fwords$
(FI
) = q1$
Then w
(maxWordIndex
) = starUsed$
Else w
(maxWordIndex
) = Fwords$
(FI
) FI = FI + 1
'q2$ needs to have at least one connect or skip to end
'(this block will add a little more time to each ladder but save over a sec on adult or any target word with no connects)
For i
= 1 To maxWordIndex
If w
(i
) <> q2$
Then ' just check before entering loop cnt = 0
If cnt
= 1 Then ' q2$ has a connect good to go If targetOK
= 0 Then Print "No path found! from "; q1$;
" to "; q2$:
GoTo skip
' carry on with david_uwi's original algo modified by b+ for more general use and speed help from SMcNeill
jk = 1
storeIndexs(jk) = 1
store$(1, 1) = q1$
For i
= 1 To maxWordIndex
cnt = 0
For kk
= 1 To storeIndexs
(jk
) cnt = 0
t = jk + 1
storeIndexs(t) = storeIndexs(t) + 1
store$(storeIndexs(t), t) = w(i)
changes
(storeIndexs
(t
), t
) = changes
(kk
, jk
) + Mid$(w
(i
), zz
, 1) + Chr$(zz
) + " " ' try Steve's T substitution version w(i) = starUsed$
kflag = 0
''*****new routine!!! by david_uwi
cnu = 0
For i
= storeIndexs
(t
) To 1 Step -1 ' b+ reversed this for shortest path alphabetically cnu = 0
If cnu
= wordLength
- 1 Then kflag
= 99: final$
= changes
(i
, t
)
If storeIndexs
(t
) = 0 Then kflag
= 99 jk = jk + 1
If jk
> 100 Then Print "No path found! from "; q1$;
" to "; q2$:
GoTo skip
'b+ added this for words that wont connect else error's out If storeIndexs
(jk
) = 0 Then Print "No path found! from "; q1$;
" to "; q2$
' b+ removed a print blank line If storeIndexs
(jk
) > 0 Then ' this is Steve's t substitution for david_uwi's jk + 1 using Asc instead of Mid$ t$ = q1$
t$ = t$ + " " + q1$
skip:
Print "time taken = ";
Timer(.001) - tt!;
" seconds"
curpos
= 1: arrpos
= LBound(loadMeArray
): LD
= Len(delim
) dpos
= InStr(curpos
, SplitMeString
, delim
) loadMeArray
(arrpos
) = Mid$(SplitMeString
, curpos
, dpos
- curpos
) arrpos = arrpos + 1
curpos = dpos + LD
dpos
= InStr(curpos
, SplitMeString
, delim
) loadMeArray
(arrpos
) = Mid$(SplitMeString
, curpos
)
