Rosetta Code

Anagrams/Deranged anagrams: Difference between revisions

Page Discussion

Anagrams/Deranged anagrams (view source)

Revision as of 10:35, 6 November 2023

44,056 bytes added ,  6 months ago
m
→‎{{header|Wren}}: Minor tidy
m (→‎{{header|Wren}}: Minor tidy)
 
(18 intermediate revisions by 14 users not shown)
Line 5:
By analogy with [[Permutations/Derangements|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
{{task heading}}
 
Use the word list at [http://wiki.puzzlers.org/pub/wordlists/unixdict.txt unixdict] to find and display the longest deranged anagram.
 
 
{{task heading|;Related tasks}}
* [[Permutations/Derangements]]
* [[Best_shuffle|Best shuffle]]
Line 22:
=={{header|11l}}==
{{trans|Kotlin}}
<langsyntaxhighlight lang="11l">F is_not_deranged(s1, s2)
L(i) 0 .< s1.len
I s1[i] == s2[i]
Line 31:
V count = 0
L(word) File(‘unixdict.txt’).read().split("\n")
V a = sorted(word).join(‘’)
I a !C anagram
anagram[a] = [word]
Line 44:
L(ana) anagram.values()
I ana.len > 1 & ana[0].len == count
print(ana)</langsyntaxhighlight>
{{out}}
<pre>[excitation, intoxicate]</pre>
 
=={{header|AArch64 Assembly}}==
{{works with|as|Raspberry Pi 3B version Buster 64 bits <br> or android 64 bits with application Termux }}
<syntaxhighlight lang="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"
 
</syntaxhighlight>
<pre>
Program 64 bits start.
excitation intoxicate
</pre>
=={{header|Ada}}==
{{Works with|Ada 2005}}
<langsyntaxhighlight Adalang="ada">with Ada.Text_IO; use Ada.Text_IO;
with Ada.Containers.Generic_Array_Sort;
with Ada.Containers.Indefinite_Vectors;
Line 94 ⟶ 570:
Close (File);
Put_Line (Vect.Element (p1) & " " & Vect.Element (p2));
end Danagrams;</langsyntaxhighlight>
{{out}}
<pre>intoxicate excitation</pre>
Line 100 ⟶ 576:
=={{header|ALGOL 68}}==
{{works with|ALGOL 68G|Any - tested with release 2.8.3.win32}} Uses the "read" PRAGMA of Algol 68 G to include the associative array code from the [[Associative_array/Iteration]] task.
<langsyntaxhighlight lang="algol68"># 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
Line 223 ⟶ 699:
)
)
FI</langsyntaxhighlight>
{{out}}
<pre>
Line 230 ⟶ 706:
 
=={{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
<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)
script o
property wordList : listOfWords
property doctoredWordsgroupingTexts : {}wordList's items
property hitLengthderangementLength : 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 of my wordList
set groupCountgroupSize to b - a + 1
set wordLength to (count beginning of anagramGroup)
repeat with i from 1 to (groupCountgroupSize - 1)
set w1 to anagramGroup's item i of anagramGroup
repeat with j from (i + 1) to groupCountgroupSize
set w2 to anagramGroup's item j of anagramGroup
set areDeranged to true
repeat with c from 1 to wordLength
if (w1's character c of= w1 =w2's character c of w2) then
set areDeranged to false
exit repeat
end if
end repeat
-- Append any deranged pairs found to the output list and note theirthe wordwords' length.
if (areDeranged) then
set end of my output to {w1, w2}
set hitLengthderangementLength 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
-- BuildReplace anotherthe listwords containing doctored versions ofin the inputgroupingTexts wordslist with theirsorted-character characters lexically sortedversions.
setrepeat astidwith toi AppleScript'sfrom text1 itemto delimiterswordCount
set AppleScriptchrs to o's textgroupingTexts's item delimiters toi's ""characters
tell sorter to sort(chrs, 1, -1, {})
repeat with thisWord in o's wordList
set theseCharso's to thisWordgroupingTexts's charactersitem 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
set-- AppleScript'sSort the list descending by text itemlength and ascending delimiters(say) toby astidvalue
-- 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}})
-- SortWork through the listruns of doctoredgrouping wordstexts, intostarting descendingwith order by length and ascending order bythe valuelongest withintexts.
-- 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 currentText to beginning of o's doctoredWordsgroupingTexts
repeat with j from 2 to (count o's doctoredWordswordCount)
set thisText to item j of o's doctoredWordsgroupingTexts's item j
if (thisText is not currentText) then
if (j - i > 1) then tell o to testPairs(i, j - 1)
Line 306 ⟶ 784:
set i to j
end if
-- Stop on reaching a wordtext that's shorter than the longestany derangement(s) found.
if ((count thisText) < o's hitLengthderangementLength) then exit repeat
end repeat
if (j > i) then tell o to testPairs(i, j)
Line 315 ⟶ 793:
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
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»)
return longestDerangedAnagrams(wordList)</langsyntaxhighlight>
 
{{output}}
<langsyntaxhighlight lang="applescript">{{"excitation", "intoxicate"}}</langsyntaxhighlight>
 
=={{header|ARM Assembly}}==
{{works with|as|Raspberry Pi <br> or android 32 bits with application Termux}}
<syntaxhighlight lang="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"
</syntaxhighlight>
<pre>
Program 32 bits start.
excitation intoxicate
</pre>
=={{header|Arturo}}==
 
<syntaxhighlight lang="rebol">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</syntaxhighlight>
 
{{out}}
 
<pre>excitation intoxicate</pre>
 
=={{header|AutoHotkey}}==
<langsyntaxhighlight Autohotkeylang="autohotkey">Time := A_TickCount
SetWorkingDir %A_ScriptDir% ; Ensures a consistent starting directory.
SetBatchLines -1
Line 383 ⟶ 1,331:
}
old1 := no_let1, old2 := A_Loopfield
}</langsyntaxhighlight>
{{out}}
<pre>
Line 391 ⟶ 1,339:
{{works with|GNU awk (gawk) 3.1.5}}
 
