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

June 2018 Update

Browse source
This commit is contained in:
Ingy döt Net 2018-06-22 20:57:24 +00:00
parent ba8067c3b7
commit 22f33d4004
5278 changed files with 84726 additions and 14379 deletions
Download patch file Download diff file Expand all files Collapse all files

7
Task/Anagrams/APL/anagrams-1.apl Normal file
View file

@ -0,0 +1,7 @@
anagrams←{
tie←⍵ ⎕NTIE 0
dict←⎕NREAD tie 80(⎕NSIZE tie)0
boxes←((⎕UCS 10)≠dict)⊆dict
ana←(({⍵[⍋⍵]}¨boxes)({⍵}⌸)boxes)
({~' '∊¨(⊃/¯1↑[2]⍵)}ana)⌿ana ⋄ ⎕NUNTIE
}

2
Task/Anagrams/APL/anagrams-2.apl Normal file
View file

@ -0,0 +1,2 @@
⎕SH'wget http://www.puzzlers.org/pub/wordlists/unixdict.txt'
]display anagrams 'unixdict.txt'

20
Task/Anagrams/BaCon/anagrams.bacon Normal file
View file

@ -0,0 +1,20 @@
OPTION COLLAPSE TRUE
DECLARE idx$ ASSOC STRING
FOR w$ IN LOAD$("unixdict.txt") STEP NL$
set$ = SORT$(EXPLODE$(w$, 1))
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 n$ SIZE x
FOR y = 0 TO x-1
IF MaxCount = AMOUNT(idx$(n$[y])) THEN PRINT n$[y], ": ", idx$(n$[y])
NEXT

3
Task/Anagrams/Clojure/anagrams-2.clj
View file

