aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

149
Task/Anagrams/QB64/anagrams-1.qb64 Normal file
View file

@ -0,0 +1,149 @@
$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 #7 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://wiki.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

145
Task/Anagrams/QB64/anagrams-2.qb64 Normal file
View file

@ -0,0 +1,145 @@
$CHECKING:OFF
SCREEN _NEWIMAGE(640, 480, 32)
_DELAY .5
_SCREENMOVE _MIDDLE
DEFLNG A-Z
TYPE DataType
Word AS _UNSIGNED INTEGER
Value AS STRING * 26
END TYPE
REDIM Words(0 TO 30000) AS DataType
REDIM WordList(0 TO 30000) AS STRING * 25
DIM Anagrams(0 TO 30000, 0 TO 10) AS LONG
DIM EndLine AS STRING, Endlength AS LONG
IF INSTR(temp$, CHR$(13)) THEN EndLine = CHR$(13) + CHR$(10) ELSE EndLine = CHR$(10)
Endlength = LEN(EndLine)
DIM t AS _FLOAT 'high precisition timer
DIM t1 AS _FLOAT
DIM letters(97 TO 122) AS _UNSIGNED _BYTE
DIM m1 AS _MEM, m2 AS _MEM, m3 AS _MEM
DIM a AS _UNSIGNED _BYTE
DIM matched(30000) AS _BYTE
m1 = _MEM(letters()): m2 = _MEM(Words()): m3 = _MEM(WordList())
blank$ = STRING$(26, 0)
t1 = TIMER
oldenter = 1
DO UNTIL TIMER - t1 > 1
t = t1
looper = looper + 1
OPEN "unixdict.txt" FOR BINARY AS #1
temp$ = SPACE$(LOF(1))
GET #1, 1, temp$ 'just grab the whole datafile from the drive in one swoop
CLOSE #1
'PRINT USING "##.###### seconds to load data from disk."; TIMER - t
t = TIMER
index = -1 'we want our first word to be indexed at 0, for ease of array/mem swappage
DO 'and parse it manually into our array
skip:
enter = INSTR(oldenter, temp$, EndLine)
IF enter THEN
l = enter - oldenter - 1
wd$ = MID$(temp$, oldenter, l)
oldenter = enter + Endlength
ELSE
wd$ = MID$(temp$, oldenter)
l = LEN(wd$)
END IF
_MEMPUT m1, m1.OFFSET, blank$ 'ERASE letters
j = 1
DO UNTIL j > l
a = ASC(wd$, j)
IF a < 97 OR a > 122 GOTO skip
letters(a) = letters(a) + 1 'and count them
j = j + 1
LOOP
index = index + 1
WordList(index) = wd$
Words(index).Word = index
_MEMCOPY m1, m1.OFFSET, 26 TO m2, m2.OFFSET + m2.ELEMENTSIZE * (index) + 2
LOOP UNTIL enter = 0
CLOSE #1
'PRINT USING "##.###### seconds to parse data into array."; TIMER - t
t = TIMER
combsort Words(), index
i = 1
DO UNTIL i > index
IF matched(i) = 0 THEN
count = 0
DO
count = count + 1
c = i + count
IF c > index THEN EXIT DO
IF _STRICMP(Words(i).Value, Words(c).Value) <> 0 THEN EXIT DO
Anagrams(anagram_count, count) = c
matched(c) = -1
LOOP
IF count > 1 THEN
Anagrams(anagram_count, 0) = i
Anagrams(anagram_count, 10) = count
i = c - 1
anagram_count = anagram_count + 1
END IF
END IF
i = i + 1
LOOP
t2## = TIMER
'PRINT USING "##.###### seconds to make matches."; t2## - t
'PRINT USING "##.###### total time from start to finish."; t2## - t1
'PRINT
LOOP
$CHECKING:ON
PRINT "LOOPER:"; looper; "executions from start to finish, in one second."
PRINT "Note, this is including disk access for new data each time."
PRINT
PRINT USING "#.################ seconds on average to run"; 1## / looper
INPUT "Anagram Pool Limit Size (Or larger) =>"; limit
IF limit < 1 THEN END
FOR i = 0 TO anagram_count - 1
v = Anagrams(i, 10)
IF v >= limit THEN
FOR j = 0 TO v
SELECT CASE j
CASE 0
CASE v: PRINT
CASE ELSE: PRINT ", ";
END SELECT
PRINT LEFT$(WordList(Words(Anagrams(i, j)).Word), INSTR(WordList(Words(Anagrams(i, j)).Word), " "));
NEXT
END IF
NEXT
END
SUB combsort (array() AS DataType, index AS LONG)
DIM gap AS LONG
'This is the routine I tend to use personally and promote.
'It's short, simple, and easy to implement into code.
gap = index
DO
gap = INT(gap / 1.247330925103979)
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
IF array(i).Value > array(i + gap).Value THEN
SWAP array(i), array(i + gap)
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > index
LOOP UNTIL gap = 1 AND swapped = 0
END SUB

11
Task/Anagrams/QB64/anagrams-3.qb64 Normal file
View file

@ -0,0 +1,11 @@
LOOPER: 7134 executions from start to finish, in one second.
Note, this is including disk access for new data each time.
0.000140138155313 seconds on average to run
Anagram Pool Limit Size (or larger) =>? 5
veil, levi, live, vile, evil
lane, neal, lean, lena, elan
alger, lager, large, glare, regal
glean, angel, galen, angle, lange
caret, trace, crate, carte, cater
bale, abel, able, elba, bela