<langsyntaxhighlight lang="awk">#!/bin/gawk -f
BEGIN{
FS=""
Line 449 ⟶ 1,397:
if (length(found) > 0) exit
}
}</langsyntaxhighlight>
On my system, this awk-file is located at /usr/local/bin/deranged,
so it can be invoked with:
Line 457 ⟶ 1,405:
 
Regular invocation would be:
<langsyntaxhighlight lang="sh">gawk -f deranged.awk /tmp/unixdict.txt</langsyntaxhighlight>
{{out}}
<pre>
Line 463 ⟶ 1,411:
</pre>
 
=={{header|BaConBASIC}}==
==={{header|BaCon}}===
<lang freebasic>DECLARE idx$ ASSOC STRING
<syntaxhighlight lang="freebasic">DECLARE idx$ ASSOC STRING
 
FUNCTION Deranged(a$, b$)
Line 492 ⟶ 1,441:
PRINT "Maximum deranged anagrams: ", an1$, " and ", an2$
 
PRINT NL$, "Total time: ", TIMER, " msecs.", NL$</langsyntaxhighlight>
{{out}}
<pre>
Line 500 ⟶ 1,449:
</pre>
 
==={{header|BBC BASIC}}===
{{works with|BBC BASIC for Windows}}
<langsyntaxhighlight lang="bbcbasic"> INSTALL @lib$+"SORTLIB"
Sort% = FN_sortinit(0,0)
Line 554 ⟶ 1,503:
$$^a&(0) = A$
CALL Sort%, a&(0)
= $$^a&(0)</langsyntaxhighlight>
{{out}}
<pre>
Line 580 ⟶ 1,529:
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.
<langsyntaxhighlight lang="bracmat"> get$("unixdict.txt",STR):?wordList
& 1:?product
& :?unsorted
Line 642 ⟶ 1,591:
* ?
| out$!derangedAnagrams
);</langsyntaxhighlight>
{{out}}
<pre>excitation.intoxicate</pre>
 
=={{header|C}}==
<langsyntaxhighlight Clang="c">#include <stdio.h>
#include <stdlib.h>
#include <string.h>
Line 756 ⟶ 1,705:
 
return 0;
}</langsyntaxhighlight>
{{out}}
<pre>
Line 762 ⟶ 1,711:
</pre>
 
