Anagrams/Deranged anagrams: Difference between revisions
Alextretyak (talk | contribs) m (→{{header|11l}}: `sorted(String)` now returns `String`, not `Array`) |
m (→{{header|Wren}}: Minor tidy) |
||
(7 intermediate revisions by 7 users not shown) | |||
Line 706: | Line 706: | ||
=={{header|AppleScript}}== |
=={{header|AppleScript}}== |
||
<syntaxhighlight lang="applescript">use AppleScript version "2.3.1" -- OS X 10.9 (Mavericks) or later. |
|||
use sorter : script ¬ |
|||
"Custom Iterative Ternary Merge Sort" -- <www.macscripter.net/t/timsort-and-nigsort/71383/3> |
|||
use scripting additions |
|||
on join(lst, delim) |
|||
This can now return all the co-longest deranged anagrams when there are more than one. However it turns out that unixdict.txt only contains one. :) |
|||
set astid to AppleScript's text item delimiters |
|||
set AppleScript's text item delimiters to delim |
|||
<syntaxhighlight lang="applescript">use AppleScript version "2.3.1" -- OS X 10.9 (Mavericks) or later — for these 'use' commands! |
|||
set txt to lst as text |
|||
-- Uses the customisable AppleScript-coded sort shown at <https://macscripter.net/viewtopic.php?pid=194430#p194430>. |
|||
set AppleScript's text item delimiters to astid |
|||
-- It's assumed scripters will know how and where to install it as a library. |
|||
return txt |
|||
use sorter : script "Custom Iterative Ternary Merge Sort" |
|||
end join |
|||
use scripting additions |
|||
on longestDerangedAnagrams(listOfWords) |
on longestDerangedAnagrams(listOfWords) |
||
script o |
script o |
||
property wordList : listOfWords |
property wordList : listOfWords |
||
property |
property groupingTexts : wordList's items |
||
property |
property derangementLength : 0 |
||
property output : {} |
property output : {} |
||
-- Test for any deranged pairs amongst the words of an anagram group. |
-- Test for any deranged pairs amongst the words of an anagram group. |
||
on testPairs(a, b) |
on testPairs(a, b) |
||
set anagramGroup to items a thru b |
set anagramGroup to my wordList's items a thru b |
||
set |
set groupSize to b - a + 1 |
||
set wordLength to (count beginning of anagramGroup) |
set wordLength to (count beginning of anagramGroup) |
||
repeat with i from 1 to ( |
repeat with i from 1 to (groupSize - 1) |
||
set w1 to item i |
set w1 to anagramGroup's item i |
||
repeat with j from (i + 1) to |
repeat with j from (i + 1) to groupSize |
||
set w2 to item j |
set w2 to anagramGroup's item j |
||
set areDeranged to true |
set areDeranged to true |
||
repeat with c from 1 to wordLength |
repeat with c from 1 to wordLength |
||
if (character c |
if (w1's character c = w2's character c) then |
||
set areDeranged to false |
set areDeranged to false |
||
exit repeat |
exit repeat |
||
end if |
end if |
||
end repeat |
end repeat |
||
-- Append any deranged pairs found to the output |
-- Append any deranged pairs found to the output and note the words' length. |
||
if (areDeranged) then |
if (areDeranged) then |
||
set end of |
set end of output to {w1, w2} |
||
set |
set derangementLength to wordLength |
||
end if |
end if |
||
end repeat |
end repeat |
||
end repeat |
end repeat |
||
end testPairs |
end testPairs |
||
-- Custom comparison handler for the sort. Text a should go after text b if |
|||
-- it's the same length and has a greater lexical value or it's shorter than b. |
|||
-- (The lexical sort direction isn't really relevant. It's just to group equal texts.) |
|||
on isGreater(a, b) |
|||
set aLen to a's length |
|||
set bLen to b's length |
|||
if (aLen = bLen) then return (a > b) -- or (b < a)! |
|||
return (aLen < bLen) |
|||
end isGreater |
|||
end script |
end script |
||
set wordCount to (count o's wordList) |
|||
ignoring case |
ignoring case |
||
-- |
-- Replace the words in the groupingTexts list with sorted-character versions. |
||
repeat with i from 1 to wordCount |
|||
set |
set chrs to o's groupingTexts's item i's characters |
||
tell sorter to sort(chrs, 1, -1, {}) |
|||
repeat with thisWord in o's wordList |
|||
set |
set o's groupingTexts's item i to join(chrs, "") |
||
-- A straight ascending in-place sort here. |
|||
tell sorter to sort(theseChars, 1, -1, {}) -- Params: (list, start index, end index, customisation spec.). |
|||
set end of o's doctoredWords to theseChars as text |
|||
end repeat |
end repeat |
||
-- Sort the list descending by text length and ascending (say) by value |
|||
-- within lengths. Echo the moves in the original word list. |
|||
tell sorter to sort(o's groupingTexts, 1, wordCount, {comparer:o, slave:{o's wordList}}) |
|||
-- |
-- Work through the runs of grouping texts, starting with the longest texts. |
||
-- each length, rearranging the original-word list in parallel to maintain the index correspondence. |
|||
script descendingByLengthAscendingByValue |
|||
on isGreater(a, b) |
|||
set lenA to (count a) |
|||
set lenB to (count b) |
|||
if (lenA = lenB) then return (a > b) |
|||
return (lenB > lenA) |
|||
end isGreater |
|||
end script |
|||
tell sorter to sort(o's doctoredWords, 1, -1, {comparer:descendingByLengthAscendingByValue, slave:{o's wordList}}) |
|||
-- Locate each run of equal doctored words and test the corresponding originals for deranged pairs. |
|||
set i to 1 |
set i to 1 |
||
set currentText to beginning of o's |
set currentText to beginning of o's groupingTexts |
||
repeat with j from 2 to ( |
repeat with j from 2 to (wordCount) |
||
set thisText to |
set thisText to o's groupingTexts's item j |
||
if (thisText is not currentText) then |
if (thisText is not currentText) then |
||
if (j - i > 1) then tell o to testPairs(i, j - 1) |
if (j - i > 1) then tell o to testPairs(i, j - 1) |
||
Line 782: | Line 784: | ||
set i to j |
set i to j |
||
end if |
end if |
||
-- Stop on reaching a |
-- Stop on reaching a text that's shorter than any derangement(s) found. |
||
if ((count thisText) < o's |
if ((count thisText) < o's derangementLength) then exit repeat |
||
end repeat |
end repeat |
||
if (j > i) then tell o to testPairs(i, j) |
if (j > i) then tell o to testPairs(i, j) |
||
Line 791: | Line 793: | ||
end longestDerangedAnagrams |
end longestDerangedAnagrams |
||
-- The closing values of AppleScript 'run handler' variables not explicity declared local are |
|||
-- saved back to the script file afterwards — and "unixdict.txt" contains 25,104 words! |
|||
local wordFile, wordList |
local wordFile, wordList |
||
set wordFile to ((path to desktop as text) & "www.rosettacode.org:unixdict.txt") as «class furl» |
|||
-- The words in "unixdict.txt" are arranged one per line in alphabetical order. |
|||
-- Some contain punctuation characters, so they're best extracted as 'paragraphs' rather than as 'words'. |
|||
set wordFile to ((path to desktop as text) & "unixdict.txt") as «class furl» |
|||
set wordList to paragraphs of (read wordFile as «class utf8») |
set wordList to paragraphs of (read wordFile as «class utf8») |
||
return longestDerangedAnagrams(wordList)</syntaxhighlight> |
return longestDerangedAnagrams(wordList)</syntaxhighlight> |
||
Line 802: | Line 800: | ||
{{output}} |
{{output}} |
||
<syntaxhighlight lang="applescript">{{"excitation", "intoxicate"}}</syntaxhighlight> |
<syntaxhighlight lang="applescript">{{"excitation", "intoxicate"}}</syntaxhighlight> |
||
=={{header|ARM Assembly}}== |
=={{header|ARM Assembly}}== |
||
{{works with|as|Raspberry Pi <br> or android 32 bits with application Termux}} |
{{works with|as|Raspberry Pi <br> or android 32 bits with application Termux}} |
||
Line 1,412: | Line 1,411: | ||
</pre> |
</pre> |
||
=={{header| |
=={{header|BASIC}}== |
||
==={{header|BaCon}}=== |
|||
<syntaxhighlight lang="freebasic">DECLARE idx$ ASSOC STRING |
<syntaxhighlight lang="freebasic">DECLARE idx$ ASSOC STRING |
||
Line 1,449: | Line 1,449: | ||
</pre> |
</pre> |
||
=={{header|BBC BASIC}}== |
==={{header|BBC BASIC}}=== |
||
{{works with|BBC BASIC for Windows}} |
{{works with|BBC BASIC for Windows}} |
||
<syntaxhighlight lang="bbcbasic"> INSTALL @lib$+"SORTLIB" |
<syntaxhighlight lang="bbcbasic"> INSTALL @lib$+"SORTLIB" |
||
Line 1,813: | Line 1,813: | ||
=={{header|COBOL}}== |
=={{header|COBOL}}== |
||
{{Works with|X/Open COBOL}} |
|||
<syntaxhighlight lang="cobol"> |
|||
<syntaxhighlight lang="cobolfree">****************************************************************** |
|||
* COBOL solution to Anagrams Deranged challange |
|||
* The program was run on OpenCobolIDE |
|||
* Input data is stored in file 'Anagrams.txt' on my PC |
|||
****************************************************************** |
|||
IDENTIFICATION DIVISION. |
|||
PROGRAM-ID. DERANGED. |
|||
ENVIRONMENT DIVISION. |
|||
INPUT-OUTPUT SECTION. |
|||
FILE-CONTROL. |
|||
SELECT IN-FILE ASSIGN TO 'C:\Both\Rosetta\Anagrams.txt' |
|||
ORGANIZATION IS LINE SEQUENTIAL. |
|||
DATA DIVISION. |
|||
FILE SECTION. |
|||
FD IN-FILE. |
|||
01 IN-RECORD PIC X(22). |
|||
WORKING-STORAGE SECTION. |
|||
01 SWITCHES. |
|||
05 WS-EOF PIC X VALUE 'N'. |
|||
05 WS-FND PIC X VALUE 'N'. |
|||
05 WS-EXIT PIC X VALUE 'N'. |
|||
01 COUNTERS. |
|||
05 WS-TOT-RECS PIC 9(5) USAGE PACKED-DECIMAL VALUE 0. |
|||
05 WS-SEL-RECS PIC 9(5) USAGE PACKED-DECIMAL VALUE 0. |
|||
05 WT-REC-NBR PIC 9(5) USAGE PACKED-DECIMAL VALUE 0. |
|||
* Extra byte to guarentee a space at end - needed in sort logic. |
|||
01 WS-WORD-TEMP PIC X(23). |
|||
01 FILLER REDEFINES WS-WORD-TEMP. |
|||
05 WS-LETTER OCCURS 23 TIMES PIC X. |
|||
77 WS-LETTER-HLD PIC X. |
|||
77 WS-WORD-IN PIC X(22). |
|||
77 WS-WORD-KEY PIC X(22). |
|||
01 WS-WORD-TABLE. |
|||
05 WT-RECORD OCCURS 0 to 24000 TIMES |
|||
DEPENDING ON WT-REC-NBR |
|||
DESCENDING KEY IS WT-WORD-LEN |
|||
INDEXED BY WT-IDX. |
|||
10 WT-WORD-KEY PIC X(22). |
|||
10 WT-WORD-LEN PIC 9(2). |
|||
10 WT-ANAGRAM-CNT PIC 9(5) USAGE PACKED-DECIMAL. |
|||
10 WT-ANAGRAMS OCCURS 6 TIMES. |
|||
15 WT-ANAGRAM PIC X(22). |
|||
01 WS-WORD-TEMP1 PIC X(22). |
|||
01 FILLER REDEFINES WS-WORD-TEMP1. |
|||
05 WS-LETTER1 PIC X OCCURS 22 TIMES. |
|||
01 WS-WORD-TEMP2 PIC X(22). |
|||
01 FILLER REDEFINES WS-WORD-TEMP2. |
|||
05 WS-LETTER2 OCCURS 22 TIMES PIC X. |
|||
77 WS-I PIC 9(5) USAGE PACKED-DECIMAL. |
|||
77 WS-J PIC 9(5) USAGE PACKED-DECIMAL. |
|||
77 WS-K PIC 9(5) USAGE PACKED-DECIMAL. |
|||
77 WS-L PIC 9(5) USAGE PACKED-DECIMAL. |
|||
77 WS-BEG PIC 9(5) USAGE PACKED-DECIMAL. |
|||
77 WS-MAX PIC 9(5) USAGE PACKED-DECIMAL. |
|||
PROCEDURE DIVISION. |
|||
000-MAIN. |
|||
PERFORM 100-INITIALIZE. |
|||
PERFORM 200-PROCESS-RECORD UNTIL WS-EOF = 'Y'. |
|||
SORT WT-RECORD ON DESCENDING KEY WT-WORD-LEN. |
|||
UNTIL WS-EOF = 'Y'. |
|||
PERFORM 500-FIND-DERANGED. |
|||
SORT WT-RECORD ON DESCENDING KEY WT-WORD-LEN. |
|||
PERFORM 900-TERMINATE. |
|||
STOP RUN. |
|||
PERFORM 900-TERMINATE. |
|||
STOP RUN. |
|||
100-INITIALIZE. |
|||
OPEN INPUT IN-FILE. |
|||
PERFORM 150-READ-RECORD. |
|||
150-READ-RECORD. |
|||
READ IN-FILE INTO WS-WORD-IN |
|||
AT END |
|||
MOVE 'Y' TO WS-EOF |
|||
NOT AT END |
|||
COMPUTE WS-TOT-RECS = WS-TOT-RECS + 1 |
|||
END-READ. |
|||
200-PROCESS-RECORD. |
|||
IF WS-WORD-IN IS ALPHABETIC |
|||
COMPUTE WS-SEL-RECS = WS-SEL-RECS + 1 END-COMPUTE |
|||
MOVE WS-WORD-IN TO WS-WORD-TEMP |
|||
PERFORM 300-SORT-WORD |
|||
MOVE WS-WORD-TEMP TO WS-WORD-KEY |
|||
PERFORM 400-ADD-TO-TABLE |
|||
END-IF. |
|||
PERFORM 150-READ-RECORD. |
|||
* bubble sort: |
|||
PERFORM 150-READ-RECORD. |
|||
300-SORT-WORD. |
|||
PERFORM VARYING WS-MAX FROM 1 BY 1 |
|||
UNTIL WS-LETTER(WS-MAX) = SPACE |
|||
END-PERFORM. |
|||
PERFORM VARYING WS-I FROM 1 BY 1 UNTIL WS-I = WS-MAX |
|||
PERFORM VARYING WS-J FROM WS-I BY 1 |
|||
UNTIL WS-J > WS-MAX - 1 |
|||
IF WS-LETTER(WS-J) < WS-LETTER(WS-I) THEN |
|||
MOVE WS-LETTER(WS-I) TO WS-LETTER-HLD |
|||
MOVE WS-LETTER(WS-J) TO WS-LETTER(WS-I) |
|||
MOVE WS-LETTER-HLD TO WS-LETTER(WS-J) |
|||
END-IF |
|||
END-PERFORM |
|||
END-PERFORM. |
|||
400-ADD-TO-TABLE. |
|||
* bubble sort: |
|||
SET WT-IDX TO 1. |
|||
SEARCH WT-RECORD |
|||
PERFORM VARYING WS-MAX FROM 1 BY 1 |
|||
AT END |
|||
UNTIL WS-LETTER(WS-MAX) = SPACE |
|||
PERFORM 420-ADD-RECORD |
|||
WHEN WT-WORD-KEY(WT-IDX) = WS-WORD-KEY |
|||
PERFORM 440-UPDATE-RECORD |
|||
END-SEARCH. |
|||
420-ADD-RECORD. |
|||
PERFORM VARYING WS-I FROM 1 BY 1 UNTIL WS-I = WS-MAX |
|||
ADD 1 To WT-REC-NBR. |
|||
PERFORM VARYING WS-J FROM WS-I BY 1 |
|||
MOVE WS-WORD-KEY TO WT-WORD-KEY(WT-REC-NBR). |
|||
UNTIL WS-J > WS-MAX - 1 |
|||
COMPUTE WT-WORD-LEN(WT-REC-NBR) = WS-MAX - 1 END-COMPUTE. |
|||
IF WS-LETTER(WS-J) < WS-LETTER(WS-I) THEN |
|||
MOVE 1 TO WT-ANAGRAM-CNT(WT-REC-NBR). |
|||
MOVE WS-LETTER(WS-I) TO WS-LETTER-HLD |
|||
MOVE WS-WORD-IN TO |
|||
WT-ANAGRAM(WT-REC-NBR, WT-ANAGRAM-CNT(WT-REC-NBR)). |
|||
MOVE WS-LETTER-HLD TO WS-LETTER(WS-J) |
|||
END-IF |
|||
END-PERFORM |
|||
END-PERFORM. |
|||
440-UPDATE-RECORD. |
|||
400-ADD-TO-TABLE. |
|||
ADD 1 TO WT-ANAGRAM-CNT(WT-IDX). |
|||
MOVE WS-WORD-IN TO |
|||
SEARCH WT-RECORD |
|||
WT-ANAGRAM(WT-IDX, WT-ANAGRAM-CNT(WT-IDX)). |
|||
AT END |
|||
PERFORM 420-ADD-RECORD |
|||
WHEN WT-WORD-KEY(WT-IDX) = WS-WORD-KEY |
|||
PERFORM 440-UPDATE-RECORD |
|||
END-SEARCH. |
|||
500-FIND-DERANGED. |
|||
420-ADD-RECORD. |
|||
PERFORM VARYING WS-I FROM 1 BY 1 |
|||
UNTIL WS-I > WT-REC-NBR OR WS-FND = 'Y' |
|||
PERFORM VARYING WS-J FROM 1 BY 1 |
|||
UNTIL WS-J > WT-ANAGRAM-CNT(WS-I) - 1 OR WS-FND = 'Y' |
|||
COMPUTE WS-BEG = WS-J + 1 END-COMPUTE |
|||
PERFORM VARYING WS-K FROM WS-BEG BY 1 |
|||
WT-ANAGRAM(WT-REC-NBR, WT-ANAGRAM-CNT(WT-REC-NBR)). |
|||
UNTIL WS-K > WT-ANAGRAM-CNT(WS-I) OR WS-FND = 'Y' |
|||
MOVE WT-ANAGRAM(WS-I, WS-J) TO WS-WORD-TEMP1 |
|||
MOVE WT-ANAGRAM(WS-I, WS-K) To WS-WORD-TEMP2 |
|||
PERFORM 650-CHECK-DERANGED |
|||
END-PERFORM |
|||
END-PERFORM |
|||
END-PERFORM. |
|||
650-CHECK-DERANGED. |
|||
440-UPDATE-RECORD. |
|||
MOVE 'N' TO WS-EXIT. |
|||
PERFORM VARYING WS-L FROM 1 BY 1 |
|||
MOVE WS-WORD-IN TO |
|||
UNTIL WS-L > WT-WORD-LEN(WS-I) OR WS-EXIT = 'Y' |
|||
IF WS-LETTER1(WS-L) = WS-LETTER2(WS-L) |
|||
MOVE 'Y' TO WS-EXIT |
|||
END-IF |
|||
END-PERFORM. |
|||
IF WS-EXIT = 'N' |
|||
DISPLAY |
|||
WS-WORD-TEMP1(1:WT-WORD-LEN(WS-I)) ' ' WS-WORD-TEMP2 |
|||
END-DISPLAY |
|||
MOVE 'Y' TO WS-FND |
|||
END-IF. |
|||
900-TERMINATE. |
|||
500-FIND-DERANGED. |
|||
DISPLAY 'RECORDS READ: ' WS-TOT-RECS. |
|||
PERFORM VARYING WS-I FROM 1 BY 1 |
|||
DISPLAY 'RECORDS SELECTED ' WS-SEL-RECS. |
|||
UNTIL WS-I > WT-REC-NBR OR WS-FND = 'Y' |
|||
DISPLAY 'RECORD KEYS: ' WT-REC-NBR. |
|||
PERFORM VARYING WS-J FROM 1 BY 1 |
|||
CLOSE IN-FILE. |
|||
UNTIL WS-J > WT-ANAGRAM-CNT(WS-I) - 1 OR WS-FND = 'Y' |
|||
COMPUTE WS-BEG = WS-J + 1 |
|||
PERFORM VARYING WS-K FROM WS-BEG BY 1 |
|||
UNTIL WS-K > WT-ANAGRAM-CNT(WS-I) OR WS-FND = 'Y' |
|||
MOVE WT-ANAGRAM(WS-I, WS-J) TO WS-WORD-TEMP1 |
|||
MOVE WT-ANAGRAM(WS-I, WS-K) To WS-WORD-TEMP2 |
|||
PERFORM 650-CHECK-DERANGED |
|||
END-PERFORM |
|||
END-PERFORM |
|||
END-PERFORM. |
|||
END PROGRAM DERANGED. |
|||
MOVE 'N' TO WS-EXIT. |
|||
PERFORM VARYING WS-L FROM 1 BY 1 |
|||
UNTIL WS-L > WT-WORD-LEN(WS-I) OR WS-EXIT = 'Y' |
|||
IF WS-LETTER1(WS-L) = WS-LETTER2(WS-L) |
|||
MOVE 'Y' TO WS-EXIT |
|||
END-PERFORM. |
|||
IF WS-EXIT = 'N' |
|||
DISPLAY WS-WORD-TEMP1(1:WT-WORD-LEN(WS-I)) |
|||
' ' |
|||
WS-WORD-TEMP2 |
|||
MOVE 'Y' TO WS-FND |
|||
END-IF. |
|||
*> OUTPUT: |
|||
900-TERMINATE. |
|||
DISPLAY 'RECORDS READ: ' WS-TOT-RECS. |
|||
DISPLAY 'RECORDS SELECTED ' WS-SEL-RECS. |
|||
DISPLAY 'RECORD KEYS: ' WT-REC-NBR. |
|||
CLOSE IN-FILE. |
|||
*> excitation intoxicate |
|||
*> RECORDS READ: 25104 |
|||
*> RECORDS SELECTED 24978 |
|||
*> RECORD KEYS: 23441 |
|||
*> BUBBLE SORT REFERENCE: |
|||
*> excitation intoxicate |
|||
*> https://mainframegeek.wordpress.com/tag/bubble-sort-in-cobol |
|||
*> RECORDS READ: 25104 |
|||
*> RECORDS SELECTED 24978 |
|||
*> RECORD KEYS: 23441 |
|||
*> BUBBLE SORT REFERENCE: |
|||
*> https://mainframegeek.wordpress.com/tag/bubble-sort-in-cobol |
|||
</syntaxhighlight> |
</syntaxhighlight> |
||
Line 2,729: | Line 2,729: | ||
Took 0.089 seconds on i3 @ 2.13 GHz |
Took 0.089 seconds on i3 @ 2.13 GHz |
||
</pre> |
</pre> |
||
=={{header|FutureBasic}}== |
|||
While there is nothing time sensitive about this task, fast code is often efficient code. Several of the entries in this category show their computation times. This FutureBasic entry is designed to outrace them all. |
|||
The other entries examined have started by sorting the letters in each word. Here we take a different approach by creating an "avatar" for each word. All anagrams of a word have the same avatar—-without any sorting. Here's how it works:<br> |
|||
An 8-byte variable can hold a lot of information. We create a 64-bit avatar that starts at the high end with 8 bits for the length of the word, so that longer words will be sorted first. The remaining 56 bits contain 2-bit fields for each letter of the alphabet. A 2-bit field can record from 0 to 3 occurrences of the letter, but even if there were 4 or more occurrences (think "Mississippi"), bleeding into the next field, the only matching avatar would still be an exact anagram. Here's how the bits would be set for the word "Anagrams": |
|||
<syntaxhighlight lang="future basic"> |
|||
Anagrams |
|||
length ZzYyXx WwVvUuTt SsRrQqPp OoNnMmLl KkJjIiHh GgFfEeDd CcBbAa |
|||
00001000 00000000 00000000 01010000 00010100 00000000 01000000 00001100 |
|||
</syntaxhighlight> |
|||
Bit shifts and 8-byte comparisons are fast operations, which contribute to the speed. As each avatar is generated, it is saved, along with the offset to its word, and an index to it inserted in a sorted list, guaranteeing that longest words occur first, and all matching anagrams are adjacent. |
|||
When words have the same avatars, they are anagrams, but for this task we still need to check for letters occurring in the same location in both words. That is a quick check that only has to be done for otherwise qualified candidates. |
|||
On a 1.2 GHz Quad-Core Intel Core i7 MacBook Pro, this code runs in ~6 ms, which is several times faster than times claimed by other entries. In that time, it finds not just the longest, but all 486 deranged anagrams in unixdict.txt. (Yes, there is an option to view all of them.) |
|||
FWIW, this code can easily be amended to show all 1800+ anagram pairs. |
|||
<syntaxhighlight lang="future basic"> |
|||
#plist NSAppTransportSecurity @{NSAllowsArbitraryLoads:YES} |
|||
defstr long |
|||
begin globals |
|||
xref xwords( 210000 ) as char |
|||
long gAvatars( 26000 ) |
|||
uint32 gwordNum, gfilen, gcount = 0, gOffset( 26000 ) |
|||
uint16 gndx( 26000 ), deranged( 600, 1 ) |
|||
long sh : sh = system( _scrnHeight ) -100 |
|||
long sw : sw = (system( _scrnWidth ) -360 ) / 2 |
|||
CFTimeInterval t |
|||
_len = 56 |
|||
end globals |
|||
local fn loadDictionary |
|||
CFURLRef url = fn URLWithString( @"http://wiki.puzzlers.org/pub/wordlists/unixdict.txt" ) |
|||
CFStringRef dictStr = fn StringWithContentsOfURL( url, NSUTF8StringEncoding, NULL ) |
|||
dictStr = fn StringByAppendingString( @" ", dictStr ) |
|||
xwords = fn StringUTF8String( dictstr ) |
|||
gfilen = len(dictstr) |
|||
end fn |
|||
local fn deranagrams |
|||
uint64 ch, p, wordStart = 0 |
|||
long avatar = 0 |
|||
uint32 med, bot, top |
|||
byte chk, L |
|||
for p = 1 to gfilen |
|||
ch = xwords(p) //build avatar |
|||
if ch > _" " then avatar += (long) 1 << ( ch and 31 ) * 2: continue |
|||
avatar += (long)(p - wordStart - 1) << _len //complete avatar by adding word length |
|||
gAvatars(gWordNum) = avatar //store the avatar in list |
|||
gOffset( gWordNum) = wordStart //store offset to the word |
|||
//Insert into ordered list of avatars |
|||
bot = 0 : top = gwordNum //quick search for place to insert |
|||
while (top - bot) > 1 |
|||
med = ( top + bot ) >> 1 |
|||
if avatar > gAvatars(gndx(med)) then bot = med else top = med |
|||
wend |
|||
blockmove( @gndx( top ), @gndx( top + 1 ), ( gwordNum - top ) * 2 ) |
|||
gndx(top) = gWordNum |
|||
gwordNum++ : wordStart = p : avatar = 0 //ready for new word |
|||
next p |
|||
//Check for matching avatars |
|||
for p = gWordNum to 1 step -1 |
|||
chk = 1 //to make sure each word is compared with all matching avatars |
|||
while gAvatars( gndx( p ) ) == gAvatars( gndx( p - chk ) ) |
|||
// found anagram; now check for chars in same position |
|||
L = ( gAvatars( gndx( p ) ) >> _len ) //get word length |
|||
while L |
|||
if xwords(gOffset(gndx(p)) +L) == xwords(gOffset(gndx(p-chk)) +L) then break |
|||
L-- |
|||
wend |
|||
if L == 0 |
|||
//no matching chars: found Deranged Anagram! |
|||
deranged( gcount, 0 ) = gndx( p ) |
|||
deranged( gcount, 1 ) = gndx( p - chk ) |
|||
gcount++ |
|||
end if |
|||
chk++ |
|||
wend |
|||
next |
|||
end fn |
|||
local fn printPair( ndx as uint32, chrsToCntr as byte ) |
|||
ptr p : str255 pair : pair = "" |
|||
short n = ( gAvatars( deranged( ndx, 0 ) ) >> _len ) |
|||
if n < chrsToCntr then print string$( chrsToCntr - n, " " ); |
|||
p = xwords + gOffset( deranged( ndx, 0 ) ) |
|||
p.0`` = n : print p.0$; " "; |
|||
p = xwords + gOffset( deranged( ndx, 1 ) ) |
|||
p.0`` = n : print p.0$ |
|||
end fn |
|||
local fn doDialog(evt as long) |
|||
if evt == _btnclick |
|||
long r |
|||
button -1 : window 1,,(sw,50,335,sh-50) |
|||
for r = 1 to gcount-1 |
|||
fn printPair( r, 21 ) |
|||
next |
|||
end if |
|||
end fn |
|||
fn loadDictionary : t = fn CACurrentMediaTime |
|||
fn deranagrams : t = fn CACurrentMediaTime - t |
|||
window 1, @"Deranged Anagrams in FutureBasic",(sw,sh-130,335,130) |
|||
printf @"\n %u deranged anagrams found among \n %u words ¬ |
|||
in %.2f ms.\n", gcount, gWordNum, t * 1000 |
|||
print " Longest:";: fn printPair( 0, 11 ) |
|||
button 1,,,fn StringWithFormat(@"Show remaining %u deranged anagrams.",gcount-1),(24,20,285,34) |
|||
on dialog fn doDialog |
|||
handleevents |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
[[File:FB output for Deranged Anagrams.png]] |
|||
=={{header|GAP}}== |
=={{header|GAP}}== |
||
Line 2,904: | Line 3,027: | ||
{{out}} |
{{out}} |
||
<pre>Longest deranged anagrams: excitation and intoxicate</pre> |
<pre>Longest deranged anagrams: excitation and intoxicate</pre> |
||
and a variant: |
|||
<syntaxhighlight lang="haskell">import Control.Monad ((<=<)) |
|||
import Data.Function (on) |
|||
import Data.List (find, groupBy, sort, sortOn) |
|||
import Data.Ord (Down (Down)) |
|||
-------------------- DERANGED ANAGRAMS ------------------- |
|||
longestDeranged :: [String] -> String |
|||
longestDeranged xs = |
|||
case find deranged (longestAnagramPairs xs) of |
|||
Nothing -> "No deranged anagrams found." |
|||
Just (a, b) -> a <> " -> " <> b |
|||
deranged :: (String, String) -> Bool |
|||
deranged (a, b) = and (zipWith (/=) a b) |
|||
longestAnagramPairs :: [String] -> [(String, String)] |
|||
longestAnagramPairs = ((<*>) =<< fmap (,)) <=< |
|||
(sortOn (Down . length . head) . anagramGroups) |
|||
anagramGroups :: [String] -> [[String]] |
|||
anagramGroups xs = |
|||
groupBy |
|||
(on (==) fst) |
|||
(sortOn fst (((,) =<< sort) <$> xs)) |
|||
>>= (\g -> [snd <$> g | 1 < length g]) |
|||
--------------------------- TEST ------------------------- |
|||
main :: IO () |
|||
main = |
|||
readFile "unixdict.txt" |
|||
>>= (putStrLn . longestDeranged . lines)</syntaxhighlight> |
|||
{{Out}} |
|||
<pre>excitation -> intoxicate</pre> |
|||
=={{header|Icon}} and {{header|Unicon}}== |
=={{header|Icon}} and {{header|Unicon}}== |
||
Line 3,811: | Line 3,971: | ||
=={{header|Perl}}== |
=={{header|Perl}}== |
||
===String operations=== |
|||
<syntaxhighlight lang="perl">sub deranged { # only anagrams ever get here |
|||
<syntaxhighlight lang="perl">use strict; |
|||
use warnings; |
|||
sub deranged { # only anagrams ever get here |
|||
my @a = split('', shift); # split word into letters |
my @a = split('', shift); # split word into letters |
||
my @b = split('', shift); |
my @b = split('', shift); |
||
Line 3,845: | Line 4,009: | ||
keys %letter_list ) |
keys %letter_list ) |
||
{ |
{ |
||
# if we find a pair, they are the |
# if we find a pair, they are the longest due to the sort before |
||
last if find_deranged(@{ $letter_list{$_} }); |
last if find_deranged(@{ $letter_list{$_} }); |
||
}</syntaxhighlight> |
}</syntaxhighlight> |
||
{{out}} |
{{out}} |
||
<pre>length 10: excitation => intoxicate</pre> |
|||
<pre> |
|||
===Bitwise operations=== |
|||
length 10: excitation => intoxicate |
|||
<syntaxhighlight lang="perl">use strict; |
|||
</pre> |
|||
===Alternate=== |
|||
<syntaxhighlight lang="perl">#!/usr/bin/perl |
|||
use strict; # https://rosettacode.org/wiki/Anagrams/Deranged_anagrams |
|||
use warnings; |
use warnings; |
||
use feature 'bitwise'; |
|||
local (@ARGV, $/) = 'unixdict.txt'; |
local (@ARGV, $/) = 'unixdict.txt'; |
||
Line 3,864: | Line 4,025: | ||
{ |
{ |
||
my $key = join '', sort +split //, $word; |
my $key = join '', sort +split //, $word; |
||
($_ ^ $word) =~ /\0/ or exit !print "$_ $word\n" for @{ $anagrams{$key} }; |
($_ ^. $word) =~ /\0/ or exit !print "$_ $word\n" for @{ $anagrams{$key} }; |
||
push @{ $anagrams{$key} }, $word; |
push @{ $anagrams{$key} }, $word; |
||
}</syntaxhighlight> |
}</syntaxhighlight> |
||
{{out}} |
{{out}} |
||
<pre>excitation intoxicate</pre> |
|||
<pre> |
|||
excitation intoxicate |
|||
</pre> |
|||
=={{header|Phix}}== |
=={{header|Phix}}== |
||
Line 5,495: | Line 5,654: | ||
Time to compute : 97,00781 sec.</pre> |
Time to compute : 97,00781 sec.</pre> |
||
=={{header|Vlang}}== |
=={{header|V (Vlang)}}== |
||
{{trans|Go}} |
{{trans|Go}} |
||
<syntaxhighlight lang="vlang">import os |
<syntaxhighlight lang="v (vlang)">import os |
||
fn deranged(a string, b string) bool { |
fn deranged(a string, b string) bool { |
||
Line 5,548: | Line 5,707: | ||
=={{header|Wren}}== |
=={{header|Wren}}== |
||
{{libheader|Wren-sort}} |
{{libheader|Wren-sort}} |
||
<syntaxhighlight lang=" |
<syntaxhighlight lang="wren">import "io" for File |
||
import "/sort" for Sort |
import "./sort" for Sort |
||
// assumes w1 and w2 are anagrams of each other |
// assumes w1 and w2 are anagrams of each other |
Latest revision as of 10:35, 6 November 2023
You are encouraged to solve this task according to the task description, using any language you may know.
Two or more words are said to be anagrams if they have the same characters, but in a different order.
By analogy with derangements we define a deranged anagram as two words with the same characters, but in which the same character does not appear in the same position in both words.
- Task
Use the word list at unixdict to find and display the longest deranged anagram.
- Related
- Metrics
- Counting
- Word frequency
- Letter frequency
- Jewels and stones
- I before E except after C
- Bioinformatics/base count
- Count occurrences of a substring
- Count how many vowels and consonants occur in a string
- Remove/replace
- XXXX redacted
- Conjugate a Latin verb
- Remove vowels from a string
- String interpolation (included)
- Strip block comments
- Strip comments from a string
- Strip a set of characters from a string
- Strip whitespace from a string -- top and tail
- Strip control codes and extended characters from a string
- Anagrams/Derangements/shuffling
- Word wheel
- ABC problem
- Sattolo cycle
- Knuth shuffle
- Ordered words
- Superpermutation minimisation
- Textonyms (using a phone text pad)
- Anagrams
- Anagrams/Deranged anagrams
- Permutations/Derangements
- Find/Search/Determine
- ABC words
- Odd words
- Word ladder
- Semordnilap
- Word search
- Wordiff (game)
- String matching
- Tea cup rim text
- Alternade words
- Changeable words
- State name puzzle
- String comparison
- Unique characters
- Unique characters in each string
- Extract file extension
- Levenshtein distance
- Palindrome detection
- Common list elements
- Longest common suffix
- Longest common prefix
- Compare a list of strings
- Longest common substring
- Find common directory path
- Words from neighbour ones
- Change e letters to i in words
- Non-continuous subsequences
- Longest common subsequence
- Longest palindromic substrings
- Longest increasing subsequence
- Words containing "the" substring
- Sum of the digits of n is substring of n
- Determine if a string is numeric
- Determine if a string is collapsible
- Determine if a string is squeezable
- Determine if a string has all unique characters
- Determine if a string has all the same characters
- Longest substrings without repeating characters
- Find words which contains all the vowels
- Find words which contains most consonants
- Find words which contains more than 3 vowels
- Find words which first and last three letters are equals
- Find words which odd letters are consonants and even letters are vowels or vice_versa
- Formatting
- Substring
- Rep-string
- Word wrap
- String case
- Align columns
- Literals/String
- Repeat a string
- Brace expansion
- Brace expansion using ranges
- Reverse a string
- Phrase reversals
- Comma quibbling
- Special characters
- String concatenation
- Substring/Top and tail
- Commatizing numbers
- Reverse words in a string
- Suffixation of decimal numbers
- Long literals, with continuations
- Numerical and alphabetical suffixes
- Abbreviations, easy
- Abbreviations, simple
- Abbreviations, automatic
- Song lyrics/poems/Mad Libs/phrases
- Mad Libs
- Magic 8-ball
- 99 Bottles of Beer
- The Name Game (a song)
- The Old lady swallowed a fly
- The Twelve Days of Christmas
- Tokenize
- Text between
- Tokenize a string
- Word break problem
- Tokenize a string with escaping
- Split a character string based on change of character
- Sequences
11l
F is_not_deranged(s1, s2)
L(i) 0 .< s1.len
I s1[i] == s2[i]
R 1B
R 0B
Dict[String, Array[String]] anagram
V count = 0
L(word) File(‘unixdict.txt’).read().split("\n")
V a = sorted(word)
I a !C anagram
anagram[a] = [word]
E
L(ana) anagram[a]
I is_not_deranged(ana, word)
L.break
L.was_no_break
anagram[a].append(word)
count = max(count, word.len)
L(ana) anagram.values()
I ana.len > 1 & ana[0].len == count
print(ana)
- Output:
[excitation, intoxicate]
AArch64 Assembly
/* ARM assembly AARCH64 Raspberry PI 3B */
/* program anaderan64.s */
/*******************************************/
/* Constantes file */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"
.equ MAXI, 50000
.equ BUFFERSIZE, 300000
/*********************************/
/* Structures */
/*********************************/
/* this structure has size multiple de 8 */
/* see task anagram for program not use structure */
.struct 0
Word_Ptr_buffer: // p.quader word buffer
.struct Word_Ptr_buffer + 8
Word_Ptr_sorted: // p.quader word sorted letters
.struct Word_Ptr_sorted + 8
Word_length: // word length
.struct Word_length + 8
Word_top: // top
.struct Word_top + 8
Word_end:
/*********************************/
/* Initialized data */
/*********************************/
.data
szFileName: .asciz "./unixdict.txt"
//szFileName: .asciz "./listwordT.txt"
szMessErreur: .asciz "FILE ERROR."
szMessStart: .asciz "Program 64 bits start.\n"
szCarriageReturn: .asciz "\n"
szMessSpace: .asciz " "
ptBuffex1: .quad sBuffex1
/*********************************/
/* UnInitialized data */
/*********************************/
.bss
tbStWords: .skip Word_end * MAXI
qNBword: .skip 8
sBuffer: .skip BUFFERSIZE
sBuffex1: .skip BUFFERSIZE
/*********************************/
/* code section */
/*********************************/
.text
.global main
main: // entry of program
ldr x0,qAdrszMessStart
bl affichageMess
mov x4,#0 // loop indice
mov x0,AT_FDCWD // current directory
ldr x1,qAdrszFileName // file name
mov x2,#O_RDWR // flags
mov x3,#0 // mode
mov x8,#OPEN //
svc 0
cmp x0,#0 // error open
ble 99f
mov x9,x0 // FD save Fd
ldr x1,qAdrsBuffer // buffer address
ldr x2,qSizeBuf // buffersize
mov x8, #READ
svc 0
cmp x0,#0 // error read ?
blt 99f
mov x5,x0 // save size read bytes
ldr x4,qAdrsBuffer // buffer address
ldr x0,qAdrsBuffer // start word address
mov x2,#0
mov x1,#0 // word length
1:
cmp x2,x5
bge 2f
ldrb w3,[x4,x2]
cmp w3,#0xD // end word ?
cinc x1,x1,ne // increment word length
cinc x2,x2,ne // increment indice
bne 1b // and loop
strb wzr,[x4,x2] // store final zero
bl anaWord // sort word letters
add x2,x2,#2 // jump OD and 0A
add x0,x4,x2 // new address begin word
mov x1,#0 // init length
b 1b // and loop
2:
strb wzr,[x4,x2] // last word
bl anaWord
mov x0,x9 // file Fd
mov x8, #CLOSE
svc 0
cmp x0,#0 // error close ?
blt 99f
ldr x0,qAdrtbStWords // array structure words address
mov x1,#0 // first indice
ldr x2,qAdrqNBword
ldr x2,[x2] // last indice
bl triRapide // quick sort
ldr x4,qAdrtbStWords // array structure words address
mov x0,x4
mov x9,x2 // size word array
mov x8,#0 // indice first occurence
ldr x3,[x4,#Word_Ptr_sorted] // load first value
mov x2,#1 // loop indice
mov x10,#Word_end // words structure size
mov x12,#0 // max word length
3: // begin loop
madd x7,x2,x10,x4 // compute array index
ldr x5,[x7,#Word_Ptr_sorted] // load next value
mov x0,x3
mov x1,x5
bl comparStrings
cmp x0,#0 // sorted strings equal ?
bne 4f
madd x11,x8,x10,x4
ldr x0,[x11,#Word_Ptr_buffer] // address word 1
ldr x1,[x7,#Word_Ptr_buffer] // address word 2
bl controlLetters
cmp x0,#0 // not ok ?
beq 5f
mov x0,#1 // letters ok
str x0,[x7,#Word_top] // store top in first occurence
str x0,[x11,#Word_top] // store top in current occurence
ldr x0,[x7,#Word_length] // word length
cmp x0,x12 // compare maxi
csel x12,x0,x12,gt // yes length word -> value max
b 5f
4: // no
mov x0,x8
add x8,x8,#1 // init index new first occurence
madd x11,x8,x10,x4 // compute array index
ldr x3,[x11,#Word_Ptr_sorted] // init value new first occurence
mov x2,x0 // reprise au debut de la sequence
5:
add x2,x2,#1 // increment indice
cmp x2,x9 // end word array ?
blt 3b // no -> loop
mov x2,#0 // raz indice
ldr x4,qAdrtbStWords // array structure words address
6: // begin display loop
madd x11,x2,x10,x4 // compute array index
ldr x6,[x11,#Word_top] // load top
cmp x6,#0 // top ok ?
beq 7f
ldr x6,[x11,#Word_length] // load length
cmp x6,x12 // compare maxi
bne 7f
ldr x0,[x11,#Word_Ptr_buffer] // load address first word
bl affichageMess // display first word
add x2,x2,#1 // increment indice
madd x11,x2,x10,x4 // compute array index
ldr x6,[x11,#Word_top] // load top
cmp x6,#0 // top ok ?
beq 7f
ldr x0,qAdrszMessSpace
bl affichageMess
ldr x0,[x11,#Word_Ptr_buffer] // load address other word
bl affichageMess // display second word
ldr x0,qAdrszCarriageReturn
bl affichageMess
7:
add x2,x2,#1 // increment indice
cmp x2,x9 // maxi ?
blt 6b // no -> loop
b 100f
99: // display error
ldr x0,qAdrszMessErreur
bl affichageMess
100: // standard end of the program
mov x0, #0 // return code
mov x8, #EXIT // request to exit program
svc #0 // perform the system call
qAdrszCarriageReturn: .quad szCarriageReturn
qAdrszFileName: .quad szFileName
qAdrszMessErreur: .quad szMessErreur
qAdrsBuffer: .quad sBuffer
qSizeBuf: .quad BUFFERSIZE
qAdrszMessSpace: .quad szMessSpace
qAdrtbStWords: .quad tbStWords
qAdrszMessStart: .quad szMessStart
/******************************************************************/
/* analizing word */
/******************************************************************/
/* x0 word address */
/* x1 word length */
anaWord:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
stp x6,x7,[sp,-16]! // save registers
mov x5,x0
mov x6,x1
ldr x1,qAdrtbStWords
ldr x2,qAdrqNBword
ldr x3,[x2]
mov x4,#Word_end
madd x1,x3,x4,x1
str x0,[x1,#Word_Ptr_buffer]
mov x0,#0
str x0,[x1,#Word_top]
str x6,[x1,#Word_length]
ldr x4,qAdrptBuffex1
ldr x0,[x4]
add x6,x6,x0
add x6,x6,#1
str x6,[x4]
str x0,[x1,#Word_Ptr_sorted]
add x3,x3,#1
str x3,[x2]
mov x1,x0
mov x0,x5
bl triLetters // sort word letters
mov x2,#0
100:
ldp x6,x7,[sp],16 // restaur 2 registers
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
qAdrqNBword: .quad qNBword
qAdrptBuffex1: .quad ptBuffex1
/******************************************************************/
/* sort word letters */
/******************************************************************/
/* x0 address begin word */
/* x1 address recept array */
triLetters:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
stp x6,x7,[sp,-16]! // save registers
mov x2,#0
1:
ldrb w3,[x0,x2] // load letter
cmp w3,#0 // end word ?
beq 6f
cmp x2,#0 // first letter ?
bne 2f
strb w3,[x1,x2] // yes store in first position
add x2,x2,#1 // increment indice
b 1b // and loop
2:
mov x4,#0
3: // begin loop to search insertion position
ldrb w5,[x1,x4] // load letter
cmp w3,w5 // compare
blt 4f // to low -> insertion
add x4,x4,#1 // increment indice
cmp x4,x2 // compare to letters number in place
blt 3b // search loop
strb w3,[x1,x2] // else store in last position
add x2,x2,#1
b 1b // and loop
4: // move first letters in one position
sub x6,x2,#1 // start indice
5:
ldrb w5,[x1,x6] // load letter
add x7,x6,#1 // store indice - 1
strb w5,[x1,x7] // store letter
sub x6,x6,#1 // decrement indice
cmp x6,x4 // end ?
bge 5b // no loop
strb w3,[x1,x4] // else store letter in free position
add x2,x2,#1
b 1b // and loop
6:
strb wzr,[x1,x2] // final zéro
100:
ldp x6,x7,[sp],16 // restaur 2 registers
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/******************************************************************/
/* control letters */
/******************************************************************/
/* x0 address word 1*/
/* x1 address word 2 */
controlLetters:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
mov x2,#0
mov x5,x0
1:
ldrb w3,[x5,x2] // load a letter
cmp w3,#0 // end word ?
cset x0,eq
// moveq x0,#1 // yes it is OK
beq 100f
ldrb w4,[x1,x2] // load a letter word 2 same position
cmp w3,w4 // equal ?
cset x0,ne // yes -> not good
//moveq x0,#0 // yes -> not good
beq 100f
add x2,x2,#1
b 1b
100:
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/***************************************************/
/* Appel récursif Tri Rapide quicksort */
/***************************************************/
/* x0 contains the address of table */
/* x1 contains index of first item */
/* x2 contains the number of elements > 0 */
triRapide:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
sub x2,x2,#1 // last item index
cmp x1,x2 // first > last ?
bge 100f // yes -> end
mov x4,x0 // save x0
mov x5,x2 // save x2
bl partition1 // cutting.quado 2 parts
mov x2,x0 // index partition
mov x0,x4 // table address
bl triRapide // sort lower part
mov x0,x4 // table address
add x1,x2,#1 // index begin = index partition + 1
add x2,x5,#1 // number of elements
bl triRapide // sort higter part
100: // end function
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/******************************************************************/
/* Partition table elements */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains index of first item */
/* x2 contains index of last item */
partition1:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
stp x6,x7,[sp,-16]! // save registers
stp x8,x9,[sp,-16]! // save registers
mov x8,x0 // save address table 2
mov x7,x2
mov x9,#Word_end
madd x3,x7,x9,x8
ldr x6,[x3,#Word_Ptr_sorted] // load string address last index
mov x4,x1 // init with first index
mov x5,x1 // init with first index
1: // begin loop
madd x3,x5,x9,x8
ldr x0,[x3,#Word_Ptr_sorted] // load current string address
mov x1,x6 // first string address
bl comparStrings
cmp x0,#0
bge 2f
mov x0,x8 // current string < first string
mov x1,x4 // swap array
mov x2,x5
bl swapWord
add x4,x4,#1 // and increment index 1
2:
add x5,x5,#1 // increment index 2
cmp x5,x7 // end ?
blt 1b // no -> loop
mov x0,x8 // and swap array
mov x1,x4
mov x2,x7
bl swapWord
mov x0,x4 // return index partition
100:
ldp x8,x9,[sp],16 // restaur 2 registers
ldp x6,x7,[sp],16 // restaur 2 registers
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/******************************************************************/
/* Swap table elements */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains index 1 */
/* x2 contains index 2 */
swapWord:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
stp x6,x7,[sp,-16]! // save registers
mov x3,#Word_end
madd x4,x1,x3,x0 // compute array index
madd x5,x2,x3,x0
mov x6,#0
1:
ldr x2,[x4,x6] // load 4 bytes
ldr x3,[x5,x6]
str x2,[x5,x6] // store 4 bytes
str x3,[x4,x6]
add x6,x6,#8 // increment 4 bytes
cmp x6,#Word_end // structure size is multiple to 4
blt 1b
100:
ldp x6,x7,[sp],16 // restaur 2 registers
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/************************************/
/* Strings case sensitive comparisons */
/************************************/
/* x0 et x1 contains the address of strings */
/* return 0 in x0 if equals */
/* return -1 if string x0 < string x1 */
/* return 1 if string x0 > string x1 */
comparStrings:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
stp x4,x5,[sp,-16]! // save registers
mov x2,#0 // counter
1:
ldrb w3,[x0,x2] // byte string 1
ldrb w4,[x1,x2] // byte string 2
cmp w3,w4
blt 2f // small
bgt 3f // greather
cmp x3,#0 // 0 end string
beq 4f // end string
add x2,x2,#1 // else add 1 in counter
b 1b // and loop
2:
mov x0,#-1 // small
b 100f
3:
mov x0,#1 // greather
b 100f
4:
mov x0,#0 // equal
100:
ldp x4,x5,[sp],16 // restaur 2 registers
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/********************************************************/
/* File Include fonctions */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"
Program 64 bits start. excitation intoxicate
Ada
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Containers.Generic_Array_Sort;
with Ada.Containers.Indefinite_Vectors;
procedure Danagrams is
package StringVector is new Ada.Containers.Indefinite_Vectors
(Positive, String);
procedure StrSort is new Ada.Containers.Generic_Array_Sort
(Index_Type => Positive,
Element_Type => Character,
Array_Type => String);
function Derange (s1 : String; s2 : String) return Boolean is begin
for i in s1'Range loop
if (s1 (i) = s2 (i)) then return False; end if;
end loop;
return True;
end Derange;
File : File_Type;
len, foundlen : Positive := 1;
Vect, SVect : StringVector.Vector;
index, p1, p2 : StringVector.Extended_Index := 0;
begin
Open (File, In_File, "unixdict.txt");
while not End_Of_File (File) loop
declare str : String := Get_Line (File);
begin
len := str'Length;
if len > foundlen then
Vect.Append (str);
StrSort (str);
index := 0;
loop -- Loop through anagrams by index in vector of sorted strings
index := SVect.Find_Index (str, index + 1);
exit when index = StringVector.No_Index;
if Derange (Vect.Last_Element, Vect.Element (index)) then
p1 := Vect.Last_Index; p2 := index;
foundlen := len;
end if;
end loop;
SVect.Append (str);
end if;
end;
end loop;
Close (File);
Put_Line (Vect.Element (p1) & " " & Vect.Element (p2));
end Danagrams;
- Output:
intoxicate excitation
ALGOL 68
Uses the "read" PRAGMA of Algol 68 G to include the associative array code from the Associative_array/Iteration task.
# find the largest deranged anagrams in a list of words #
# use the associative array in the Associate array/iteration task #
PR read "aArray.a68" PR
# returns the length of str #
OP LENGTH = ( STRING str )INT: 1 + ( UPB str - LWB str );
# returns TRUE if a and b are the same length and have no #
# identical characters at any position, #
# FALSE otherwise #
PRIO ALLDIFFER = 9;
OP ALLDIFFER = ( STRING a, b )BOOL:
IF LENGTH a /= LENGTH b
THEN
# the two stringa are not the same size #
FALSE
ELSE
# the strings are the same length, check the characters #
BOOL result := TRUE;
INT b pos := LWB b;
FOR a pos FROM LWB a TO UPB a WHILE result := ( a[ a pos ] /= b[ b pos ] )
DO
b pos +:= 1
OD;
result
FI # ALLDIFFER # ;
# returns text with the characters sorted #
OP SORT = ( STRING text )STRING:
BEGIN
STRING sorted := text;
FOR end pos FROM UPB sorted - 1 BY -1 TO LWB sorted
WHILE
BOOL swapped := FALSE;
FOR pos FROM LWB sorted TO end pos DO
IF sorted[ pos ] > sorted[ pos + 1 ]
THEN
CHAR t := sorted[ pos ];
sorted[ pos ] := sorted[ pos + 1 ];
sorted[ pos + 1 ] := t;
swapped := TRUE
FI
OD;
swapped
DO SKIP OD;
sorted
END # SORTED # ;
# read the list of words and find the longest deranged anagrams #
CHAR separator = "|"; # character that will separate the anagrams #
IF FILE input file;
STRING file name = "unixdict.txt";
open( input file, file name, stand in channel ) /= 0
THEN
# failed to open the file #
print( ( "Unable to open """ + file name + """", newline ) )
ELSE
# file opened OK #
BOOL at eof := FALSE;
# set the EOF handler for the file #
on logical file end( input file, ( REF FILE f )BOOL:
BEGIN
# note that we reached EOF on the #
# latest read #
at eof := TRUE;
# return TRUE so processing can continue #
TRUE
END
);
REF AARRAY words := INIT LOC AARRAY;
STRING word;
INT longest derangement := 0;
STRING longest word := "<none>";
STRING longest anagram := "<none>";
WHILE NOT at eof
DO
STRING word;
get( input file, ( word, newline ) );
INT word length = LENGTH word;
IF word length >= longest derangement
THEN
# this word is at least long as the longest derangement #
# found so far - test it #
STRING sorted word = SORT word;
IF ( words // sorted word ) /= ""
THEN
# we already have this sorted word - test for #
# deranged anagrams #
# the word list will have a leading separator #
# and be followed by one or more words separated by #
# the separator #
STRING word list := words // sorted word;
INT list pos := LWB word list + 1;
INT list max = UPB word list;
BOOL is deranged := FALSE;
WHILE list pos < list max
AND NOT is deranged
DO
STRING anagram = word list[ list pos : ( list pos + word length ) - 1 ];
IF is deranged := word ALLDIFFER anagram
THEN
# have a deranged anagram #
longest derangement := word length;
longest word := word;
longest anagram := anagram
FI;
list pos +:= word length + 1
OD
FI;
# add the word to the anagram list #
words // sorted word +:= separator + word
FI
OD;
close( input file );
print( ( "Longest deranged anagrams: "
, longest word
, " and "
, longest anagram
, newline
)
)
FI
- Output:
Longest deranged anagrams: intoxicate and excitation
AppleScript
use AppleScript version "2.3.1" -- OS X 10.9 (Mavericks) or later.
use sorter : script ¬
"Custom Iterative Ternary Merge Sort" -- <www.macscripter.net/t/timsort-and-nigsort/71383/3>
use scripting additions
on join(lst, delim)
set astid to AppleScript's text item delimiters
set AppleScript's text item delimiters to delim
set txt to lst as text
set AppleScript's text item delimiters to astid
return txt
end join
on longestDerangedAnagrams(listOfWords)
script o
property wordList : listOfWords
property groupingTexts : wordList's items
property derangementLength : 0
property output : {}
-- Test for any deranged pairs amongst the words of an anagram group.
on testPairs(a, b)
set anagramGroup to my wordList's items a thru b
set groupSize to b - a + 1
set wordLength to (count beginning of anagramGroup)
repeat with i from 1 to (groupSize - 1)
set w1 to anagramGroup's item i
repeat with j from (i + 1) to groupSize
set w2 to anagramGroup's item j
set areDeranged to true
repeat with c from 1 to wordLength
if (w1's character c = w2's character c) then
set areDeranged to false
exit repeat
end if
end repeat
-- Append any deranged pairs found to the output and note the words' length.
if (areDeranged) then
set end of output to {w1, w2}
set derangementLength to wordLength
end if
end repeat
end repeat
end testPairs
-- Custom comparison handler for the sort. Text a should go after text b if
-- it's the same length and has a greater lexical value or it's shorter than b.
-- (The lexical sort direction isn't really relevant. It's just to group equal texts.)
on isGreater(a, b)
set aLen to a's length
set bLen to b's length
if (aLen = bLen) then return (a > b) -- or (b < a)!
return (aLen < bLen)
end isGreater
end script
set wordCount to (count o's wordList)
ignoring case
-- Replace the words in the groupingTexts list with sorted-character versions.
repeat with i from 1 to wordCount
set chrs to o's groupingTexts's item i's characters
tell sorter to sort(chrs, 1, -1, {})
set o's groupingTexts's item i to join(chrs, "")
end repeat
-- Sort the list descending by text length and ascending (say) by value
-- within lengths. Echo the moves in the original word list.
tell sorter to sort(o's groupingTexts, 1, wordCount, {comparer:o, slave:{o's wordList}})
-- Work through the runs of grouping texts, starting with the longest texts.
set i to 1
set currentText to beginning of o's groupingTexts
repeat with j from 2 to (wordCount)
set thisText to o's groupingTexts's item j
if (thisText is not currentText) then
if (j - i > 1) then tell o to testPairs(i, j - 1)
set currentText to thisText
set i to j
end if
-- Stop on reaching a text that's shorter than any derangement(s) found.
if ((count thisText) < o's derangementLength) then exit repeat
end repeat
if (j > i) then tell o to testPairs(i, j)
end ignoring
return o's output
end longestDerangedAnagrams
local wordFile, wordList
set wordFile to ((path to desktop as text) & "www.rosettacode.org:unixdict.txt") as «class furl»
set wordList to paragraphs of (read wordFile as «class utf8»)
return longestDerangedAnagrams(wordList)
- Output:
{{"excitation", "intoxicate"}}
ARM Assembly
/* ARM assembly Raspberry PI */
/* program anaderan.s */
/* REMARK 1 : this program use routines in a include file
see task Include a file language arm assembly
for the routine affichageMess conversion10
see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */
/************************************/
/* Constantes */
/************************************/
.include "../constantes.inc"
.equ MAXI, 50000
.equ BUFFERSIZE, 300000
.equ READ, 3 @ system call
.equ OPEN, 5 @ system call
.equ CLOSE, 6 @ system call
.equ O_RDWR, 0x0002 @ open for reading and writing
/*********************************/
/* Structures */
/*********************************/
/* this structure has size multiple de 4 */
.struct 0
Word_Ptr_buffer: @ pointer word buffer
.struct Word_Ptr_buffer + 4
Word_Ptr_sorted: @ pointer word sorted letters
.struct Word_Ptr_sorted + 4
Word_length: @ word length
.struct Word_length + 4
Word_top: @ top
.struct Word_top + 4
Word_end:
/*********************************/
/* Initialized data */
/*********************************/
.data
szFileName: .asciz "./unixdict.txt"
//szFileName: .asciz "./listwordT.txt"
szMessErreur: .asciz "FILE ERROR."
szMessStart: .asciz "Program 32 bits start.\n"
szCarriageReturn: .asciz "\n"
szMessSpace: .asciz " "
ptBuffer1: .int sBuffer1
/*********************************/
/* UnInitialized data */
/*********************************/
.bss
tbStWords: .skip Word_end * MAXI
iNBword: .skip 4
sBuffer: .skip BUFFERSIZE
sBuffer1: .skip BUFFERSIZE
/*********************************/
/* code section */
/*********************************/
.text
.global main
main: @ entry of program
ldr r0,iAdrszMessStart
bl affichageMess
mov r4,#0 @ loop indice
ldr r0,iAdrszFileName @ file name
mov r1,#O_RDWR @ flags
mov r2,#0 @ mode
mov r7,#OPEN @
svc 0
cmp r0,#0 @ error open
ble 99f
mov r8,r0 @ FD save Fd
ldr r1,iAdrsBuffer @ buffer address
ldr r2,iSizeBuf @ buffersize
mov r7, #READ
svc 0
cmp r0,#0 @ error read ?
blt 99f
mov r5,r0 @ save size read bytes
ldr r4,iAdrsBuffer @ buffer address
ldr r0,iAdrsBuffer @ start word address
mov r2,#0
mov r1,#0 @ word length
1:
cmp r2,r5
bge 2f
ldrb r3,[r4,r2]
cmp r3,#0xD @ end word ?
addne r1,r1,#1 @ increment word length
addne r2,r2,#1 @ increment indice
bne 1b @ and loop
mov r3,#0
strb r3,[r4,r2] @ store final zero
bl anaWord @ sort word letters
add r2,r2,#2 @ jump OD and 0A
add r0,r4,r2 @ new address begin word
mov r1,#0 @ init length
b 1b @ and loop
2:
mov r3,#0 @ last word
strb r3,[r4,r2]
bl anaWord
mov r0,r8 @ file Fd
mov r7, #CLOSE
svc 0
cmp r0,#0 @ error close ?
blt 99f
ldr r0,iAdrtbStWords @ array structure words address
mov r1,#0 @ first indice
ldr r2,iAdriNBword
ldr r2,[r2] @ last indice
bl triRapide @ quick sort
ldr r4,iAdrtbStWords @ array structure words address
mov r0,r4
mov r9,r2 @ size word array
mov r8,#0 @ indice first occurence
ldr r3,[r4,#Word_Ptr_sorted] @ load first value
mov r2,#1 @ loop indice
mov r10,#Word_end @ words structure size
mov r12,#0 @ max word length
3: @ begin loop
mla r7,r2,r10,r4 @ compute array index
ldr r5,[r7,#Word_Ptr_sorted] @ load next value
mov r0,r3
mov r1,r5
bl comparStrings
cmp r0,#0 @ sorted strings equal ?
bne 4f
mla r11,r8,r10,r4
ldr r0,[r11,#Word_Ptr_buffer] @ address word 1
ldr r1,[r7,#Word_Ptr_buffer] @ address word 2
bl controlLetters
cmp r0,#0 @ not ok ?
beq 5f
mov r0,#1 @ letters ok
str r0,[r7,#Word_top] @ store top in first occurence
str r0,[r11,#Word_top] @ store top in current occurence
ldr r0,[r7,#Word_length] @ word length
cmp r0,r12 @ compare maxi
movgt r12,r0 @ yes length word -> value max
b 5f
4: @ no
mov r0,r8
add r8,r8,#1 @ init index new first occurence
mla r11,r8,r10,r4 @ compute array index
ldr r3,[r11,#Word_Ptr_sorted] @ init value new first occurence
mov r2,r0 @ reprise au debut de la sequence
5:
add r2,r2,#1 @ increment indice
cmp r2,r9 @ end word array ?
blt 3b @ no -> loop
mov r2,#0 @ raz indice
ldr r4,iAdrtbStWords @ array structure words address
6: @ begin display loop
mla r11,r2,r10,r4 @ compute array index
ldr r6,[r11,#Word_top] @ load top
cmp r6,#0 @ top ok ?
beq 7f
ldr r6,[r11,#Word_length] @ load length
cmp r6,r12 @ compare maxi
bne 7f
ldr r0,[r11,#Word_Ptr_buffer] @ load address first word
bl affichageMess @ display first word
add r2,r2,#1 @ increment indice
mla r11,r2,r10,r4 @ compute array index
ldr r6,[r11,#Word_top] @ load top
cmp r6,#0 @ top ok ?
beq 7f
ldr r0,iAdrszMessSpace
bl affichageMess
ldr r0,[r11,#Word_Ptr_buffer] @ load address other word
bl affichageMess @ display second word
ldr r0,iAdrszCarriageReturn
bl affichageMess
7:
add r2,r2,#1 @ increment indice
cmp r2,r9 @ maxi ?
blt 6b @ no -> loop
b 100f
99: @ display error
ldr r1,iAdrszMessErreur
bl displayError
100: @ standard end of the program
mov r0, #0 @ return code
mov r7, #EXIT @ request to exit program
svc #0 @ perform the system call
iAdrszCarriageReturn: .int szCarriageReturn
iAdrszFileName: .int szFileName
iAdrszMessErreur: .int szMessErreur
iAdrsBuffer: .int sBuffer
iSizeBuf: .int BUFFERSIZE
iAdrszMessSpace: .int szMessSpace
iAdrtbStWords: .int tbStWords
iAdrszMessStart: .int szMessStart
/******************************************************************/
/* analizing word */
/******************************************************************/
/* r0 word address */
/* r1 word length */
anaWord:
push {r1-r6,lr}
mov r5,r0
mov r6,r1
//ldr r1,iAdrptTabBuffer
ldr r1,iAdrtbStWords
ldr r2,iAdriNBword
ldr r3,[r2]
mov r4,#Word_end
mla r1,r3,r4,r1
str r0,[r1,#Word_Ptr_buffer]
mov r0,#0
str r0,[r1,#Word_top]
str r6,[r1,#Word_length]
ldr r4,iAdrptBuffer1
ldr r0,[r4]
add r6,r6,r0
add r6,r6,#1
str r6,[r4]
str r0,[r1,#Word_Ptr_sorted]
add r3,r3,#1
str r3,[r2]
mov r1,r0
mov r0,r5
bl triLetters @ sort word letters
mov r2,#0
100:
pop {r1-r6,pc}
iAdriNBword: .int iNBword
iAdrptBuffer1: .int ptBuffer1
/******************************************************************/
/* sort word letters */
/******************************************************************/
/* r0 address begin word */
/* r1 address recept array */
triLetters:
push {r1-r7,lr}
mov r2,#0
1:
ldrb r3,[r0,r2] @ load letter
cmp r3,#0 @ end word ?
beq 6f
cmp r2,#0 @ first letter ?
bne 2f
strb r3,[r1,r2] @ yes store in first position
add r2,r2,#1 @ increment indice
b 1b @ and loop
2:
mov r4,#0
3: @ begin loop to search insertion position
ldrb r5,[r1,r4] @ load letter
cmp r3,r5 @ compare
blt 4f @ to low -> insertion
add r4,r4,#1 @ increment indice
cmp r4,r2 @ compare to letters number in place
blt 3b @ search loop
strb r3,[r1,r2] @ else store in last position
add r2,r2,#1
b 1b @ and loop
4: @ move first letters in one position
sub r6,r2,#1 @ start indice
5:
ldrb r5,[r1,r6] @ load letter
add r7,r6,#1 @ store indice - 1
strb r5,[r1,r7] @ store letter
sub r6,r6,#1 @ decrement indice
cmp r6,r4 @ end ?
bge 5b @ no loop
strb r3,[r1,r4] @ else store letter in free position
add r2,r2,#1
b 1b @ and loop
6:
mov r3,#0 @ final zéro
strb r3,[r1,r2]
100:
pop {r1-r7,pc}
/******************************************************************/
/* control letters */
/******************************************************************/
/* r0 address word 1*/
/* r1 address word 2 */
controlLetters:
push {r1-r4,lr}
mov r2,#0
1:
ldrb r3,[r0,r2] @ load a letter
cmp r3,#0 @ end word ?
moveq r0,#1 @ yes it is OK
beq 100f
ldrb r4,[r1,r2] @ load a letter word 2 same position
cmp r3,r4 @ equal ?
moveq r0,#0 @ yes -> not good
beq 100f
add r2,r2,#1
b 1b
100:
pop {r1-r4,pc}
/***************************************************/
/* Appel récursif Tri Rapide quicksort */
/***************************************************/
/* r0 contains the address of table */
/* r1 contains index of first item */
/* r2 contains the number of elements > 0 */
triRapide:
push {r2-r5,lr} @ save registers
sub r2,#1 @ last item index
cmp r1,r2 @ first > last ?
bge 100f @ yes -> end
mov r4,r0 @ save r0
mov r5,r2 @ save r2
bl partition1 @ cutting into 2 parts
mov r2,r0 @ index partition
mov r0,r4 @ table address
bl triRapide @ sort lower part
mov r0,r4 @ table address
add r1,r2,#1 @ index begin = index partition + 1
add r2,r5,#1 @ number of elements
bl triRapide @ sort higter part
100: @ end function
pop {r2-r5,lr} @ restaur registers
bx lr @ return
/******************************************************************/
/* Partition table elements */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains index of first item */
/* r2 contains index of last item */
partition1:
push {r1-r9,lr} @ save registers
mov r8,r0 @ save address table 2
mov r7,r2
mov r9,#Word_end
mla r3,r7,r9,r8
ldr r6,[r3,#Word_Ptr_sorted] @ load string address last index
mov r4,r1 @ init with first index
mov r5,r1 @ init with first index
1: @ begin loop
mla r3,r5,r9,r8
ldr r0,[r3,#Word_Ptr_sorted] @ load current string address
mov r1,r6 @ first string address
bl comparStrings
cmp r0,#0
bge 2f
mov r0,r8 @ current string < first string
mov r1,r4 @ swap array
mov r2,r5
bl swapWord
add r4,r4,#1 @ and increment index 1
2:
add r5,r5,#1 @ increment index 2
cmp r5,r7 @ end ?
blt 1b @ no -> loop
mov r0,r8 @ and swap array
mov r1,r4
mov r2,r7
bl swapWord
mov r0,r4 @ return index partition
100:
pop {r1-r9,lr}
bx lr
/******************************************************************/
/* Swap table elements */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains index 1 */
/* r2 contains index 2 */
swapWord:
push {r1-r6,lr} @ save registers
mov r3,#Word_end
mla r4,r1,r3,r0 @ compute array index
mla r5,r2,r3,r0
mov r6,#0
1:
ldr r2,[r4,r6] @ load 4 bytes
ldr r3,[r5,r6]
str r2,[r5,r6] @ store 4 bytes
str r3,[r4,r6]
add r6,r6,#4 @ increment 4 bytes
cmp r6,#Word_end @ structure size is multiple to 4
blt 1b
100:
pop {r1-r6,pc}
/************************************/
/* Strings case sensitive comparisons */
/************************************/
/* r0 et r1 contains the address of strings */
/* return 0 in r0 if equals */
/* return -1 if string r0 < string r1 */
/* return 1 if string r0 > string r1 */
comparStrings:
push {r1-r4} @ save des registres
mov r2,#0 @ counter
1:
ldrb r3,[r0,r2] @ byte string 1
ldrb r4,[r1,r2] @ byte string 2
cmp r3,r4
movlt r0,#-1 @ small
movgt r0,#1 @ greather
bne 100f @ not equals
cmp r3,#0 @ 0 end string
moveq r0,#0 @ equals
beq 100f @ end string
add r2,r2,#1 @ else add 1 in counter
b 1b @ and loop
100:
pop {r1-r4}
bx lr
/***************************************************/
/* ROUTINES INCLUDE */
/***************************************************/
.include "../affichage.inc"
Program 32 bits start. excitation intoxicate
Arturo
isDeranged?: function [p][
[a,b]: p
loop 0..dec size a 'i [
if a\[i] = b\[i] [return false]
]
return true
]
wordset: map read.lines relative "unixdict.txt" => strip
anagrams: #[]
loop wordset 'word [
anagram: sort to [:char] word
unless key? anagrams anagram ->
anagrams\[anagram]: new []
anagrams\[anagram]: anagrams\[anagram] ++ word
]
deranged: select values anagrams 'anagram [ 2 = size anagram]
maxDeranged: ["" ""]
loop deranged 'd [
if (size first d) > size first maxDeranged [
pair: @[first d, last d]
if isDeranged? pair [
maxDeranged: pair
]
]
]
print maxDeranged
- Output:
excitation intoxicate
AutoHotkey
Time := A_TickCount
SetWorkingDir %A_ScriptDir% ; Ensures a consistent starting directory.
SetBatchLines -1
Loop, Read, unixdict.txt
StrOut .= StrLen(A_LoopReadLine) - 2 . "," . A_LoopReadLine . "`n"
Sort StrOut, N R
Loop, Parse, StrOut, `n, `r
{
StringSplit, No_Let, A_Loopfield, `,
if ( old1 = no_let1 )
string .= old2 "`n"
if ( old1 != no_let1 )
{
string := trim(string old2)
if ( old2 != "" )
Loop, Parse, string, `n, `r ; Specifying `n prior to `r allows both Windows and Unix files to be Parsed.
line_number := A_Index
if ( line_number > 1 )
{
Loop, Parse, string, `n, `r
{
StringSplit, newstr, A_Loopfield, `, ; break the string based on Comma
Loop, Parse, newstr2
k .= A_LoopField " "
Sort k, D%A_Space%
k := RegExReplace( k, "\s", "" )
file .= "`r`n" k . "," . newstr1 . "," . newstr2
k =
}
Sort File
Loop, Parse, File, `n, `r
{
if ( A_Loopfield != "" )
{
StringSplit, T_C, A_Loopfield, `,
if ( old = T_C1 )
{
Loop, 1
{
Loop % T_C2
if (SubStr(T_C3, A_Index, 1) = SubStr(old3, A_Index, 1))
break 2
Time := (A_tickcount - Time)/1000
MsgBox % T_C3 " " old3 " in " Time . " seconds."
ExitApp
}
}
old := T_C1, old3 := T_C3
}
}
file =
}
string =
}
old1 := no_let1, old2 := A_Loopfield
}
- Output:
intoxicate excitation in 0.844000 seconds.
AWK
#!/bin/gawk -f
BEGIN{
FS=""
wordcount = 0
maxlength = 0
}
# hash generates the sorted sequence of characters in a word,
# so that the hashes for a pair of anagrams will be the same.
# Example: hash meat = aemt and hash team = aemt
function hash(myword, i,letters,myhash){
split(myword,letters,"")
asort(letters)
for (i=1;i<=length(myword);i++) myhash=myhash letters[i]
return myhash
}
# deranged checks two anagrems for derangement
function deranged(worda, wordb, a,b,i,n,len){
n=0
len=split(worda,a,"")
split(wordb,b,"")
for (i=len; i>=1; i--){
if (a[i] == b[i]) n = n+1
}
return n==0
}
# field separator null makes gawk split input record character by character.
# the split function works the same way
{
wordcount = wordcount + 1
fullword[wordcount]=$0
bylength[length($0)]=bylength[length($0)] wordcount "|"
if (length($0) > maxlength) maxlength = length($0)
}
END{
for (len=maxlength; len>1; len--){
numwords=split(bylength[len],words,"|")
split("",hashed)
split("",anagrams)
for (i=1;i<=numwords;i++){
# make lists of anagrams in hashed
myword = fullword[words[i]]
myhash = hash(myword)
hashed[myhash] = hashed[myhash] myword " "
}
# check anagrams for derangement
for (myhash in hashed){
n = split(hashed[myhash],anagrams," ")
for (i=1; i< n; i++)
for (j=i+1; j<=n; j++){
if(deranged(anagrams[i],anagrams[j])) found = found anagrams[i] " " anagrams[j] " "
}
}
if (length(found) > 0 ) print "deranged: " found
if (length(found) > 0) exit
}
}
On my system, this awk-file is located at /usr/local/bin/deranged, so it can be invoked with:
deranged /tmp/unixdict.txt
Regular invocation would be:
gawk -f deranged.awk /tmp/unixdict.txt
- Output:
deranged: excitation intoxicate
BASIC
BaCon
DECLARE idx$ ASSOC STRING
FUNCTION Deranged(a$, b$)
FOR i = 1 TO LEN(a$)
IF MID$(a$, i, 1) = MID$(b$, i, 1) THEN RETURN FALSE
NEXT
RETURN TRUE
END FUNCTION
FOR w$ IN LOAD$(DIRNAME$(ME$) & "/unixdict.txt") STEP NL$
set$ = EXTRACT$(SORT$(EXPLODE$(w$, 1)), " ")
idx$(set$) = APPEND$(idx$(set$), 0, w$)
NEXT
FOR w$ IN OBTAIN$(idx$)
FOR x = 1 TO AMOUNT(idx$(w$))
FOR y = x+1 TO AMOUNT(idx$(w$))
IF Deranged(TOKEN$(idx$(w$), x), TOKEN$(idx$(w$), y)) AND LEN(TOKEN$(idx$(w$), x)) > current THEN
current = LEN(TOKEN$(idx$(w$), x))
an1$ = TOKEN$(idx$(w$), x)
an2$ = TOKEN$(idx$(w$), y)
END IF
NEXT
NEXT
NEXT
PRINT "Maximum deranged anagrams: ", an1$, " and ", an2$
PRINT NL$, "Total time: ", TIMER, " msecs.", NL$
- Output:
Maximum deranged anagrams: excitation and intoxicate Total time: 75 msecs.
BBC BASIC
INSTALL @lib$+"SORTLIB"
Sort% = FN_sortinit(0,0)
DIM dict$(26000), sort$(26000), indx%(26000)
REM Load the dictionary:
dict% = OPENIN("C:\unixdict.txt")
IF dict%=0 ERROR 100, "No dictionary file"
index% = 0
REPEAT
index% += 1
dict$(index%) = GET$#dict%
indx%(index%) = index%
UNTIL EOF#dict%
CLOSE #dict%
Total% = index%
TIME = 0
REM Sort the letters in each word:
FOR index% = 1 TO Total%
sort$(index%) = FNsortstring(dict$(index%))
NEXT
REM Sort the sorted words:
C% = Total%
CALL Sort%, sort$(1), indx%(1)
REM Find anagrams and deranged anagrams:
maxlen% = 0
maxidx% = 0
FOR index% = 1 TO Total%-1
IF sort$(index%) = sort$(index%+1) THEN
One$ = dict$(indx%(index%))
Two$ = dict$(indx%(index%+1))
FOR c% = 1 TO LEN(One$)
IF MID$(One$,c%,1) = MID$(Two$,c%,1) EXIT FOR
NEXT
IF c%>LEN(One$) IF c%>maxlen% maxlen% = c% : maxidx% = index%
ENDIF
NEXT
PRINT "The longest deranged anagrams are '" dict$(indx%(maxidx%));
PRINT "' and '" dict$(indx%(maxidx%+1)) "'"
PRINT "(taking " ; TIME/100 " seconds)"
END
DEF FNsortstring(A$)
LOCAL C%, a&()
C% = LEN(A$)
DIM a&(C%)
$$^a&(0) = A$
CALL Sort%, a&(0)
= $$^a&(0)
- Output:
The longest deranged anagrams are 'excitation' and 'intoxicate' (taking 0.95 seconds)
Bracmat
The file is read into a single string, wordList
.
Then, in a while loop, each line is read and, in a nested loop, atomised into single letters.
The letters are added together to create a sorted list that is the letter sum, the 'anagram fingerprint', of the word.
To make sure that even single letter words create a sum of at least two terms, the sum is initialised with the empty string rather than zero.
(Otherwise the words a and aaa later on would get the same fingerprint, the factors 1
and 3
being factored out.)
For the word bizarre the letter sum is (+a+b+e+2*r+z+i)
.
The letter sum, with the word as the exponent ((+a+b+e+2*r+z+i)^bizarre
) is prepended to a list unsorted
.
Somewhat later the word brazier also is prepended to the unsorted
list.
This word happens to have the same letter sum as bizarre, so these two words must be anagrams of each other. The program brings these two elements together by merge sorting the unsorted
list, using Bracmat's Computer Algebra powers to normalise sums and products by sorting and combining like terms or factors.
During the sort, all elements in the the unsorted
list are multiplied together, combining factors with the same letter sums by adding their exponents together. So at some stage during sorting, the two elements (+a+b+e+2*r+z+i)^bizarre
and (+a+b+e+2*r+z+i)^brazier
are brought together in a product (+a+b+e+2*r+z+i)^bizarre*(+a+b+e+2*r+z+i)^brazier
which immediately is transformed to the single factor (+a+b+e+2*r+z+i)^(bizarre+brazier)
.
In the product of all elements the anagrams are to be found in the exponents consisting of a sum of at least two terms.
To find the longest deranged anagrams, we traverse the product list to find all exponents with multiple words, check that the length of the first word is at least as long as the length of the longest deranged anagram up to now, and check each pair of words for being deranged.
If a pair of deranged anagrams is found with more letters than previously found deranged anagrams, the earlier finds are forgotten. If the new anagrams are the same length, however, they are added to the output.
The Bracmat solution to the similar task anagrams skips the explicit merge sort and instead prepends new factors directly to the product one by one. Bracmat shuffles each new factor into place to keep the growing product normalized before continuing with the next word from the list. The result is exactly the same, but the running time becomes much longer.
get$("unixdict.txt",STR):?wordList
& 1:?product
& :?unsorted
& whl
' ( @(!wordList:(%?word:?letterString) \n ?wordList)
& :?letterSum
& whl
' ( @(!letterString:%?letter ?letterString)
& (!letter:~#|str$(N !letter))+!letterSum
: ?letterSum
)
& !letterSum^!word !unsorted:?unsorted
)
& ( mergeSort
= newL L first second
. !arg:?L
& whl
' ( !L:% %
& :?newL
& whl
' ( !L:%?first %?second ?L
& !first*!second !newL:?newL
)
& !L !newL:?L
)
& !L
)
& mergeSort$!unsorted:?product
& 0:?maxLength:?oldMaxLength
& :?derangedAnagrams
& ( deranged
= nextLetter Atail Btail
. !arg
: ( (.)
| ( @(?:%@?nextLetter ?Atail)
. @(?:(%@:~!nextLetter) ?Btail)
)
& deranged$(!Atail.!Btail)
)
)
& ( !product
: ?
* ?
^ ( %+%
: @(%:? ([~<!maxLength:[?maxLength))+?
: ?
+ %@?anagramA
+ ?
+ %@?anagramB
+ ( ?
& deranged$(!anagramA.!anagramB)
& (!anagramA.!anagramB)
( !maxLength:>!oldMaxLength:?oldMaxLength
&
| !derangedAnagrams
)
: ?derangedAnagrams
& ~
)
)
* ?
| out$!derangedAnagrams
);
- Output:
excitation.intoxicate
C
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <sys/types.h>
#include <fcntl.h>
#include <sys/stat.h>
// Letter lookup by frequency. This is to reduce word insertion time.
const char *freq = "zqxjkvbpygfwmucldrhsnioate";
int char_to_idx[128];
// Trie structure of sorts
struct word {
const char *w;
struct word *next;
};
union node {
union node *down[10];
struct word *list[10];
};
int deranged(const char *s1, const char *s2)
{
int i;
for (i = 0; s1[i]; i++)
if (s1[i] == s2[i]) return 0;
return 1;
}
int count_letters(const char *s, unsigned char *c)
{
int i, len;
memset(c, 0, 26);
for (len = i = 0; s[i]; i++) {
if (s[i] < 'a' || s[i] > 'z')
return 0;
len++, c[char_to_idx[(unsigned char)s[i]]]++;
}
return len;
}
const char * insert(union node *root, const char *s, unsigned char *cnt)
{
int i;
union node *n;
struct word *v, *w = 0;
for (i = 0; i < 25; i++, root = n) {
if (!(n = root->down[cnt[i]]))
root->down[cnt[i]] = n = calloc(1, sizeof(union node));
}
w = malloc(sizeof(struct word));
w->w = s;
w->next = root->list[cnt[25]];
root->list[cnt[25]] = w;
for (v = w->next; v; v = v->next) {
if (deranged(w->w, v->w))
return v->w;
}
return 0;
}
int main(int c, char **v)
{
int i, j = 0;
char *words;
struct stat st;
int fd = open(c < 2 ? "unixdict.txt" : v[1], O_RDONLY);
if (fstat(fd, &st) < 0) return 1;
words = malloc(st.st_size);
read(fd, words, st.st_size);
close(fd);
union node root = {{0}};
unsigned char cnt[26];
int best_len = 0;
const char *b1, *b2;
for (i = 0; freq[i]; i++)
char_to_idx[(unsigned char)freq[i]] = i;
/* count words, change newline to null */
for (i = j = 0; i < st.st_size; i++) {
if (words[i] != '\n') continue;
words[i] = '\0';
if (i - j > best_len) {
count_letters(words + j, cnt);
const char *match = insert(&root, words + j, cnt);
if (match) {
best_len = i - j;
b1 = words + j;
b2 = match;
}
}
j = ++i;
}
if (best_len) printf("longest derangement: %s %s\n", b1, b2);
return 0;
}
- Output:
longest derangement: intoxicate excitation
C#
public static void Main()
{
var lookupTable = File.ReadLines("unixdict.txt").ToLookup(line => AnagramKey(line));
var query = from a in lookupTable
orderby a.Key.Length descending
let deranged = FindDeranged(a)
where deranged != null
select deranged[0] + " " + deranged[1];
Console.WriteLine(query.FirstOrDefault());
}
static string AnagramKey(string word) => new string(word.OrderBy(c => c).ToArray());
static string[] FindDeranged(IEnumerable<string> anagrams) => (
from first in anagrams
from second in anagrams
where !second.Equals(first)
&& Enumerable.Range(0, first.Length).All(i => first[i] != second[i])
select new [] { first, second })
.FirstOrDefault();
- Output:
excitation intoxicate
C++
#include <algorithm>
#include <fstream>
#include <functional>
#include <iostream>
#include <map>
#include <numeric>
#include <set>
#include <string>
bool is_deranged(const std::string& left, const std::string& right)
{
return (left.size() == right.size()) &&
(std::inner_product(left.begin(), left.end(), right.begin(), 0, std::plus<int>(), std::equal_to<char>()) == 0);
}
int main()
{
std::ifstream input("unixdict.txt");
if (!input) {
std::cerr << "can't open input file\n";
return EXIT_FAILURE;
}
typedef std::set<std::string> WordList;
typedef std::map<std::string, WordList> AnagraMap;
AnagraMap anagrams;
std::pair<std::string, std::string> result;
size_t longest = 0;
for (std::string value; input >> value; /**/) {
std::string key(value);
std::sort(key.begin(), key.end());
if (longest < value.length()) { // is it a long candidate?
if (0 < anagrams.count(key)) { // is it an anagram?
for (const auto& prior : anagrams[key]) {
if (is_deranged(prior, value)) { // are they deranged?
result = std::make_pair(prior, value);
longest = value.length();
}
}
}
}
anagrams[key].insert(value);
}
std::cout << result.first << ' ' << result.second << '\n';
return EXIT_SUCCESS;
}
- Output:
excitation intoxicate
Clojure
(->> (slurp "unixdict.txt") ; words
(re-seq #"\w+") ; |
(group-by sort) ; anagrams
vals ; |
(filter second) ; |
(remove #(some true? (apply map = %))) ; deranged
(sort-by #(count (first %)))
last
prn)
- Output:
$ lein exec deranged.clj ["excitation" "intoxicate"]
COBOL
******************************************************************
* COBOL solution to Anagrams Deranged challange
* The program was run on OpenCobolIDE
* Input data is stored in file 'Anagrams.txt' on my PC
******************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. DERANGED.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT IN-FILE ASSIGN TO 'C:\Both\Rosetta\Anagrams.txt'
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD IN-FILE.
01 IN-RECORD PIC X(22).
WORKING-STORAGE SECTION.
01 SWITCHES.
05 WS-EOF PIC X VALUE 'N'.
05 WS-FND PIC X VALUE 'N'.
05 WS-EXIT PIC X VALUE 'N'.
01 COUNTERS.
05 WS-TOT-RECS PIC 9(5) USAGE PACKED-DECIMAL VALUE 0.
05 WS-SEL-RECS PIC 9(5) USAGE PACKED-DECIMAL VALUE 0.
05 WT-REC-NBR PIC 9(5) USAGE PACKED-DECIMAL VALUE 0.
* Extra byte to guarentee a space at end - needed in sort logic.
01 WS-WORD-TEMP PIC X(23).
01 FILLER REDEFINES WS-WORD-TEMP.
05 WS-LETTER OCCURS 23 TIMES PIC X.
77 WS-LETTER-HLD PIC X.
77 WS-WORD-IN PIC X(22).
77 WS-WORD-KEY PIC X(22).
01 WS-WORD-TABLE.
05 WT-RECORD OCCURS 0 to 24000 TIMES
DEPENDING ON WT-REC-NBR
DESCENDING KEY IS WT-WORD-LEN
INDEXED BY WT-IDX.
10 WT-WORD-KEY PIC X(22).
10 WT-WORD-LEN PIC 9(2).
10 WT-ANAGRAM-CNT PIC 9(5) USAGE PACKED-DECIMAL.
10 WT-ANAGRAMS OCCURS 6 TIMES.
15 WT-ANAGRAM PIC X(22).
01 WS-WORD-TEMP1 PIC X(22).
01 FILLER REDEFINES WS-WORD-TEMP1.
05 WS-LETTER1 PIC X OCCURS 22 TIMES.
01 WS-WORD-TEMP2 PIC X(22).
01 FILLER REDEFINES WS-WORD-TEMP2.
05 WS-LETTER2 OCCURS 22 TIMES PIC X.
77 WS-I PIC 9(5) USAGE PACKED-DECIMAL.
77 WS-J PIC 9(5) USAGE PACKED-DECIMAL.
77 WS-K PIC 9(5) USAGE PACKED-DECIMAL.
77 WS-L PIC 9(5) USAGE PACKED-DECIMAL.
77 WS-BEG PIC 9(5) USAGE PACKED-DECIMAL.
77 WS-MAX PIC 9(5) USAGE PACKED-DECIMAL.
PROCEDURE DIVISION.
000-MAIN.
PERFORM 100-INITIALIZE.
PERFORM 200-PROCESS-RECORD UNTIL WS-EOF = 'Y'.
SORT WT-RECORD ON DESCENDING KEY WT-WORD-LEN.
PERFORM 500-FIND-DERANGED.
PERFORM 900-TERMINATE.
STOP RUN.
100-INITIALIZE.
OPEN INPUT IN-FILE.
PERFORM 150-READ-RECORD.
150-READ-RECORD.
READ IN-FILE INTO WS-WORD-IN
AT END
MOVE 'Y' TO WS-EOF
NOT AT END
COMPUTE WS-TOT-RECS = WS-TOT-RECS + 1
END-READ.
200-PROCESS-RECORD.
IF WS-WORD-IN IS ALPHABETIC
COMPUTE WS-SEL-RECS = WS-SEL-RECS + 1 END-COMPUTE
MOVE WS-WORD-IN TO WS-WORD-TEMP
PERFORM 300-SORT-WORD
MOVE WS-WORD-TEMP TO WS-WORD-KEY
PERFORM 400-ADD-TO-TABLE
END-IF.
PERFORM 150-READ-RECORD.
* bubble sort:
300-SORT-WORD.
PERFORM VARYING WS-MAX FROM 1 BY 1
UNTIL WS-LETTER(WS-MAX) = SPACE
END-PERFORM.
PERFORM VARYING WS-I FROM 1 BY 1 UNTIL WS-I = WS-MAX
PERFORM VARYING WS-J FROM WS-I BY 1
UNTIL WS-J > WS-MAX - 1
IF WS-LETTER(WS-J) < WS-LETTER(WS-I) THEN
MOVE WS-LETTER(WS-I) TO WS-LETTER-HLD
MOVE WS-LETTER(WS-J) TO WS-LETTER(WS-I)
MOVE WS-LETTER-HLD TO WS-LETTER(WS-J)
END-IF
END-PERFORM
END-PERFORM.
400-ADD-TO-TABLE.
SET WT-IDX TO 1.
SEARCH WT-RECORD
AT END
PERFORM 420-ADD-RECORD
WHEN WT-WORD-KEY(WT-IDX) = WS-WORD-KEY
PERFORM 440-UPDATE-RECORD
END-SEARCH.
420-ADD-RECORD.
ADD 1 To WT-REC-NBR.
MOVE WS-WORD-KEY TO WT-WORD-KEY(WT-REC-NBR).
COMPUTE WT-WORD-LEN(WT-REC-NBR) = WS-MAX - 1 END-COMPUTE.
MOVE 1 TO WT-ANAGRAM-CNT(WT-REC-NBR).
MOVE WS-WORD-IN TO
WT-ANAGRAM(WT-REC-NBR, WT-ANAGRAM-CNT(WT-REC-NBR)).
440-UPDATE-RECORD.
ADD 1 TO WT-ANAGRAM-CNT(WT-IDX).
MOVE WS-WORD-IN TO
WT-ANAGRAM(WT-IDX, WT-ANAGRAM-CNT(WT-IDX)).
500-FIND-DERANGED.
PERFORM VARYING WS-I FROM 1 BY 1
UNTIL WS-I > WT-REC-NBR OR WS-FND = 'Y'
PERFORM VARYING WS-J FROM 1 BY 1
UNTIL WS-J > WT-ANAGRAM-CNT(WS-I) - 1 OR WS-FND = 'Y'
COMPUTE WS-BEG = WS-J + 1 END-COMPUTE
PERFORM VARYING WS-K FROM WS-BEG BY 1
UNTIL WS-K > WT-ANAGRAM-CNT(WS-I) OR WS-FND = 'Y'
MOVE WT-ANAGRAM(WS-I, WS-J) TO WS-WORD-TEMP1
MOVE WT-ANAGRAM(WS-I, WS-K) To WS-WORD-TEMP2
PERFORM 650-CHECK-DERANGED
END-PERFORM
END-PERFORM
END-PERFORM.
650-CHECK-DERANGED.
MOVE 'N' TO WS-EXIT.
PERFORM VARYING WS-L FROM 1 BY 1
UNTIL WS-L > WT-WORD-LEN(WS-I) OR WS-EXIT = 'Y'
IF WS-LETTER1(WS-L) = WS-LETTER2(WS-L)
MOVE 'Y' TO WS-EXIT
END-IF
END-PERFORM.
IF WS-EXIT = 'N'
DISPLAY
WS-WORD-TEMP1(1:WT-WORD-LEN(WS-I)) ' ' WS-WORD-TEMP2
END-DISPLAY
MOVE 'Y' TO WS-FND
END-IF.
900-TERMINATE.
DISPLAY 'RECORDS READ: ' WS-TOT-RECS.
DISPLAY 'RECORDS SELECTED ' WS-SEL-RECS.
DISPLAY 'RECORD KEYS: ' WT-REC-NBR.
CLOSE IN-FILE.
END PROGRAM DERANGED.
*> OUTPUT:
*> excitation intoxicate
*> RECORDS READ: 25104
*> RECORDS SELECTED 24978
*> RECORD KEYS: 23441
*> BUBBLE SORT REFERENCE:
*> https://mainframegeek.wordpress.com/tag/bubble-sort-in-cobol
CoffeeScript
This example was tested with node.js.
http = require 'http'
is_derangement = (word1, word2) ->
for c, i in word1
return false if c == word2[i]
true
show_longest_derangement = (word_lst) ->
anagrams = {}
max_len = 0
for word in word_lst
continue if word.length < max_len
key = word.split('').sort().join('')
if anagrams[key]
for prior in anagrams[key]
if is_derangement(prior, word)
max_len = word.length
result = [prior, word]
else
anagrams[key] = []
anagrams[key].push word
console.log "Longest derangement: #{result.join ' '}"
get_word_list = (process) ->
options =
host: "www.puzzlers.org"
path: "/pub/wordlists/unixdict.txt"
req = http.request options, (res) ->
s = ''
res.on 'data', (chunk) ->
s += chunk
res.on 'end', ->
process s.split '\n'
req.end()
get_word_list show_longest_derangement
- Output:
> coffee anagrams.coffee Longest derangement: excitation intoxicate
Common Lisp
(defun read-words (file)
(with-open-file (stream file)
(loop with w = "" while w collect (setf w (read-line stream nil)))))
(defun deranged (a b)
(loop for ac across a for bc across b always (char/= ac bc)))
(defun longest-deranged (file)
(let ((h (make-hash-table :test #'equal))
(wordlist (sort (read-words file)
#'(lambda (x y) (> (length x) (length y))))))
(loop for w in wordlist do
(let* ((ws (sort (copy-seq w) #'char<))
(l (gethash ws h)))
(loop for w1 in l do
(if (deranged w w1)
(return-from longest-deranged (list w w1))))
(setf (gethash ws h) (cons w l))))))
(format t "~{~A~%~^~}" (longest-deranged "unixdict.txt"))
- Output:
intoxicate excitation
D
Short Version
void main() {
import std.stdio, std.file, std.algorithm, std.string, std.array;
string[][dstring] anags;
foreach (const w; "unixdict.txt".readText.split)
anags[w.array.sort().release.idup] ~= w;
anags
.byValue
.map!(words => words.cartesianProduct(words)
.filter!q{ a[].equal!q{ a != b }})
.join
.minPos!q{ a[0].length > b[0].length }[0]
.writeln;
}
- Output:
Tuple!(string, string)("intoxicate", "excitation")
Runtime: about 0.11 seconds with LDC2 compiler.
Using const(ubytes)[] instead of dstrings gives a runtime of about 0.07 seconds:
string[][ubyte[]] anags;
foreach (const w; "unixdict.txt".readText.split)
anags[w.dup.representation.sort().release.assumeUnique] ~= w;
Faster Version
import std.stdio, std.file, std.algorithm, std.string, std.array,
std.functional, std.exception;
string[2][] findDeranged(in string[] words) pure nothrow /*@safe*/ {
// return words
// .map!representation
// .pairwise
// .filter!(ww => ww[].equal!q{ a != b });
typeof(return) result;
foreach (immutable i, immutable w1; words)
foreach (immutable w2; words[i + 1 .. $])
if (w1.representation.equal!q{ a != b }(w2.representation))
result ~= [w1, w2];
return result;
}
void main() /*@safe*/ {
Appender!(string[])[30] wClasses;
foreach (const w; "unixdict.txt".readText.splitter)
wClasses[$ - w.length] ~= w;
foreach (const ws; wClasses[].map!q{ a.data }.filter!(not!empty)) {
string[][const ubyte[]] anags; // Assume ASCII input.
foreach (immutable w; ws)
anags[w.dup.representation.sort().release.assumeUnique] ~= w;
auto pairs = anags.byValue.map!findDeranged.joiner;
if (!pairs.empty)
return writefln("Longest deranged: %-(%s %)", pairs.front);
}
}
- Output:
Longest deranged: excitation intoxicate
Runtime: about 0.03 seconds.
Delphi
program Anagrams_Deranged;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
System.Classes,
System.Diagnostics;
function Sort(s: string): string;
var
c: Char;
i, j, aLength: Integer;
begin
aLength := s.Length;
if aLength = 0 then
exit('');
Result := s;
for i := 1 to aLength - 1 do
for j := i + 1 to aLength do
if result[i] > result[j] then
begin
c := result[i];
result[i] := result[j];
result[j] := c;
end;
end;
function IsAnagram(s1, s2: string): Boolean;
begin
if s1.Length <> s2.Length then
exit(False);
Result := Sort(s1) = Sort(s2);
end;
function CompareLength(List: TStringList; Index1, Index2: Integer): Integer;
begin
result := List[Index1].Length - List[Index2].Length;
if Result = 0 then
Result := CompareText(Sort(List[Index2]), Sort(List[Index1]));
end;
function IsDerangement(word1, word2: string): Boolean;
var
i: Integer;
begin
for i := 1 to word1.Length do
if word1[i] = word2[i] then
exit(False);
Result := True;
end;
var
Dict: TStringList;
Count, Index: Integer;
words: string;
StopWatch: TStopwatch;
begin
StopWatch := TStopwatch.Create;
StopWatch.Start;
Dict := TStringList.Create();
Dict.LoadFromFile('unixdict.txt');
Dict.CustomSort(CompareLength);
Index := Dict.Count - 1;
words := '';
Count := 1;
while Index - Count >= 0 do
begin
if IsAnagram(Dict[Index], Dict[Index - Count]) then
begin
if IsDerangement(Dict[Index], Dict[Index - Count]) then
begin
words := Dict[Index] + ' - ' + Dict[Index - Count];
Break;
end;
Inc(Count);
end
else
begin
Dec(Index, Count);
Count := 1;
end;
end;
StopWatch.Stop;
Writeln(Format('Time pass: %d ms [i7-4500U Windows 7]', [StopWatch.ElapsedMilliseconds]));
writeln(#10'Longest derangement words are:'#10#10, words);
Dict.Free;
Readln;
end.
- Output:
Time pass: 455 ms [i7-4500U Windows 7] Longest derangement words are: intoxicate - excitation
EchoLisp
For a change, we use the french dictionary included in EchoLisp package.
(lib 'hash)
(lib 'struct)
(lib 'sql)
(lib 'words)
(define H (make-hash))
(define (deranged w1 w2)
(for ((a w1) (b w2))
#:break (string=? a b) => #f
#t))
(define (anagrams (normal) (name) (twins))
(for ((w *words*))
(set! name (word-name w))
(set! normal (list->string (list-sort string<? (string->list name))))
(set! twins (or (hash-ref H normal) null))
#:continue (member name twins)
#:when (or (null? twins) (for/or ((anagram twins)) (deranged name anagram)))
(hash-set H normal (cons name twins))))
(define (task (lmin 8))
(anagrams)
(for ((lw (hash-values H))) ;; lw = list of words
#:continue (= (length lw) 1)
#:continue (< (string-length (first lw)) lmin)
(set! lmin (string-length (first lw)))
(write lmin) (for-each write lw)
(writeln)))
- Output:
(lib 'dico.fr.no-accent) ;; 209315 words into *words* table
(task)
[...]
13 tractionnaire contrariaient
13 ressourcement contremesures
13 saintsimonien inseminations
14 tergiversation interrogatives
14 suralimenterai mineralisateur
14 transoceaniens reconnaissante
(lib 'dico.en ) ;; 235886 words
(task)
[...]
12 reaccomplish accomplisher
12 chromatician achromatinic
12 unaccumulate acutenaculum
14 charlatanistic antarchistical
15 megachiropteran cinematographer
17 misconstitutional constitutionalism
Eiffel
class
ANAGRAMS_DERANGED
create
make
feature
make
-- Longest deranged anagram.
local
deranged_anagrams: LINKED_LIST [STRING]
count: INTEGER
do
read_wordlist
across
words as wo
loop
deranged_anagrams := check_list_for_deranged (wo.item)
if not deranged_anagrams.is_empty and deranged_anagrams [1].count > count then
count := deranged_anagrams [1].count
end
wo.item.wipe_out
wo.item.append (deranged_anagrams)
end
across
words as wo
loop
across
wo.item as w
loop
if w.item.count = count then
io.put_string (w.item + "%T")
io.new_line
end
end
end
end
original_list: STRING = "unixdict.txt"
feature {NONE}
check_list_for_deranged (list: LINKED_LIST [STRING]): LINKED_LIST [STRING]
-- Deranged anagrams in 'list'.
do
create Result.make
across
1 |..| list.count as i
loop
across
(i.item + 1) |..| list.count as j
loop
if check_for_deranged (list [i.item], list [j.item]) then
Result.extend (list [i.item])
Result.extend (list [j.item])
end
end
end
end
check_for_deranged (a, b: STRING): BOOLEAN
-- Are 'a' and 'b' deranged anagrams?
local
n: INTEGER
do
across
1 |..| a.count as i
loop
if a [i.item] = b [i.item] then
n := n + 1
end
end
Result := n = 0
end
read_wordlist
-- Hashtable 'words' with alphabetically sorted Strings used as key.
local
l_file: PLAIN_TEXT_FILE
sorted: STRING
empty_list: LINKED_LIST [STRING]
do
create l_file.make_open_read_write (original_list)
l_file.read_stream (l_file.count)
wordlist := l_file.last_string.split ('%N')
l_file.close
create words.make (wordlist.count)
across
wordlist as w
loop
create empty_list.make
sorted := sort_letters (w.item)
words.put (empty_list, sorted)
if attached words.at (sorted) as ana then
ana.extend (w.item)
end
end
end
wordlist: LIST [STRING]
sort_letters (word: STRING): STRING
--Alphabetically sorted.
local
letters: SORTED_TWO_WAY_LIST [STRING]
do
create letters.make
create Result.make_empty
across
1 |..| word.count as i
loop
letters.extend (word.at (i.item).out)
end
across
letters as s
loop
Result.append (s.item)
end
end
words: HASH_TABLE [LINKED_LIST [STRING], STRING]
end
- Output:
excitation intoxicate
Elixir
defmodule Anagrams do
def deranged(fname) do
File.read!(fname)
|> String.split
|> Enum.map(fn word -> to_charlist(word) end)
|> Enum.group_by(fn word -> Enum.sort(word) end)
|> Enum.filter(fn {_,words} -> length(words) > 1 end)
|> Enum.sort_by(fn {key,_} -> -length(key) end)
|> Enum.find(fn {_,words} -> find_derangements(words) end)
end
defp find_derangements(words) do
comb(words,2) |> Enum.find(fn [a,b] -> deranged?(a,b) end)
end
defp deranged?(a,b) do
Enum.zip(a, b) |> Enum.all?(fn {chr_a,chr_b} -> chr_a != chr_b end)
end
defp comb(_, 0), do: [[]]
defp comb([], _), do: []
defp comb([h|t], m) do
(for l <- comb(t, m-1), do: [h|l]) ++ comb(t, m)
end
end
case Anagrams.deranged("/work/unixdict.txt") do
{_, words} -> IO.puts "Longest derangement anagram: #{inspect words}"
_ -> IO.puts "derangement anagram: nothing"
end
- Output:
Longest derangement anagram: ["intoxicate", "excitation"]
Erlang
Using anagrams:fetch/2 from Anagrams and init_http/0 from Rosetta_Code/Find_unimplemented_tasks. Exporting words_from_url/1 to Ordered_words.
-module( anagrams_deranged ).
-export( [task/0, words_from_url/1] ).
task() ->
find_unimplemented_tasks:init_http(),
Words = words_from_url( "http://www.puzzlers.org/pub/wordlists/unixdict.txt" ),
Anagram_dict = anagrams:fetch( Words, dict:new() ),
Deranged_anagrams = deranged_anagrams( Anagram_dict ),
{_Length, Longest_anagrams} = dict:fold( fun keep_longest/3, {0, []}, Deranged_anagrams ),
Longest_anagrams.
words_from_url( URL ) ->
{ok, {{_HTTP, 200, "OK"}, _Headers, Body}} = httpc:request( URL ),
string:tokens( Body, "\n" ).
deranged_anagrams( Dict ) ->
Deranged_dict = dict:map( fun deranged_words/2, Dict ),
dict:filter( fun is_anagram/2, Deranged_dict ).
deranged_words( _Key, [H | T] ) ->
[{H, X} || X <- T, is_deranged_word(H, X)].
keep_longest( _Key, [{One, _} | _]=New, {Length, Acc} ) ->
keep_longest_new( erlang:length(One), Length, New, Acc ).
keep_longest_new( New_length, Acc_length, New, _Acc ) when New_length > Acc_length ->
{New_length, New};
keep_longest_new( New_length, Acc_length, New, Acc ) when New_length =:= Acc_length ->
{Acc_length, Acc ++ New};
keep_longest_new( _New_length, Acc_length, _New, Acc ) ->
{Acc_length, Acc}.
is_anagram( _Key, [] ) -> false;
is_anagram( _Key, _Value ) -> true.
is_deranged_word( Word1, Word2 ) ->
lists:all( fun is_deranged_char/1, lists:zip(Word1, Word2) ).
is_deranged_char( {One, Two} ) -> One =/= Two.
- Output:
8> anagrams_deranged:task(). [{"excitation","intoxicate"}]
F#
open System;
let keyIsSortedWord = Seq.sort >> Seq.toArray >> String
let isDeranged = Seq.forall2 (<>)
let rec pairs acc l = function
| [] -> acc
| x::rtail ->
pairs (acc @ List.fold (fun acc y -> (y, x)::acc) [] l) (x::l) rtail
[<EntryPoint>]
let main args =
System.IO.File.ReadAllLines("unixdict.txt")
|> Seq.groupBy keyIsSortedWord
|> Seq.fold (fun (len, found) (key, words) ->
if String.length key < len || Seq.length words < 2 then (len, found)
else
let d = List.filter (fun (a, b) -> isDeranged a b) (pairs [] [] (List.ofSeq words))
if List.length d = 0 then (len, found)
elif String.length key = len then (len, found @ d)
else (String.length key, d)
) (0, [])
|> snd
|> printfn "%A"
0
- Output:
[("excitation", "intoxicate")]
Factor
USING: assocs fry io.encodings.utf8 io.files kernel math
math.combinatorics sequences sorting strings ;
IN: rosettacode.deranged-anagrams
: derangement? ( str1 str2 -- ? ) [ = not ] 2all? ;
: derangements ( seq -- seq )
2 [ first2 derangement? ] filter-combinations ;
: parse-dict-file ( path -- hash )
utf8 file-lines
H{ } clone [
'[
[ natural-sort >string ] keep
_ [ swap suffix ] with change-at
] each
] keep ;
: anagrams ( hash -- seq ) [ nip length 1 > ] assoc-filter values ;
: deranged-anagrams ( path -- seq )
parse-dict-file anagrams [ derangements ] map concat ;
: longest-deranged-anagrams ( path -- anagrams )
deranged-anagrams [ first length ] sort-with last ;
"unixdict.txt" longest-deranged-anagrams . { "excitation" "intoxicate" }
FreeBASIC
' FB 1.05.0 Win64
Type IndexedWord
As String word
As Integer index
End Type
' selection sort, quick enough for sorting small number of letters
Sub sortWord(s As String)
Dim As Integer i, j, m, n = Len(s)
For i = 0 To n - 2
m = i
For j = i + 1 To n - 1
If s[j] < s[m] Then m = j
Next j
If m <> i Then Swap s[i], s[m]
Next i
End Sub
' quicksort for sorting whole dictionary of IndexedWord instances by sorted word
Sub quicksort(a() As IndexedWord, first As Integer, last As Integer)
Dim As Integer length = last - first + 1
If length < 2 Then Return
Dim pivot As String = a(first + length\ 2).word
Dim lft As Integer = first
Dim rgt As Integer = last
While lft <= rgt
While a(lft).word < pivot
lft +=1
Wend
While a(rgt).word > pivot
rgt -= 1
Wend
If lft <= rgt Then
Swap a(lft), a(rgt)
lft += 1
rgt -= 1
End If
Wend
quicksort(a(), first, rgt)
quicksort(a(), lft, last)
End Sub
Function isDeranged(s1 As String, s2 As String) As Boolean
For i As Integer = 0 To Len(s1) - 1
If s1[i] = s2[i] Then Return False
Next
Return True
End Function
Dim t As Double = timer
Dim As String w() '' array to hold actual words
Open "undict.txt" For Input As #1
Dim count As Integer = 0
While Not Eof(1)
count +=1
Redim Preserve w(1 To count)
Line Input #1, w(count)
Wend
Close #1
Dim As IndexedWord iw(1 To count) '' array to hold sorted words and their index into w()
Dim word As String
For i As Integer = 1 To count
word = w(i)
sortWord(word)
iw(i).word = word
iw(i).index = i
Next
quickSort iw(), 1, count '' sort the IndexedWord array by sorted word
Dim As Integer startIndex = 1, maxLength, ub
Dim As Integer maxIndex()
Dim As IndexedWord iWord = iw(1)
maxLength = 0
For i As Integer = 2 To count
If iWord.word = iw(i).word Then
If isDeranged(w(iword.index), w(iw(i).index)) Then
If startIndex + 1 < i Then Swap iw(i), iw(startIndex + 1)
If Len(iWord.word) > maxLength Then
maxLength = Len(iWord.word)
Erase maxIndex
ub = 1
Redim maxIndex(1 To ub)
maxIndex(ub) = startIndex
startIndex += 2
i = startIndex
iWord = iw(i)
ElseIf Len(iWord.word) = maxLength Then
ub += 1
Redim Preserve maxIndex(1 To ub)
maxIndex(ub) = startIndex
startIndex += 2
i = startIndex
iWord = iw(i)
End If
End If
ElseIf i = count Then
Exit For
Else
For j As Integer = i To count - 1
iWord = iw(j)
If Len(iWord.word) >= maxLength Then
startIndex = j
i = startIndex
Exit For
End If
Next
End If
Next
Print Str(count); " words in the dictionary"
Print "The deranged anagram pair(s) with the greatest length (namely"; maxLength; ") is:"
Print
Dim iws(1 To maxLength) As IndexedWord '' array to hold each deranged anagram pair
For i As Integer = 1 To UBound(maxIndex)
For j As Integer = maxIndex(i) To maxIndex(i) + 1
iws(j - maxIndex(i) + 1) = iw(j)
Next j
If iws(1).index > iws(2).index Then swap iws(1), iws(2) '' ensure pair is in correct order
For j As Integer = 1 To 2
Print w(iws(j).index); " ";
Next j
Print
Next i
Print
Print "Took ";
Print Using "#.###"; timer - t;
Print " seconds on i3 @ 2.13 GHz"
Print
Print "Press any key to quit"
Sleep
- Output:
25104 words in the dictionary The deranged anagram pair(s) with the greatest length (namely 10) is: excitation intoxicate Took 0.089 seconds on i3 @ 2.13 GHz
FutureBasic
While there is nothing time sensitive about this task, fast code is often efficient code. Several of the entries in this category show their computation times. This FutureBasic entry is designed to outrace them all.
The other entries examined have started by sorting the letters in each word. Here we take a different approach by creating an "avatar" for each word. All anagrams of a word have the same avatar—-without any sorting. Here's how it works:
An 8-byte variable can hold a lot of information. We create a 64-bit avatar that starts at the high end with 8 bits for the length of the word, so that longer words will be sorted first. The remaining 56 bits contain 2-bit fields for each letter of the alphabet. A 2-bit field can record from 0 to 3 occurrences of the letter, but even if there were 4 or more occurrences (think "Mississippi"), bleeding into the next field, the only matching avatar would still be an exact anagram. Here's how the bits would be set for the word "Anagrams":
Anagrams
length ZzYyXx WwVvUuTt SsRrQqPp OoNnMmLl KkJjIiHh GgFfEeDd CcBbAa
00001000 00000000 00000000 01010000 00010100 00000000 01000000 00001100
Bit shifts and 8-byte comparisons are fast operations, which contribute to the speed. As each avatar is generated, it is saved, along with the offset to its word, and an index to it inserted in a sorted list, guaranteeing that longest words occur first, and all matching anagrams are adjacent.
When words have the same avatars, they are anagrams, but for this task we still need to check for letters occurring in the same location in both words. That is a quick check that only has to be done for otherwise qualified candidates.
On a 1.2 GHz Quad-Core Intel Core i7 MacBook Pro, this code runs in ~6 ms, which is several times faster than times claimed by other entries. In that time, it finds not just the longest, but all 486 deranged anagrams in unixdict.txt. (Yes, there is an option to view all of them.)
FWIW, this code can easily be amended to show all 1800+ anagram pairs.
#plist NSAppTransportSecurity @{NSAllowsArbitraryLoads:YES}
defstr long
begin globals
xref xwords( 210000 ) as char
long gAvatars( 26000 )
uint32 gwordNum, gfilen, gcount = 0, gOffset( 26000 )
uint16 gndx( 26000 ), deranged( 600, 1 )
long sh : sh = system( _scrnHeight ) -100
long sw : sw = (system( _scrnWidth ) -360 ) / 2
CFTimeInterval t
_len = 56
end globals
local fn loadDictionary
CFURLRef url = fn URLWithString( @"http://wiki.puzzlers.org/pub/wordlists/unixdict.txt" )
CFStringRef dictStr = fn StringWithContentsOfURL( url, NSUTF8StringEncoding, NULL )
dictStr = fn StringByAppendingString( @" ", dictStr )
xwords = fn StringUTF8String( dictstr )
gfilen = len(dictstr)
end fn
local fn deranagrams
uint64 ch, p, wordStart = 0
long avatar = 0
uint32 med, bot, top
byte chk, L
for p = 1 to gfilen
ch = xwords(p) //build avatar
if ch > _" " then avatar += (long) 1 << ( ch and 31 ) * 2: continue
avatar += (long)(p - wordStart - 1) << _len //complete avatar by adding word length
gAvatars(gWordNum) = avatar //store the avatar in list
gOffset( gWordNum) = wordStart //store offset to the word
//Insert into ordered list of avatars
bot = 0 : top = gwordNum //quick search for place to insert
while (top - bot) > 1
med = ( top + bot ) >> 1
if avatar > gAvatars(gndx(med)) then bot = med else top = med
wend
blockmove( @gndx( top ), @gndx( top + 1 ), ( gwordNum - top ) * 2 )
gndx(top) = gWordNum
gwordNum++ : wordStart = p : avatar = 0 //ready for new word
next p
//Check for matching avatars
for p = gWordNum to 1 step -1
chk = 1 //to make sure each word is compared with all matching avatars
while gAvatars( gndx( p ) ) == gAvatars( gndx( p - chk ) )
// found anagram; now check for chars in same position
L = ( gAvatars( gndx( p ) ) >> _len ) //get word length
while L
if xwords(gOffset(gndx(p)) +L) == xwords(gOffset(gndx(p-chk)) +L) then break
L--
wend
if L == 0
//no matching chars: found Deranged Anagram!
deranged( gcount, 0 ) = gndx( p )
deranged( gcount, 1 ) = gndx( p - chk )
gcount++
end if
chk++
wend
next
end fn
local fn printPair( ndx as uint32, chrsToCntr as byte )
ptr p : str255 pair : pair = ""
short n = ( gAvatars( deranged( ndx, 0 ) ) >> _len )
if n < chrsToCntr then print string$( chrsToCntr - n, " " );
p = xwords + gOffset( deranged( ndx, 0 ) )
p.0`` = n : print p.0$; " ";
p = xwords + gOffset( deranged( ndx, 1 ) )
p.0`` = n : print p.0$
end fn
local fn doDialog(evt as long)
if evt == _btnclick
long r
button -1 : window 1,,(sw,50,335,sh-50)
for r = 1 to gcount-1
fn printPair( r, 21 )
next
end if
end fn
fn loadDictionary : t = fn CACurrentMediaTime
fn deranagrams : t = fn CACurrentMediaTime - t
window 1, @"Deranged Anagrams in FutureBasic",(sw,sh-130,335,130)
printf @"\n %u deranged anagrams found among \n %u words ¬
in %.2f ms.\n", gcount, gWordNum, t * 1000
print " Longest:";: fn printPair( 0, 11 )
button 1,,,fn StringWithFormat(@"Show remaining %u deranged anagrams.",gcount-1),(24,20,285,34)
on dialog fn doDialog
handleevents
- Output:
File:FB output for Deranged Anagrams.png
GAP
Using function Anagrams.
IsDeranged := function(a, b)
local i, n;
for i in [1 .. Size(a)] do
if a[i] = b[i] then
return false;
fi;
od;
return true;
end;
# This solution will find all deranged pairs of any length.
Deranged := function(name)
local sol, ana, u, v;
sol := [ ];
ana := Anagrams(name);
for u in ana do
for v in Combinations(u, 2) do
if IsDeranged(v[1], v[2]) then
Add(sol, v);
fi;
od;
od;
return sol;
end;
# Now we find all deranged pairs of maximum length
a := Deranged("unixdict.txt");;
n := Maximum(List(a, x -> Size(x[1])));
Filtered(a, x -> Size(x[1]) = n);
# [ [ "excitation", "intoxicate" ] ]
Go
package main
import (
"fmt"
"io/ioutil"
"strings"
"sort"
)
func deranged(a, b string) bool {
if len(a) != len(b) {
return false
}
for i := range(a) {
if a[i] == b[i] { return false }
}
return true
}
func main() {
/* read the whole thing in. how big can it be? */
buf, _ := ioutil.ReadFile("unixdict.txt")
words := strings.Split(string(buf), "\n")
m := make(map[string] []string)
best_len, w1, w2 := 0, "", ""
for _, w := range(words) {
// don't bother: too short to beat current record
if len(w) <= best_len { continue }
// save strings in map, with sorted string as key
letters := strings.Split(w, "")
sort.Strings(letters)
k := strings.Join(letters, "")
if _, ok := m[k]; !ok {
m[k] = []string { w }
continue
}
for _, c := range(m[k]) {
if deranged(w, c) {
best_len, w1, w2 = len(w), c, w
break
}
}
m[k] = append(m[k], w)
}
fmt.Println(w1, w2, ": Length", best_len)
}
- Output:
excitation intoxicate : Length 10
Groovy
Solution:
def map = new TreeMap<Integer,Map<String,List<String>>>()
new URL('http://www.puzzlers.org/pub/wordlists/unixdict.txt').eachLine { word ->
def size = - word.size()
map[size] = map[size] ?: new TreeMap<String,List<String>>()
def norm = word.toList().sort().sum()
map[size][norm] = map[size][norm] ?: []
map[size][norm] << word
}
def result = map.findResult { negasize, normMap ->
def size = - negasize
normMap.findResults { x, anagrams ->
def n = anagrams.size()
(0..<(n-1)).findResults { i ->
((i+1)..<n).findResult { j ->
(0..<size).every { k -> anagrams[i][k] != anagrams[j][k] } \
? anagrams[i,j]
: null
}
}?.flatten() ?: null
}?.flatten() ?: null
}
if (result) {
println "Longest deranged anagram pair: ${result}"
} else {
println 'Deranged anagrams are a MYTH!'
}
- Output:
Longest deranged anagram pair: [excitation, intoxicate]
Haskell
If the longest deranged anagram includes three or more words we'll only print two of them. We also correctly handle duplicate words in the input.
{-# LANGUAGE TupleSections #-}
import Data.List (maximumBy, sort, unfoldr)
import Data.Ord (comparing)
import qualified Data.Map as M
import qualified Data.Set as S
-- Lists of words grouped by their "signatures". A signature is a sorted
-- list of characters. Duplicate words stored in sets.
groupBySig :: [String] -> [(String, S.Set String)]
groupBySig = map ((,) . sort <*> S.singleton)
-- Groups as lists of equivalent words.
equivs :: [(String, S.Set String)] -> [[String]]
equivs = map (S.toList . snd) . M.toList . M.fromListWith S.union
-- True if a pair of words differs in all character positions.
isDerangement :: (String, String) -> Bool
isDerangement (a, b) = and $ zipWith (/=) a b
-- All pairs of elements, ignoring order.
pairs :: [t] -> [(t, t)]
pairs = concat . unfoldr step
where
step (x:xs) = Just (map (x, ) xs, xs)
step [] = Nothing
-- All anagram pairs in the input string.
anagrams :: [String] -> [(String, String)]
anagrams = concatMap pairs . equivs . groupBySig
-- The pair of words forming the longest deranged anagram.
maxDerangedAnagram :: [String] -> Maybe (String, String)
maxDerangedAnagram = maxByLen . filter isDerangement . anagrams
where
maxByLen [] = Nothing
maxByLen xs = Just $ maximumBy (comparing (length . fst)) xs
main :: IO ()
main = do
input <- readFile "unixdict.txt"
case maxDerangedAnagram $ words input of
Nothing -> putStrLn "No deranged anagrams were found."
Just (a, b) -> putStrLn $ "Longest deranged anagrams: " <> a <> " and " <> b
- Output:
Longest deranged anagrams: excitation and intoxicate
and a variant:
import Control.Monad ((<=<))
import Data.Function (on)
import Data.List (find, groupBy, sort, sortOn)
import Data.Ord (Down (Down))
-------------------- DERANGED ANAGRAMS -------------------
longestDeranged :: [String] -> String
longestDeranged xs =
case find deranged (longestAnagramPairs xs) of
Nothing -> "No deranged anagrams found."
Just (a, b) -> a <> " -> " <> b
deranged :: (String, String) -> Bool
deranged (a, b) = and (zipWith (/=) a b)
longestAnagramPairs :: [String] -> [(String, String)]
longestAnagramPairs = ((<*>) =<< fmap (,)) <=<
(sortOn (Down . length . head) . anagramGroups)
anagramGroups :: [String] -> [[String]]
anagramGroups xs =
groupBy
(on (==) fst)
(sortOn fst (((,) =<< sort) <$> xs))
>>= (\g -> [snd <$> g | 1 < length g])
--------------------------- TEST -------------------------
main :: IO ()
main =
readFile "unixdict.txt"
>>= (putStrLn . longestDeranged . lines)
- Output:
excitation -> intoxicate
Icon and Unicon
This solution (which works in both languages) does a strict interpretation of the problem and ignores the fact that there may be multiple derangements that are the same length (including ignoring multiple derangements arising from the same set of words that are all anagrams).
link strings # for csort() procedure
procedure main()
anagrams := table() # build lists of anagrams
every *(word := !&input) > 1 do {
canon := csort(word)
/anagrams[canon] := []
put(anagrams[canon], word)
}
longest := 1 # find a longest derangement
every *(aList := !anagrams) > 1 do
if derangement := derange(aList) then
if longest <:= *derangement[1] then long := derangement
every writes((!\long||" ")|"\n") # show longest
end
procedure derange(aList) # Return a single derangement from this list
while aWord := get(aList) do return noMatch(aWord, !aList)
end
procedure noMatch(s1,s2) # Produce pair only if s1,s2 are deranged.
every i := 1 to *s1 do if s1[i] == s2[i] then fail
return [s1,s2]
end
- Sample run:
->dra <unixdict.txt excitation intoxicate ->
J
This assumes that unixdict.txt has been saved in the current directory.
#words=: 'b' freads 'unixdict.txt'
25104
#anagrams=: (#~ 1 < #@>) (</.~ /:~&>) words
1303
#maybederanged=: (#~ (1 -.@e. #@~."1)@|:@:>&>) anagrams
432
#longest=: (#~ [: (= >./) #@>@{.@>) maybederanged
1
longest
┌───────────────────────┐
│┌──────────┬──────────┐│
││excitation│intoxicate││
│└──────────┴──────────┘│
└───────────────────────┘
Note that anagram sets with more than two members might, hypothetically, have made things more complicated. By lucky coincidence, this was not an issue. We could have taken advantage of that coincidence to achieve slight further simplifications. Perhaps maybederanged=: (#~ (-: ~."1)@|:@:>&>) anagrams
In other words, if we had had to consider whether ascertain/cartesian/sectarian
contained a deranged pair, we would have had to break it out into the three pairs it contains. However, since 'excitation' is a longer word than 'ascertain', we know that this triple cannot contain the longest deranged anagram pair. And since there are no anagrams longer than 'excitation' which involve more than a single pair, we know that we can ignore this issue entirely.
Java
import java.io.File;
import java.io.IOException;
import java.nio.file.Files;
import java.util.ArrayList;
import java.util.Arrays;
import java.util.Comparator;
import java.util.HashMap;
import java.util.List;
import java.util.Map;
public class DerangedAnagrams {
public static void main(String[] args) throws IOException {
List<String> words = Files.readAllLines(new File("unixdict.txt").toPath());
printLongestDerangedAnagram(words);
}
private static void printLongestDerangedAnagram(List<String> words) {
words.sort(Comparator.comparingInt(String::length).reversed().thenComparing(String::toString));
Map<String, ArrayList<String>> map = new HashMap<>();
for (String word : words) {
char[] chars = word.toCharArray();
Arrays.sort(chars);
String key = String.valueOf(chars);
List<String> anagrams = map.computeIfAbsent(key, k -> new ArrayList<>());
for (String anagram : anagrams) {
if (isDeranged(word, anagram)) {
System.out.printf("%s %s%n", anagram, word);
return;
}
}
anagrams.add(word);
}
System.out.println("no result");
}
private static boolean isDeranged(String word1, String word2) {
for (int i = 0; i < word1.length(); i++) {
if (word1.charAt(i) == word2.charAt(i)) {
return false;
}
}
return true;
}
}
- Output:
excitation intoxicate
JavaScript
Spidermonkey
This example is a little long because it tries to emphasize generality and clarity over brevity.
#!/usr/bin/env js
function main() {
var wordList = read('unixdict.txt').split(/\s+/);
var anagrams = findAnagrams(wordList);
var derangedAnagrams = findDerangedAnagrams(anagrams);
var longestPair = findLongestDerangedPair(derangedAnagrams);
print(longestPair.join(' '));
}
function findLongestDerangedPair(danas) {
var longestLen = danas[0][0].length;
var longestPair = danas[0];
for (var i in danas) {
if (danas[i][0].length > longestLen) {
longestLen = danas[i][0].length;
longestPair = danas[i];
}
}
return longestPair;
}
function findDerangedAnagrams(anagrams) {
var deranged = [];
function isDeranged(w1, w2) {
for (var c = 0; c < w1.length; c++) {
if (w1[c] == w2[c]) {
return false;
}
}
return true;
}
function findDeranged(anas) {
for (var a = 0; a < anas.length; a++) {
for (var b = a + 1; b < anas.length; b++) {
if (isDeranged(anas[a], anas[b])) {
deranged.push([anas[a], anas[b]]);
}
}
}
}
for (var a in anagrams) {
var anas = anagrams[a];
findDeranged(anas);
}
return deranged;
}
function findAnagrams(wordList) {
var anagrams = {};
for (var wordNum in wordList) {
var word = wordList[wordNum];
var key = word.split('').sort().join('');
if (!(key in anagrams)) {
anagrams[key] = [];
}
anagrams[key].push(word);
}
for (var a in anagrams) {
if (anagrams[a].length < 2) {
delete(anagrams[a]);
}
}
return anagrams;
}
main();
- Output:
excitation intoxicate
Gecko
Word file is saved locally because browser won't fetch it cross-site. Tested on Gecko.
<html><head><title>Intoxication</title></head>
<body><pre id='x'></pre>
<script type="application/javascript">
function show(t) {
var l = document.createTextNode(t + '\n');
document.getElementById('x').appendChild(l);
}
// get words; be ware of cross-site restrictions on XMLHttpRequest
var words = null;
var req = new XMLHttpRequest();
req.open('GET', 'file:///tmp/unixdict.txt', false);
req.send(null);
words = req.responseText.split('\n');
var idx = {};
for (var i = 0; i < words.length; i++) {
var t = words[i].split('').sort().join('');
if (idx[t]) idx[t].push(words[i]);
else idx[t] = [words[i]];
}
var best = '';
var best_pair;
for (var i in idx) {
if (i.length <= best.length) continue;
if (idx[i].length == 1) continue;
var a = idx[i], got = null;
for (var j = 0, l1 = a[j]; j < a.length && !got; j++) {
for (var k = j + 1, l2 = a[k]; k < a.length && !got; k++)
for (var m = 0; m < l1.length || !(got = [l2]); m++)
if (l1[m] == l2[m]) break;
if (got) got.push(l1);
}
if (got) {
best_pair = got;
best = got[0];
}
}
show(best_pair);
</script></body></html>
- Output (in a browser window):
intoxicate,excitation
jq
This solution allows for the possibility of more than one answer.
# Input: an array of strings
# Output: a stream of arrays
def anagrams:
reduce .[] as $word (
{table: {}, max: 0}; # state
($word | explode | sort | implode) as $hash
| .table[$hash] += [ $word ]
| .max = ([ .max, ( .table[$hash] | length) ] | max ) )
| .table | .[] | select(length>1);
# Check whether the input and y are deranged,
# on the assumption that they are anagrams:
def deranged(y):
explode as $x # explode is fast
| (y | explode) as $y
| all( range(0;length); $x[.] != $y[.] );
# The task: loop through the anagrams,
# retaining only the best set of deranged anagrams so far.
split("\n") | select(length>0) # read all the words as an array
| reduce anagrams as $words ([]; # loop through all the anagrams
reduce $words[] as $v (.;
reduce ($words - [$v])[] as $w (.; # $v and $w are distinct members of $words
if $v|deranged($w)
then if length == 0 then [$v,$w]
elif ($v|length) == (.[0]|length) then . + [$v,$w]
elif ($v|length) > (.[0]|length) then [$v,$w]
else .
end
else .
end) ) )
| unique
Invocation and output
$ jq -M -s -c -R -f program.jq unixdict.txt ["excitation","intoxicate"]
Julia
using Base.isless
# Let's define the less than operator for any two vectors that have the same type:
# This does lexicographic comparison, we use it on vectors of chars in this task.
function Base.isless(t1, t2)
for (a, b) in zip(t1, t2) # zip only to the shorter length
if !isequal(a, b)
return isless(a, b)
end
end
return length(t1) < length(t2)
end
# The sort function of Julia doesn't work on strings, so we write one:
# This returns a sorted vector of the chars of the given string
sortchars(s::AbstractString) = sort(collect(Char, s))
# Custom comparator function for sorting the loaded wordlist
sortanagr(s1::AbstractString, s2::AbstractString) =
if length(s1) != length(s2) length(s1) < length(s2) else sortchars(s1) < sortchars(s2) end
# Tests if two strings are deranged anagrams, returns a bool:
# in our case s2 is never longer than s1
function deranged(s1::AbstractString, s2::AbstractString)
# Tests for derangement first
for (a, b) in zip(s1, s2)
if a == b return false end
end
# s1 and s2 are deranged, but are they anagrams at all?
return sortchars(s1) == sortchars(s2)
end
# Task starts here, we load the wordlist line by line, strip eol char, and sort the wordlist
# in a way that ensures that longer words come first and anagrams go next to each other
words = sort(open(readlines, "./data/unixdict.txt"), rev = true, lt = sortanagr)
# Now we just look for deranged anagrams in the neighbouring words of the sorted wordlist
for i in 1:length(words)-1
if deranged(words[i], words[i+1])
# The first match is guaranteed to be the longest due to the custom sorting
println("The longest deranged anagrams are $(words[i]) and $(words[i+1])")
break
end
end
- Output:
The longest deranged anagrams are excitation and intoxicate
K
/ anagram clusters
a:{x g@&1<#:'g:={x@<x}'x}@0:"unixdict.txt";
/ derangements in these clusters
b@&c=|/c:{#x[0]}'b:a@&{0=+//{x=y}':x}'a
("excitation"
"intoxicate")
Kotlin
// version 1.0.6
import java.io.BufferedReader
import java.io.InputStreamReader
import java.net.URL
fun isDeranged(s1: String, s2: String): Boolean {
return (0 until s1.length).none { s1[it] == s2[it] }
}
fun main(args: Array<String>) {
val url = URL("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
val isr = InputStreamReader(url.openStream())
val reader = BufferedReader(isr)
val anagrams = mutableMapOf<String, MutableList<String>>()
var count = 0
var word = reader.readLine()
while (word != null) {
val chars = word.toCharArray()
chars.sort()
val key = chars.joinToString("")
if (!anagrams.containsKey(key)) {
anagrams.put(key, mutableListOf<String>())
anagrams[key]!!.add(word)
}
else {
val deranged = anagrams[key]!!.any { isDeranged(it, word) }
if (deranged) {
anagrams[key]!!.add(word)
count = Math.max(count, word.length)
}
}
word = reader.readLine()
}
reader.close()
anagrams.values
.filter { it.size > 1 && it[0].length == count }
.forEach { println(it) }
}
- Output:
[excitation, intoxicate]
Lasso
local(
anagrams = map,
words = include_url('http://www.puzzlers.org/pub/wordlists/unixdict.txt') -> split('\n'),
key,
max = 0,
wordsize,
findings = array,
derangedtest = { // this code snippet is not executed until the variable is invoked. It will return true if the compared words are a deranged anagram
local(
w1 = #1,
w2 = #2,
testresult = true
)
loop(#w1 -> size) => {
#w1 -> get(loop_count) == #w2 -> get(loop_count) ? #testresult = false
}
return #testresult
}
)
// find all anagrams
with word in #words do {
#key = #word -> split('') -> sort& -> join('')
not(#anagrams >> #key) ? #anagrams -> insert(#key = array)
#anagrams -> find(#key) -> insert(#word)
}
// step thru each set of anagrams to find deranged ones
with ana in #anagrams
let ana_size = #ana -> size
where #ana_size > 1
do {
#wordsize = #ana -> first -> size
if(#wordsize >= #max) => {
loop(#ana_size - 1) => {
if(#derangedtest -> detach & invoke(#ana -> get(loop_count), #ana -> get(loop_count + 1))) => {
// we only care to save the found deranged anagram if it is longer than the previous longest one
if(#wordsize > #max) => {
#findings = array(#ana -> get(loop_count) + ', ' + #ana -> get(loop_count + 1))
else
#findings -> insert(#ana -> get(loop_count) + ', ' + #ana -> get(loop_count + 1))
}
#max = #wordsize
}
}
}
}
#findings -> join('<br />\n')
Result -> excitation, intoxicate
Liberty BASIC
print "Loading dictionary file."
open "unixdict.txt" for input as #1
a$=input$(#1,lof(#1))
close #1
dim theWord$(30000)
dim ssWord$(30000)
c10$ = chr$(10)
i = 1
print "Creating array of words."
while instr(a$,c10$,i) <> 0
j = instr(a$,c10$,i)
ln = j - i
again = 1
sWord$ = mid$(a$,i,j-i)
n = n + 1
theWord$(n) = sWord$
while again = 1
again = 0
for kk = 1 to len(sWord$) - 1
if mid$(sWord$,kk,1) > mid$(sWord$,kk +1,1) then
sWord$ = left$(sWord$,kk-1);mid$(sWord$,kk+1,1);mid$(sWord$,kk,1);mid$(sWord$,kk+2)
again = 1
end if
next kk
wend
ssWord$(n) = sWord$
i = j + 1
wend
print "Checking for deranged anagrams."
for i = 1 to n
if len(theWord$(i)) > maxLen then
for j = 1 to n
if ssWord$(i) = ssWord$(j) and i <> j then
cnt = 0
for k = 1 to len(theWord$(i))
if mid$(theWord$(i),k,1) = mid$(theWord$(j),k,1) then cnt = cnt + 1
next k
if cnt = 0 then
maxLen = len(theWord$(i))
maxPtrI = i
maxPtrJ = j
end if
end if
next j
end if
next i
print theWord$(maxPtrI);" => ";theWord$(maxPtrJ)
end
- Output:
excitation => intoxicate
Lua
string.tacnoc = function(str) -- 'inverse' of table.concat
local arr={}
for ch in str:gmatch(".") do arr[#arr+1]=ch end
return arr
end
local function deranged(s1, s2)
if s1==s2 then return false end
local t1, t2 = s1:tacnoc(), s2:tacnoc()
for i,v in ipairs(t1) do if t2[i]==v then return false end end
return true
end
local dict = {}
local f = io.open("unixdict.txt", "r")
for word in f:lines() do
local ltrs = word:tacnoc()
table.sort(ltrs)
local hash = table.concat(ltrs)
dict[hash] = dict[hash] or {}
table.insert(dict[hash], word)
end
local answer = { word="", anag="", len=0 }
for _,list in pairs(dict) do
if #list>1 and #list[1]>answer.len then
for _,word in ipairs(list) do
for _,anag in ipairs(list) do
if deranged(word, anag) then
answer.word, answer.anag, answer.len = word, anag, #word
end
end
end
end
end
print(answer.word, answer.anag, answer.len)
- Output:
excitation intoxicate 10
Maple
with(StringTools):
dict:=Split([HTTP:-Get("www.puzzlers.org/pub/wordlists/unixdict.txt")][2]):
L:=[seq(select(t->HammingDistance(t,w)=length(w),[Anagrams(w,dict)])[],w=dict)]:
len:=length(ListTools:-FindMaximalElement(L,(a,b)->length(a)<length(b))):
select(w->length(w)=len,L)[];
- Output:
"intoxicate", "excitation"
Mathematica / Wolfram Language
words=First/@Import["http://www.puzzlers.org/pub/wordlists/unixdict.txt","Table"];
anagramDegrangement=Function[{w1,w2},
Module[{c1=ToCharacterCode@w1,c2=ToCharacterCode@w2},
Sort@c1==Sort@c2&&Select[c1-c2,#==0&,1]==={}]];
gs=Select[GatherBy[words,{StringLength@#,Union@ToCharacterCode@#}&],Length@#>=2&];
First@Flatten[Function[ws,Select[Join@@Outer[List,ws,ws,1],anagramDegrangement@@#&]]/@SortBy[gs,-StringLength@First@#&],1]
- Output:
{"excitation", "intoxicate"}
A similar approach using Mathematica 10:
list = Import["http://www.puzzlers.org/pub/wordlists/unixdict.txt","Lines"];
MaximalBy[
Select[GatherBy[list, Sort@*Characters],
Length@# > 1 && And @@ MapThread[UnsameQ, Characters /@ #] &],
StringLength@*First]
- Output:
{{"excitation", "intoxicate"}}
Nim
import algorithm
import tables
import times
var anagrams: Table[seq[char], seq[string]] # Mapping sorted_list_of chars -> list of anagrams.
#---------------------------------------------------------------------------------------------------
func deranged(s1, s2: string): bool =
## Return true if "s1" and "s2" are deranged anagrams.
for i, c in s1:
if s2[i] == c:
return false
result = true
#---------------------------------------------------------------------------------------------------
let t0 = getTime()
# Build the anagrams table.
for word in lines("unixdict.txt"):
anagrams.mgetOrPut(sorted(word), @[]).add(word)
# Find the longest deranged anagrams.
var bestLen = 0
var best1, best2: string
for (key, list) in anagrams.pairs:
if key.len > bestLen:
var s1 = list[0]
for i in 1..list.high:
let s2 = list[i]
if deranged(s1, s2):
# Found a better pair.
best1 = s1
best2 = s2
bestLen = s1.len
break
echo "Longest deranged anagram pair: ", best1, " ", best2
echo "Processing time: ", (getTime() - t0).inMilliseconds, " ms."
- Output:
Longest deranged anagram pair: excitation intoxicate Processing time: 57 ms.
OCaml
let sort_chars s =
let r = String.copy s in
for i = 0 to (String.length r) - 2 do
for j = i + 1 to (String.length r) - 1 do
if r.[i] > r.[j] then begin
let tmp = r.[i] in
r.[i] <- r.[j];
r.[j] <- tmp;
end
done
done;
(r)
let deranged (s1, s2) =
let len1 = String.length s1
and len2 = String.length s2 in
if len1 <> len2 then false else
try
for i = 0 to pred len1 do
if s1.[i] = s2.[i] then raise Exit
done;
true
with Exit -> false
let pairs_of_list lst =
let rec aux acc = function
| [] -> acc
| x::xs ->
aux (List.fold_left (fun acc y -> (x,y)::acc) acc xs) xs
in
aux [] lst
let () =
let h = Hashtbl.create 3571 in
let ic = open_in "unixdict.txt" in
try while true do
let word = input_line ic in
let key = sort_chars word in
let l =
try Hashtbl.find h key
with Not_found -> []
in
Hashtbl.replace h key (word::l);
done with End_of_file ->
close_in ic;
let lst =
Hashtbl.fold (fun _ lw acc ->
if List.length lw < 2 then acc else lw::acc) h []
in
let lst =
List.fold_left (fun acc anagrams ->
let pairs = pairs_of_list anagrams in
(List.filter deranged pairs) @ acc
) [] lst
in
let res, _ =
List.fold_left (fun (res, n) (w1, w2) ->
let len = String.length w1 in
match Pervasives.compare len n with
| 0 -> ((w1, w2)::res, n)
| 1 -> ([w1, w2], len)
| _ -> (res, n)
) ([], 0) lst
in
List.iter (fun (w1, w2) -> Printf.printf "%s, %s\n" w1 w2) res
- Output:
$ ocaml deranged_anagram.ml intoxicate, excitation
ooRexx
-- This assumes you've already downloaded the following file and placed it
-- in the current directory: http://www.puzzlers.org/pub/wordlists/unixdict.txt
-- There are several different ways of reading the file. I chose the
-- supplier method just because I haven't used it yet in any other examples.
source = .stream~new('unixdict.txt')~supplier
-- this holds our mappings of the anagrams. This is good use for the
-- relation class
anagrams = .relation~new
count = 0 -- this is used to keep track of the maximums
loop while source~available
word = source~item
-- this produces a string consisting of the characters in sorted order
-- Note: the ~~ used to invoke sort makes that message return value be
-- the target array. The sort method does not normally have a return value.
key = word~makearray('')~~sort~tostring("l", "")
-- add this to our mapping. This creates multiple entries for each
-- word that uses the same key
anagrams[key] = word
source~next
end
-- now get the set of unique keys
keys = .set~new~~putall(anagrams~allIndexes)
-- the longest count tracker
longest = 0
-- our list of the longest pairs
pairs = .array~new
loop key over keys
-- don't even bother doing the deranged checks for any key
-- shorter than our current longest
if key~length < longest then iterate
words = anagrams~allAt(key)
-- singletons aren't anagrams at all
newCount = words~items
loop i = 1 to newCount - 1
word1 = words[i]
loop j = 1 to newCount
word2 = words[j]
-- bitxor will have '00'x in every position where these
-- strings match. If found, go around and check the
-- next one
if word1~bitxor(word2)~pos('00'x) > 0 then iterate
-- we have a match
else do
if word1~length > longest then do
-- throw away anything we've gathered so far
pairs~empty
longest = word1~length
end
pairs~append(.array~of(word1, word2))
end
end
end
end
say "The longest deranged anagrams we found are:"
loop pair over pairs
say pair[1] pair[2]
end
- Output:
The longest deranged anagrams we found are: intoxicate excitation
PARI/GP
dict=readstr("unixdict.txt");
len=apply(s->#s, dict);
getLen(L)=my(v=List()); for(i=1,#dict, if(len[i]==L, listput(v, dict[i]))); Vec(v);
letters(s)=vecsort(Vec(s));
getAnagrams(v)=my(u=List(),L=apply(letters,v),t,w); for(i=1,#v-1, w=List(); t=L[i]; for(j=i+1,#v, if(L[j]==t, listput(w, v[j]))); if(#w, listput(u, concat([v[i]], Vec(w))))); Vec(u);
deranged(s1,s2)=s1=Vec(s1);s2=Vec(s2); for(i=1,#s1, if(s1[i]==s2[i], return(0))); 1
getDeranged(v)=my(u=List(),w); for(i=1,#v-1, for(j=i+1,#v, if(deranged(v[i], v[j]), listput(u, [v[i], v[j]])))); Vec(u);
f(n)=my(t=getAnagrams(getLen(n))); if(#t, concat(apply(getDeranged, t)), []);
forstep(n=vecmax(len),1,-1, t=f(n); if(#t, return(t)))
- Output:
%1 = [["excitation", "intoxicate"]]
Pascal
Using extra Stringlist for sorted by character words and insertion sort.
Runtime 153 ms -> 35 ms (Free Pascal Compiler version 3.3.1-r20:47268 [2020/11/02] for x86_64)
program Anagrams_Deranged;
{$IFDEF FPC}
{$MODE Delphi}
{$Optimization ON,ALL}
uses
SysUtils,
Classes;
{$ELSE}
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Classes,
{$R *.res}
{$ENDIF}
function Sort(const s: string):string;
//insertion sort
var
pRes : pchar;
i, j, aLength: NativeInt;
tmpc: Char;
begin
aLength := s.Length;
if aLength = 0 then
exit('');
Result := s;
//without it, s will be sorted
UniqueString(Result);
//insertion sort
pRes := pChar(Result);
dec(aLength,1);
for i := 0 to aLength do
Begin
tmpc := pRes[i];
j := i-1;
while (j>=0) AND (tmpc < pRes[j]) do
Begin
pRes[j+1] := pRes[j];
dec(j);
end;
inc(j);
pRes[j]:= tmpc;
end;
end;
function CompareLength(List: TStringList; Index1, Index2: longInt): longInt;
begin
result := List[Index1].Length - List[Index2].Length;
IF result = 0 then
result := CompareStr(List[Index1],List[Index2]);
end;
function IsDerangement(const word1, word2: string): Boolean;
var
i: NativeInt;
begin
for i := word1.Length downto 1 do
if word1[i] = word2[i] then
exit(False);
Result := True;
end;
var
Dict,SortDict: TStringList;
words: string;
StopWatch: Int64;
Count, Index: NativeInt;
begin
Dict := TStringList.Create();
Dict.LoadFromFile('unixdict.txt');
StopWatch := GettickCount64;
SortDict:= TStringList.Create();
SortDict.capacity := Dict.Count;
For Index := 0 to Dict.Count - 1 do
Begin
SortDict.Add(Sort(Dict[Index]));
//remember the origin in Dict
SortDict.Objects[Index]:= TObject(Index);
end;
SortDict.CustomSort(CompareLength);
Index := Dict.Count - 1;
words := '';
Count := 1;
while Index - Count >= 0 do
begin
if SortDict[Index]= SortDict[Index - Count] then
begin
if IsDerangement(Dict[NativeInt(SortDict.Objects[Index])],
Dict[NativeInt(SortDict.Objects[Index - Count])]) then
begin
words := Dict[NativeInt(SortDict.Objects[Index])] + ' - ' +
Dict[NativeInt(SortDict.Objects[Index - Count])];
Break;
end;
Inc(Count);
end
else
begin
Dec(Index, Count);
Count := 1;
end;
end;
StopWatch := GettickCount64-StopWatch;
Writeln(Format('Time pass: %d ms [AMD 2200G-Linux Fossa]',[StopWatch]));
writeln(#10'Longest derangement words are:'#10#10, words);
SortDict.free;
Dict.Free;
end.
- Output:
Time pass: 33 ms [AMD 2200G-Linux Fossa] Longest derangement words are: excitation - intoxicate
Perl
String operations
use strict;
use warnings;
sub deranged { # only anagrams ever get here
my @a = split('', shift); # split word into letters
my @b = split('', shift);
for (0 .. $#a) {
$a[$_] eq $b[$_] and return;
}
return 1
}
sub find_deranged {
for my $i ( 0 .. $#_ ) {
for my $j ( $i+1 .. $#_ ) {
next unless deranged $_[$i], $_[$j];
print "length ", length($_[$i]), ": $_[$i] => $_[$j]\n";
return 1;
}
}
}
my %letter_list;
open my $in, 'unixdict.txt';
local $/ = undef;
for (split(' ', <$in>)) {
# store anagrams in hash table by letters they contain
push @{ $letter_list{ join('', sort split('', $_)) } }, $_
}
for ( sort { length($b) <=> length($a) } # sort by length, descending
grep { @{ $letter_list{$_} } > 1 } # take only ones with anagrams
keys %letter_list )
{
# if we find a pair, they are the longest due to the sort before
last if find_deranged(@{ $letter_list{$_} });
}
- Output:
length 10: excitation => intoxicate
Bitwise operations
use strict;
use warnings;
use feature 'bitwise';
local (@ARGV, $/) = 'unixdict.txt';
my %anagrams;
for my $word ( sort { length $b <=> length $a } split ' ', <> )
{
my $key = join '', sort +split //, $word;
($_ ^. $word) =~ /\0/ or exit !print "$_ $word\n" for @{ $anagrams{$key} };
push @{ $anagrams{$key} }, $word;
}
- Output:
excitation intoxicate
Phix
function deranged(string word1, word2) return sum(sq_eq(word1,word2))=0 end function integer fn = open("demo/unixdict.txt","r") sequence words = {}, anagrams = {}, last="", letters object word integer maxlen = 1 while 1 do word = trim(gets(fn)) if atom(word) then exit end if if length(word) then letters = sort(word) words = append(words, {letters, word}) end if end while close(fn) words = sort(words) for i=1 to length(words) do {letters,word} = words[i] if letters=last then anagrams[$] = append(anagrams[$],word) anagrams[$][1] = length(word) else last = letters anagrams = append(anagrams,{0,word}) end if end for anagrams = sort(anagrams) puts(1,"\nLongest deranged anagrams:\n") for i=length(anagrams) to 1 by -1 do last = anagrams[i] if last[1]<maxlen then exit end if for j=2 to length(last) do for k=j+1 to length(last) do if deranged(last[j],last[k]) then puts(1,last[j]&", "&last[k]&"\n") maxlen = last[1] end if end for end for end for
- Output:
Longest deranged anagrams: excitation, intoxicate
Phixmonti
/# Rosetta Code problem: http://rosettacode.org/wiki/Anagrams/Deranged_anagrams
by Galileo, 06/2022 #/
include ..\Utilitys.pmt
"unixdict.txt" "r" fopen var f
( )
true while
f fgets
dup -1 == if
drop
f fclose
false
else
-1 del
dup sort swap 2 tolist
0 put
true
endif
endwhile
sort
0 var largest
( ) var candidate
( len 2 swap ) for var i
( i 1 ) sget >ps
( i 1 - 1 ) sget ps> == if
( i 2 ) sget >ps
( i 1 - 2 ) sget ps> len >ps
true var test
tps for var j
j get rot j get rot == if false var test exitfor endif
endfor
test tps largest > and if
ps> var largest
2 tolist var candidate
else
ps> drop drop drop
endif
endif
endfor
candidate print
- Output:
["excitation", "intoxicate"] === Press any key to exit ===
PHP
<?php
$words = file(
'http://www.puzzlers.org/pub/wordlists/unixdict.txt',
FILE_IGNORE_NEW_LINES
);
$length = 0;
foreach ($words as $word) {
$chars = str_split($word);
sort($chars);
$chars = implode("", $chars);
$length = strlen($chars);
$anagrams[$length][$chars][] = $word;
}
krsort($anagrams);
foreach ($anagrams as $anagram) {
$final_words = array();
foreach ($anagram as $words) {
if (count($words) >= 2) {
$counts = array();
foreach ($words as $word) {
$counts[$word] = array($word);
foreach ($words as $second_word) {
for ($i = 0, $length = strlen($word); $i < $length; $i++) {
if ($word[$i] === $second_word[$i]) continue 2;
}
$counts[$word][] = $second_word;
}
}
$max = 0;
$max_key = '';
foreach ($counts as $name => $count) {
if (count($count) > $max) {
$max = count($count);
$max_key = $name;
}
}
if ($max > 1) {
$final_words[] = $counts[$max_key];
}
}
}
if ($final_words) break;
}
foreach ($final_words as $final_word) {
echo implode(" ", $final_word), "\n";
}
?>
- Output:
excitation intoxicate
Picat
go =>
M = [W:W in read_file_lines("unixdict.txt")].group(sort),
Deranged = [Value : _Key=Value in M, Value.length > 1, allderanged(Value)],
MaxLen = max([V[1].length : V in Deranged]),
println([V : V in Deranged, V[1].length==MaxLen]),
nl.
% A and B are deranged: i.e. there is no
% position with the same character.
deranged(A,B) =>
foreach(I in 1..A.length)
A[I] != B[I]
end.
% All words in list Value are deranged anagrams of each other.
allderanged(Value) =>
IsDeranged = 1,
foreach(V1 in Value, V2 in Value, V1 @< V2, IsDeranged = 1)
if not deranged(V1,V2) then
IsDeranged := 0
end
end,
IsDeranged == 1.
% Groups the element in List according to the function F
group(List, F) = P, list(List) =>
P = new_map(),
foreach(E in List)
V = apply(F,E),
P.put(V, P.get(V,[]) ++ [E])
end.
- Output:
[[excitation,intoxicate]]
PicoLisp
(let Words NIL
(in "unixdict.txt"
(while (line)
(let (Word @ Key (pack (sort (copy @))))
(if (idx 'Words Key T)
(push (car @) Word)
(set Key (list Word)) ) ) ) )
(maxi '((X) (length (car X)))
(extract
'((Key)
(pick
'((Lst)
(and
(find
'((L) (not (find = L Lst)))
(val Key) )
(cons (pack @) (pack Lst)) ) )
(val Key) ) )
(idx 'Words) ) ) )
- Output:
-> ("excitation" . "intoxicate")
PowerShell
function Test-Deranged ([string[]]$Strings)
{
$array1 = $Strings[0].ToCharArray()
for ($i = 1; $i -lt $Strings.Count; $i++)
{
$array2 = $Strings[$i].ToCharArray()
for ($i = 0; $i -lt $array1.Count; $i++)
{
if ($array1[$i] -match $array2[$i])
{
return $false
}
}
}
return $true
}
$words = [System.Collections.ArrayList]@()
Get-Content -Path ".\unixdict.txt" |
ForEach-Object { [void]$words.Add([PSCustomObject]@{Word=$_; SortedWord=(($_.ToCharArray() | Sort-Object) -join "")}) }
[object[]]$anagrams = $words | Group-Object -Property SortedWord | Where-Object -Property Count -GT 1 | Sort-Object {$_.Name.Length}
[string[]]$deranged = ($anagrams | ForEach-Object { if ((Test-Deranged $_.Group.Word)) {$_} } | Select-Object -Last 1).Group.Word
[PSCustomObject]@{
Length = $deranged[0].Length
Words = $deranged
}
- Output:
Length Words ------ ----- 10 {excitation, intoxicate}
Prolog
longest_deranged_anagram :-
http_open('http://www.puzzlers.org/pub/wordlists/unixdict.txt',In,[]),
read_file(In, [], Out),
close(In),
msort(Out, MOut),
group_pairs_by_key(MOut, GPL),
map_list_to_pairs(compute_len, GPL, NGPL),
predsort(my_compare, NGPL, GPLSort),
search_derangement(GPLSort).
% order tuples to have longest words first
my_compare(R, N1-(K1-E1), N2-(K2-E2)) :-
( N1 < N2 -> R = > ; N1 > N2 -> R = <;
length(E1, L1),
length(E2, L2),
( L1 < L2 -> R = <; L1 > L2 -> R = >; compare(R, K1, K2))).
compute_len(_-[H|_], Len) :-
length(H, Len).
% check derangement of anagrams
derangement([], []).
derangement([H1|T1], [H2 | T2]) :-
H1 \= H2,
derangement(T1, T2).
search_derangement([_-(_-L) | T]) :-
length(L, 1), !,
search_derangement(T).
search_derangement([_-(_-L) | T]) :-
( search(L) -> true; search_derangement(T)).
search([]) :- fail.
search([H | T]) :-
( search_one(H, T) -> true; search(T)).
search_one(Word, L) :-
include(derangement(Word), L, [H|_]),
atom_codes(W, Word),
atom_codes(W1, H),
format('Longest deranged anagrams : ~w ~w ~n', [W, W1]).
read_file(In, L, L1) :-
read_line_to_codes(In, W),
( W == end_of_file ->
L1 = L
;
msort(W, W1),
atom_codes(A, W1),
read_file(In, [A-W | L], L1)).
- Output:
?- longest_deranged_anagram. Longest deranged anagrams : excitation intoxicate true.
PureBasic
Structure anagram
word.s
letters.s
EndStructure
Structure wordList
List words.anagram()
EndStructure
#True = 1
#False = 0
Procedure.s sortLetters(*word.Character, wordLength)
;returns a string with the letters of a word sorted
Protected Dim letters.c(wordLength)
Protected *letAdr = @letters()
CopyMemoryString(*word, @*letAdr)
SortArray(letters(), #PB_Sort_Ascending, 0, wordLength - 1)
ProcedureReturn PeekS(@letters(), wordLength)
EndProcedure
;Compare a list of anagrams for derangement.
Procedure isDeranged(List anagram.s())
;If a pair of deranged anagrams is found return #True
;and and modify the list to include the pair of deranged anagrams.
Protected i, length, word.s, *ptrAnagram, isDeranged
Protected NewList deranged.s()
FirstElement(anagram())
length = Len(anagram())
Repeat
word = anagram()
*ptrAnagram = @anagram()
While NextElement(anagram())
isDeranged = #True
For i = 1 To length
If Mid(word, i, 1) = Mid(anagram(), i, 1)
isDeranged = #False
Break ;exit for/next
EndIf
Next
If isDeranged
AddElement(deranged())
deranged() = anagram()
AddElement(deranged())
deranged() = word
CopyList(deranged(), anagram())
ProcedureReturn #True ;deranged anagram found
EndIf
Wend
ChangeCurrentElement(anagram(), *ptrAnagram)
Until Not NextElement(anagram())
ProcedureReturn #False ;deranged anagram not found
EndProcedure
If OpenConsole()
;word file is assumed to be in the same directory
If Not ReadFile(0,"unixdict.txt"): End: EndIf
Define maxWordSize = 0, word.s, length
Dim wordlists.wordList(maxWordSize)
;Read word file and create separate lists of anagrams and their original
;words by length.
While Not Eof(0)
word = ReadString(0)
length = Len(word)
If length > maxWordSize
maxWordSize = length
Redim wordlists.wordList(maxWordSize)
EndIf
AddElement(wordlists(length)\words())
wordlists(length)\words()\word = word
wordlists(length)\words()\letters = sortLetters(@word, length)
Wend
CloseFile(0)
Define offset = OffsetOf(anagram\letters), option = #PB_Sort_Ascending
Define sortType = #PB_Sort_String
Define letters.s, foundDeranged
NewList anagram.s()
;start search from largest to smallest
For length = maxWordSize To 2 Step -1
If FirstElement(wordlists(length)\words()) ;only examine lists with words
;sort words to place anagrams next to each other
SortStructuredList(wordlists(length)\words(), option, offset, sortType)
With wordlists(length)\words()
letters = \letters
AddElement(anagram()): anagram() = \word
;Compose sets of anagrams and check for derangement with remaining
;words in current list.
While NextElement(wordlists(length)\words())
;Check for end of a set of anagrams?
If letters <> \letters
;if more than one word in a set of anagrams check for derangement
If ListSize(anagram()) > 1
If isDeranged(anagram())
foundDeranged = #True ;found deranged anagrams, stop processing
Break 2 ;exit while/wend and for/next
EndIf
EndIf
letters = \letters ;setup for next set of anagrams
ClearList(anagram())
EndIf
AddElement(anagram()): anagram() = \word
Wend
EndWith
EndIf
ClearList(anagram())
Next
;report results
If foundDeranged
Print("Largest 'Deranged' anagrams found are of length ")
PrintN(Str(length) + ":" + #CRLF$)
ForEach anagram()
PrintN(" " + anagram())
Next
Else
PrintN("No 'Deranged' anagrams were found." + #CRLF$)
EndIf
Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
CloseConsole()
EndIf
- Output:
Largest 'Deranged' anagrams found are of length 10: intoxicate excitation
Python
import urllib.request
from collections import defaultdict
from itertools import combinations
def getwords(url='http://www.puzzlers.org/pub/wordlists/unixdict.txt'):
return list(set(urllib.request.urlopen(url).read().decode().split()))
def find_anagrams(words):
anagram = defaultdict(list) # map sorted chars to anagrams
for word in words:
anagram[tuple(sorted(word))].append( word )
return dict((key, words) for key, words in anagram.items()
if len(words) > 1)
def is_deranged(words):
'returns pairs of words that have no character in the same position'
return [ (word1, word2)
for word1,word2 in combinations(words, 2)
if all(ch1 != ch2 for ch1, ch2 in zip(word1, word2)) ]
def largest_deranged_ana(anagrams):
ordered_anagrams = sorted(anagrams.items(),
key=lambda x:(-len(x[0]), x[0]))
for _, words in ordered_anagrams:
deranged_pairs = is_deranged(words)
if deranged_pairs:
return deranged_pairs
return []
if __name__ == '__main__':
words = getwords('http://www.puzzlers.org/pub/wordlists/unixdict.txt')
print("Word count:", len(words))
anagrams = find_anagrams(words)
print("Anagram count:", len(anagrams),"\n")
print("Longest anagrams with no characters in the same position:")
print(' ' + '\n '.join(', '.join(pairs)
for pairs in largest_deranged_ana(anagrams)))
- Output:
Word count: 25104 Anagram count: 1303 Longest anagrams with no characters in the same position: excitation, intoxicate
Python: Anagrams with most derangements
The talk page had a later discussion on groups of anagrams with the most derangements. This computes that.
Append the following to the previous code:
def most_deranged_ana(anagrams):
ordered_anagrams = sorted(anagrams.items(),
key=lambda x:(-len(x[0]), x[0]))
many_anagrams = [anas for _, anas in ordered_anagrams if len(anas) > 2]
d_of_anas = [is_deranged(ana_group) for ana_group in many_anagrams]
d_of_anas = [d_group for d_group in d_of_anas if d_group]
d_of_anas.sort(key=lambda d_group:(-len(d_group), -len(d_group[0])))
mx = len(d_of_anas[0])
most = [sorted(d_group) for d_group in d_of_anas if len(d_group) == mx]
return most
if __name__ == '__main__':
most = most_deranged_ana(anagrams)
print(f"\nThere are {len(most)} groups of anagrams all containing"
f" a max {len(most[0])} deranged word-pairs:")
for pairs in most:
print()
print(' ' + '\n '.join(', '.join(p) for p in pairs))
- Output:
Extra output generated:
There are 4 groups of anagrams all containing a max 5 deranged word-pairs: angel, glean angel, lange angle, glean galen, angle lange, glean bale, abel bela, abel elba, abel elba, able elba, bale evil, live evil, vile levi, evil levi, vile veil, live emit, item emit, time mite, emit mite, item time, item
Python: Faster Version
from collections import defaultdict
from itertools import combinations
from pathlib import Path
from typing import (Callable,
Dict,
Iterable,
Iterator,
List,
Optional,
Tuple,
TypeVar)
WORDS_FILE = 'unixdict.txt'
T1 = TypeVar('T1')
T2 = TypeVar('T2')
def main():
words = read_words(Path(WORDS_FILE))
anagram = longest_deranged_anagram(words)
if anagram:
print('The longest deranged anagram is: {}, {}'.format(*anagram))
else:
print('No deranged anagrams were found')
def read_words(path: Path) -> Iterator[str]:
"""Yields words from file at specified path"""
with path.open() as file:
for word in file:
yield word.strip()
def longest_deranged_anagram(words: Iterable[str]
) -> Optional[Tuple[str, str]]:
"""
Returns the longest pair of words
that have no character in the same position
"""
words_by_lengths = mapping_by_function(len, words)
decreasing_lengths = sorted(words_by_lengths, reverse=True)
for length in decreasing_lengths:
words = words_by_lengths[length]
anagrams_by_letters = mapping_by_function(sort_str, words)
for anagrams in anagrams_by_letters.values():
deranged_pair = next(deranged_word_pairs(anagrams), None)
if deranged_pair is not None:
return deranged_pair
return None
def mapping_by_function(function: Callable[..., T2],
iterable: Iterable[T1]) -> Dict[T2, List[T1]]:
"""
Constructs a dictionary with keys
obtained from applying an input function
to items of an iterable,
and the values filled from the same iterable
"""
mapping = defaultdict(list)
for item in iterable:
mapping[function(item)].append(item)
return mapping
def sort_str(string: str) -> str:
"""Sorts input string alphabetically"""
return ''.join(sorted(string))
def deranged_word_pairs(words: Iterable[str]) -> Iterator[Tuple[str, str]]:
"""Yields deranged words from an input list of words"""
pairs = combinations(words, 2) # type: Iterator[Tuple[str, str]]
yield from filter(is_deranged, pairs)
def is_deranged(word_pair: Tuple[str, str]) -> bool:
"""
Checks if all corresponding letters are different,
assuming that words have the same length
"""
return all(a != b for a, b in zip(*word_pair))
if __name__ == '__main__':
main()
- Output:
The longest anagram is: excitation, intoxicate
Quackery
[ over size over size != iff
[ 2drop false ] done
over sort over sort != iff
[ 2drop false ] done
true unrot witheach
[ dip behead = if
[ dip not conclude ] ]
drop ] is deranged ( $ $ --> b )
$ 'rosetta/unixdict.txt' sharefile drop nest$
[] temp put
dup size times
[ behead over witheach
[ 2dup deranged iff
[ over nested swap
nested join nested
temp take join temp put ]
else drop ]
drop ]
drop
temp take
sortwith [ 0 peek size swap 0 peek size > ]
0 peek witheach [ echo$ sp ]
- Output:
excitation intoxicate
R
puzzlers.dict <- readLines("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
longest.deranged.anagram <- function(dict=puzzlers.dict) {
anagram.groups <- function(word.group) {
sorted <- sapply(lapply(strsplit(word.group,""),sort),paste, collapse="")
grouped <- tapply(word.group, sorted, force, simplify=FALSE)
grouped <- grouped[sapply(grouped, length) > 1]
grouped[order(-nchar(names(grouped)))]
}
derangements <- function(anagram.group) {
pairs <- expand.grid(a = anagram.group, b = anagram.group,
stringsAsFactors=FALSE)
pairs <- subset(pairs, a < b)
deranged <- with(pairs, mapply(function(a,b) all(a!=b),
strsplit(a,""), strsplit(b,"")))
pairs[which(deranged),]
}
for (anagram.group in anagram.groups(dict)) {
if (nrow(d <- derangements(anagram.group)) > 0) {
return(d[1,])
}
}
}
- Output:
> longest.deranged.anagram()
a b
3 excitation intoxicate
Racket
#lang racket
(define word-list-file "data/unixdict.txt")
(define (read-words-into-anagram-keyed-hash)
(define (anagram-key word) (sort (string->list word) char<?))
(for/fold ((hsh (hash)))
((word (in-lines)))
(hash-update hsh (anagram-key word) (curry cons word) null)))
(define anagrams-list
(sort
(for/list
((v (in-hash-values
(with-input-from-file
word-list-file
read-words-into-anagram-keyed-hash)))
#:when (> (length v) 1)) v)
> #:key (compose string-length first)))
(define (deranged-anagram-pairs l (acc null))
(define (deranged-anagram-pair? hd tl)
(define (first-underanged-char? hd tl)
(for/first
(((c h) (in-parallel hd tl))
#:when (char=? c h)) c))
(not (first-underanged-char? hd tl)))
(if (null? l) acc
(let ((hd (car l)) (tl (cdr l)))
(deranged-anagram-pairs
tl
(append acc (map (lambda (x) (list hd x))
(filter (curry deranged-anagram-pair? hd) tl)))))))
;; for*/first give the first set of deranged anagrams (as per the RC problem)
;; for*/list gives a full list of the sets of deranged anagrams (which might be interesting)
(for*/first
((anagrams (in-list anagrams-list))
(daps (in-value (deranged-anagram-pairs anagrams)))
#:unless (null? daps))
daps)
- Output:
'(("intoxicate" "excitation"))
Raku
(formerly Perl 6)
my @anagrams = 'unixdict.txt'.IO.words
.map(*.comb.cache) # explode words into lists of characters
.classify(*.sort.join).values # group words with the same characters
.grep(* > 1) # only take groups with more than one word
.sort(-*[0]) # sort by length of the first word
;
for @anagrams -> @group {
for @group.combinations(2) -> [@a, @b] {
if none @a Zeq @b {
say "{@a.join} {@b.join}";
exit;
}
}
}
- Output:
excitation intoxicate
REXX
/*REXX program finds the largest deranged word (within an identified dictionary). */
iFID= 'unixdict.txt'; words=0 /*input file ID; number of words so far*/
wL.=0 /*number of words of length L. so far*/
do while lines(iFID)\==0 /*read each word in the file (word=X).*/
x= strip( linein( iFID) ) /*pick off a word from the input line. */
L= length(x); if L<3 then iterate /*onesies & twosies can't possible win.*/
words= words + 1 /*bump the count of (usable) words. */
#.words= L /*the length of the word found. */
@.words= x /*save the word in an array. */
wL.L= wL.L+1; _= wL.L /*bump counter of words of length L. */
@@.L._= x /*array of words of length L. */
do i=1 while x\==''; parse var x !.i +1 x; end /*i*/
call eSort L; z=; do j=1 for L; z= z || !.j; end /*j*/
@@s.L._= z /*store the sorted word (letters). */
@s.words= @@s.L._ /*store the sorted length L version. */
end /*while*/
a.= /*all the anagrams for word X. */
say copies('─', 30) words 'usable words in the dictionary file: ' iFID
m= 0; n.= 0 /*# anagrams for word X; m=max L. */
do j=1 for words /*process usable words that were found.*/
Lx= #.j; if Lx<m then iterate /*get length of word; skip if too short*/
x= @.j; xs= @s.j /*get some vital statistics for X */
do k=1 for wL.Lx /*process all the words of length L. */
if xs\== @@s.Lx.k then iterate /*is this not a true anagram of X ? */
if x == @@.Lx.k then iterate /*skip of processing anagram on itself.*/
do c=1 for Lx /*ensure no character position shared. */
if substr(@.j, c, 1) == substr(@@.Lx.k, c, 1) then iterate k
end /*c*/ /* [+] now compare the rest of chars. */
n.j= n.j + 1; a.j= a.j @@.Lx.k /*bump counter; then add ──► anagrams.*/
m= max(m, Lx) /*M is the maximum length of a word. */
end /*k*/
end /*j*/
do k=1 for words /*now, search all words for the maximum*/
if #.k==m then if n.k\==0 then if word(a.k, 1) > @.k then say @.k a.k
end /*k*/ /* [↑] REXX has no short-circuits. */
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
eSort: procedure expose !.; parse arg ho 1 h /*obtain number of elements; also copy.*/
do while h>1; h=h % 2; do i=1 for ho-h; j= i; k= h+i
do while !.k<!.j; t=!.j; !.j=!.k; !.k=t; if h>=j then leave; j=j-h; k=k-h
end /*while !.k···*/; end /*i*/; end /*while h>1*/; return
- output when using the default dictionary:
────────────────────────────── 24945 usable words in the dictionary file: unixdict.txt excitation intoxicate
Ring
# Project : Anagrams/Deranged anagrams
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
strbig = 1
for n = 1 to len(strlist)
for m = 1 to len(strlist)
sum = 0
if len(strlist[n]) = len(strlist[m]) 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 = len(strlist[n])
anag[n] = anag[n] + 1
if anag[n] < 6 and result[n] = 0 and result[m] = 0
anagram[n][anag[n]] = strlist[m]
if len(strlist[m]) > len(strlist[strbig])
strbig = n
ok
result[m] = 1
ok
ok
ok
next
if anag[n] > 0
result[n] = 1
ok
next
flag = 0
for m = 1 to 5
if anagram[strbig][m] != 0
if m = 1
see strlist[strbig] + " "
flag = 1
ok
see anagram[strbig][m] + " "
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
- Output:
excitation intoxicate
Ruby
def deranged?(a, b)
a.chars.zip(b.chars).all? {|char_a, char_b| char_a != char_b}
end
def find_derangements(list)
list.combination(2) {|a,b| return a,b if deranged?(a,b)}
nil
end
require 'open-uri'
anagram = open('http://www.puzzlers.org/pub/wordlists/unixdict.txt') do |f|
f.read.split.group_by {|s| s.each_char.sort}
end
anagram = anagram.select{|k,list| list.size>1}.sort_by{|k,list| -k.size}
anagram.each do |k,list|
if derangements = find_derangements(list)
puts "Longest derangement anagram: #{derangements}"
break
end
end
- Output:
Longest derangement anagram: ["excitation", "intoxicate"]
Run BASIC
a$ = httpGet$("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
dim theWord$(30000)
dim ssWord$(30000)
c10$ = chr$(10)
i = 1
while instr(a$,c10$,i) <> 0
j = instr(a$,c10$,i)
ln = j - i
again = 1
sWord$ = mid$(a$,i,j-i)
n = n + 1
theWord$(n) = sWord$
while again = 1
again = 0
for kk = 1 to len(sWord$) - 1
if mid$(sWord$,kk,1) > mid$(sWord$,kk +1,1) then
sWord$ = left$(sWord$,kk-1);mid$(sWord$,kk+1,1);mid$(sWord$,kk,1);mid$(sWord$,kk+2)
again = 1
end if
next kk
wend
ssWord$(n) = sWord$
i = j + 1
wend
for i = 1 to n
if len(theWord$(i)) > maxLen then
for j = 1 to n
if ssWord$(i) = ssWord$(j) and i <> j then
cnt = 0
for k = 1 to len(theWord$(i))
if mid$(theWord$(i),k,1) = mid$(theWord$(j),k,1) then cnt = cnt + 1
next k
if cnt = 0 then
maxLen = len(theWord$(i))
maxPtrI = i
maxPtrJ = j
end if
end if
next j
end if
next i
print maxLen;" ";theWord$(maxPtrI);" => ";theWord$(maxPtrJ)
end
- Output:
10 excitation => intoxicate
Rust
//! Deranged anagrams
use std::cmp::Ordering;
use std::collections::HashMap;
use std::fs::File;
use std::io;
use std::io::BufReader;
use std::io::BufRead;
use std::usize::MAX;
/// Get words from unix dictionary file
pub fn get_words() -> Result<Vec<String>, io::Error> {
let mut words = vec!();
// open file
let f = File::open("data/unixdict.txt")?;
// read line by line
let reader = BufReader::new(&f);
for line in reader.lines() {
words.push(line?)
}
Ok(words)
}
/// Get the longest deranged anagram in the given list of word if any
pub fn longest_deranged(v: &mut Vec<String>) -> Option<(String,String)>{
// sort by length descending then by alphabetical order
v.sort_by(|s1, s2| {
let mut c = s2.len().cmp(&s1.len());
if c == Ordering::Equal {
c = s1.cmp(s2);
}
c
});
// keep all strings keyed by sorted characters (since anagrams have the same list of sorted characters)
let mut signatures : HashMap<Vec<char>, Vec<&String>> = HashMap::new();
// save on memory by only keeping in the map strings of the current processed length
let mut previous_length = MAX;
for s in v {
// length change, clear the map
if s.len()<previous_length {
signatures.clear();
previous_length = s.len();
}
// generate key as sorted characters
let mut sorted_chars = s.chars().collect::<Vec<char>>();
sorted_chars.sort();
let anagrams = signatures.entry(sorted_chars).or_insert(vec!());
// find if any anagram (string with the same sorted character vector) is deranged
if let Some(a) = anagrams.iter().filter(|anagram| is_deranged(anagram, s)).next(){
return Some(((*a).clone(), s.clone()));
}
anagrams.push(s);
}
None
}
/// check if two strings do NOT have the same character in the same position
pub fn is_deranged(s1: &String, s2: &String) -> bool {
// we zip the character iterators and check we find no position with the same two characters
s1.chars().zip(s2.chars()).filter(|(a,b)| a == b).next().is_none()
}
/// an example main method printing the results
fn main() {
let r = get_words();
match r {
Ok(mut v) => {
let od = longest_deranged(&mut v);
match od {
None => println!("No deranged anagrams found!"),
Some((s1,s2)) => println!("{} {}",s1,s2),
}
},
Err(e) => panic!("Could not read words: {}",e)
}
}
- Output:
excitation intoxicate
Scala
object DerangedAnagrams {
/** Returns a map of anagrams keyed by the sorted characters */
def groupAnagrams(words: Iterable[String]): Map[String, Set[String]] =
words.foldLeft (Map[String, Set[String]]()) { (map, word) =>
val sorted = word.sorted
val entry = map.getOrElse(sorted, Set.empty)
map + (sorted -> (entry + word))
}
/* Returns true if the pair of strings has no positions with the same
* characters */
def isDeranged(ss: (String, String)): Boolean =
ss._1 zip ss._2 forall { case (c1, c2) => c1 != c2 }
/* Returns pairwise combination of all Strings in the argument Iterable */
def pairWords(as: Iterable[String]): Iterable[(String, String)] =
if (as.size < 2) Seq() else (as.tail map (as.head -> _)) ++ pairWords(as.tail)
/* Returns the contents of the argument URL as an Iterable[String], each
* String is one line in the file */
def readLines(url: String): Iterable[String] =
io.Source.fromURL(url).getLines().toIterable
val wordsURL = "http://www.puzzlers.org/pub/wordlists/unixdict.txt"
def main(args: Array[String]): Unit = {
val anagramMap = groupAnagrams(readLines(wordsURL))
val derangedPairs = anagramMap.values flatMap (pairWords) filter (isDeranged)
val (w1, w2) = derangedPairs maxBy (pair => pair._1.length)
println("Longest deranged pair: "+w1+" and "+w2)
}
}
- Output:
Longest deranged pair: excitation and intoxicate
Scheme
(import (scheme base)
(scheme char)
(scheme cxr)
(scheme file)
(scheme write)
(srfi 1) ; lists
(srfi 132)) ; sorting library
;; read in word list, and sort into decreasing length
(define (read-ordered-words)
(with-input-from-file
"unixdict.txt"
(lambda ()
(do ((line (read-line) (read-line))
(words '() (cons line words)))
((eof-object? line)
(list-sort (lambda (a b) (> (string-length a) (string-length b)))
words))))))
(define (find-deranged-words word-list)
(define (search words)
(let loop ((word-chars (let ((chars (map string->list words)))
(zip chars
(map (lambda (word) (list-sort char<? word))
chars)))))
(if (< (length word-chars) 2)
#f ; failed to find any
(let ((deranged-word ; seek a deranged version of the first word in word-chars
(find (lambda (chars)
(and (equal? (cadar word-chars) (cadr chars)) ; check it's an anagram?
(not (any char=? (caar word-chars) (car chars))))) ; and deranged?
word-chars)))
(if deranged-word ; if we got one, return it with the first word
(map list->string (list (caar word-chars) (car deranged-word)))
(loop (cdr word-chars)))))))
;
(let loop ((rem word-list))
(if (null? rem)
'()
(let* ((len (string-length (car rem)))
(deranged-words (search ; look through group of equal sized words
(take-while (lambda (word) (= len (string-length word)))
(cdr rem)))))
(if deranged-words
deranged-words
(loop (drop-while (lambda (word) (= len (string-length word)))
(cdr rem))))))))
(display (find-deranged-words (read-ordered-words))) (newline)
- Output:
(excitation intoxicate)
Sidef
func find_deranged(Array a) {
for i in (^a) {
for j in (i+1 .. a.end) {
overlaps(a[i], a[j]) || (
printf("length %d: %s => %s\n", a[i].len, a[i], a[j])
return true
)
}
}
return false
}
func main(File file) {
file.open_r(\var fh, \var err) ->
|| die "Can't open file `#{file}' for reading: #{err}\n"
var letter_list = Hash()
# Store anagrams in hash table by letters they contain
fh.words.each { |word|
letter_list{word.sort} := [] << word
}
letter_list.keys \
.grep {|k| letter_list{k}.len > 1} \ # take only ones with anagrams
.sort {|a,b| b.len <=> a.len} \ # sort by length, descending
.each {|key|
# If we find a pair, they are the longested due to the sort before
find_deranged(letter_list{key}) && break
}
}
main(%f'/tmp/unixdict.txt')
- Output:
length 10: excitation => intoxicate
Simula
! cim --memory-pool-size=512 deranged-anagrams.sim;
BEGIN
CLASS TEXTVECTOR;
BEGIN
CLASS TEXTARRAY(N); INTEGER N;
BEGIN TEXT ARRAY DATA(1:N);
END TEXTARRAY;
PROCEDURE EXPAND(N); INTEGER N;
BEGIN
INTEGER I;
REF(TEXTARRAY) TEMP;
TEMP :- NEW TEXTARRAY(N);
FOR I := 1 STEP 1 UNTIL SIZE DO
TEMP.DATA(I) :- ITEMS.DATA(I);
ITEMS :- TEMP;
END EXPAND;
PROCEDURE APPEND(T); TEXT T;
BEGIN
IF SIZE + 1 > CAPACITY THEN
BEGIN
CAPACITY := 2 * CAPACITY;
EXPAND(CAPACITY);
END;
SIZE := SIZE + 1;
ITEMS.DATA(SIZE) :- T;
END APPEND;
TEXT PROCEDURE ELEMENT(I); INTEGER I;
BEGIN
IF I < 1 OR I > SIZE THEN ERROR("ELEMENT: INDEX OUT OF BOUNDS");
ELEMENT :- ITEMS.DATA(I);
END ELEMENT;
INTEGER PROCEDURE FIND_INDEX(STR,INDEX); TEXT STR; INTEGER INDEX;
BEGIN
INTEGER I, FOUND;
FOUND := -1;
FOR I := INDEX STEP 1 UNTIL SIZE DO
IF STR = ELEMENT(I) THEN
BEGIN
FOUND := I;
GOTO L;
END;
L: FIND_INDEX := FOUND;
END FIND_INDEX;
INTEGER CAPACITY;
INTEGER SIZE;
REF(TEXTARRAY) ITEMS;
CAPACITY := 20;
SIZE := 0;
EXPAND(CAPACITY);
END TEXTVECTOR;
BOOLEAN PROCEDURE DERANGE(S1,S2); TEXT S1,S2;
BEGIN
INTEGER I;
BOOLEAN RESULT;
RESULT := TRUE;
I := 1;
WHILE RESULT AND I <= S1.LENGTH DO
BEGIN
CHARACTER C1, C2;
S1.SETPOS(I); C1 := S1.GETCHAR;
S2.SETPOS(I); C2 := S2.GETCHAR;
IF C1 = C2 THEN
RESULT := FALSE
ELSE
I := I+1;
END;
DERANGE := RESULT;
END DERANGE;
PROCEDURE STRSORT(STR); NAME STR; TEXT STR;
BEGIN
INTEGER N, I;
FOR N := STR.LENGTH STEP -1 UNTIL 2 DO
FOR I := 1 STEP 1 UNTIL N-1 DO
BEGIN
CHARACTER CI1,CI2;
STR.SETPOS(I); CI1 := STR.GETCHAR; CI2 := STR.GETCHAR;
IF CI1 > CI2 THEN
BEGIN
STR.SETPOS(I); STR.PUTCHAR(CI2); STR.PUTCHAR(CI1);
END;
END;
END STRSORT;
REF(INFILE) FILE;
INTEGER LEN, FOUNDLEN;
REF(TEXTVECTOR) VECT, SVECT;
INTEGER INDEX, P1, P2;
TEXT STR;
VECT :- NEW TEXTVECTOR;
SVECT :- NEW TEXTVECTOR;
FOUNDLEN := 1;
FILE :- NEW INFILE("unixdict.txt");
FILE.OPEN(BLANKS(132));
WHILE NOT FILE.LASTITEM DO
BEGIN
STR :- FILE.INTEXT(132).STRIP;
LEN := STR.LENGTH;
IF LEN > FOUNDLEN THEN
BEGIN
VECT.APPEND(COPY(STR));
STRSORT(STR);
INDEX := 0;
COMMENT Loop through anagrams by index in vector of sorted strings;
INDEX := SVECT.FIND_INDEX(STR, INDEX + 1);
WHILE INDEX > 0 DO
BEGIN
IF DERANGE(VECT.ELEMENT(VECT.SIZE), VECT.ELEMENT(INDEX)) THEN
BEGIN
P1 := VECT.SIZE;
P2 := INDEX;
FOUNDLEN := LEN;
END IF;
INDEX := SVECT.FIND_INDEX(STR, INDEX + 1);
END WHILE;
SVECT.APPEND(STR);
END IF;
END WHILE;
FILE.CLOSE;
OUTTEXT(VECT.ELEMENT(P1) & " " & VECT.ELEMENT(P2));
OUTIMAGE;
END
- Output:
intoxicate excitation 3 garbage collection(s) in 2.9 seconds.
Tcl
package require Tcl 8.5
package require http
# Fetch the words
set t [http::geturl "http://www.puzzlers.org/pub/wordlists/unixdict.txt"]
set wordlist [split [http::data $t] \n]
http::cleanup $t
# Group by characters in word
foreach word $wordlist {
dict lappend w [lsort [split $word ""]] [split $word ""]
}
# Deranged test
proc deranged? {l1 l2} {
foreach c1 $l1 c2 $l2 {
if {$c1 eq $c2} {return 0}
}
return 1
}
# Get a deranged pair from an anagram set, if one exists
proc getDeranged {words} {
foreach l1 [lrange $words 0 end-1] {
foreach l2 [lrange $words 1 end] {
if {[deranged? $l1 $l2]} {
return [list $l1 $l2 1]
}
}
}
return {{} {} 0}
}
# Find the max-length deranged anagram
set count 0
set candidates {}
set max 0
dict for {k words} $w {
incr count [expr {[llength $words] > 1}]
if {[llength $k] > $max && [lassign [getDeranged $words] l1 l2]} {
set max [llength $l1]
lappend candidates [join $l1 ""],[join $l2 ""]
}
}
# Print out what we found
puts "[llength $wordlist] words"
puts "[dict size $w] potential anagram-groups"
puts "$count real anagram-groups"
foreach pair $candidates {
puts "considered candidate pairing: $pair"
}
puts "MAXIMAL DERANGED ANAGRAM: LENGTH $max\n\t[lindex $candidates end]"
- Output:
25105 words 23567 potential anagram-groups 1303 real anagram-groups considered candidate pairing: abc,cab considered candidate pairing: abed,bade considered candidate pairing: abort,bator considered candidate pairing: afresh,shafer considered candidate pairing: alberto,latrobe considered candidate pairing: american,cinerama considered candidate pairing: ancestral,lancaster considered candidate pairing: excitation,intoxicate MAXIMAL DERANGED ANAGRAM: LENGTH 10 excitation,intoxicate
TUSCRIPT
$$ MODE TUSCRIPT,{}
requestdata = REQUEST ("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
DICT anagramm CREATE 99999
COMPILE
LOOP word=requestdata
-> ? : any character
charsInWord=STRINGS (word," ? ")
charString =ALPHA_SORT (charsInWord)
DICT anagramm LOOKUP charString,num,freq,wordalt,wlalt
IF (num==0) THEN
WL=SIZE (charString)
DICT anagramm APPEND/QUIET/COUNT charString,num,freq,word,wl;" "
ELSE
DICT anagramm APPEND/QUIET/COUNT charString,num,freq,word,"";" "
ENDIF
ENDLOOP
DICT anagramm UNLOAD charString,all,freq,anagrams,wl
index =DIGIT_INDEX (wl)
reverseIndex =REVERSE (index)
wl =INDEX_SORT (wl,reverseIndex)
freq =INDEX_SORT (freq,reverseIndex)
anagrams =INDEX_SORT (anagrams,reverseIndex)
charString =INDEX_SORT (charString,reverseIndex)
LOOP fr=freq,a=anagrams,w=wl
IF (fr==1) cycle
asplit=SPLIT (a,": :")
a1=SELECT (asplit,1,arest)
a1split=STRINGS (a1," ? ")
LOOP r=arest
rsplit=STRINGS (r," ? ")
LOOP v1=a1split,v2=rsplit
IF (v1==v2) EXIT,EXIT
ENDLOOP
PRINT "Largest deranged anagram (length: ",w,"):"
PRINT a
STOP
ENDLOOP
ENDLOOP
ENDCOMPILE
- Output:
Largest deranged anagram (length: 10): excitation intoxicate
UNIX Shell
function get_words {
typeset host=www.puzzlers.org
typeset page=/pub/wordlists/unixdict.txt
exec 7<>/dev/tcp/$host/80
print -e -u7 "GET $page HTTP/1.1\r\nhost: $host\r\nConnection: close\r\n\r\n"
# remove the http header and save the word list
sed 's/\r$//; 1,/^$/d' <&7 >"$1"
exec 7<&-
}
function is_deranged {
typeset -i i
for ((i=0; i<${#1}; i++)); do
[[ ${1:i:1} == ${2:i:1} ]] && return 1
done
return 0
}
function word2key {
typeset -a chars=( $(
for ((i=0; i<${#word}; i++)); do
echo "${word:i:1}"
done | sort
) )
typeset IFS=""
echo "${chars[*]}"
}
[[ -f word.list ]] || get_words word.list
typeset -A words
typeset -i max=0
while IFS= read -r word; do
key=$(word2key $word)
if [[ -z "${words["$key"]}" ]]; then
words["$key"]=$word
else
if (( ${#word} > max )); then
if is_deranged "${words["$key"]}" "$word"; then
max_deranged=("${words["$key"]}" "$word")
max=${#word}
fi
fi
fi
done <word.list
echo $max - ${max_deranged[@]}
- Output:
10 - excitation intoxicate
Ursala
This solution assumes the file unixdict.txt
is passed to the compiler as a command line parameter.
#import std
anagrams = |=tK33lrDSL2SL ~=&& ==+ ~~ -<&
deranged = filter not zip; any ==
#cast %sW
main = leql$^&l deranged anagrams unixdict_dot_txt
The anagrams
function is a little slow as defined above, but can be sped up by at least two orders of magnitude by grouping the words into classes of equal length, and sorting each word once in advance instead of each time a comparison is made as shown below.
anagrams = @NSiXSlK2rSS *= ^(-<&,~&)*; |=rSStFtK33lrDSL2SL ~=@br&& ==@bl
We can speed it up by about another factor of 5 by starting from the group of longest words and stopping as soon as a deranged anagram is found instead of generating all anagrams.
#import std
longest_deranged_anagram =
@NSiXSlK2rSS leql-<x&h; @NiX ~&lZrB->l ^\~&rt @rh -+
~&a^& ~&plrEkZ?ah/~&ah ~&fatPR,
^(-<&,~&)*; |=rSStFtK33lrDSL2SL ~=@br&& ==@bl+-
#cast %sW
main = longest_deranged_anagram unixdict_dot_txt
- Output:
('excitation','intoxicate')
VBA
Sub Main_DerangedAnagrams()
Dim ListeWords() As String, Book As String, i As Long, j As Long, tempLen As Integer, MaxLen As Integer, tempStr As String, IsDeranged As Boolean, count As Integer, bAnag As Boolean
Dim t As Single
t = Timer
Book = Read_File("C:\Users\" & Environ("Username") & "\Desktop\unixdict.txt")
ListeWords = Split(Book, vbNewLine)
For i = LBound(ListeWords) To UBound(ListeWords) - 1
For j = i + 1 To UBound(ListeWords)
If Len(ListeWords(i)) = Len(ListeWords(j)) Then
tempLen = 0
IsDeranged = False
bAnag = IsAnagram(ListeWords(i), ListeWords(j), IsDeranged, tempLen)
If IsDeranged Then
count = count + 1
If tempLen > MaxLen Then
MaxLen = tempLen
tempStr = ListeWords(i) & ", " & ListeWords(j)
End If
End If
End If
Next j
Next i
Debug.Print "There is : " & count & " deranged anagram, in unixdict.txt."
Debug.Print "The longest is : " & tempStr
Debug.Print "Lenght : " & MaxLen
Debug.Print "Time to compute : " & Timer - t & " sec."
End Sub
Private Function Read_File(Fic As String) As String
Dim Nb As Integer
Nb = FreeFile
Open Fic For Input As #Nb
Read_File = Input(LOF(Nb), #Nb)
Close #Nb
End Function
Function IsAnagram(str1 As String, str2 As String, DerangedAnagram As Boolean, Lenght As Integer) As Boolean
Dim i As Integer
str1 = Trim(UCase(str1))
str2 = Trim(UCase(str2))
For i = 1 To Len(str1)
If Len(Replace(str1, Mid$(str1, i, 1), vbNullString)) <> Len(Replace(str2, Mid$(str1, i, 1), vbNullString)) Then
Exit Function
End If
If Mid$(str1, i, 1) = Mid$(str2, i, 1) Then
Exit Function
End If
Next i
IsAnagram = True
DerangedAnagram = True
Lenght = Len(str1)
End Function
- Output:
There is : 507 deranged anagram, in unixdict.txt. The longest is : EXCITATION, INTOXICATE Lenght : 10 Time to compute : 97,00781 sec.
V (Vlang)
import os
fn deranged(a string, b string) bool {
if a.len != b.len {
return false
}
for i in 0..a.len {
if a[i] == b[i] { return false }
}
return true
}
fn main(){
words := os.read_lines('unixdict.txt')?
mut m := map[string][]string{}
mut best_len, mut w1, mut w2 := 0, '',''
for w in words {
// don't bother: too short to beat current record
if w.len <= best_len { continue }
// save strings in map, with sorted string as key
mut letters := w.split('')
letters.sort()
k := letters.join("")
if k !in m {
m[k] = [w]
continue
}
for c in m[k] {
if deranged(w, c) {
best_len, w1, w2 = w.len, c, w
break
}
}
m[k] << w
}
println('$w1 $w2: Length $best_len')
}
- Output:
excitation intoxicate: Length 10
Wren
import "io" for File
import "./sort" for Sort
// assumes w1 and w2 are anagrams of each other
var isDeranged = Fn.new { |w1, w2|
for (i in 0...w1.count) {
if (w1[i] == w2[i]) return false
}
return true
}
var words = File.read("unixdict.txt").split("\n").map { |w| w.trim() }
var wordMap = {}
for (word in words) {
var letters = word.toList
Sort.insertion(letters)
var sortedWord = letters.join()
if (wordMap.containsKey(sortedWord)) {
wordMap[sortedWord].add(word)
} else {
wordMap[sortedWord] = [word]
}
}
var deranged = []
for (key in wordMap.keys) {
var ana = wordMap[key]
var count = ana.count
if (count > 1) {
for (i in 0...count-1) {
for (j in i + 1...count) {
if (isDeranged.call(ana[i], ana[j])) deranged.add([ana[i], ana[j]])
}
}
}
}
var most = deranged.reduce(0) { |max, words| (words[0].count > max) ? words[0].count : max }
for (words in deranged) {
if (words[0].count == most) System.print([words[0], words[1]])
}
- Output:
[excitation, intoxicate]
zkl
words:=Dictionary(25000); //-->Dictionary(sorted word:all anagrams, ...)
File("unixdict.txt").read().pump(Void,'wrap(w){
w=w.strip(); key:=w.sort(); words[key]=words.find(key,T).append(w);
});
nws:=words.values.pump(List,fcn(ws){ //-->( (len,words), ...)
if(ws.len()>1){ // two or more anagrams
r:=List(); n:=ws[0].len(); // length of these anagrams
foreach idx,w in (ws.enumerate()){
foreach w2 in (ws[idx+1,*]){
if(Utils.zipWith('!=,w,w2).filter().len()==n)
r.write(T(w,w2));
}
}
if(r) return(r.insert(0,n));
}
Void.Skip
});
nws.filter(fcn(nws,max){ nws[0]==max },
nws.reduce(fcn(p,nws){ p.max(nws[0]) },0) )
.println();
- Output:
L(L(10,L("excitation","intoxicate")))
Replace the center section with the following for smaller code (3 lines shorter!) that is twice as slow:
nws:=words.values.pump(List,fcn(ws){ //-->( (len,words), ...)
if(ws.len()>1){ // two or more anagrams
n:=ws[0].len(); // length of these anagrams
r:=Utils.Helpers.permute(ws).filter('wrap(ws2){
n == Utils.zipWith('!=,ws2.xplode()).filter().len();
});
if(r) return(n,r[0]); // L(L("glove","vogel"))-->L(5,L("glove","vogel"))
}
Void.Skip
});
- Programming Tasks
- Solutions by Programming Task
- 11l
- AArch64 Assembly
- Ada
- ALGOL 68
- AppleScript
- ARM Assembly
- Arturo
- AutoHotkey
- AWK
- BASIC
- BaCon
- BBC BASIC
- Bracmat
- C
- C sharp
- System
- System.Collections.Generic
- System.Linq
- System.IO
- C++
- Clojure
- COBOL
- CoffeeScript
- Common Lisp
- D
- Delphi
- System.SysUtils
- System.Classes
- System.Diagnostics
- EchoLisp
- Eiffel
- Elixir
- Erlang
- F Sharp
- Factor
- FreeBASIC
- FutureBasic
- Pages with broken file links
- GAP
- Go
- Groovy
- Haskell
- Icon
- Unicon
- J
- Java
- JavaScript
- Jq
- Julia
- K
- Kotlin
- Lasso
- Liberty BASIC
- Lua
- Maple
- Mathematica
- Wolfram Language
- Nim
- OCaml
- OoRexx
- PARI/GP
- Pascal
- Perl
- Phix
- Phixmonti
- PHP
- Picat
- PicoLisp
- PowerShell
- Prolog
- PureBasic
- Python
- Quackery
- R
- Racket
- Raku
- REXX
- Ring
- Ruby
- Run BASIC
- Rust
- Scala
- Scheme
- Sidef
- Simula
- Tcl
- TUSCRIPT
- UNIX Shell
- Ursala
- VBA
- V (Vlang)
- Wren
- Wren-sort
- Zkl