Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Chris Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Program needed for change of letters within a string 5

Status
Not open for further replies.

german12

Programmer
Nov 12, 2001
563
DE
Tonight I saw a riddle on television.

They looked for a meaningful german word, however the problem has nothing to do with the language.
They placed the following 9 letters on screen:

B L U T M E O P F

and asked "what meaningful word is hidden here?"

I know that this has to been recognized as a string-change-problem where every letter can have the place from 1 to 9 (no doubles) to cover all possibilities and then it would be easy (for me,not easy for the program) to find out what a meaningful word is.

I thought about a loop to deliver me all possibilities but I
did not come to a solution.

How has that loop to be coded?
And - how many words (senseless or not) will that produce in total in case of this example ?

It is not necessary to compare the words found with an enzyklopedia.

I know that Foxpro can do it with just a few commands (as well as Basic or C++) but in Fox it would be most understandable for me.

Thanks folks.

By the way - they awarded 4,000 Euro for the right word, and
next time when they have a similiar riddle, I would run such
a evaluation-program to be the first who phones *ggg

Peace worldwide - it starts here...
 
You can use the Permutation code I posted in:

All Combinations
thread184-823742

...just modify the array so that it includes an element for each of the 9 letters you've been given.

boyd.gif

 
Hi Craig,

many thanks, your prog was the easiest for me to modify and
I really came up with 362,880 records found by your program which is the solution of 9! = (1*2*3*4*5*6*7*8*9).
I changed your program a litte to write all the records directly into an opened *.dbf-file by appending each found record - which was much more faster than putting the results on screen - which I did not expect.

Now it would be easy to compare that database with a german encylopaedia (I am just looking for one) and then ask by a litte program for matching records.

A star for you!

regards
Klaus



Peace worldwide - it starts here...
 
german12,

Glad it helped. If you get time perhaps you could post the revised code here with the results going into a table instead of being printed on the screen... might help someone in the future.

baltman,

I just noticed you slipped in before me or I wouldn't have posted the link again. [smile]

boyd.gif

 
@Craig: I will display the modification within the next days,
because I would like to try also to create the dimension statement right away from the given word (abcd..)in order to automate that program a little bit more.
(Hope that my knowledge is good enough, as I am not a professional...)

@koen: I looked at that program and tried it, however there is reported an error when I ran it:
a class-definition missing for the command line:
ox=CREATEOBJECT('dictionary.dict') && Instantiate the dictionary COM object.

Anyway, I would like to study the idea of that program to use
what I can understand for my purpose. Thank you so much.

@TheRambler: A great Site! It is at least that what I am trying here - and it is more due to selectable languages.
All I reget is, that I could not see, HOW that is coded.
That is a big star for you! Thanks.

Klaus




Peace worldwide - it starts here...
 
Here's a working example that puts the permutations to a cursor and includes a progress bar class I threw together real quick. Cut-N-Paste the code below into a prg and execute it from within VFP:

Code:
*!* Show all permutations for a given set of characters
GetCharPermutations("PERMUTE")

