RosettaCodeData/Task/Anagrams/QB64/anagrams-2.qb64
2023-07-01 13:44:08 -04:00

145 lines
4.1 KiB
Text

$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