Can you show me an effective algorithm to create all possible words(of any combination) from some characters inputted?
Eg:
Input: a,b,c
Output:
abc
acb
bac
bca
cab
cba
Printable View
Can you show me an effective algorithm to create all possible words(of any combination) from some characters inputted?
Eg:
Input: a,b,c
Output:
abc
acb
bac
bca
cab
cba
Hello,
You can use this function:
And then do something like this:Code:Public Function GenerateStr()
strInputString = txtInput.Text ' Change this textbox with your own
intLength = Len(strInputString)
intNameLength = Len(txtInput.Text)
strName = ""
For intStep = 1 To intNameLength
intRnd = Int((intLength * Rnd) + 1)
strName = strName & Mid$(strInputString, intRnd, 1)
Next
GenerateStr = strName
End Function
This will work ;)Code:Private Sub Command1_Click()
txtOutput.Text = GenerateStr ' Change this textbox with your own "output textbox"
End Sub
EDIT: You can add this function inside module if you want.
For additional information or maybe other solutions, search the forum for: permutation.
The greater the source string, the greater the time required to return the permutations.
Thanks guys...:wave:
I found this upon searching: http://www.vbforums.com/showpost.php...5&postcount=17
I have some doubts.
* What is the use of that Optional X string ?
Akhil
Here is my stab at your puzzle .. and quite the puzzle it is :)
The image (below) shows 2 cases:
- abc
- abcd
The code has 2 basic components
- permutation logic
- FlexGrid logic (for display purposes)
Hopefully, the display logic isn't too messy.
The approach I used was to use
- 2 nested loops (common to both cases)
- multiple "passes" (some commonality, but some differences in each case)
The lack of commonality between the multiple "passes"
means that as you go to
- 5 characters, an 4th pass would be needed
- 6 characters, a 5th pass would be needed.
Not as "generic" as I would have liked, but at least
this might serve as a starting point for you.
All you need is a MSHFlexGrid named FG1.
Note: I put most of the FG1 properties at the bottom of
the code frag, for clarity. You may want to move them
to the top as you play around with it.
EDIT:
Now that I think about it, the logic as shown only works for
the characters a,b,c,d. Even though I facilitate you setting
the initial txt variable, the loops are hard-wired to start
at Chr(97), which is "a".
To make the code frag react to a different string, say, txt = "hot",
some additional logic would need to be added.
SpooCode:With FG1
.Cols = 7
.Rows = 26
.Clear
' demonstrate for 2 cases: abc, abcd
For jj = 1 To 2
'----------------------
' 1. computation
'----------------------
If jj = 1 Then ' abc
txt = "abc"
ElseIf jj = 2 Then ' abcd
txt = "abcd"
End If
nn = Len(txt)
' num of permutations - common
nop = 1
For kk = nn To 1 Step -1
nop = nop * kk
Next kk
Dim aP() As String
ReDim aP(nop)
' the permutations - specific
'.......................................................
' 1.1. abc 3x2 = 6
'.......................................................
If jj = 1 Then
' pass-1 - 1st 2 chars
nn = 0
For aa = 1 To 3 ' 3
For bb = 1 To 3 ' 2
If bb <> aa Then
nn = nn + 1
aP(nn) = aP(nn) + Chr(96 + aa) + Chr(96 + bb)
End If
Next bb
Next aa
' display pass1
For kk = 1 To nop
.TextMatrix(kk + 1, (jj - 1) * 3 + 1) = aP(kk)
Next kk
' pass-2 - 3rd (last) char
For nn = 1 To nop
For bb = 1 To 3 ' 2
tst = Chr(96 + bb)
v1 = InStr(aP(nn), tst)
If v1 = 0 Then
aP(nn) = aP(nn) + Chr(96 + bb)
End If
Next bb
Next nn
'.......................................................
' 1.2. abcd 4x3x2 = 24
'.......................................................
ElseIf jj = 2 Then
' pass-1 - 1st 2 chars
nn = 0
For aa = 1 To 4 ' 4
For bb = 1 To 4 ' 3
If bb <> aa Then
nn = nn + 1
aP(nn) = aP(nn) + Chr(96 + aa) + Chr(96 + bb)
' do twice
nn = nn + 1
aP(nn) = aP(nn) + Chr(96 + aa) + Chr(96 + bb)
End If
Next bb
Next aa
' display pass1
For kk = 1 To nop
.TextMatrix(kk + 1, (jj - 1) * 3 + 1) = aP(kk)
Next kk
' pass-2 - 3rd char
For nn = 1 To nop
For bb = 1 To 4 ' 2
tst = Chr(96 + bb)
v1 = InStr(aP(nn), tst)
If v1 = 0 Then
' chk if this already exists
chk = aP(nn) + Chr(96 + bb)
hv = 0
For mm = 1 To nn
If chk = aP(mm) Then ' it exists
hv = 1
Exit For
End If
Next mm
If hv = 0 Then
aP(nn) = aP(nn) + Chr(96 + bb)
Exit For
End If
End If
Next bb
Next nn
' display pass1
For kk = 1 To nop
.TextMatrix(kk + 1, (jj - 1) * 3 + 2) = aP(kk)
Next kk
' pass-3 - 4th (last) char
For nn = 1 To nop
For bb = 1 To 4 ' 2
tst = Chr(96 + bb)
v1 = InStr(aP(nn), tst)
If v1 = 0 Then
aP(nn) = aP(nn) + Chr(96 + bb)
End If
Next bb
Next nn
End If
'----------------------
' 2. display
'----------------------
' caption - original
.Row = 0
.Col = (jj - 1) * 3 + 1
.CellBackColor = RGB(200, 255, 255)
.Text = txt
.CellAlignment = 3
'
.Col = (jj - 1) * 3 + 2
.CellBackColor = RGB(200, 255, 255)
.Text = txt
.CellAlignment = 3
If jj = 2 Then
.Col = (jj - 1) * 3 + 3
.CellBackColor = RGB(200, 255, 255)
.Text = txt
.CellAlignment = 3
End If
' pass number
.Row = 1
.Col = (jj - 1) * 3 + 1
.CellBackColor = RGB(200, 255, 255)
.Text = "pass1"
.Col = (jj - 1) * 3 + 2
.CellBackColor = RGB(200, 255, 255)
.Text = "pass2"
If jj = 2 Then
.Col = (jj - 1) * 3 + 3
.CellBackColor = RGB(200, 255, 255)
.Text = "pass3"
End If
' data
oo = jj + 1
For kk = 1 To nop
.TextMatrix(kk + 1, (jj - 1) * 3) = kk ' row number
.Row = kk + 1
.Col = (jj - 1) * 3
.CellBackColor = RGB(200, 255, 255)
.TextMatrix(kk + 1, (jj - 1) * 3 + oo) = aP(kk) ' final data
Next kk
Next jj
.Top = 4200
.Left = 14000
.Height = 5000
.Visible = True
.Height = .Rows * 240
.ColWidth(0) = 300
.ColWidth(1) = 600
.ColWidth(2) = 600
.ColWidth(3) = 300
.ColWidth(4) = 600
.ColWidth(5) = 600
.ColWidth(6) = 600
.Width = 3600
.MergeCells = flexMergeFree ' = flexMergeRestrictColumns
.MergeRow(0) = True
End With
.
Thanks Spoo...:wave:
Thanks for the effort. I will try reading it line by line to understand the logic behind it... :)
Akhil
10-4.
Holler if you have any questions
Spoo
Thanks Spoo...:wave:Quote:
Originally Posted by Spoo
It takes some time for me to completely understand your code. If I have doubts, I will surely ask you...:wave:
Akhil: check this out http://en.wikipedia.org/wiki/Permuta...e_permutations
Thanks Zach...:wave:Quote:
Originally Posted by Zach_VB6
Akhil
I realize that it can be a pain to try to reverse-engineer
someone else's logic, so here's a little crib sheet to help
you out.
Let's first just consider jj = 1 (for the "abc" condition)
1. txt = "abc"
2. nn = Len(txt) = 3
3. nop loop will iterate to 1*3*2*1 = 6 (number of permutations)
4. Dim, ReDim aP() -- will be a 1-D array to hold the results
5. pass-1 (1st 2 chars) nested loops
-- each loop goes from 1 to 3 (where 3 is hardwired, but is really just nn)
-- test bb <> aa is to prevent repeated letters
6. display results of pass-1
7. pass-2 (last char) -- loop thru all results so far, and add the missing letter
Now, let's consider jj = 2 (for the "abcd" condition)
1. txt = "abcd"
2. nn = Len(txt) = 4
3. nop loop will iterate to 1*4*3*2*1 = 24 (number of permutations)
4. Dim, ReDim aP() -- will be a 1-D array to hold the results
5. pass-1 (1st 2 chars) nested loops
-- each loop goes from 1 to 4 (where 4 is hardwired, but is still just nn)
-- test bb <> aa is to prevent repeated letters
-- do twice -- I cheated here. This wasn't needed for jj=1. But "generically"
the "need" here seems to be governed by the 3rd number in the permutation,
ie, the 2 in 4x3x2x1
6. display results of pass-1
7. pass-2 (3rd char)
-- outer loop is all 24
-- inner loop is nn (ie,4)
-- introduces new concept - the InStr() test
8. display results of pass-2
9. pass-3 (last char) -- loop thru all results so far, and add the missing letter.
This is the same as the final pass for the other case
I adopted mostly a trial and error process to achieve the
results (hence the utility of displaying results at end of each pass).
But again, while there isn't full compatability between the two cases,
some sort of pattern seems to be emerging.
-- I was able to keep the number of loops constant (2, an outer and inner)
-- I was not able to devise a generic way to handle the number of passes
Hope this helps.
Spoo
ZachQuote:
Originally Posted by Zach_VB6
D'oh! Great thought.
I did a preliminary Forum search (not much help), but didn't think
of Wiki.
Akhil
The Wiki section "systematic generation of all permutations" seems to
be the answer. Now, can you turn that brief discussion into code?
I expect a report :)
Spoo
Hi guys..:wave:
I've worked on another part of this game. That is, user will input a word which has some missing characters. So, it's the job for the computer to generate all combinations of words by filling the missing characters with some alphabets.
I've programmed it in this way. You need to have a CommandButton and ListBox for trying this code.
Each line has comments, describing it's usage. So, I think you'll be able to get my idea by reading those comments. ;)
When the user's input is: *s*om* , the array size (dynamic array) is about 18278 and the total words generated is about 17576.Code:Option Explicit
Dim strTempWords() As String '~~~ This will hold the Temporary words
Dim lngTempCount As Long '~~~ Counter
Private Sub Command1_Click() '~~~ On clicking the button
Dim strInput As String
Dim i As Long
Dim j As Long
Dim lngMissing As Long
strInput = "*s*om*" '~~~ Input string that has missing characters (marked in "*")
lngTempCount = -1 '~~~ Initial value
'~~~ We are inserting the string strInput into the array
lngTempCount = lngTempCount + 1
ReDim Preserve strTempWords(lngTempCount)
strTempWords(lngTempCount) = strInput
lngMissing = 1 '~~~ This will holds the number of words that has missing characters in the strTempWords array
i = 0
Dim strTemp As String
Dim strTemp2 As String
While lngMissing > 0 '~~~ Loops until there's no word with missing characters
strTemp = strTempWords(i) '~~~ Copies an element from the array
strTempWords(i) = "" '~~~ That corresponding element in the array is emptied. (I think, it is better to shift the array here)
lngMissing = lngMissing - 1 '~~~ We have selected a word that contains the missing words from the array. So, we will decrement it's count
For j = 97 To 122 '~~~ a to z
strTemp2 = Replace(strTemp, "*", Chr$(j), , 1) '~~~ We will replace the first occurence of the '*' with the character
If InStr(1, strTemp2, "*") > 0 Then lngMissing = lngMissing + 1 '~~~ Check if this new word contains atleast a single missing character. ie. '*'. If so, increment the lngMissing counter
'~~~ We are adding this new word to our strTempWords array
lngTempCount = lngTempCount + 1
ReDim Preserve strTempWords(lngTempCount)
strTempWords(lngTempCount) = strTemp2
Next
If lngMissing > 0 Then i = i + 1 '~~~ If there's a word that contains missing character, we will increment it. (We are moving to the next element in the array, during the next iteration of the While..Wend loop)
Wend
'~~~ Displays the final words in a Listbox
For i = LBound(strTempWords) To UBound(strTempWords)
If Len(strTempWords(i)) > 0 Then List1.AddItem strTempWords(i) '~~~ The words in the strTempArray that contains non-empty string is added to the ListBox
Next
'~~~ Displays the size of the array. It is very large here. I think, array shifting needs to be done !
MsgBox "Array size: " & UBound(strTempWords) & vbCrLf & "Word count in Listbox: " & List1.ListCount
End Sub
Guys, do you think my code is not efficient ? Or, is there anything that I can do it to improve ?
One thing I noticed is the array size. I'm using a dynamic array for the entire process.
That is, all words will be inserted into the same array. I think, there's a need of array shifting !
What's your opinion, guys ? :)
Any ideas ???
@akhil, sorry this has nothing to do with your last post. Its a version of the algorithm mentioned in Wikipedia. It uses a little bit a array hacking to have a string which is also an Integer array.
Results in...Code:Dim x As cPermutations
Set x = New cPermutations
x.Text = "banana"
Do While x.PermutationsLeft
Debug.Print Join(x.NextNPermutations(7), ", ")
Loop
Code:aaabnn, aaanbn, aaannb, aabann, aabnan, aabnna, aanabn
aananb, aanban, aanbna, aannab, aannba, abaann, abanan
abanna, abnaan, abnana, abnnaa, anaabn, anaanb, anaban
anabna, ananab, ananba, anbaan, anbana, anbnaa, annaab
annaba, annbaa, baaann, baanan, baanna, banaan, banana
bannaa, bnaaan, bnaana, bnanaa, bnnaaa, naaabn, naaanb
naaban, naabna, naanab, naanba, nabaan, nabana, nabnaa
nanaab, nanaba, nanbaa, nbaaan, nbaana, nbanaa, nbnaaa
nnaaab, nnaaba, nnabaa, nnbaaa
Thanks Milk...:wave:
Once again, thanks to all those posters in this thread...:wave:
Another question regarding to all those posts(except post#13):
What will be the best way to check if it's an actual word in English. I mean, upon generating the words, I would check the words with a list of words in textfile (which are valid words in English), to find whether it exists in English language.
Do you have any tweaks or ideas to make it faster ?
Currently, I will grab all the words into an array on apllication startup. And then, loop through those arrays to find a matching word.
I think instead of looping through the arrays, can't we Join the array to a single string, and then check the existence of the word using Instr() in the string variable ?
Guys, what do you think ? Any ideas ?
This is my own way to use recursive to build an array of words from a given number of characters.
It is a short and simple function.
@Merri/Milk, perhaps you can optimize it. On my laptop, with 9 characters input, it generates 362,880words in 2.7 seconds in Excel VBA.
Code:Option Explicit
Sub BuildWords(Chars As String, Words() As String, Optional bPredim As Boolean)
'-- bPredim for internal use only
'-- Chars should not have more than 10 characters (max 12)
Dim i As Long, j As Long, p As Long, n As Long
Dim ch As String
Dim Chars1 As String, Words1() As String
n = Len(Chars)
Select Case n
Case Is > 1
p = 1: For i = 2 To n - 1: p = p * i: Next '-- p = (n-1)!
ReDim Words1(1 To p)
If Not bPredim Then ReDim Words(1 To n * p)
For i = 1 To n
ch = Mid$(Chars, i, 1)
Chars1 = Left$(Chars, i - 1) & Mid$(Chars, i + 1)
BuildWords Chars1, Words1, True
For j = 1 To p
Words((i - 1) * p + j) = ch & Words1(j)
Next
Next
Case 1
If Not bPredim Then ReDim Words(1 To 1)
Words(1) = Chars
Case 0
Words = Split("")
End Select
End Sub
Code:Sub Test_BuildWords()
Dim Chars As String
Dim Words() As String
Dim i As Long
Dim t As Single
Chars = "abcefghij"
'-- with 9 characters, 362880 words will be generated
t = Timer
BuildWords Chars, Words
t = Timer - t
'For i = 1 To UBound(Words)
' Debug.Print i; Words(i)
'Next
Debug.Print UBound(Words), t
End Sub
Thanks anhn... :wave:
AkhilQuote:
Originally Posted by akhileshbc
One thought.. kind of like a google-search algo.
1. Put all the English words in an array (say, 1,000,000 words)
2. In another array, create "level 1 pointers". For example
- "a" begins at 1
- "b" begins at 38,000 (ie, the first word that begins with the letter "b")
- "c" begins at 68,205
- ...
- "w" begins at 900,000
- etc.
This would be a 1-time endeavor
- You could take this several levels deep, if that would be helpful.
- Downside is that if new English words are added, you'd need to redo this
Then you're ready to look at the list of your "generated" words.
- if your word begins with "a", piece of cake
- if your word begins with "w", instead of needing the first
900,000 interations, you could begin at 900,000... that would be faster.
Does that get you started?
Spoo
That's a nice idea Spoo...:)
Thanks. I will try that one...:wave:
Do you have any comments about my post #13 ?
If your looking to make an anagram solver then you should be going about this in a completely different way. Using a twelve letter anagram as an example, assuming it contains twelve unique characters, it will have 479'001'600 different permutations. Only a very small portion of these permutations will be actual words eg < 8. It's a complete waste of time and memory to calculate all the permutations then check if it is a word or not.Quote:
Originally Posted by akhileshbc
Have a look at this recent thread (#4+), and see if you understand what I'm on about (I'm not sure the OP did)
I think the approach might help indirectly with the problem that post #13 alludes to.
Akhil
Sorry, at the moment, I don't.
I get what you're trying to do, but as my initial attempt
at the basic algo was incomplete, and as I haven't had
time to study "array shifting", I'm afraid I'm just an outsider
at this point.
EDIT
Thank goodness Milk is on the job!
Spoo
Thanks guys...:wave:
It will took some hours for me to understand the idea. So, after understanding it, I will post my doubts and the codes.
Thanks again....:wave:
@Milk: As I was reading your posts on the other thread several times, the code generation is not clear to me. Assigning numbers to characters ? :confused:
Can you provide an example ?
Thanks again...:wave:
You could try a function like this...
Depending on the bigger picture you might want something a little different. The raise operator (^) is very slow, it could well be a good Idea to keep a module level array of Bit values (1, 2, 4, 8... ...536870912, 1073741824, -2147483648) to use for getting/setting bits. The score gives no indication of the order of the letters, it indicates which letters are present and how long the word isCode:Private Function ScoreWord(Word As String) As Long
Dim buf() As Byte, i As Long, score As Long
If Len(Word) < 32 Then
score = score Or (Len(Word)) * &H4000000
buf = StrConv(LCase$(Word), vbFromUnicode)
For i = 0 To UBound(buf)
If buf(i) > 96 And buf(i) < 122 Then
score = score Or 2 ^ (buf(i) - 97)
Else
ScoreWord = -1 'indicates word contains illegal letters
Exit Function
End If
Next i
ScoreWord = score
Else
ScoreWord = -2 'indicates word is too long
End If
End Function
Have a look at the words and associated scores in the example. All the words with equal score are possibly an anagram of each other. For any set of letters (<32) you can generate a score and compare it to the scores in the list.
Thanks Milk....:wave:
I will try that, and will post the doubts tomorrow (It is 10.30pm here ;))
Thanks Milk...:wave:Quote:
Originally Posted by Milk
Milk, I'm trying to learn the idea. But a small question, is "z" an invalid character ?:confused:
Ok. I think, I got the idea. I will say it. Correct me if I'm wrong.
Phase1:
First, I will generate numerical codes for all the words available with me.
Then sort it according to the codes.
Done !
Phase2:
Then, in the word generator, when all possible combinations of words are generated based on the string inputted by the user (using one of the methods posted in this thread - permutations).
Then, corresponding numerical codes are also generated for this generated words.
Done !
Phase3:
Then, these codes of the newly generated words are searched with those in which are generated in the first phase (available words list). If a match is found, then display it.
Done !
Am I right ? :)
Did I missed something ?
Oops no :p, should be <= 122 or < 123, but you know that ;)
Ok. Thanks...:wave:Quote:
Originally Posted by Milk
Ahh, no. You don't have to generate all the possible combinations (this is the whole point of scoring the words in such a way)Quote:
Originally Posted by akhileshbc
User inputs a string, the string is given a score. Compare this new score to the stored scores. If a match is found then check to see if they both contain the same letter duplicates (if any)
You can be inventive with the various bitwise operators to make more complicated queries, such as using wildcards as in post #13
Thanks Milk... :wave: Now I got the idea...:)Quote:
Originally Posted by Milk
Sorry to ask again. But can you explain this idea ?Quote:
Originally Posted by Milk
And which are the bitwise operators in VB ? ("<<" and ">>" ?):confused:
Not And Or Xor are VBs bitwise operators
A wildcard search could work like this...
User enters a string with wildcards "tomb???"
The string is scored to get 470306818 (function above won't like the ?s, it would need to be adjusted)
The high bits of the score would indicate the length (7 -> 469762048)
The low bits would indicate the letters ("tomb" -> 544770)
To search for all the 7 letter words that contain the letters "tomb" we need to look for scores >= 470306818, < 536870912 (8 letters) which also share the same letter bits.
Code:Const ALPHABETSIZE As Long = 26
Const SIZESHIFT As Long = 2^ALPHABETSIZE
Const LETTERMASK As Long = SIZESHIFT - 1
Const SIZEMASK = Not LETTERMASK Xor &H80000000 '(not using the highest bit)
'FindIndex() is an imaginary binary search function that returns an index to a word
'if the passed score does not exist then it returns the next
For i = FindIndex(Score) to FindIndex((Score And SIZEMASK) + LETTERMASK) - 1
If (WordScores(i) Or Score) = WordScores(i) Then 'same length and contains same letters
'Check letter duplicates and other letters do not exceed number of wildcards
'...
An anagram search could be...
Code:i = FindIndex(Score)
Do While WordScores(i) = Score
'Check for letter duplicates
i = i + 1
Loop
Thanks Milk...:wave:
I understand the idea(your explanation). But the code you provided (that includes constants), is little difficult for me to understand. (I will try to play with it to know more)
But can you do one more favor ? Can you explain these constants(I mean, what it holds by providing a small example, like you did with "tomb???"):
Thanks again...:wave:Code:ALPHABETSIZE
SIZESHIFT
LETTERMASK
SIZEMASK
The numbers those constants represent are useful you will find they get used quite often (eg in the ScoreWord function, score = score Or (Len(Word)) * SIZESHIFT). They should be stored at a modular level. By using similar constants rather than literals you create code which is more flexible.
ALPHABETSIZE is only used to define the other constants (26 is easy to remember and understand)
SIZESHIFT is the multiplier for the word length part of the score. (Score \ SIZESHIFT = word length)
LETTERMASK is the bit mask for the letter part of the score. (Score And LETTERMASK = letter score)
SIZEMASK is the bit mask for the length part of the score. (Score And SIZEMASK = length score)
I just noticed a typo :)
FindIndex((Score And SIZEMASK) + LETTERMASK) - 1
The above line finds the highest word index in that size group. Score And SIZEMASK gets just the length part, then by adding (or Or) the LETTERMASK you end up with the highest possible score. FindIndex() will not find a word with the actual score (eg. 7 letters and contains the whole alphabet) so it will return the next, which will be the first word of the next size group, hence the -1.
Thanks Milk....:wave: