Anagrams bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-06-2017, 06:28 PM This post was last modified: 12-08-2017, 01:17 PM by bplus.Edited 0 times Speed this up! http://rosettacode.org/wiki/Anagrams Append: BTW the link to the dictionary file from which the words are being found can be found from the Rosetta Code link above. Code:```_TITLE "Searching for large sets of Anagrams with same characters, loading data..." DIM w\$(30000, 1): DIM SHARED er\$: er\$ = STR\$(999999999) index = 0: t = TIMER OPEN "unixdict.txt" FOR INPUT AS #1 WHILE NOT (EOF(1))    INPUT #1, wd\$    IF LEN(wd\$) > 2 THEN index = index + 1: w\$(index, 0) = wd\$: w\$(index, 1) = order\$(wd\$) WEND CLOSE #1 FOR i = 1 TO index - 1    b\$ = w\$(i, 0): anaFlag = 0    FOR j = i + 1 TO index        IF w\$(i, 1) = w\$(j, 1) THEN b\$ = b\$ + ", " + w\$(j, 0): anaFlag = anaFlag + 1    NEXT    IF anaFlag > 3 THEN PRINT b\$ NEXT PRINT "Done !!! "; TIMER - t FUNCTION order\$ (word\$)    DIM a(26)    FOR i = 1 TO LEN(word\$)        ac = ASC(MID\$(word\$, i, 1)) - 96        IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1    NEXT    b\$ = ""    FOR i = 1 TO 26: b\$ = b\$ + LTRIM\$(STR\$(a(i))): NEXT    IF flag THEN er\$ = STR\$(VAL(er\$) - 1)    IF flag <> 1 THEN order\$ = b\$ ELSE order\$ = er\$ END FUNCTION``` Attached Files Thumbnail(s) B += x bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-06-2017, 08:16 PM Sped up considerably with QSort: Code:```_TITLE "Searching for large sets of Anagrams with same characters, loading data..." DIM SHARED w\$(30000): DIM SHARED er\$: er\$ = "999" index = 0: t = TIMER OPEN "unixdict.txt" FOR INPUT AS #1 WHILE NOT (EOF(1))    INPUT #1, wd\$    IF LEN(wd\$) > 2 THEN index = index + 1: w\$(index) = order\$(wd\$) + "!" + wd\$ WEND CLOSE #1 QSort 0, index FOR i = 1 TO index - 1    IF first\$(w\$(i)) = first\$(w\$(i + 1)) AND flag THEN b\$ = b\$ + ", " + w2\$(w\$(i + 1)): cnt = cnt + 1    IF first\$(w\$(i)) = first\$(w\$(i + 1)) AND flag = 0 THEN b\$ = w2\$(w\$(i)) + ", " + w2\$(w\$(i + 1)): cnt = 2: flag = -1    IF first\$(w\$(i)) <> first\$(w\$(i + 1)) THEN        IF cnt > 4 THEN PRINT b\$        cnt = 0: b\$ = "": flag = 0    END IF NEXT PRINT "Done !!! "; TIMER - t FUNCTION order\$ (word\$)    DIM a(26)    FOR i = 1 TO LEN(word\$)        ac = ASC(MID\$(word\$, i, 1)) - 96        IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1    NEXT    b\$ = ""    FOR i = 1 TO 26: b\$ = b\$ + LTRIM\$(STR\$(a(i))): NEXT    IF flag THEN er\$ = STR\$(VAL(er\$) - 1)    IF flag <> 1 THEN order\$ = b\$ ELSE order\$ = er\$ END FUNCTION SUB QSort (Start, Finish)    i = Start: j = Finish: x\$ = w\$(INT((i + j) / 2))    WHILE i <= j        WHILE w\$(i) < x\$: i = i + 1: WEND        WHILE w\$(j) > x\$: j = j - 1: WEND        IF i <= j THEN            a\$ = w\$(i): w\$(i) = w\$(j): w\$(j) = a\$            i = i + 1: j = j - 1        END IF    WEND    IF j > Start THEN QSort Start, j    IF i < Finish THEN QSort i, Finish END SUB FUNCTION first\$ (wd\$)    first\$ = MID\$(wd\$, 1, INSTR(wd\$, "!") - 1) END FUNCTION FUNCTION w2\$ (wd\$)    w2 = MID\$(wd\$, INSTR(wd\$, "!") + 1) END FUNCTION``` Attached Files Thumbnail(s) B += x bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-07-2017, 11:21 AM This post was last modified: 12-07-2017, 11:23 AM by bplus.Edited 0 times Shaved off some more time: Code:```_TITLE "Searching for large sets of Anagrams with same characters, loading data..." 'anagrams3 is starting to adapt to data, 'there are no 5 set anagrams of 3 letters nor of digits or apostrophes 'so they are not added to the word list to sort. 'The word coding has also been shortened. 'Multiple IF's reduced to IF THEN ELSEIF ELSE where ever possible. 'No calls to subs or functions except the recursive QSort routine. DIM SHARED w\$(24200) index = 0: t = TIMER OPEN "unixdict.txt" FOR INPUT AS #1 WHILE NOT (EOF(1))    INPUT #1, wd\$    'don't bother with 3 letter words even though possibe to have 6 permutations there are none of 5 or more    IF LEN(wd\$) > 3 THEN        REDIM a(26): flag = 0        FOR i = 1 TO LEN(wd\$)            ac = ASC(MID\$(wd\$, i, 1)) - 96            IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1: EXIT FOR        NEXT        'don't code and store a word unless all letters, no digits or apostrophes        IF flag = 0 THEN            b\$ = "": zc = 0            'zc zero counts replaces strings of 0's with a letter according to how many in string            'this shortens the strings considerably before the sort            FOR i = 1 TO 26                IF a(i) = 0 THEN                    zc = zc + 1                ELSE                    IF zc > 0 THEN b\$ = b\$ + CHR\$(96 + zc): zc = 0                    b\$ = b\$ + LTRIM\$(STR\$(a(i)))                END IF            NEXT            index = index + 1            w\$(index) = b\$ + "!" + wd\$        END IF    END IF WEND CLOSE #1 QSort 0, index flag = 0 FOR i = 1 TO index - 1    IF MID\$(w\$(i), 1, INSTR(w\$(i), "!") - 1) <> MID\$(w\$(i + 1), 1, INSTR(w\$(i + 1), "!") - 1) THEN        IF cnt > 4 THEN PRINT b\$        cnt = 0: b\$ = "": flag = 0    ELSEIF flag THEN        b\$ = b\$ + ", " + MID\$(w\$(i + 1), INSTR(w\$(i + 1), "!") + 1): cnt = cnt + 1    ELSE        b\$ = MID\$(w\$(i), INSTR(w\$(i), "!") + 1) + ", " + MID\$(w\$(i + 1), INSTR(w\$(i + 1), "!") + 1): cnt = 2: flag = -1    END IF NEXT PRINT "Done !!! "; TIMER - t SUB QSort (Start, Finish)    i = Start: j = Finish: x\$ = w\$(INT((i + j) / 2))    WHILE i <= j        WHILE w\$(i) < x\$: i = i + 1: WEND        WHILE w\$(j) > x\$: j = j - 1: WEND        IF i <= j THEN            a\$ = w\$(i): w\$(i) = w\$(j): w\$(j) = a\$            i = i + 1: j = j - 1        END IF    WEND    IF j > Start THEN QSort Start, j    IF i < Finish THEN QSort i, Finish END SUB``` Oh look, they are in alpha order again! Attached Files Thumbnail(s) B += x Adrian Huang Registered Offline This member has written at least 129 posts and created at least 9 threads on this forum since joining inJun 2015. 12-07-2017, 03:45 PM nice! can this be extended to find anagram sentences? I like to program in BASIC With code that is simple and slick I learnt it in school And it is still cool So it is my number one pick bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-08-2017, 03:34 AM RE: Anagram sentences possible? Sure, absolutely!  But the point of this thread was to find fastest most elegant code to answer the Rosetta Code challenge. I was attempting a version in QB64.  For me, it is like the Phillips tutorial to speed up Mandelbrot.  I was hoping people would pitch in and show off their tricks with memory. It would be cool to see QB64 represented at Rosetta Code. B += x bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-08-2017, 11:07 AM This post was last modified: 12-08-2017, 01:19 PM by bplus.Edited 0 times Yeah! I have below the 1 sec mile stone! Code:```_TITLE "Rosetta Code Anagrams: mod #4 by bplus 2017-12-07" 'anagrams4 the word coding has also been shortened again! 'GET file in one gulp = buf\$ and then find words 'Multiple IF's reduced to IF THEN ELSEIF ELSE where ever possible. 'No calls to subs or functions except the recursive QSort routine. 'FOR... NEXT replaced with WHILE... WEND DIM SHARED w\$(24200) index = 0: t = TIMER OPEN "unixdict.txt" FOR BINARY AS #1 fl = LOF(1): buf\$ = SPACE\$(fl) GET #1, , buf\$ CLOSE #1 p = 1 WHILE p < fl    np = INSTR(p, buf\$, CHR\$(10))    wd\$ = MID\$(buf\$, p, np - p)    IF LEN(wd\$) > 2 THEN        REDIM a(26): flag = 0: i = 1        WHILE i <= LEN(wd\$)            ac = ASC(MID\$(wd\$, i, 1)) - 96            IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1: EXIT WHILE            i = i + 1        WEND        'don't code and store a word unless all letters, no digits or apostrophes        IF flag = 0 THEN            b\$ = "": i = 1            WHILE i < 27                IF a(i) <> 0 THEN b\$ = b\$ + STRING\$(a(i), CHR\$(96 + i))                i = i + 1            WEND            index = index + 1            w\$(index) = b\$ + "!" + wd\$        END IF    END IF    IF np THEN p = np + 1 ELSE p = fl WEND QSort 0, index flag = 0 WHILE i < index    IF MID\$(w\$(i), 1, INSTR(w\$(i), "!") - 1) <> MID\$(w\$(i + 1), 1, INSTR(w\$(i + 1), "!") - 1) THEN        IF cnt > 4 THEN PRINT b\$        cnt = 0: b\$ = "": flag = 0    ELSEIF flag THEN        b\$ = b\$ + ", " + MID\$(w\$(i + 1), INSTR(w\$(i + 1), "!") + 1): cnt = cnt + 1    ELSE        b\$ = MID\$(w\$(i), INSTR(w\$(i), "!") + 1) + ", " + MID\$(w\$(i + 1), INSTR(w\$(i + 1), "!") + 1): cnt = 2: flag = -1    END IF    i = i + 1 WEND PRINT "Done !!! "; TIMER - t SUB QSort (Start, Finish)    i = Start: j = Finish: x\$ = w\$(INT((i + j) / 2))    WHILE i <= j        WHILE w\$(i) < x\$: i = i + 1: WEND        WHILE w\$(j) > x\$: j = j - 1: WEND        IF i <= j THEN            a\$ = w\$(i): w\$(i) = w\$(j): w\$(j) = a\$            i = i + 1: j = j - 1        END IF    WEND    IF j > Start THEN QSort Start, j    IF i < Finish THEN QSort i, Finish END SUB``` EDIT: I changed the word length checks to > 2 letters from > 3, apparently it doesn't take significantly longer time to check all words 3 letters long with the rest. Even though I know there are NOT any 3 letter words with an anagram set of 5 or more, it might be a kind of cheat to use that info. Theoretically a 3 letter word could have total of 6 permutations, all words in unixdict.txt. Screen shot shows new time (pretty much same as previous screen shot before edit.) Attached Files Thumbnail(s) B += x eoredson Programmer Elite Offline This member has written at least 239 posts and created at least 60 threads on this forum since joining inNov 2017. 12-08-2017, 12:40 PM Can you make some Palindromes too?? dndbbs project: Links to my MUD: (strictly 16-bit); AKA XP: Dndbbs executables http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip Dndbbs source http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip Dndbbs upgrade http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip DNDDOOR - DUNGEON - https://bit.ly/EriksDungeon Interpreter - Hex Editor - Utilities -  QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: -  bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-08-2017, 01:14 PM Hi Erik, That sounds like fun! I will get right on that. I tried Steve's Mem Sort to see if it would work faster than the QSort and though it worked, it was not faster. It did require fixed length strings and the longest word was 22 characters. So I had to fix the length of the array to sort at 45 the longest word *2 + 1 for the coding divider between the coded word and the actual word. As I recall it took over a sec. Then I tried for a fixed length of 11, yes much faster and I think all the correct answers did appear with all the extra garbage that was printed . 82 secs, still not faster! So unless there is a faster way to sort a variable length string array, I am done with this Rosetta Code challenge. There might be a faster sort because the version of QSort I used is recursive and I've heard that isn't always the fastest. B += x Adrian Huang Registered Offline This member has written at least 129 posts and created at least 9 threads on this forum since joining inJun 2015. 12-08-2017, 11:27 PM This post was last modified: 12-08-2017, 11:33 PM by Adrian Huang.Edited 0 times hi bplus, I tried running anagrams4.bas but it doesn't print out any words. Only a timing that's close to zero seconds. I like to program in BASIC With code that is simple and slick I learnt it in school And it is still cool So it is my number one pick bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-09-2017, 03:56 AM Hi Adrian, I am shaking my head, not a single indication that no file has been loaded, the whole thing runs fine whether there is a file to check or not. But hey! look at the time! (see screen shot) So my guess is you are running this without getting the file from Rosetta Code link at start of this thread. Just for you, here is unixdict.txt, 25104 words. I used same file for Palindromes. Attached Files Thumbnail(s)  unixdict.txt (Size: 201.57 KB / Downloads: 6) B += x bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-09-2017, 07:36 AM Oh criminy! the most obvious speed trick of them all, proper types! Code:```_TITLE "Rosetta Code Anagrams: mod #4.1 by bplus 2017-12-08" 'anagrams4_1 oh hey integers and other exact types 'anagrams4 the word coding has also been shortened again! 'GET file in one gulp = buf\$ and then find words 'Multiple IF's reduced to IF THEN ELSEIF ELSE where ever possible. 'No calls to subs or functions except the recursive QSort routine. 'FOR... NEXT replaced with WHILE... WEND DEFINT A-Z DIM SHARED w\$(25100) index = 0: t! = TIMER OPEN "unixdict.txt" FOR BINARY AS #1 fl& = LOF(1): buf\$ = SPACE\$(fl& GET #1, , buf\$ CLOSE #1 p& = 1 WHILE p& < fl&    np& = INSTR(p&, buf\$, CHR\$(10))    wd\$ = MID\$(buf\$, p&, np& - p&    IF LEN(wd\$) > 2 THEN        REDIM a(26): flag = 0: i = 1        WHILE i <= LEN(wd\$)            ac = ASC(MID\$(wd\$, i, 1)) - 96            IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1: EXIT WHILE            i = i + 1        WEND        'don't code and store a word unless all letters, no digits or apostrophes        IF flag = 0 THEN            b\$ = "": i = 1            WHILE i < 27                IF a(i) <> 0 THEN b\$ = b\$ + STRING\$(a(i), CHR\$(96 + i))                i = i + 1            WEND            index = index + 1            w\$(index) = b\$ + "!" + wd\$        END IF    END IF    IF np& THEN p& = np& + 1 ELSE p& = fl& WEND QSort 0, index flag = 0 WHILE i < index    IF MID\$(w\$(i), 1, INSTR(w\$(i), "!") - 1) <> MID\$(w\$(i + 1), 1, INSTR(w\$(i + 1), "!") - 1) THEN        IF cnt > 4 THEN PRINT b\$        cnt = 0: b\$ = "": flag = 0    ELSEIF flag THEN        b\$ = b\$ + ", " + MID\$(w\$(i + 1), INSTR(w\$(i + 1), "!") + 1): cnt = cnt + 1    ELSE        b\$ = MID\$(w\$(i), INSTR(w\$(i), "!") + 1) + ", " + MID\$(w\$(i + 1), INSTR(w\$(i + 1), "!") + 1): cnt = 2: flag = -1    END IF    i = i + 1 WEND PRINT "Done !!! "; TIMER - t! SUB QSort (Start, Finish)    i = Start: j = Finish: x\$ = w\$(INT((i + j) / 2))    WHILE i <= j        WHILE w\$(i) < x\$: i = i + 1: WEND        WHILE w\$(j) > x\$: j = j - 1: WEND        IF i <= j THEN            a\$ = w\$(i): w\$(i) = w\$(j): w\$(j) = a\$            i = i + 1: j = j - 1        END IF    WEND    IF j > Start THEN QSort Start, j    IF i < Finish THEN QSort i, Finish END SUB``` Attached Files Thumbnail(s) B += x Adrian Huang Registered Offline This member has written at least 129 posts and created at least 9 threads on this forum since joining inJun 2015. 12-09-2017, 02:51 PM This post was last modified: 12-09-2017, 02:55 PM by Adrian Huang.Edited 0 times hi bplus, Thanks for the mod, I think some closed brackets are missing on lines 12 and 18 in your code snippet. Yes, I downloaded the Unixdict.txt file and anagram1.bas to anagram3.bas worked fine. However, I'm still not seeing words printed for anagram4.1, only "Done!!! 0.0546785" Cheers! I like to program in BASIC With code that is simple and slick I learnt it in school And it is still cool So it is my number one pick bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-10-2017, 03:25 AM This post was last modified: 12-10-2017, 03:27 AM by bplus.Edited 0 times Hi Adrian and all,  I tried running the a copy / paste of Anagrams4_1.bas with lines 12 and 18 corrected on build /82 and Walter's QB64 both worked fine. Do you use Windows? Here is a zip copy of my State of Art Anagram programs 4_1 and 6 with a non recursive Quick Sort and \$CHECKING FF both the source code and exe's are included with the txt file. On my machine I am getting around .6 secs for 4_1 and  <.5 to <.6 for Anagrams6.exe. What kind of results do you get? Attached Files anagram package.zip (Size: 1.09 MB / Downloads: 5) B += x Adrian Huang Registered Offline This member has written at least 129 posts and created at least 9 threads on this forum since joining inJun 2015. 12-10-2017, 03:52 PM Hi bplus, Thanks. Everything works fine now. My timing for 4_1 and 6 is 0.109375 secs I like to program in BASIC With code that is simple and slick I learnt it in school And it is still cool So it is my number one pick bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-10-2017, 04:22 PM Thanks Adrian, I appreciate the feedback! B += x bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 12-15-2017, 03:19 AM Hi Adrian and all,  I had reworked Anagrams employing several lessons from Steve's example and my version is now down to under .4 secs (when take average in 100 runs) on my dinosaur thanks to his example! I have more thoroughly commented the code and used more self documenting variable names to help tell the story of what is going on. But I was blown away by Steve's version, I didn't think it necessary to post my latest version which I think I would prefer to represent QB64 at Rosetta Code, if Steve's example were to be accompanied by a much slower version. I leave this in Adrian's court since he got the ball going with Rosetta Code way sooner than I was expecting. I think Steve's version "wins" getting the most impressive results and btw I think the output should be posted with his code. Code:```\$CHECKING:OFF ' Warning: Keep the above line commented out until you know your newly edited code works. '          You can NOT stop a program in mid run (using top right x button) with checkng off. ' _TITLE "Rosetta Code Anagrams: mod Waltersmind's - Single Color LED sign with scrolling letters Best times yet w/o memory techniques by bplus 2017-12-12" ' This program now below .4 secs for average time to do 100 loops compared to 92 secs for 1 ' loop on my "dinosaur" when I first coded a successful run. ' ' Steve McNeil at QB64.net has +7000 loops per sec on his machine with help of using ' memory techniques.  see page 3 @  http://www.qb64.net/forum/index.php?topic=14622.30 ' ' Thanks Steve! I learned allot and am NOW very motivated to learn memory techniques. ' ' This program has timings for 1 loop broken into sections currently commented out and another ' set of timings for multiple loop testing currently set, now at 100 tests for a sort of average. ' But average is misleading, the first test is usually always the longest and really only one test ' is necessary to get the results from a data file that does not change. ' ' Breaking code into logical sections and timing those can help spot trouble areas or the difference ' in a small or great change. ' ' Here is review of speed tips commented as they occur in code: ' DEFINT A-Z 'there are 25,105 words in the unixdict.txt file so main array index '           and pointers in sort can all be integers. ' The letters from a word read in from the dictionary file (really just a word list in alpha order) ' are to be counted and coded into an alpha order sequence of letters: '       eg.  eilv is the same code for words: evil, levi, live, veil, vile ' The longest word in the file had 22 letters, they are all lower case but there are other symbols ' in file like ' and digits we want to filter out. TYPE wordData     code AS STRING * 22     theWord AS STRING * 22 END TYPE ' I originally was coding a word into the whole list (array) of letter counts as a string. ' Then realized I could drop all the zeros if I converted the numbers back to letters. ' I then attached THE word to the end of the coded word using ! to separate the 2 sections. ' That was allot of manipulation with INSTR to find the ! separator and then MID\$ to extract the ' code or THE word when I needed the value. All this extra manipulation ended by using TYPE with ' the code part and the word part sharing the same index. Learned from Steve's example! ' Pick the lowest number type needed to cover the problem DIM SHARED w(25105) AS wordData '  the main array DIM anagramSetsCount AS _BYTE ' the Rosetta Code Challenge was to find only the largest sets of Anagrams DIM codeCount AS _BYTE ' counting number of words with same code DIM wordIndex AS _BYTE DIM wordLength AS _BYTE DIM flag AS _BIT 'flag used as true or false DIM letterCounts(1 TO 26) AS _BYTE 'stores letter counts for coding word ' b\$  always stands for building a string. ' For long and strings, I am using the designated suffix t1# = TIMER: loops = 100 FOR test = 1 TO loops     'reset these for multiple loop tests     indexTop = 0 'indexTop for main data array     anagramSetsCount = 0 'anagrams count if exceed 4 for any one code     anagramList\$ = "" 'list of anagrams     'get the file data loaded in one pop, disk access is slow!     OPEN "unixdict.txt" FOR BINARY AS #1     ' http://www.puzzlers.org/pub/wordlists/unixdict.txt     ' note: when I downloaded this file line breaks were by chr\$(10) only.     ' Steve had coded for either chr\$(13) + chr\$(10) or just chr\$(10)     fileLength& = LOF(1): buf\$ = SPACE\$(fileLength&)     GET #1, , buf\$     CLOSE #1     ' Getting the data into a big long string saved allot of time as compared to     ' reading from the file line by line.     'Process the file data by extracting the word from the long file string and then     'coding each word of interest, loading up the w() array.     filePosition& = 1     WHILE filePosition& < fileLength&         nextPosition& = INSTR(filePosition&, buf\$, CHR\$(10))         wd\$ = MID\$(buf\$, filePosition&, nextPosition& - filePosition&)         wordLength = LEN(wd\$)         IF wordLength > 2 THEN             'From Steve's example, changing from REDIM to ERASE saved an amzing amount of time!             ERASE letterCounts: flag = 0: wordIndex = 1             WHILE wordIndex <= wordLength                 'From Steve's example, I was not aware of this version of ASC with MID\$ built-in                 ansciChar = ASC(wd\$, wordIndex) - 96                 IF 0 < ansciChar AND ansciChar < 27 THEN letterCounts(ansciChar) = letterCounts(ansciChar) + 1 ELSE flag = 1: EXIT WHILE                 wordIndex = wordIndex + 1             WEND             'don't code and store a word unless all letters, no digits or apostrophes             IF flag = 0 THEN                 b\$ = "": wordIndex = 1                 WHILE wordIndex < 27                     IF letterCounts(wordIndex) THEN b\$ = b\$ + STRING\$(letterCounts(wordIndex), CHR\$(96 + wordIndex))                     wordIndex = wordIndex + 1                 WEND                 indexTop = indexTop + 1                 w(indexTop).code = b\$                 w(indexTop).theWord = wd\$             END IF         END IF         IF nextPosition& THEN filePosition& = nextPosition& + 1 ELSE filePosition& = fileLength&     WEND     't2# = TIMER     'PRINT t2# - t1#; " secs to load word array."     'Sort using a recursive Quick Sort routine on the code key of wordData Type defined.     QSort 0, indexTop     't3# = TIMER     'PRINT t3# - t2#; " secs to sort array."     'Now find all the anagrams, word permutations, from the same word "code" that we sorted by.     flag = 0: j = 0     WHILE j < indexTop         'Does the sorted code key match the next one on the list?         IF w(j).code <> w(j + 1).code THEN ' not matched so stop counting and add to report             IF codeCount > 4 THEN ' only want the largest sets of anagrams 5 or more                 anagramList\$ = anagramList\$ + b\$ + CHR\$(10)                 anagramSetsCount = anagramSetsCount + 1             END IF             codeCount = 0: b\$ = "": flag = 0         ELSEIF flag THEN ' match and match flag set so just add to count and build set             b\$ = b\$ + ", " + RTRIM\$(w(j + 1).theWord)             codeCount = codeCount + 1         ELSE ' no flag means first match, start counting and building a new set             b\$ = RTRIM\$(w(j).theWord) + ", " + RTRIM\$(w(j + 1).theWord)             codeCount = 2: flag = 1         END IF         j = j + 1     WEND     't4# = TIMER     'PRINT t4# - t3#; " secs to count matches from array." NEXT PRINT "Ave time per loop"; (TIMER - t1#) / loops; " secs, there were"; anagramSetsCount; " anagrams sets of 5 or more words." PRINT anagramList\$ 'This sub modified for wordData Type, to sort by the .code key, the w() array is SHARED SUB QSort (Start, Finish)     i = Start: j = Finish: x\$ = w(INT((i + j) / 2)).code     WHILE i <= j         WHILE w(i).code < x\$: i = i + 1: WEND         WHILE w(j).code > x\$: j = j - 1: WEND         IF i <= j THEN             SWAP w(i), w(j)             i = i + 1: j = j - 1         END IF     WEND     IF j > Start THEN QSort Start, j     IF i < Finish THEN QSort i, Finish END SUB``` B += x Adrian Huang Registered Offline This member has written at least 129 posts and created at least 9 threads on this forum since joining inJun 2015. 12-15-2017, 04:37 AM hi bplus, I have updated the entry in Rosetta Code with your latest version, and also added output from Steve's program. Cheers! A. I like to program in BASIC With code that is simple and slick I learnt it in school And it is still cool So it is my number one pick SMcNeill Registered Offline This member has written at least 59 posts and created at least 25 threads on this forum since joining inJun 2014. 12-15-2017, 08:01 AM That's a lot of mentions of my name up there in your code, Bp.   I had no idea that anyone had actually studied it that close, or that anyone had learned so many little things from it.  Nice to see that some people actually do take such interest in some of my stuff, and it's nice to know that I actually helped somebody, somewhere, learn and improve their understanding of the language better.   I'm happy I could be of assistance. « Next Oldest | Next Newest » 