@ -1,9 +1,8 @@
(->> (slurp "http://www.puzzlers.org/pub/wordlists/unixdict.txt")
(apply str)
clojure.string/split-lines
(group-by sort)
vals
(sort-by count #(compare %2 %1)) ;; sort in reverse
(sort-by count >) ;; sort in reverse
(partition-by count)
first)

11
Task/Anagrams/Elena/anagrams.elena
View file

@ -1,26 +1,25 @@
import system'routines.
import system'calendar.
import system'io.
import system'collections.
import extensions.
import extensions'routines.
import extensions'text.
extension op
{
normalized
= self toArray; ascendant; summarize(String new); literal.
= self toArray; ascendant; summarize(StringWriter new); literal.
}
symbol program =
public program =
[
var aDictionary := Dictionary new.
File new("unixdict.txt"); forEachLine(:aWord)
[
var s := aWord.
var aKey := aWord normalized.
var anItem := aDictionary[aKey].
if ($nil == anItem)
if (nil == anItem)
[
anItem := ArrayList new.
aDictionary[aKey] := anItem.
@ -29,7 +28,7 @@ symbol program =
anItem append:aWord.
].
aDictionary array_list;
aDictionary values;
sort(:aFormer:aLater)( aFormer length > aLater length );
top:20; forEach(:aPair)[ console printLine(aPair value) ].

21
Task/Anagrams/Julia/anagrams.julia
View file

@ -1,15 +1,16 @@
url = "http://www.puzzlers.org/pub/wordlists/unixdict.txt"
wordlist = open(readlines, download(url))
wsort(word) = join(sort(collect(word)))
wsort(word::AbstractString) = join(sort(collect(word)))
function anagram(wordlist)
hash = Dict() ; ananum = 0
for word in wordlist
sorted = wsort(word)
hash[sorted] = [ get(hash, sorted, []); word ]
ananum = max(length(hash[sorted]), ananum)
end
collect(values(filter((x,y)-> length(y) == ananum, hash)))
function anagram(wordlist::Vector{<:AbstractString})
dict = Dict{String, Set{String}}()
for word in wordlist
sorted = wsort(word)
push!(get!(dict, sorted, Set{String}()), word)
end
wcnt = maximum(length, values(dict))
return collect(Iterators.filter((y) -> length(y) == wcnt, values(dict)))
end
println.(anagram(wordlist))

12
Task/Anagrams/Oforth/anagrams.oforth
View file

@ -1,5 +1,11 @@
import: mapping
import: collect
import: quicksort
: anagrams
| m |
File new("unixdict.txt") groupBy(#sort)
dup sortBy(#[ second size]) last second size ->m
filter(#[ second size m == ]) apply(#[ second .cr ]) ;
"unixdict.txt" File new groupBy( #sort )
dup sortBy( #[ second size] ) last second size ->m
filter( #[ second size m == ] )
apply ( #[ second .cr ] )
;

34
Task/Anagrams/REXX/anagrams-1.rexx
View file

@ -1,30 +1,30 @@
/*REXX program finds words with the largest set of anagrams (of the same size). */
iFID= 'unixdict.txt' /*the dictionary input File IDentifier.*/
$=; !.=; #.=0; w=0; uw=0; most=0 /*initialize a bunch of REXX variables.*/
$=; !.=; ww=0; uw=0; most=0 /*initialize a bunch of REXX variables.*/
/* [↓] read the entire file (by lines)*/
do while lines(iFID)\==0 /*Got any data? Then read a record. */
@=space( linein(iFID), 0) /*pick off a word from the input line. */
L=length(@); if L<3 then iterate /*onesies and twosies words can't win. */
if \datatype(@, 'M') then iterate /*ignore any non─anagramable words. */
uw=uw+1 /*count of the (useable) words in file.*/
z=sortA(@) /*sort the letters in the word. */
!.z=!.z @; #.z=#.z+1 /*append it to !.z; bump the counter. */
if #.z>most then do; $=z; most=#.z; if L>w then w=L; iterate; end
if #.z==most then $=$ z /*append the sorted word──► max anagram*/
do while lines(iFID) \== 0 /*Got any data? Then read a record. */
parse value linein(iFID) with @ . /*obtain a word from an input line. */
len=length(@); if len<3 then iterate /*onesies and twosies words can't win. */
if \datatype(@, 'M') then iterate /*ignore any non─anagramable words. */
uw=uw + 1 /*count of the (useable) words in file.*/
_=sortA(@) /*sort the letters in the word. */
!._=!._ @; #=words(!._) /*append it to !._; bump the counter. */
if #==most then $=$ _ /*append the sorted word──► max anagram*/
else if #>most then do; $=_; most=#; if len>ww then ww=len; end
end /*while*/ /*$ ◄── list of high count anagrams. */
say '─────────────────────────' uw "useable words in the dictionary file: " iFID
say '─────────────────────────' uw "usable words in the dictionary file: " iFID
say
do m=1 for words($); z=subword($, m, 1) /*the high count of the anagrams. */
say ' ' left(subword(!.z, 1, 1), w) ' [anagrams: ' subword(!.z, 2)"]"
say ' ' left(word(!.z, 1), ww) ' [anagrams: ' subword(!.z, 2)"]"
end /*m*/ /*W is the maximum width of any word.*/
say
say '───── Found' words($) "words (each of which have" #.z-1 'anagrams).'
say '───── Found' words($) "words (each of which have" words(!.z)-1 'anagrams).'
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
sortA: procedure; arg char +1 xx,@. /*get the first letter of arg; @.=null*/
sortA: arg char 2 xx,@. /*get the first letter of arg; @.=null*/
@.char=char /*no need to concatenate the first char*/
/*[↓] sort/put letters alphabetically.*/
do length(xx); parse var xx char +1 xx; @.char=@.char || char; end
do length(xx); parse var xx char 2 xx; @.char=@.char || char; end
/*reassemble word with sorted letters. */
return @.a||@.b||@.c||@.d||@.e||@.f||@.g||@.h||@.i||@.j||@.k||@.l||@.m||,
@.n||@.o||@.p||@.q||@.r||@.s||@.t||@.u||@.v||@.w||@.x||@.y||@.z
return @.a || @.b || @.c || @.d || @.e || @.f||@.g||@.h||@.i||@.j||@.k||@.l||@.m||,
@.n || @.o || @.p || @.q || @.r || @.s||@.t||@.u||@.v||@.w||@.x||@.y||@.z

49
Task/Anagrams/REXX/anagrams-2.rexx
View file

@ -1,27 +1,30 @@
/*REXX program finds words with the largest set of anagrams (of the same size). */
iFID= 'unixdict.txt' /*the dictionary input File IDentifier.*/
$=; !.=; #.=0; ww=0; uw=0; most=0 /*initialize a bunch of REXX variables.*/
$=; !.=; ww=0; uw=0; most=0 /*initialize a bunch of REXX variables.*/
/* [↓] read the entire file (by lines)*/
do while lines(iFID)\==0 /*Got any data? Then read a record. */
@=space( linein(iFID), 0) /*pick off a word from the input line. */
LL=length(@); if LL<3 then iterate /*onesies and twosies (words) can't win*/
if \datatype(@, 'M') then iterate /*ignore any non─anagramable words. */
uw=uw+1 /*count of the (useable) words in file.*/
parse upper var @ _ +1 xx @. /*get uppercase @ and nullify @. */
@._=_ /*get the first letter (special case). */
/*[↓] sort/put letters alphabetically.*/
do LL-1; parse var xx _ +1 xx; @._=@._||_; end /*get the rest of the word.*/
/*reassemble word with sorted letters. */
zz=@.a||@.b||@.c||@.d||@.e||@.f||@.g||@.h||@.i||@.j||@.k||@.l||@.m||,
@.n||@.o||@.p||@.q||@.r||@.s||@.t||@.u||@.v||@.w||@.x||@.y||@.z
!.zz=!.zz @; #.zz=#.zz+1 /*append it to !.zz; bump the counter.*/
if #.zz>most then do; $=zz; most=#.zz; if LL>ww then ww=LL; iterate; end
if #.zz==most then $=$ zz /*append the sorted word──► $ anagrams.*/
end /*while*/
say '─────────────────────────' uw "useable words in the dictionary file: " iFID
do while lines(iFID) \== 0 /*Got any data? Then read a record. */
parse value linein(iFID) with @ . /*obtain a word from an input line. */
len=length(@); if len<3 then iterate /*onesies and twosies words can't win. */
if \datatype(@, 'M') then iterate /*ignore any non─anagramable words. */
uw=uw + 1 /*count of the (useable) words in file.*/
_=sortA(@) /*sort the letters in the word. */
!._=!._ @; #=words(!._) /*append it to !._; bump the counter. */
if #==most then $=$ _ /*append the sorted word──► max anagram*/
else if #>most then do; $=_; most=#; if len>ww then ww=len; end
end /*while*/ /*$ ◄── list of high count anagrams. */
say '─────────────────────────' uw "usable words in the dictionary file: " iFID
say
do m=1 for words($); z=subword($,m,1) /*the high count of the anagrams. */
say ' ' left(subword(!.z, 1, 1), ww) " [anagrams: " subword(!.z,2)"]"
end /*m*/ /*WW is the maximum width of any word.*/
say /*stick a fork in it, we're all done. */
say '───── Found' words($) "words (each of which have" #.z-1 'anagrams).'
do m=1 for words($); z=subword($, m, 1) /*the high count of the anagrams. */
say ' ' left(word(!.z, 1), ww) ' [anagrams: ' subword(!.z, 2)"]"
end /*m*/ /*W is the maximum width of any word.*/
say
say '───── Found' words($) "words (each of which have" words(!.z)-1 'anagrams).'
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
sortA: arg char 2 xx,@. /*get the first letter of arg; @.=null*/
@.char=char /*no need to concatenate the first char*/
/*[↓] sort/put letters alphabetically.*/
do length(xx); parse var xx char 2 xx; @.char=@.char || char; end
/*reassemble word with sorted letters. */
return @.a || @.b || @.c || @.d || @.e || @.f||@.g||@.h||@.i||@.j||@.k||@.l||@.m||,
@.n || @.o || @.p || @.q || @.r || @.s||@.t||@.u||@.v||@.w||@.x||@.y||@.z

50
Task/Anagrams/REXX/anagrams-3.rexx
View file

@ -1,27 +1,23 @@
/*REXX program finds words with the largest set of anagrams (of the same size). */
iFID= 'unixdict.txt' /*the dictionary input File IDentifier.*/
$=; !.=; #.=0; ww=0; uw=0; most=0 /*initialize a bunch of REXX variables.*/
/* [↓] read the entire file (by lines)*/
do while lines(iFID)\==0 /*Got any data? Then read a record. */
@=space( linein(iFID), 0) /*pick off a word from the input line. */
LL=length(@); if LL<3 then iterate /*onesies and twosies (words) can't win*/
if \datatype(@, 'M') then iterate /*ignore any non─anagramable words. */
uw=uw+1 /*count of the (useable) words in file.*/
parse upper var @ _ +1 xx . @. /*get uppercase @ and nullify @. */
@._=_ /*get the first letter (special case). */
/*[↓] sort/put letters alphabetically.*/
do LL-1; parse var xx _ +1 xx; @._=@._ || _; end /*get rest of the word*/
/*reassemble word with sorted letters. */
zz=@.a|| @.b|| @.c|| @.d|| @.e|| @.f|| @.g|| @.h|| @.i|| @.j|| @.k|| @.l|| @.m ||,
@.n|| @.o|| @.p|| @.q|| @.r|| @.s|| @.t|| @.u|| @.v|| @.w|| @.x|| @.y|| @.z
!.zz=!.zz @; #.zz=#.zz+1 /*append it to !.zz; bump the counter.*/
if #.zz>most then do; $=zz; most=#.zz; if LL>ww then ww=LL; iterate; end
if #.zz==most then $=$ zz /*append the sorted word──► $ anagrams.*/
end /*while*/
say '─────────────────────────' uw 'useable words in the dictionary file: ' iFID
say
do m=1 for words($); z=subword($, m, 1) /*the high count of the anagrams. */
say ' ' left(subword(!.z, 1, 1), ww) " [anagrams: " subword(!.z, 2)']'
end /*m*/ /*WW is the maximum width of any word.*/
say /*stick a fork in it, we're all done. */
say '───── Found' words($) "words (each of which have" #.z-1 'anagrams).'
u= 'Halloween' /*word to be sorted by (Latin) letter.*/
upper u /*fast method to uppercase a variable. */
/*another: u = translate(u) */
/*another: parse upper var u u */
/*another: u = upper(u) */
/*not always available [↑] */
say 'u=' u
_.=
do until u=='' /*keep truckin' until U is null. */
parse var u y +1 u /*get the next (first) character in U.*/
xx='?'y /*assign a prefixed character to XX. */
_.xx=_.xx || y /*append it to all the Y characters. */
end /*until*/ /*U now has the first character elided.*/
/*Note: the variable U is destroyed.*/
/* [↓] constructs a sorted letter word*/
z=_.?a||_.?b||_.?c||_.?d||_.?e||_.?f||_.?g||_.?h||_.?i||_.?j||_.?k||_.?l||_.?m||,
_.?n||_.?o||_.?p||_.?q||_.?r||_.?s||_.?t||_.?u||_.?v||_.?w||_.?x||_.?y||_.?z
/*Note: the ? is prefixed to the letter to avoid */
/*collisions with other REXX one-character variables.*/
say 'z=' z

17
Task/Anagrams/REXX/anagrams-4.rexx
View file

@ -1,23 +1,18 @@
u= 'Halloween' /*word to be sorted by (Latin) letter.*/
upper u /*fast method to uppercase a variable. */
/*another: u = translate(u) */
/*another: parse upper var u u */
/*another: u = upper(u) */
/*not always available [↑] */
L=length(u) /*get the length of the word (in bytes)*/
say 'u=' u
say 'L=' L
_.=
do until u=='' /*keep truckin' until U is null. */
parse var u y +1 u /*get the next (first) character in U.*/
do k=1 for L /*keep truckin' for L characters. */
parse var u =(k) y +1 /*get the Kth character in U string.*/
xx='?'y /*assign a prefixed character to XX. */
_.xx=_.xx || y /*append it to all the Y characters. */
end /*until*/ /*U now has the first character elided.*/
/*Note: the variable U is destroyed.*/
end /*do k*/ /*U now has the first character elided.*/
/* [↓] constructs a sorted letter word*/
/* [↓] construct a sorted letter word.*/
z=_.?a||_.?b||_.?c||_.?d||_.?e||_.?f||_.?g||_.?h||_.?i||_.?j||_.?k||_.?l||_.?m||,
_.?n||_.?o||_.?p||_.?q||_.?r||_.?s||_.?t||_.?u||_.?v||_.?w||_.?x||_.?y||_.?z
/*Note: the ? is prefixed to the letter to avoid */
/*collisions with other REXX one-character variables.*/
say 'z=' z

79
Task/Anagrams/REXX/anagrams-5.rexx
View file

@ -1,18 +1,61 @@
u= 'Halloween' /*word to be sorted by (Latin) letter.*/
upper u /*fast method to uppercase a variable. */
L=length(u) /*get the length of the word (in bytes)*/
say 'u=' u
say 'L=' L
_.=
do k=1 for L /*keep truckin' for L characters. */
parse var u =(k) y +1 /*get the Kth character in U string.*/
xx='?'y /*assign a prefixed character to XX. */
_.xx=_.xx || y /*append it to all the Y characters. */
end /*do k*/ /*U now has the first character elided.*/
/* [↓] construct a sorted letter word.*/
z=_.?a||_.?b||_.?c||_.?d||_.?e||_.?f||_.?g||_.?h||_.?i||_.?j||_.?k||_.?l||_.?m||,
_.?n||_.?o||_.?p||_.?q||_.?r||_.?s||_.?t||_.?u||_.?v||_.?w||_.?x||_.?y||_.?z
say 'z=' z
/*REXX program finds words with the largest set of anagrams (same size)
* 07.08.2013 Walter Pachl
* sorta for word compression courtesy Gerard Schildberger,
* modified, however, to obey lowercase
* 10.08.2013 Walter Pachl take care of mixed case dictionary
* following Version 1's method
**********************************************************************/
Parse Value 'A B C D E F G H I J K L M N O P Q R S T U V W X Y Z',
With a b c d e f g h i j k l m n o p q r s t u v w x y z
Call time 'R'
ifid='unixdict.txt' /* input file identifier */
words=0 /* number of usable words */
maxl=0 /* maximum number of anagrams */
wl.='' /* wl.ws words that have ws */
Do ri=1 By 1 While lines(ifid)\==0 /* read each word in file */
word=space(linein(ifid),0) /* pick off a word from the input.*/
If length(word)<3 Then /* onesies and twosies can't win. */
Iterate
If\datatype(word,'M') Then /* not an anagramable word */
Iterate
words=words+1 /* count of (useable) words. */
ws=sorta(word) /* sort the letters in the word. */
wl.ws=wl.ws word /* add word to list of ws */
wln=words(wl.ws) /* number of anagrams with ws */
Select
When wln>maxl Then Do /* a new maximum */
maxl=wln /* use this */
wsl=ws /* list of resulting ws values */
End
When wln=maxl Then /* same as the one found */
wsl=wsl ws /* add ws to the list */
Otherwise /* shorter */
Nop /* not yet of interest */
End
End
Say ' '
Say copies('-',10) ri-1 'words in the dictionary file: ' ifid
Say copies(' ',10) words 'thereof are anagram candidates'
Say ' '
Say 'There are' words(wsl) 'set(s) of anagrams with' maxl,
'elements each:'
Say ' '
Do while wsl<>''
Parse Var wsl ws wsl
Say ' 'wl.ws
End
Say time('E')
Exit
sorta:
/**********************************************************************
* sort the characters in word_p (lowercase translated to uppercase)
* 'chARa' -> 'AACHR'
**********************************************************************/
Parse Upper Arg word_p
c.=''
Do While word_p>''
Parse Var word_p cc +1 word_p
c.cc=c.cc||cc
End
Return c.a||c.b||c.c||c.d||c.e||c.f||c.g||c.h||c.i||c.j||c.k||c.l||,
c.m||c.n||c.o||c.p||c.q||c.r||c.s||c.t||c.u||c.v||c.w||c.x||c.y||c.z

16
Task/Anagrams/Red/anagrams.red Normal file
View file

@ -0,0 +1,16 @@
Red []
m: make map! [] 25000
maxx: 0
foreach word read/lines http://www.puzzlers.org/pub/wordlists/unixdict.txt [
sword: sort copy word ;; sorted characters of word
either find m sword [
append m/:sword word
maxx: max maxx length? m/:sword
] [
put m sword append copy [] word
]
]
foreach v values-of m [ if maxx = length? v [print v] ]

83
Task/Anagrams/Ring/anagrams.ring Normal file
View file

@ -0,0 +1,83 @@
# Project : Anagrams
# Date : 2017/11/28
# Author : Gal Zsolt (~ CalmoSoft ~)
# Email : <calmosoft@gmail.com>
load "stdlib.ring"
fn1 = "unixdict.txt"
fp = fopen(fn1,"r")
str = fread(fp, getFileSize(fp))
fclose(fp)
strlist = str2list(str)
anagram = newlist(len(strlist), 5)
anag = list(len(strlist))
result = list(len(strlist))
for x = 1 to len(result)
result[x] = 0
next
for x = 1 to len(anag)
anag[x] = 0
next
for x = 1 to len(anagram)
for y = 1 to 5
anagram[x][y] = 0
next
next
for n = 1 to len(strlist)
for m = 1 to len(strlist)
sum = 0
if len(strlist[n]) = 4 and len(strlist[m]) = 4 and n != m
for p = 1 to len(strlist[m])
temp1 = count(strlist[n], strlist[m][p])
temp2 = count(strlist[m], strlist[m][p])
if temp1 = temp2
sum = sum + 1
ok
next
if sum = 4
anag[n] = anag[n] + 1
if anag[n] < 6 and result[n] = 0 and result[m] = 0
anagram[n][anag[n]] = strlist[m]
result[m] = 1
ok
ok
ok
next
if anag[n] > 0
result[n] = 1
ok
next
for n = 1 to len(anagram)
flag = 0
for m = 1 to 5
if anagram[n][m] != 0
if m = 1
see strlist[n] + " "
flag = 1
ok
see anagram[n][m] + " "
ok
next
if flag = 1
see nl
ok
next
func getFileSize fp
c_filestart = 0
c_fileend = 2
fseek(fp,0,c_fileend)
nfilesize = ftell(fp)
fseek(fp,0,c_filestart)
return nfilesize
func count(astring,bstring)
cnt = 0
while substr(astring,bstring) > 0
cnt = cnt + 1
astring = substr(astring,substr(astring,bstring)+len(string(sum)))
end
return cnt

16
Task/Anagrams/Stata/anagrams.stata Normal file
View file

@ -0,0 +1,16 @@
import delimited http://www.puzzlers.org/pub/wordlists/unixdict.txt, clear
mata
a=st_sdata(.,.)
n=rows(a)
for (i=1; i<=n; i++) a[i]=char(sort(ascii(a[i])',1)')
st_addvar(st_vartype(1),"group")
st_sstore(.,2,a)
end
bysort group (v1): gen k=_N
qui sum k
keep if k==r(max)
by group: replace k=_n
reshape wide v1, i(k) j(group) string
drop k
list, noobs noheader

162
Task/Anagrams/VBA/anagrams.vba Normal file
View file

@ -0,0 +1,162 @@
Option Explicit
Public Sub Main_Anagram()
Dim varReturn
Dim temp
Dim strContent As String
Dim strFile As String
Dim Num As Long
Dim i As Long
Dim countTime As Single
'Open & read txt file
Num = FreeFile
strFile = "C:\Users\" & Environ("Username") & "\Desktop\unixdict.txt"
Open strFile For Input As #Num
strContent = Input(LOF(1), #Num)
Close #Num
Debug.Print UBound(Split(strContent, vbCrLf)) + 1 & " words, in the dictionary"
countTime = Timer
'Compute
varReturn = Anagrams(strContent)
'Return
Debug.Print "The anagram set(s) with the greatest number of words (namely " & UBound(varReturn, 2) & ") is : "
Debug.Print ""
For i = LBound(varReturn, 1) To UBound(varReturn, 1)
ReDim temp(LBound(varReturn, 2) To UBound(varReturn, 2))
For Num = LBound(varReturn, 2) To UBound(varReturn, 2)
temp(Num) = varReturn(i, Num)
Next
SortOneDimArray temp, LBound(temp), UBound(temp)
Debug.Print Mid(Join(temp, ", "), 3)
Next i
Debug.Print ""
Debug.Print "Time to go : " & Timer - countTime & " seconds."
End Sub
Private Function Anagrams(strContent As String) As Variant
Dim arrList
Dim arrTemp() As String
Dim arrReturn() As String
Dim Num As Long
Dim lngCountTemp As Long
Dim lngCount As Long
Dim i As Long
'Put the content of txt file in an One Dim Array
arrList = Split(strContent, vbCrLf)
ReDim arrTemp(0 To UBound(arrList, 1), 0 To 2)
'Transfer Datas in a 2nd Array Multi-Dim
'Col 0 = words with letters sorted
'Col 1 = words
'Col 2 = Number of same words with letters sorted in the list
For Num = LBound(arrList) To UBound(arrList)
arrTemp(Num, 0) = SortLetters(CStr(arrList(Num)), Chr(0))
arrTemp(Num, 1) = CStr(arrList(Num))
Next
SortTwoDimArray arrTemp, LBound(arrTemp, 1), UBound(arrTemp, 1), 0
For Num = LBound(arrTemp, 1) To UBound(arrTemp, 1)
arrTemp(Num, 2) = NbIf(arrTemp(Num, 0), arrTemp, Num, 0)
If arrTemp(Num, 2) > lngCountTemp Then lngCountTemp = arrTemp(Num, 2)
Next
'return
ReDim arrReturn(0 To lngCountTemp, 0)
For Num = LBound(arrTemp, 1) To UBound(arrTemp, 1)
If lngCountTemp = arrTemp(Num, 2) Then
ReDim Preserve arrReturn(0 To lngCountTemp, 0 To lngCount)
For i = 0 To lngCountTemp - 1
arrReturn(i, lngCount) = arrTemp(Num + i, 1)
Next i
lngCount = lngCount + 1
End If
Next Num
Anagrams = Transposition(arrReturn)
End Function
Private Function SortLetters(s As String, sep As String) As String
Dim temp
temp = Split(StrConv(s, vbUnicode), sep)
SortOneDimArray temp, LBound(temp), UBound(temp)
SortLetters = Join(temp, sep)
End Function
Private Function NbIf(strValue As String, arr As Variant, lngInd As Long, Optional lngColumn As Long) As Long
Dim i As Long
Dim lngCount As Long
For i = lngInd To UBound(arr, 1)
If arr(i, lngColumn) = strValue Then
lngCount = lngCount + 1
Else
Exit For
End If
Next i
NbIf = lngCount
End Function
Private Function Transposition(ByRef myArr As Variant) As Variant
Dim tabl
Dim i As Long
Dim j As Long
ReDim tabl(LBound(myArr, 2) To UBound(myArr, 2), LBound(myArr, 1) To UBound(myArr, 1))
For i = LBound(myArr, 1) To UBound(myArr, 1)
For j = LBound(myArr, 2) To UBound(myArr, 2)
tabl(j, i) = myArr(i, j)
Next j
Next i
Transposition = tabl
Erase tabl
End Function
Private Sub SortOneDimArray(ByRef myArr As Variant, mini As Long, Maxi As Long)
Dim i As Long
Dim j As Long
Dim Pivot As Variant
Dim temp As Variant
On Error Resume Next
i = mini: j = Maxi
Pivot = myArr((mini + Maxi) \ 2)
While i <= j
While myArr(i) < Pivot And i < Maxi: i = i + 1: Wend
While Pivot < myArr(j) And j > mini: j = j - 1: Wend
If i <= j Then
temp = myArr(i)
myArr(i) = myArr(j)
myArr(j) = temp
i = i + 1: j = j - 1
End If
Wend
If (mini < j) Then Call SortOneDimArray(myArr, mini, j)
If (i < Maxi) Then Call SortOneDimArray(myArr, i, Maxi)
End Sub
Private Sub SortTwoDimArray(ByRef myArr As Variant, mini As Long, Maxi As Long, Optional Colonne As Long = 0)
Dim i As Long
Dim j As Long
Dim Pivot As Variant
Dim myArrTemp As Variant
Dim ColTemp As Long
On Error Resume Next
i = mini: j = Maxi
Pivot = myArr((mini + Maxi) \ 2, Colonne)
While i <= j
While myArr(i, Colonne) < Pivot And i < Maxi: i = i + 1: Wend
While Pivot < myArr(j, Colonne) And j > mini: j = j - 1: Wend
If i <= j Then
ReDim myArrTemp(LBound(myArr, 2) To UBound(myArr, 2))
For ColTemp = LBound(myArr, 2) To UBound(myArr, 2)
myArrTemp(ColTemp) = myArr(i, ColTemp)
myArr(i, ColTemp) = myArr(j, ColTemp)
myArr(j, ColTemp) = myArrTemp(ColTemp)
Next ColTemp
Erase myArrTemp
i = i + 1: j = j - 1
End If
Wend
If (mini < j) Then Call SortTwoDimArray(myArr, mini, j, Colonne)
If (i < Maxi) Then Call SortTwoDimArray(myArr, i, Maxi, Colonne)
End Sub