=={{header|C sharp|C#}}==
{{libheader|System}}
{{libheader|System.Collections.Generic}}
Line 768 ⟶ 1,717:
{{libheader|System.IO}}
{{works with|C sharp|6}}
<langsyntaxhighlight lang="csharp">public static void Main()
{
var lookupTable = File.ReadLines("unixdict.txt").ToLookup(line => AnagramKey(line));
Line 787 ⟶ 1,736:
&& Enumerable.Range(0, first.Length).All(i => first[i] != second[i])
select new [] { first, second })
.FirstOrDefault();</langsyntaxhighlight>
{{out}}
<pre>
Line 794 ⟶ 1,743:
 
=={{header|C++}}==
<langsyntaxhighlight lang="cpp">#include <algorithm>
#include <fstream>
#include <functional>
Line 843 ⟶ 1,792:
std::cout << result.first << ' ' << result.second << '\n';
return EXIT_SUCCESS;
}</langsyntaxhighlight>
{{out}}
<pre>
Line 850 ⟶ 1,799:
 
=={{header|Clojure}}==
<langsyntaxhighlight Clojurelang="clojure">(->> (slurp "unixdict.txt") ; words
(re-seq #"\w+") ; |
(group-by sort) ; anagrams
Line 858 ⟶ 1,807:
(sort-by #(count (first %)))
last
prn)</langsyntaxhighlight>
{{out}}
<pre>$ lein exec deranged.clj
Line 864 ⟶ 1,813:
 
=={{header|COBOL}}==
{{Works with|X/Open COBOL}}
<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 01 COUNTERS.
05 WS-TOT-RECS PIC 9(5) USAGE COMPPACKED-3 DECIMAL VALUE 0.
05 WS-SEL-RECS PIC 9(5) USAGE COMPPACKED-3 DECIMAL VALUE 0.
05 WT-REC-NBR PIC 9(5) USAGE COMPPACKED-3 DECIMAL VALUE 0.
 
* Extra byte to guarentee a space at end - needed in sort logic.
01 01 WS-WORD-TEMP PIC X(23).
01 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 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) COMPUSAGE PACKED-3DECIMAL.
10 WT-ANAGRAMS OCCURS 6 TIMES.
15 WT-ANAGRAM PIC X(22).
 
01 01 WS-WORD-TEMP1 PIC X(22).
01 01 FILLER REDEFINES WS-WORD-TEMP1.
05 WS-LETTER1 05 WS-LETTER1 PIC X OCCURS 22 TIMES PIC X.
 
01 01 WS-WORD-TEMP2 PIC X(22).
01 01 FILLER REDEFINES WS-WORD-TEMP2.
05 WS-LETTER2 OCCURS 22 TIMES PIC X.
 
77 WS-I PIC 999999(5) USAGE COMPPACKED-3DECIMAL.
77 WS-J PIC 999999(5) USAGE COMPPACKED-3DECIMAL.
77 WS-K PIC 999999(5) USAGE COMPPACKED-3DECIMAL.
77 WS-L PIC 999999(5) USAGE COMPPACKED-3DECIMAL.
77 WS-BEG PIC 999999(5) USAGE COMPPACKED-3DECIMAL.
77 WS-MAX PIC 999999(5) USAGE COMPPACKED-3DECIMAL.
 
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 500-FIND900-DERANGEDTERMINATE.
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 300-SORT-WORD1.
SEARCH WT-RECORD
PERFORM VARYING WS-MAX FROM 1 BY 1
AT END
UNTIL WS-LETTER(WS-MAX) = SPACE
END- 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-LETTER(WSWORD-J) IN TO WS-LETTER(WS-I)
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 SETTO WT-ANAGRAM-CNT(WT-IDX TO 1).
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 ADDBY 1 To WT-REC-NBR.
MOVEUNTIL WS-WORD-KEYI TO> WT-WORD-KEY(WT-REC-NBR). OR WS-FND = 'Y'
PERFORM VARYING COMPUTE WTWS-WORD-LEN(WT-REC-NBR)J =FROM WS-MAX1 -BY 1.
UNTIL MOVEWS-J 1 TO> WT-ANAGRAM-CNT(WTWS-REC-NBRI). - 1 OR WS-FND = 'Y'
MOVE COMPUTE WS-WORDBEG = WS-INJ TO+ 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 ADD 1'N' TO WT-ANAGRAM-CNT(WTWS-IDX)EXIT.
PERFORM VARYING WS-L FROM 1 BY 1
MOVE WS-WORD-IN TO
UNTIL WS-L > WT-ANAGRAMWORD-LEN(WTWS-IDX,I) WTOR WS-ANAGRAM-CNT(WT-IDX)).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 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-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 OUTPUT: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
</syntaxhighlight>
*> RECORDS SELECTED 24978
*> RECORD KEYS: 23441
 
*> BUBBLE SORT REFERENCE:
*> https://mainframegeek.wordpress.com/tag/bubble-sort-in-cobol
</lang>
 
=={{header|CoffeeScript}}==
This example was tested with node.js.
<langsyntaxhighlight lang="coffeescript">http = require 'http'
 
is_derangement = (word1, word2) ->
Line 1,088 ⟶ 2,037:
req.end()
get_word_list show_longest_derangement</langsyntaxhighlight>
{{out}}
<pre>
Line 1,096 ⟶ 2,045:
 
=={{header|Common Lisp}}==
<langsyntaxhighlight lang="lisp">(defun read-words (file)
(with-open-file (stream file)
(loop with w = "" while w collect (setf w (read-line stream nil)))))
Line 1,115 ⟶ 2,064:
(setf (gethash ws h) (cons w l))))))
 
(format t "~{~A~%~^~}" (longest-deranged "unixdict.txt"))</langsyntaxhighlight>
{{out}}
<pre>intoxicate
Line 1,122 ⟶ 2,071:
=={{header|D}}==
===Short Version===
<langsyntaxhighlight lang="d">void main() {
import std.stdio, std.file, std.algorithm, std.string, std.array;
 
Line 1,136 ⟶ 2,085:
.minPos!q{ a[0].length > b[0].length }[0]
.writeln;
}</langsyntaxhighlight>
{{out}}
<pre>Tuple!(string, string)("intoxicate", "excitation")</pre>
Line 1,142 ⟶ 2,091:
 
Using const(ubytes)[] instead of dstrings gives a runtime of about 0.07 seconds:
<langsyntaxhighlight lang="d"> string[][ubyte[]] anags;
foreach (const w; "unixdict.txt".readText.split)
anags[w.dup.representation.sort().release.assumeUnique] ~= w;</langsyntaxhighlight>
 
===Faster Version===
<langsyntaxhighlight lang="d">import std.stdio, std.file, std.algorithm, std.string, std.array,
std.functional, std.exception;
 
Line 1,176 ⟶ 2,125:
return writefln("Longest deranged: %-(%s %)", pairs.front);
}
}</langsyntaxhighlight>
{{out}}
<pre>Longest deranged: excitation intoxicate</pre>
Line 1,184 ⟶ 2,133:
{{libheader| System.Classes}}
{{libheader| System.Diagnostics}}
<langsyntaxhighlight Delphilang="delphi">program Anagrams_Deranged;
 
{$APPTYPE CONSOLE}
Line 1,288 ⟶ 2,237:
Dict.Free;
Readln;
end.</langsyntaxhighlight>
 
{{out}}
Line 1,301 ⟶ 2,250:
=={{header|EchoLisp}}==
For a change, we use the french dictionary included in EchoLisp package.
<langsyntaxhighlight lang="scheme">(lib 'hash)
(lib 'struct)
(lib 'sql)
Line 1,332 ⟶ 2,281:
(write lmin) (for-each write lw)
(writeln)))
</syntaxhighlight>
</lang>
{{out}}
<langsyntaxhighlight lang="scheme">
(lib 'dico.fr.no-accent) ;; 209315 words into *words* table
(task)
Line 1,356 ⟶ 2,305:
14 charlatanistic antarchistical
15 megachiropteran cinematographer
17 misconstitutional constitutionalism</langsyntaxhighlight>
 
=={{header|Eiffel}}==
<langsyntaxhighlight Eiffellang="eiffel">class
ANAGRAMS_DERANGED
 
Line 1,482 ⟶ 2,431:
words: HASH_TABLE [LINKED_LIST [STRING], STRING]
 
end</langsyntaxhighlight>
{{out}}
<pre>
Line 1,491 ⟶ 2,440:
=={{header|Elixir}}==
{{trans|Ruby}}
<langsyntaxhighlight lang="elixir">defmodule Anagrams do
def deranged(fname) do
File.read!(fname)
Line 1,520 ⟶ 2,469:
{_, words} -> IO.puts "Longest derangement anagram: #{inspect words}"
_ -> IO.puts "derangement anagram: nothing"
end</langsyntaxhighlight>
 
{{out}}
Line 1,529 ⟶ 2,478:
=={{header|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]].
<langsyntaxhighlight Erlanglang="erlang">-module( anagrams_deranged ).
-export( [task/0, words_from_url/1] ).
 
Line 1,568 ⟶ 2,517:
lists:all( fun is_deranged_char/1, lists:zip(Word1, Word2) ).
 
is_deranged_char( {One, Two} ) -> One =/= Two.</langsyntaxhighlight>
{{out}}
<pre>
Line 1,576 ⟶ 2,525:
 
=={{header|F_Sharp|F#}}==
<langsyntaxhighlight lang="fsharp">open System;
 
let keyIsSortedWord = Seq.sort >> Seq.toArray >> String
Line 1,601 ⟶ 2,550:
|> snd
|> printfn "%A"
0</langsyntaxhighlight>
{{out}}
<pre>[("excitation", "intoxicate")]</pre>
 
=={{header|Factor}}==
<langsyntaxhighlight lang="factor">USING: assocs fry io.encodings.utf8 io.files kernel math
math.combinatorics sequences sorting strings ;
IN: rosettacode.deranged-anagrams
Line 1,629 ⟶ 2,578:
 
: longest-deranged-anagrams ( path -- anagrams )
deranged-anagrams [ first length ] sort-with last ;</langsyntaxhighlight>
 
"unixdict.txt" longest-deranged-anagrams .
Line 1,635 ⟶ 2,584:
 
=={{header|FreeBASIC}}==
<langsyntaxhighlight lang="freebasic">' FB 1.05.0 Win64
 
Type IndexedWord
Line 1,769 ⟶ 2,718:
Print
Print "Press any key to quit"
Sleep</langsyntaxhighlight>
 
{{out}}
Line 1,780 ⟶ 2,729:
Took 0.089 seconds on i3 @ 2.13 GHz
</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}}==
Using function [[Anagrams#GAP|Anagrams]].
<langsyntaxhighlight lang="gap">IsDeranged := function(a, b)
local i, n;
for i in [1 .. Size(a)] do
Line 1,812 ⟶ 2,884:
n := Maximum(List(a, x -> Size(x[1])));
Filtered(a, x -> Size(x[1]) = n);
# [ [ "excitation", "intoxicate" ] ]</langsyntaxhighlight>
 
=={{header|Go}}==
<langsyntaxhighlight lang="go">package main
import (
"fmt"
Line 1,866 ⟶ 2,938:
 
fmt.Println(w1, w2, ": Length", best_len)
}</langsyntaxhighlight>
{{out}}
<pre>
Line 1,874 ⟶ 2,946:
=={{header|Groovy}}==
Solution:
<langsyntaxhighlight lang="groovy">def map = new TreeMap<Integer,Map<String,List<String>>>()
 
new URL('http://www.puzzlers.org/pub/wordlists/unixdict.txt').eachLine { word ->
Line 1,902 ⟶ 2,974:
} else {
println 'Deranged anagrams are a MYTH!'
}</langsyntaxhighlight>
 
{{out}}
Line 1,909 ⟶ 2,981:
=={{header|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.
<langsyntaxhighlight lang="haskell">{-# LANGUAGE TupleSections #-}
 
import Data.List (maximumBy, sort, unfoldr)
Line 1,952 ⟶ 3,024:
case maxDerangedAnagram $ words input of
Nothing -> putStrLn "No deranged anagrams were found."
Just (a, b) -> putStrLn $ "Longest deranged anagrams: " <> a <> " and " <> b</langsyntaxhighlight>
{{out}}
<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}}==
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).
<langsyntaxhighlight lang="unicon">link strings # for csort() procedure
 
procedure main()
Line 1,983 ⟶ 3,092:
every i := 1 to *s1 do if s1[i] == s2[i] then fail
return [s1,s2]
end</langsyntaxhighlight>
{{out|Sample run}}
<pre>->dra <unixdict.txt
Line 1,991 ⟶ 3,100:
=={{header|J}}==
This assumes that [http://www.puzzlers.org/pub/wordlists/unixdict.txt unixdict.txt] has been saved in the current directory.
<langsyntaxhighlight lang="j"> #words=: 'b' freads 'unixdict.txt'
25104
#anagrams=: (#~ 1 < #@>) (</.~ /:~&>) words
Line 2,004 ⟶ 3,113:
││excitation│intoxicate││
│└──────────┴──────────┘│
└───────────────────────┘</langsyntaxhighlight>
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 <code>maybederanged=: (#~ (-: ~."1)@|:@:>&>) anagrams</code>
 
Line 2,011 ⟶ 3,120:
=={{header|Java}}==
{{works with|Java|8}}
<langsyntaxhighlight lang="java">import java.io.File;
import java.io.IOException;
import java.nio.file.Files;
Line 2,057 ⟶ 3,166:
return true;
}
}</langsyntaxhighlight>
{{out}}
<pre>excitation intoxicate</pre>
Line 2,069 ⟶ 3,178:
brevity.
 
<langsyntaxhighlight JavaScriptlang="javascript">#!/usr/bin/env js
 
function main() {
Line 2,143 ⟶ 3,252:
}
 
main();</langsyntaxhighlight>
 
{{out}}
Line 2,150 ⟶ 3,259:
=== Gecko ===
Word file is saved locally because browser won't fetch it cross-site. Tested on Gecko.
<langsyntaxhighlight lang="javascript"><html><head><title>Intoxication</title></head>
<body><pre id='x'></pre>
<script type="application/javascript">
Line 2,194 ⟶ 3,303:
 
show(best_pair);
</script></body></html></langsyntaxhighlight>
 
{{Out|Output (in a browser window)}}
Line 2,204 ⟶ 3,313:
This solution allows for the possibility of more than one answer.
 
<langsyntaxhighlight lang="jq"># Input: an array of strings
# Output: a stream of arrays
def anagrams:
Line 2,235 ⟶ 3,344:
else .
end) ) )
| unique</langsyntaxhighlight>
 
'''Invocation and output'''
Line 2,243 ⟶ 3,352:
=={{header|Julia}}==
 
<langsyntaxhighlight lang="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.
Line 2,285 ⟶ 3,394:
break
end
end</langsyntaxhighlight>
 
{{out}}
Line 2,291 ⟶ 3,400:
 
=={{header|K}}==
<langsyntaxhighlight Klang="k"> / anagram clusters
a:{x g@&1<#:'g:={x@<x}'x}@0:"unixdict.txt";
Line 2,297 ⟶ 3,406:
b@&c=|/c:{#x[0]}'b:a@&{0=+//{x=y}':x}'a
("excitation"
"intoxicate")</langsyntaxhighlight>
 
=={{header|Kotlin}}==
<langsyntaxhighlight lang="scala">// version 1.0.6
 
import java.io.BufferedReader
Line 2,338 ⟶ 3,447:
.filter { it.size > 1 && it[0].length == count }
.forEach { println(it) }
}</langsyntaxhighlight>
 
{{out}}
Line 2,346 ⟶ 3,455:
 
=={{header|Lasso}}==
<langsyntaxhighlight Lassolang="lasso">local(
anagrams = map,
words = include_url('http://www.puzzlers.org/pub/wordlists/unixdict.txt') -> split('\n'),
Line 2,398 ⟶ 3,507:
}
 
#findings -> join('<br />\n')</langsyntaxhighlight>
 
Result -> excitation, intoxicate
 
=={{header|Liberty BASIC}}==
<langsyntaxhighlight lang="lb">print "Loading dictionary file."
open "unixdict.txt" for input as #1
a$=input$(#1,lof(#1))
Line 2,454 ⟶ 3,563:
 
print theWord$(maxPtrI);" => ";theWord$(maxPtrJ)
end</langsyntaxhighlight>
{{out}}
excitation => intoxicate
 
=={{header|Lua}}==
<langsyntaxhighlight lang="lua">string.tacnoc = function(str) -- 'inverse' of table.concat
local arr={}
for ch in str:gmatch(".") do arr[#arr+1]=ch end
Line 2,494 ⟶ 3,603:
end
end
print(answer.word, answer.anag, answer.len)</langsyntaxhighlight>
{{out}}
<pre>excitation intoxicate 10</pre>
 
=={{header|Maple}}==
<langsyntaxhighlight Maplelang="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)[];</langsyntaxhighlight>
{{out}}
<pre>
Line 2,510 ⟶ 3,619:
 
=={{header|Mathematica}} / {{header|Wolfram Language}}==
<langsyntaxhighlight Mathematicalang="mathematica">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]</langsyntaxhighlight>
{{out}}
<pre>
Line 2,522 ⟶ 3,631:
 
A similar approach using Mathematica 10:
<langsyntaxhighlight Mathematicalang="mathematica">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]</langsyntaxhighlight>
 
{{out}}
Line 2,534 ⟶ 3,643:
 
=={{header|Nim}}==
<langsyntaxhighlight Nimlang="nim">import algorithm
import tables
import times
Line 2,574 ⟶ 3,683:
 
echo "Longest deranged anagram pair: ", best1, " ", best2
echo "Processing time: ", (getTime() - t0).inMilliseconds, " ms."</langsyntaxhighlight>
 
{{out}}
Line 2,581 ⟶ 3,690:
 
=={{header|OCaml}}==
<langsyntaxhighlight lang="ocaml">let sort_chars s =
let r = String.copy s in
for i = 0 to (String.length r) - 2 do
Line 2,645 ⟶ 3,754:
) ([], 0) lst
in
List.iter (fun (w1, w2) -> Printf.printf "%s, %s\n" w1 w2) res</langsyntaxhighlight>
{{out}}
<pre>$ ocaml deranged_anagram.ml
Line 2,651 ⟶ 3,760:
 
=={{header|ooRexx}}==
<langsyntaxhighlight ooRexxlang="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
 
Line 2,713 ⟶ 3,822:
loop pair over pairs
say pair[1] pair[2]
end</langsyntaxhighlight>
{{out}}
<pre>
Line 2,721 ⟶ 3,830:
 
=={{header|PARI/GP}}==
<langsyntaxhighlight lang="parigp">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);
Line 2,729 ⟶ 3,838:
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)))</langsyntaxhighlight>
{{out}}
<pre>%1 = [["excitation", "intoxicate"]]</pre>
Line 2,736 ⟶ 3,845:
Using extra Stringlist for sorted by character words and insertion sort.<BR>
Runtime 153 ms -> 35 ms (Free Pascal Compiler version 3.3.1-r20:47268 [2020/11/02] for x86_64)
<langsyntaxhighlight lang="pascal">program Anagrams_Deranged;
{$IFDEF FPC}
{$MODE Delphi}
Line 2,852 ⟶ 3,961:
Dict.Free;
end.
</syntaxhighlight>
</lang>
{{out}}
<pre>
Line 2,862 ⟶ 3,971:
 
=={{header|Perl}}==
===String operations===
<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 @b = split('', shift);
Line 2,896 ⟶ 4,009:
keys %letter_list )
{
# if we find a pair, they are the longestedlongest due to the sort before
last if find_deranged(@{ $letter_list{$_} });
}</langsyntaxhighlight>
{{out}}
<pre>length 10: excitation => intoxicate</pre>
<pre>
===Bitwise operations===
length 10: excitation => intoxicate
<syntaxhighlight lang="perl">use strict;
</pre>
===Alternate===
<lang perl>#!/usr/bin/perl
 
use strict; # https://rosettacode.org/wiki/Anagrams/Deranged_anagrams
use warnings;
use feature 'bitwise';
 
local (@ARGV, $/) = 'unixdict.txt';
Line 2,915 ⟶ 4,025:
{
my $key = join '', sort +split //, $word;
($_ ^. $word) =~ /\0/ or exit !print "$_ $word\n" for @{ $anagrams{$key} };
push @{ $anagrams{$key} }, $word;
}</langsyntaxhighlight>
{{out}}
<pre>excitation intoxicate</pre>
<pre>
excitation intoxicate
</pre>
 
=={{header|Phix}}==
<!--<langsyntaxhighlight Phixlang="phix">-->
<span style="color: #008080;">function</span> <span style="color: #000000;">deranged</span><span style="color: #0000FF;">(</span><span style="color: #004080;">string</span> <span style="color: #000000;">word1</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">word2</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">return</span> <span style="color: #7060A8;">sum</span><span style="color: #0000FF;">(</span><span style="color: #000000;">sq_eq</span><span style="color: #0000FF;">(</span><span style="color: #000000;">word1</span><span style="color: #0000FF;">,</span><span style="color: #000000;">word2</span><span style="color: #0000FF;">))=</span><span style="color: #000000;">0</span>
Line 2,970 ⟶ 4,078:
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<!--</langsyntaxhighlight>-->
{{out}}
<pre>
Line 2,976 ⟶ 4,084:
excitation, intoxicate
</pre>
 
=={{header|Phixmonti}}==
<syntaxhighlight lang="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
</syntaxhighlight>
{{out}}
<pre>["excitation", "intoxicate"]
=== Press any key to exit ===</pre>
 
=={{header|PHP}}==
<langsyntaxhighlight PHPlang="php"><?php
$words = file(
'http://www.puzzlers.org/pub/wordlists/unixdict.txt',
Line 3,028 ⟶ 4,189:
echo implode(" ", $final_word), "\n";
}
?></langsyntaxhighlight>
{{out}}
<pre>
excitation intoxicate
</pre>
 
=={{header|Picat}}==
<syntaxhighlight lang="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.</syntaxhighlight>
 
{{out}}
<pre>[[excitation,intoxicate]]</pre>
 
=={{header|PicoLisp}}==
<langsyntaxhighlight PicoLisplang="picolisp">(let Words NIL
(in "unixdict.txt"
(while (line)
Line 3,053 ⟶ 4,250:
(cons (pack @) (pack Lst)) ) )
(val Key) ) )
(idx 'Words) ) ) )</langsyntaxhighlight>
{{out}}
<pre>-> ("excitation" . "intoxicate")</pre>
 
=={{header|PowerShell}}==
<langsyntaxhighlight PowerShelllang="powershell">function Test-Deranged ([string[]]$Strings)
{
$array1 = $Strings[0].ToCharArray()
Line 3,090 ⟶ 4,287:
Length = $deranged[0].Length
Words = $deranged
}</langsyntaxhighlight>
{{Out}}
<pre>
Line 3,100 ⟶ 4,297:
=={{header|Prolog}}==
{{Works with|SWI Prolog}}
<langsyntaxhighlight Prologlang="prolog">longest_deranged_anagram :-
http_open('http://www.puzzlers.org/pub/wordlists/unixdict.txt',In,[]),
read_file(In, [], Out),
Line 3,157 ⟶ 4,354:
msort(W, W1),
atom_codes(A, W1),
read_file(In, [A-W | L], L1)).</langsyntaxhighlight>
{{out}}
<pre> ?- longest_deranged_anagram.
Line 3,165 ⟶ 4,362:
 
=={{header|PureBasic}}==
<langsyntaxhighlight PureBasiclang="purebasic">Structure anagram
word.s
letters.s
Line 3,299 ⟶ 4,496:
Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
CloseConsole()
EndIf</langsyntaxhighlight>
{{out}}
<pre>Largest 'Deranged' anagrams found are of length 10:
Line 3,307 ⟶ 4,504:
 
=={{header|Python}}==
<langsyntaxhighlight lang="python">import urllib.request
from collections import defaultdict
from itertools import combinations
Line 3,345 ⟶ 4,542:
print("Longest anagrams with no characters in the same position:")
print(' ' + '\n '.join(', '.join(pairs)
for pairs in largest_deranged_ana(anagrams)))</langsyntaxhighlight>
{{out}}
<pre>Word count: 25104
Line 3,357 ⟶ 4,554:
 
Append the following to the previous code:
<langsyntaxhighlight lang="python">def most_deranged_ana(anagrams):
ordered_anagrams = sorted(anagrams.items(),
key=lambda x:(-len(x[0]), x[0]))
Line 3,374 ⟶ 4,571:
for pairs in most:
print()
print(' ' + '\n '.join(', '.join(p) for p in pairs))</langsyntaxhighlight>
 
{{out}}
Line 3,406 ⟶ 4,603:
 