PROCEDURE GetCharPermutations(tcCharacters)
	LOCAL lnMembers, lnCounter, loProgress, lnTemp, lnTemp2, lnLoopCounter, lnTotalPermutations, lnPermutationsDone
	SET ESCAPE ON
	lnMembers = LEN(tcCharacters)
	lnTotalPermutations = 1
	lnPermutationsDone = 0
	DIMENSION tcSet(lnMembers)
	DIMENSION aryIndice(lnMembers)
	FOR lnLoopCounter = 1 TO lnMembers
		tcSet(lnLoopCounter) = SUBSTR(tcCharacters, lnLoopCounter, 1)
		lnTotalPermutations = lnTotalPermutations * lnLoopCounter
	ENDFOR
	aryIndice = -1
	CREATE CURSOR crsResult (permute c(lnMembers))
	loProgress = CREATEOBJECT("progress", "Processing...", 0, lnTotalPermutations, 0)
	loProgress.show()
	DO WHILE .T.
		IF(aryIndice(1) < 0)
			lnCounter = 1
			DO WHILE  lnCounter < lnMembers + 1
				aryIndice(lnCounter) = lnCounter - 1
				lnCounter = lnCounter + 1 && was above
			ENDDO
			lnBeginning = lnMembers +1
			lnEnd = lnMembers
			DO WHILE lnBeginning < lnEnd
				lnTemp2 = aryIndice(lnBeginning)
				aryIndice(lnBeginning) = aryIndice(lnEnd)
				lnBeginning = lnBeginning + 1
				aryIndice(lnEnd) = lnTemp2
				lnEnd = lnEnd - 1
			ENDDO
			lnPermutationsDone = lnPermutationsDone + 1
			loProgress.VALUE = lnPermutationsDone
			INSERT INTO crsResult (permute) VALUES (LEFT(DisplayString(lnMembers, @tcSet, @aryIndice), lnMembers))
			LOOP
		ELSE
			lnCounter = lnMembers - 1
			DO WHILE lnCounter >= 1 AND aryIndice(lnCounter) >= aryIndice(lnCounter + 1)
				lnCounter = lnCounter - 1
			ENDDO
			IF(lnCounter < 1)
				EXIT
			ELSE
				lnLeast = lnCounter + 1
				lnTemp = lnCounter + 2
				DO WHILE lnTemp < lnMembers + 1
					IF(aryIndice(lnTemp) < aryIndice(lnLeast) AND aryIndice(lnTemp) > aryIndice(lnCounter))
						lnLeast = lnTemp
					ENDIF
					lnTemp = lnTemp + 1 && was above
				ENDDO
				lnTemp2 = aryIndice(lnCounter)
				aryIndice(lnCounter) = aryIndice(lnLeast)
				aryIndice(lnLeast) = lnTemp2
				IF (lnMembers > lnCounter)
					lnBeginning = lnCounter + 1
					lnEnd = lnMembers
					DO WHILE lnBeginning < lnEnd
						lnTemp2 = aryIndice(lnBeginning)
						aryIndice(lnBeginning) = aryIndice(lnEnd)
						lnBeginning = lnBeginning + 1
						aryIndice(lnEnd) = lnTemp2
						lnEnd = lnEnd - 1
					ENDDO
					lnBeginning = lnMembers + 1
					lnEnd = lnMembers
					DO WHILE lnBeginning < lnEnd
						lnTemp2 = aryIndice(lnBeginning)
						aryIndice(lnBeginning) = aryIndice(lnEnd)
						lnBeginning = lnBeginning + 1
						aryIndice(lnEnd) = lnTemp2
						lnEnd = lnEnd - 1
					ENDDO
				ENDIF
				lnPermutationsDone = lnPermutationsDone + 1
				loProgress.VALUE = lnPermutationsDone
				INSERT INTO crsResult (permute) VALUES (LEFT(DisplayString(lnMembers, @tcSet, @aryIndice), lnMembers))
				LOOP
			ENDIF
		ENDIF
	ENDDO
	RELEASE loProgress
	IF MESSAGEBOX("Done processing '" + tcCharacters + "' would you like to browse the results?",36,"PROCESS FINISHED") = 6
		GO TOP IN "crsResult"
		BROWSE
	ENDIF
ENDPROC


FUNCTION DisplayString(tcMembers, tcSet, tcIndice)
	LOCAL lnCounter, lcString
	lcString = []
	FOR lnCounter = 1 TO tcMembers
		IF (tcIndice(lnCounter) + 1) != 0
			lcString = lcString + TRANSFORM(tcSet(tcIndice(lnCounter)+1))
		ENDIF
	ENDFOR
	RETURN ALLTRIM(lcString)
ENDFUNC

