Recent Posts

Pages: [1] 2 3 ... 10
1
Code and examples / Re: Anagrams
« Last post by Mike Lobanovsky on 13. December 2017, 15:20:37 »
Pretty impressive! I mean, very impressive even if not particularly pretty. :)
2
Code and examples / Re: Anagrams
« Last post by B+ on 13. December 2017, 07:06:09 »
Steve McNeil has Anagrams running very fast with QB64.

3rd page @ http://www.qb64.net/forum/index.php?topic=14622.30
3
Code and examples / Re: Anagrams
« Last post by Mike Lobanovsky on 13. December 2017, 04:41:23 »
However, the generated C code uses the standard libc system header files and links to libc...  :-\

But that's perfectly legal in the context of RosettaCode challenges! And so does my C code by the way; it's just that it compiles directly in memory on program load using standard windows.h and stdio.h system headers and links against msvcrt.dll that's a Windows-specific dynamic analog to your libc static library. :)
4
Code and examples / Re: Anagrams
« Last post by Peter on 12. December 2017, 20:06:36 »
Thanks Mike - at least I'm not importing any particular language specific modules. However, the generated C code uses the standard libc system header files and links to libc...  :-\
5
Code and examples / Re: Anagrams
« Last post by Mike Lobanovsky on 12. December 2017, 13:43:04 »
Looks very elegant, Peter! Leaves no chance for Ruby, does it?  :)
6
Code and examples / Re: Anagrams
« Last post by Peter on 11. December 2017, 14:15:12 »
Maybe not the fastest (approx 3.8 seconds) but the shortest on this page until now....

Code: [Select]
OPTION COLLAPSE TRUE

DECLARE idx$ ASSOC STRING

FOR w$ IN LOAD$("unixdict.txt") STEP NL$

    SPLIT w$ BY 1 TO letter$ SIZE length
    SORT letter$ SIZE length
    JOIN letter$ TO set$ SIZE length

    idx$(set$) = APPEND$(idx$(set$), 0, w$)
    total = AMOUNT(idx$(set$))

    IF MaxCount < total THEN MaxCount = total
NEXT

PRINT "Analyzing took ", TIMER, " msecs.", NL$

LOOKUP idx$ TO name$ SIZE x
FOR y = 0 TO x-1
    IF MaxCount = AMOUNT(idx$(name$[y])) THEN PRINT name$[y], ": ", idx$(name$[y])
NEXT

7
The game ended up massively more complex to implement so it won't be ready in time :)
8
Hi D, any progress?
9
Code and examples / Re: Anagrams
« Last post by B+ on 08. December 2017, 22:39:41 »
Criminy!
Code: [Select]
_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
10
Code and examples / Re: Anagrams
« Last post by B+ on 08. December 2017, 03:46:10 »
OK well under a sec! and pretending not to know there aren't any large 3 letter word sets (with 5 or 6 permutations that are words), ie taking the time to test all words that could have 4 or more anagrams.
Code: [Select]
_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$(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
Pages: [1] 2 3 ... 10