===Python: Faster Version===
<langsyntaxhighlight lang="python">from collections import defaultdict
from itertools import combinations
from pathlib import Path
Line 3,492 ⟶ 4,689:
 
if __name__ == '__main__':
main()</langsyntaxhighlight>
{{out}}
<pre>The longest anagram is: excitation, intoxicate</pre>
Line 3,498 ⟶ 4,695:
=={{header|Quackery}}==
 
<langsyntaxhighlight Quackerylang="quackery"> [ over size over size != iff
[ 2drop false ] done
over sort over sort != iff
Line 3,520 ⟶ 4,717:
temp take
sortwith [ 0 peek size swap 0 peek size > ]
0 peek witheach [ echo$ sp ]</langsyntaxhighlight>
 
{{out}}
Line 3,527 ⟶ 4,724:
 
=={{header|R}}==
<langsyntaxhighlight Rlang="r">puzzlers.dict <- readLines("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
 
longest.deranged.anagram <- function(dict=puzzlers.dict) {
Line 3,551 ⟶ 4,748:
}
}
}</langsyntaxhighlight>
 
{{out}}
 
<langsyntaxhighlight Rlang="r">> longest.deranged.anagram()
a b
3 excitation intoxicate</langsyntaxhighlight>
 
=={{header|Racket}}==
<langsyntaxhighlight lang="racket">#lang racket
(define word-list-file "data/unixdict.txt")
 
Line 3,601 ⟶ 4,798:
(daps (in-value (deranged-anagram-pairs anagrams)))
#:unless (null? daps))
daps)</langsyntaxhighlight>
{{out}}
<pre>'(("intoxicate" "excitation"))</pre>
Line 3,610 ⟶ 4,807:
{{works with|Rakudo|2016.08}}
 
<syntaxhighlight lang="raku" perl6line>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
Line 3,624 ⟶ 4,821:
}
}
}</langsyntaxhighlight>
 
{{out}}
Line 3,630 ⟶ 4,827:
 
=={{header|REXX}}==
<langsyntaxhighlight lang="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*/
Line 3,671 ⟶ 4,868:
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</langsyntaxhighlight>
{{out|output|text= &nbsp; when using the default dictionary:}}
<pre>
Line 3,679 ⟶ 4,876:
 
=={{header|Ring}}==
<langsyntaxhighlight lang="ring"># Project : Anagrams/Deranged anagrams
 
load "stdlib.ring"
Line 3,757 ⟶ 4,954:
astring = substr(astring,substr(astring,bstring)+len(string(sum)))
end
return cnt</langsyntaxhighlight>
{{out}}
<pre>
Line 3,764 ⟶ 4,961:
 
=={{header|Ruby}}==
<langsyntaxhighlight lang="ruby">def deranged?(a, b)
a.chars.zip(b.chars).all? {|char_a, char_b| char_a != char_b}
end
Line 3,785 ⟶ 4,982:
break
end
end</langsyntaxhighlight>
{{out}}
<pre>
Line 3,792 ⟶ 4,989:
 
=={{header|Run BASIC}}==
<langsyntaxhighlight lang="runbasic">a$ = httpGet$("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
dim theWord$(30000)
dim ssWord$(30000)
Line 3,838 ⟶ 5,035:
 
print maxLen;" ";theWord$(maxPtrI);" => ";theWord$(maxPtrJ)
end</langsyntaxhighlight>
{{out}}
<pre>10 excitation => intoxicate</pre>
 
=={{header|Rust}}==
<langsyntaxhighlight lang="rust">//! Deranged anagrams
use std::cmp::Ordering;
use std::collections::HashMap;
Line 3,917 ⟶ 5,114:
Err(e) => panic!("Could not read words: {}",e)
}
}</langsyntaxhighlight>
{{out}}
<pre>excitation intoxicate</pre>
 
=={{header|Scala}}==
<langsyntaxhighlight lang="scala">object DerangedAnagrams {
 
/** Returns a map of anagrams keyed by the sorted characters */
Line 3,955 ⟶ 5,152:
}
 
}</langsyntaxhighlight>
{{out}}
<pre>Longest deranged pair: excitation and intoxicate</pre>
Line 3,961 ⟶ 5,158:
=={{header|Scheme}}==
 
