DefDbl A-Z
Dim crlf$, wLen
Function mform$(x, t$)
a$ = Format$(x, t$)
If Len(a$) < Len(t$) Then a$ = Space$(Len(t$) - Len(a$)) & a$
mform$ = a$
End Function
Private Sub Form_Load()
Text1.Text = ""
crlf$ = Chr(13) + Chr(10)
Form1.Visible = True
Open "ragman from 3 to 10.txt" For Output As #5
Open "c:\words\words.txt" For Input As #1
Do
Input #1, l$
DoEvents
wLen = Len(l)
If wLen >= 5 And wLen <= 10 Then
Select Case wLen
Case 5
ord$ = "24351"
Case 6
ord$ = "541236"
Case 7
ord$ = "7615342"
Case 8
ord$ = "36172584"
Case 9
ord$ = ""
Case 10
ord$ = ""
End Select
If Len(ord) > 1 Then
w$ = ""
For i = 1 To wLen
w = w + Mid(l, Val(Mid(ord, i, 1)), 1)
Next
If isWord(w) Then
Text1.Text = Text1.Text & mform(wLen, "#0") & " " & l & " " & w & crlf
Print #5, mform(wLen, "#0") & " " & l & " " & w
End If
Else
findAnag (l)
End If
End If
Loop Until EOF(1)
Close 1
Close 5
Text1.Text = Text1.Text & "done"
End Sub
Sub findAnag(l$)
Open "c:\words\words" + LTrim(Str(wLen)) + ".txt" For Binary As #2
w$ = Space$(wLen)
Do
DoEvents
Get #2, , w
If EOF(2) Then Close 2: Exit Sub
w1$ = l
If w <> l Then good = 1 Else good = 0
For i = 1 To wLen
ix = InStr(w1, Mid(w, i, 1))
If ix = 0 Then good = 0: Exit For
w1 = Left(w1, ix - 1) + Mid(w1, ix + 1)
Next
If good Then
Text1.Text = Text1.Text & mform(wLen, "#0") & " " & l & " " & w & crlf
Print #5, mform(wLen, "#0") & " " & l & " " & w
End If
Loop
Close 2
End Sub
Function isWord(w$)
n = Len(w$)
w1$ = Space$(n)
Open "c:\words\words" + LTrim$(Str$(n)) + ".txt" For Binary As #2
l = LOF(2) / n
low = 1: high = l
Do
DoEvents
middle = Int((low + high) / 2)
Get #2, (middle - 1) * n + 1, w1$
If w1$ = w$ Then isWord = 1: Close 2: Exit Function
If w1$ < w$ Then low = middle + 1 Else high = middle - 1
Loop Until low > high
isWord = 0
Close 2
End Function
This first program neglected to make sure that each letter of the word (and of course its scrambled form) is unique within the word, so this second program scrubbed the output to do that check:
DefDbl A-Z
Dim crlf$
Private Sub Form_Load()
Text1.Text = ""
crlf$ = Chr(13) + Chr(10)
Form1.Visible = True
Open "ragman from 3 to 10.txt" For Input As #1
Open "ragman from 3 to 10 soln.txt" For Output As #2
Do
Line Input #1, l$
DoEvents
l2$ = LTrim(Mid(l, 4))
ix = InStr(l2, " ")
w$ = Left(l2, ix - 1)
good = 1
For i = 1 To Len(w)
If InStr(w, Mid(w, i, 1)) <> i Then good = 0: Exit For
Next
If good Then Print #2, l
Loop Until EOF(1)
Close 1
Close 2
Text1.Text = Text1.Text & "done"
End Sub
The results for length 5 through 8:
(you decide which are common words)
5 apers presa
5 dance acned
5 ecrus curse
5 elain liane
5 ramie aimer
5 sarin airns
5 scald clads
5 scalp claps
5 scaly clays
5 scarp craps
5 scion coins
5 scold clods
5 scrap carps
5 scrod cords
5 scrub curbs
5 seral earls
5 shiel heils
5 shier heirs
5 shlep helps
5 shred herds
5 skier keirs
5 skint knits
5 slued leuds
5 speir piers
5 spile plies
5 spire pries
5 sprat parts
5 steal taels
5 stirp trips
5 story troys
5 strap tarps
5 suint units
5 tails alist
5 train riant
6 ardebs beards
6 averts traves
6 biders rebids
6 bleats tables
6 borals labors
6 brails libras
6 buyers rebuys
6 capers recaps
6 chaser eschar
6 cheats taches
6 chiral archil
6 chiros orchis
6 colins nicols
6 corset escort
6 dreams madres
6 ganevs vegans
6 girned engird
6 inerts trines
6 inkers reinks
6 jorams majors
6 layers relays
6 manors romans
6 medals lameds
6 merits timers
6 miters remits
6 nerols loners
6 oilers reoils
6 palets tepals
6 payers repays
6 picots topics
6 squire risque
6 strawy wastry
6 thenar anther
6 velars ravels
6 verily livery
7 adverts starved
7 orients stonier
7 reclaim miracle
8 integral triangle
computer solution for lengths 5 through 8