DEFINE CLASS progress AS FORM

	AUTOCENTER = .T.
	ALWAYSONTOP = .T.
	TOP = 0
	LEFT = 0
	HEIGHT = 74
	WIDTH = 298
	DOCREATE = .T.
	CAPTION = ""
	TITLEBAR = 0
	BORDERSTYLE = 2
	VALUE = 0
	NAME = "frmProgress"
	MIN = 0
	MAX = 100
	
	PROCEDURE INIT
		LPARAMETERS tcTitle, tnMin, tnMax, tnValue
		LOCAL lnCounter, lnLeft, lcShapeName

		THIS.ADDOBJECT("shape26", "Shape")
		WITH THIS.shape26
			.TOP = 23
			.LEFT = 12
			.HEIGHT = 25
			.WIDTH = 277
			.BACKSTYLE = 0
			.SPECIALEFFECT = 0
			.VISIBLE = .T.
		ENDWITH

		THIS.ADDOBJECT("title", "label")
		WITH THIS.TITLE
			.BACKSTYLE = 0
			.CAPTION = ""
			.HEIGHT = 18
			.LEFT = 12
			.TOP = 3
			.WIDTH = 277
			.VISIBLE = .T.
		ENDWITH

		THIS.ADDOBJECT("percentage", "label")
		WITH THIS.percentage
			.FONTBOLD = .T.
			.ALIGNMENT = 2
			.BACKSTYLE = 0
			.CAPTION = ""
			.HEIGHT = 18
			.LEFT = 12
			.TOP = 52
			.WIDTH = 277
			.FORECOLOR = RGB(0,128,192)
			.VISIBLE = .T.
		ENDWITH

		lnLeft = 13
		FOR lnCounter = 1 TO 25 && Easier than adding and removing them should progress go backwards at some point
			lcShapeName = "Shape" + TRANSFORM(lnCounter)
			THIS.ADDOBJECT(lcShapeName, "Shape")
			WITH THIS.&lcShapeName
				.TOP = 24
				.LEFT = lnLeft
				.HEIGHT = 23
				.WIDTH = 10
				.BORDERSTYLE = 0
				.SPECIALEFFECT = 1
				.VISIBLE = .F.
				.BACKCOLOR = RGB(0,128,192)
			ENDWITH
			lnLeft = lnLeft + 11
		ENDFOR

		IF TYPE("tcTitle") = "C"
			THIS.TITLE.Caption = tcTitle
		ENDIF
		IF TYPE("tnMin") = "N"
			THIS.MIN = tnMin
		ENDIF
		IF TYPE("tnMax") = "N"
			THIS.MAX = tnMax
		ENDIF
		IF TYPE("tnValue") = "N"
			THIS.VALUE = tnValue
		ENDIF
	ENDPROC

	PROCEDURE value_assign
		LPARAMETERS vNewVal
		LOCAL lnCounter, lcShapeName, lnPercentage
		THIS.LOCKSCREEN = .T.
		lnPercentage = INT(m.vNewVal/(THIS.MAX - THIS.MIN)*100)
		FOR lnCounter = 1 TO 25
			lcShapeName = "Shape" + TRANSFORM(lnCounter)
			this.&lcShapeName..VISIBLE = lnCounter <= (lnPercentage/4)
		ENDFOR
		THIS.percentage.Caption = TRANSFORM(lnPercentage) + "%"
		THIS.LOCKSCREEN = .F.
		IF lnPercentage = 100 && Show this for a .5 seconds so user can see it
			INKEY(.5,"H")
		ENDIF
		THIS.VALUE = m.vNewVal
	ENDPROC

	PROCEDURE max_assign
		LPARAMETERS vNewVal
		THISFORM.VALUE = THISFORM.VALUE && in case max is changed refresh progress bar
		THIS.MAX = m.vNewVal
	ENDPROC

	PROCEDURE min_assign
		LPARAMETERS vNewVal
		THISFORM.VALUE = THISFORM.VALUE && in case min is changed refresh progress bar
		THIS.MIN = m.vNewVal
	ENDPROC

ENDDEFINE

boyd.gif

 
Hi, Craig, here is your modified code.
Would be glad if you could test it once.

Regards
Klaus

Code:
*!*	Wordmix.prg

*!*	Authors: Craig Boyd and Klaus Briesemeister /2004

*!*	This prog changes the position of a given word for each letter (permutation)
*!*	Example: abc leads to  abc,acb, bac, bca, cab, cba (6 possibilities)
*!*	Formular for the amounts to be expected is the faculty of the amount of
*!*	letters within the word.
*!*	Example: A word which consists of 5 letters will be 5! = 1*2*3*4*5 = 120  possible words.

*!*	This permutation program is based on Craig Boyds permutation-Program shown in
*!*	[URL unfurl="true"]http://www.tek-tips.com/viewthread.cfm?qid=82374[/URL]
*!*	My program would not work without this basis-program as it contains the highly sophisticated
*!*	algorithm-loops for the permutation.

*!*	The modifications made by me are mainly as follows:
*!*	1)The hard-coded dimension is soft-coded now.
*!*	That means one can input any word and the program will automatically adjust the
*!*	DIMENSION to be used.

*!*	2)All output will directly be written into a dbf-file named wortmix.
*!*   Field name = wort, field-type = character, length = variable
*!*	  The structure of this file will be automatically built by the users input.

*!*	3)The user can see in advance, how many records will be generated and can stop
*!*	  the process (cancel) in advance, when the file seems to become too big.
*!*
*!*	The created file will be overwritten with every new input of the given basic word


*Code


CLEA
CLEAR WINDOW ALL
CLOSE DATABASES
SET SAFETY OFF
CLEAR

*Inputmask
searchedword =INPUTBOX("Give me a word for permutation?","Your word?","abc")
DO WHILE LEN(searchedword) = 0   && Input requested
	searchedword =INPUTBOX("Give me a word for permutation?","Your word?","abc")
ENDDO


wordlength = (LEN(searchedword)) && to define the field-width


*Show the records which will be calculated in advance
*by the faculty-formular....
RECORDS = 1
FOR i = 1 TO wordlength
	RECORDS = RECORDS * i
ENDFOR

*...to the user
cMessageTitle = 'Records to be calculated for:' + searchedword
cMessageText = "Your calculation will lead to: "+ALLTRIM(STR(RECORDS))+ " records - Continue?"
nDialogType = 4 + 32 + 256
*  4 = Yes and No buttons
*  32 = Question mark icon
*  256 = Second button is default

nAnswer = MESSAGEBOX(cMessageText, nDialogType, cMessageTitle)



*Build automatically the dimension based on the wordlenght via user-input
DIMENSION aryGroup(wordlength)

*Build automatically the array-elements based on the users input by
*a loop (each single letter is a different array-element)
*Example: Input = abc then: arygroup(1) = a, arrygroup(2) = b,arrygroup(3) = c)
firstword = ""
FOR i = 1 TO wordlength
	groupelement = SUBSTR(searchedword, i, 1)
	aryGroup(i) = [&groupelement]
	firstword = firstword+groupelement
ENDFOR

*Give the user a chance to break when result will be too high
*means: calculate the records (n! faculty)
DO CASE
CASE nAnswer = 6 && Yes
*do nothing
CASE nAnswer = 7 && No
	CLEA
	CLOSE DATA
	CANCEL
ENDCASE

*Build a table automatically
CREATE TABLE wortmix (wort C(wordlength))
APPEND BLANK
REPLACE wort WITH firstword &&given the first record.


*

GetPermutations(wordlength,@aryGroup)
GO TOP
BROWSE TITLE FULLPATH(DBF())+" "+ ALLTRIM(STR(RECCOUNT()))+ " Records ready"


*Here mainly starts craigs code:

PROCEDURE GetPermutations(tcSize, tcSet)
LOCAL lnMembers, lnCounter, lnTemp, lnTemp2
lnMembers = ALEN(tcSet)
DIMENSION aryIndice(lnMembers)
counter = 1
aryIndice = -1
DO WHILE .T.
	IF(aryIndice(1) < 0)
		lnCounter = 1
		DO WHILE  lnCounter < lnMembers + 1
			aryIndice(lnCounter) = lnCounter - 1
			lnCounter = lnCounter + 1 && was above
		ENDDO
		lnBeginning = tcSize +1
		lnEnd = lnMembers
		DO WHILE lnBeginning < lnEnd
			lnTemp2 = aryIndice(lnBeginning)
			aryIndice(lnBeginning) = aryIndice(lnEnd)
			lnBeginning = lnBeginning + 1
			aryIndice(lnEnd) = lnTemp2
			lnEnd = lnEnd - 1
		ENDDO
		?LEFT(DisplayString(lnMembers, @tcSet, @aryIndice), tcSize)
		LOOP
	ELSE
		lnCounter = lnMembers - 1
		DO WHILE lnCounter >= 1 AND aryIndice(lnCounter) >= aryIndice(lnCounter + 1)
			lnCounter = lnCounter - 1
		ENDDO
		IF(lnCounter < 1)
			EXIT
		ELSE
			lnLeast = lnCounter + 1
			lnTemp = lnCounter + 2
			DO WHILE lnTemp < lnMembers + 1
				IF(aryIndice(lnTemp) < aryIndice(lnLeast) AND aryIndice(lnTemp) > aryIndice(lnCounter))
					lnLeast = lnTemp
				ENDIF
				lnTemp = lnTemp + 1 && was above
			ENDDO
			lnTemp2 = aryIndice(lnCounter)
			aryIndice(lnCounter) = aryIndice(lnLeast)
			aryIndice(lnLeast) = lnTemp2
			IF (tcSize > lnCounter)
				lnBeginning = lnCounter + 1
				lnEnd = lnMembers
				DO WHILE lnBeginning < lnEnd
					lnTemp2 = aryIndice(lnBeginning)
					aryIndice(lnBeginning) = aryIndice(lnEnd)
					lnBeginning = lnBeginning + 1
					aryIndice(lnEnd) = lnTemp2
					lnEnd = lnEnd - 1
				ENDDO
				lnBeginning = tcSize + 1
				lnEnd = lnMembers
				DO WHILE lnBeginning < lnEnd
					lnTemp2 = aryIndice(lnBeginning)
					aryIndice(lnBeginning) = aryIndice(lnEnd)
					lnBeginning = lnBeginning + 1
					aryIndice(lnEnd) = lnTemp2
					lnEnd = lnEnd - 1
				ENDDO
			ENDIF

*Write your results into a dbf-file wortmix.dbf
			APPEND BLANK
			REPLACE wort WITH LEFT(DisplayString(lnMembers, @tcSet, @aryIndice), tcSize)
			LOOP
		ENDIF
	ENDIF
ENDDO
ENDPROC

*--------------------------------------------------------------------------------------
FUNCTION DisplayString(tcMembers, tcSet, tcIndice)
LOCAL lnCounter, lcString
lcString = []
FOR lnCounter = 1 TO tcMembers
	IF (tcIndice(lnCounter) + 1) != 0
		lcString = lcString + TRANSFORM(tcSet(tcIndice(lnCounter)+1))
	ENDIF
ENDFOR
RETURN ALLTRIM(lcString)

*end of program

Peace worldwide - it starts here...
 
@Craig: A very fine built in - progress-bar.
The user stays perhaps patient when the program runs.

Sorry that I did not see it earlier, otherwise I would have built it into my modified program as well.
Perhaps later....

The performance-gain by using an open file and just REPLACE only the within an APPEND command is great, isn't it?


At the moment I think about what has to be done when one
has made an input of let's say a word-length of 13.

That would lead to a file of 6,227,020,800 records.

Therefore I built a brake in my modifications, but it would
be nicer to have the chance while your progress-bar runs, but how, without reducing performance?

regards
Klaus










Peace worldwide - it starts here...
 
A more efficient methodology would be to let VFP do the heavy listing if you have a word list to begin with. I'm no German expert, but I did find a small word list. It couldn't solve your particular riddle, but I made one of my own.

Brian

Code:
*download [URL unfurl="true"]http://www.dict.cc/download/dict-wordlist-de-en.zip[/URL]

CREATE TABLE GermanWL (WordData c(80))
APPEND FROM dict-wordlist-de-en.txt TYPE sdf
REPLACE ALL WordData WITH UPPER(WordData)

lcLetters=[AFLLOSTEN]

lcSearchClause=[]
lcLetters=UPPER(lcLetters)
 FOR lnLetters= 1 TO LEN(lcLetters)
  lcSearchClause = lcSearchClause + [ and ']+SUBSTR(lcLetters,lnLetters,1)+['$LEFT(WordData,ATC(CHR(32),WordData,1))]
 ENDFOR
 
 lcSearchClause = [LEN(LEFT(worddata,ATC(CHR(32),worddata,1)))-1=LEN(lcLetters)] + lcSearchClause 
 
SELECT * from GermanWL WHERE &lcSearchClause nowait

BROWSE NOWAIT
 
Great Brian!
I tested your prog and it worked also with german words (of course, because the problem is not language-bounded.)
This is really a more efficient method - i still have the problem to get a german word-language book which contains more words, but for a first trial your prog is very useful und extremely short.

A big star for you!!!

Happy New Year to all of you.
I learned a lot with this question.
Thx.

Klaus








Peace worldwide - it starts here...
 
After posting it occured to me that using OCCURS(EachChrInString)=OCCURS(InWord) instead of '$' would be even better... but yes, this method allows you to test really long words quickly whereas testing each possible permutation would take a really really long time.

Good luck. If you win please share some of the prize with Tek-Tips :)

Brian
 
Hi Klaus,

Well, the riddle itself isn't hard: TOPFBLUME
(Pot flower).

But as this was just an example the strategy to
create all permutations of the word is okay for
a computer, but brian's idea of searching words
with the needed letters should be much faster.

You may also start with extracting only words
with 9 characters and then search for those words
with all the letters in them.

Finding word's with identical length is easy.
Make an INDEX ON LEN(ALLTRIM(cWordfield)) TAG Len.
Then Set Order to Len, Set Key To 9 and you can
scan through such words only.

But such riddles are solved quite fast even without
a computer. The thing is, you have to get through
when calling in. You don't think the viewers take
long to solve such a puzzle, just because only
every 5 minutes or so a caller is choosen? They
have to earn the 4000 EUR (plus profit) from the
49 cents per call...

Bye, Olaf.
 
Hi Klaus,

If I understand you correctly you are looking for the anagram of a given word/letters.
Brian's code works but fails on words/combinations where letters occur > 1.
I think I created a routine which will also deal with that. However I shall need a list of all German words. Can you supply?

Bye Bye,

Koen
 
@Koen - as I mentioned already above in my answers, there was an error when I tried your program for the line....
ox=CREATEOBJECT('dictionary.dict') - vpf reports a missing class-definition for dictionary.dict -however you did not answer and therefore your program was out of my sight.

They are more real senseful words which I am looking for (may
be that they are called anagrams as a strict definition) however the problem arose that one can have a lot of answers (e.g. if a search entry has a length of only 7 letters, you are overwhelmed with n!=7) = 5,040 results and therefore I concentrated myself on Brian's program as he had already a wordbook written in German included, because I had no electronical one.
-----

@Olaf - thx for the tip by indexing a field via its length
(I never did that before) and - yes - you are right, they
have to earn their money before they hand it over.
I tried it several times but always had no luck.
No one can proof what really happens in the background.
Theoretically they can tell ALL viewers that they did not come through, and in TV you will hear only wrong answers produced by people belonging to them - and the last person - who has the right answer is also belonging to them.....

Who does control them?

Regards to both of you.

Klaus


Peace worldwide - it starts here...
 
Having no sense of German I could not judge, but if I modify my lcSearchClause to match a length >= the length of the string I do indeed get many 'flower pot' related results from the dictionary I posted a link to.

I actually expected that the riddle was much more difficult to solve and would not have been found in my 'freeware' German dictionary.

Brian
 
Another Idea:

create a new field in the dictionary containing the (upper case) letters of the word in alphabetical order.

Then searching for possible words would be done by sorting the letters of the puzzle and then seeking all words of the dictionary with the same letters. You only once need to sort all words of the dictionary. Combined with an index on the length this would be very fast even for longer words in a large dictionary.

To sort a word:
Code:
? sortword("Blutmeopf")
? sortword("Topfblume")
* both result in BEFLMOPTU

Function sortword()
   LParameters tcWord
   
   tcWord = IIf(Empty(tcWord),"",Upper(AllTrim(tcWord)))
   
   Local Array laLetters[Len(tcWord)]
   Local lnCnt
   For lnCnt=1 to Len(tcWord)
      laLetters[lnCnt]=Substr(tcWord,lnCnt,1)
   EndFor lnCnt
   
   ASort(laLetters)
   
   Local lcSorted
   lcSorted = ""
   For lnCnt=1 to Len(tcWord)
      lcSorted = lcSorted + laLetters[lnCnt]
   EndFor lnCnt
   
   Return lcSorted
EndFunc

Bye, Olaf.
 
Wow, Olaf! Thats an amazing idea!
I would never had come to such a solution I think.

Big star for you!

regards
Klaus


Peace worldwide - it starts here...
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top