<langsyntaxhighlight lang="scheme">(import (scheme base)
(scheme char)
(scheme cxr)
Line 4,009 ⟶ 5,206:
(cdr rem))))))))
 
(display (find-deranged-words (read-ordered-words))) (newline)</langsyntaxhighlight>
 
{{out}}
Line 4,017 ⟶ 5,214:
 
=={{header|Sidef}}==
<langsyntaxhighlight lang="ruby">func find_deranged(Array a) {
for i in (^a) {
for j in (i+1 .. a.end) {
Line 4,051 ⟶ 5,248:
}
 
main(%f'/tmp/unixdict.txt')</langsyntaxhighlight>
{{out}}
<pre>length 10: excitation => intoxicate</pre>
 
=={{header|Simula}}==
<langsyntaxhighlight lang="simula">! cim --memory-pool-size=512 deranged-anagrams.sim;
BEGIN
 
Line 4,187 ⟶ 5,384:
OUTTEXT(VECT.ELEMENT(P1) & " " & VECT.ELEMENT(P2));
OUTIMAGE;
END</langsyntaxhighlight>
{{out}}
<pre>intoxicate excitation
Line 4,195 ⟶ 5,392:
 
=={{header|Tcl}}==
<langsyntaxhighlight lang="tcl">package require Tcl 8.5
package require http
 
Line 4,247 ⟶ 5,444:
puts "considered candidate pairing: $pair"
}
puts "MAXIMAL DERANGED ANAGRAM: LENGTH $max\n\t[lindex $candidates end]"</langsyntaxhighlight>
{{out}}
<pre>
Line 4,266 ⟶ 5,463:
 
=={{header|TUSCRIPT}}==
<langsyntaxhighlight lang="tuscript">$$ MODE TUSCRIPT,{}
requestdata = REQUEST ("http://www.puzzlers.org/pub/wordlists/unixdict.txt")
 
Line 4,310 ⟶ 5,507:
ENDLOOP
ENDLOOP
ENDCOMPILE</langsyntaxhighlight>
{{out}}
<pre>
Line 4,319 ⟶ 5,516:
=={{header|UNIX Shell}}==
{{works with|ksh93}}
<langsyntaxhighlight lang="bash">function get_words {
typeset host=www.puzzlers.org
typeset page=/pub/wordlists/unixdict.txt
Line 4,365 ⟶ 5,562:
fi
done <word.list
echo $max - ${max_deranged[@]} </langsyntaxhighlight>
{{out}}
<pre>10 - excitation intoxicate</pre>
Line 4,371 ⟶ 5,568:
=={{header|Ursala}}==
This solution assumes the file <code>unixdict.txt</code> is passed to the compiler as a command line parameter.
<langsyntaxhighlight Ursalalang="ursala">#import std
 
anagrams = |=tK33lrDSL2SL ~=&& ==+ ~~ -<&
Line 4,379 ⟶ 5,576:
#cast %sW
 
main = leql$^&l deranged anagrams unixdict_dot_txt</langsyntaxhighlight>
The <code>anagrams</code> 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.
<langsyntaxhighlight Ursalalang="ursala">anagrams = @NSiXSlK2rSS *= ^(-<&,~&)*; |=rSStFtK33lrDSL2SL ~=@br&& ==@bl</langsyntaxhighlight>
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.
<langsyntaxhighlight Ursalalang="ursala">#import std
 
longest_deranged_anagram =
Line 4,393 ⟶ 5,590:
#cast %sW
 
main = longest_deranged_anagram unixdict_dot_txt</langsyntaxhighlight>
{{out}}
<pre>
Line 4,400 ⟶ 5,597:
 
=={{header|VBA}}==
<langsyntaxhighlight lang="vb">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
Line 4,449 ⟶ 5,646:
DerangedAnagram = True
Lenght = Len(str1)
End Function</langsyntaxhighlight>
 
{{out}}
Line 4,456 ⟶ 5,653:
Lenght : 10
Time to compute : 97,00781 sec.</pre>
 
=={{header|V (Vlang)}}==
{{trans|Go}}
<syntaxhighlight lang="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')
}</syntaxhighlight>
 
{{out}}
<pre>
excitation intoxicate: Length 10
</pre>
 
=={{header|Wren}}==
{{libheader|Wren-sort}}
<langsyntaxhighlight ecmascriptlang="wren">import "io" for File
import "./sort" for Sort
 
// assumes w1 and w2 are anagrams of each other
Line 4,499 ⟶ 5,747:
for (words in deranged) {
if (words[0].count == most) System.print([words[0], words[1]])
}</langsyntaxhighlight>
 
{{out}}
Line 4,507 ⟶ 5,755:
 
=={{header|zkl}}==
<langsyntaxhighlight lang="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);
Line 4,528 ⟶ 5,776:
nws.filter(fcn(nws,max){ nws[0]==max },
nws.reduce(fcn(p,nws){ p.max(nws[0]) },0) )
.println();</langsyntaxhighlight>
{{out}}
<pre>
Line 4,534 ⟶ 5,782:
</pre>
Replace the center section with the following for smaller code (3 lines shorter!) that is twice as slow:
<langsyntaxhighlight lang="zkl">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
Line 4,543 ⟶ 5,791:
}
Void.Skip
});</langsyntaxhighlight>
PureFox
9,476

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/181008...350733"