/* ARM assembly Raspberry PI  */
/*  program anagram.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,         40000
.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

/*********************************/
/* Initialized data              */
/*********************************/
.data
szFileName:           .asciz "./listword.txt"
szMessErreur:         .asciz "FILE ERROR."
szCarriageReturn:     .asciz "\n"
szMessSpace:          .asciz " "

ptBuffer1:            .int sBuffer1
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
ptTabBuffer:                .skip 4 * MAXI
ptTabAna:                   .skip 4 * MAXI
tbiCptAna:                  .skip 4 * MAXI
iNBword:                    .skip 4
sBuffer:                    .skip BUFFERSIZE
sBuffer1:                   .skip BUFFERSIZE

/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                      @ entry of program
    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,iAdrptTabAna    @ address sorted string area
    mov r1,#0              @ first indice
    ldr r2,iAdriNBword
    ldr r2,[r2]            @ last indice
    ldr r3,iAdrptTabBuffer @ address sorted string area
    bl triRapide           @ quick sort
    ldr r4,iAdrptTabAna    @ address sorted string area
    ldr r7,iAdrptTabBuffer @ address sorted string area
    ldr r10,iAdrtbiCptAna  @ address counter occurences
    mov r9,r2              @ size word array
    mov r8,#0              @ indice first occurence
    ldr r3,[r4,r8,lsl #2]  @ load first value
    mov r2,#1              @ loop indice
    mov r6,#0              @ counter
    mov r12,#0             @ counter value max
3:
    ldr r5,[r4,r2,lsl #2]  @ load next value
    mov r0,r3
    mov r1,r5
    bl comparStrings
    cmp r0,#0              @ sorted strings equal ?
    bne 4f
    add r6,r6,#1           @ yes increment counter
    b 5f
4:                         @ no
    str r6,[r10,r8,lsl #2] @ store counter in first occurence
    cmp r6,r12             @ counter > value max
    movgt r12,r6           @ yes  counter -> value max
    mov r6,#0              @ raz counter
    mov r8,r2              @ init index first occurence
    mov r3,r5              @ init value first occurence
5:
    add r2,r2,#1           @ increment indice
    cmp r2,r9              @ end word array ?
    blt 3b                 @ no -> loop

    mov r2,#0              @ raz indice
6:                         @ display loop
    ldr r6,[r10,r2,lsl #2] @ load counter
    cmp r6,r12             @ equal to max value ?
    bne 8f
    ldr r0,[r7,r2,lsl #2]  @ load address first word
    bl affichageMess
    add r3,r2,#1           @ increment new indixe
    mov r4,#0              @ counter
7:
    ldr r0,iAdrszMessSpace
    bl affichageMess
    ldr r0,[r7,r3,lsl #2]  @ load address other word
    bl affichageMess
    add r3,r3,#1           @ increment indice
    add r4,r4,#1           @ increment counter
    cmp r4,r6              @ max value ?
    blt 7b                 @ no loop
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
8:
    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
iAdrtbiCptAna:               .int tbiCptAna
/******************************************************************/
/*     analizing word                                   */
/******************************************************************/
/*  r0  word address */
/*  r1 word length   */
anaWord:
    push {r1-r6,lr}
    mov r5,r0
    mov r6,r1
    ldr r1,iAdrptTabBuffer
    ldr r2,iAdriNBword
    ldr r3,[r2]
    str r0,[r1,r3,lsl #2]

    ldr r1,iAdrptTabAna
    ldr r4,iAdrptBuffer1
    ldr r0,[r4]
    add r6,r6,r0
    add r6,r6,#1
    str r6,[r4]
    str r0,[r1,r3,lsl #2]

    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}
iAdrptTabBuffer:        .int ptTabBuffer
iAdrptTabAna:           .int ptTabAna
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}
/***************************************************/
/*   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  */
/* r3 contains the address of table 2 */
triRapide:
    push {r2-r6,lr}         @ save registers
    mov r6,r3
    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
    mov r3,r6
    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-r6,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   */
/* r3 contains the address of table 2 */
partition1:
    push {r1-r12,lr}        @ save registers
    mov r8,r0               @ save address table 2
    mov r9,r1
    ldr r10,[r8,r2,lsl #2]  @ load string address last index
    mov r4,r9               @ init with first index
    mov r5,r9               @ init with first index
1:                          @ begin loop
    ldr r6,[r8,r5,lsl #2]   @ load string address
    mov r0,r6
    mov r1,r10
    bl comparStrings
    cmp r0,#0
    ldrlt r7,[r8,r4,lsl #2]  @ if < swap value table
    strlt r6,[r8,r4,lsl #2]
    strlt r7,[r8,r5,lsl #2]
    ldrlt r7,[r3,r4,lsl #2]  @ swap array 2
    ldrlt r12,[r3,r5,lsl #2]
    strlt r7,[r3,r5,lsl #2]
    strlt r12,[r3,r4,lsl #2]
    addlt r4,#1              @ and increment index 1
    add    r5,#1             @ increment index 2
    cmp r5,r2                @ end ?
    blt 1b                   @ no -> loop
    ldr r7,[r8,r4,lsl #2]    @ swap value
    str r10,[r8,r4,lsl #2]
    str r7,[r8,r2,lsl #2]
    ldr r7,[r3,r4,lsl #2]    @ swap array 2
    ldr r12,[r3,r2,lsl #2]
    str r7,[r3,r2,lsl #2]
    str r12,[r3,r4,lsl #2]

    mov r0,r4                @ return index partition
100:
    pop {r1-r12,lr}
    bx lr
/************************************/
/* 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"


// version 1.1

fun sumProperDivisors(n: Int): Int {
    if (n < 2) return 0
    return (1..n / 2).filter{ (n % it) == 0 }.sum()
}

fun main(args: Array<String>) {
    val sum = IntArray(20000, { sumProperDivisors(it) } )
    println("The pairs of amicable numbers below 20,000 are:\n")
    for(n in 2..19998) {
        val m = sum[n]
        if (m > n && m < 20000 && n == sum[m]) {
            println(n.toString().padStart(5) + " and " + m.toString().padStart(5))
        }
    }
}


function sumDivs (n)
    local sum = 1
    for d = 2, math.sqrt(n) do
        if n % d == 0 then
            sum = sum + d
            sum = sum + n / d
        end
    end
    return sum
end

for n = 2, 20000 do
    m = sumDivs(n)
    if m > n then
        if sumDivs(m) == n then print(n, m) end
    end
end


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.


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
]

loop select values anagrams 'x [5 =< size x] 'words ->
    print join.with:", " words


FileRead, Contents, unixdict.txt
Loop, Parse, Contents, % "`n", % "`r"
{ ; parsing each line of the file we just read
    Loop, Parse, A_LoopField ; parsing each letter/character of the current word
        Dummy .= "," A_LoopField
    Sort, Dummy, % "D," ; sorting those letters before removing the delimiters (comma)
    StringReplace, Dummy, Dummy, % ",", % "", All
    List .= "`n" Dummy " " A_LoopField , Dummy := ""
} ; at this point, we have a list where each line looks like <LETTERS><SPACE><WORD>
Count := 0, Contents := "", List := SubStr(List,2)
Sort, List
Loop, Parse, List, % "`n", % "`r"
{ ; now the list is sorted, parse it counting the consecutive lines with the same set of <LETTERS>
    Max := (Count > Max) ? Count : Max
    StringSplit, LinePart, A_LoopField, % " " ; (LinePart1 are the letters, LinePart2 is the word)
    If ( PreviousLinePart1 = LinePart1 )
        Count++ , WordList .= "," LinePart2
    Else
        var_Result .= ( Count <> Max ) ? "" ; don't append if the number of common words is too low
        : "`n" Count "`t" PreviousLinePart1 "`t" SubStr(WordList,2)
        , WordList := "" , Count := 0
    PreviousLinePart1 := LinePart1
}
List := "", var_Result := SubStr(var_Result,2)
Sort, var_Result, R N ; make the higher scores appear first
Loop, Parse, var_Result, % "`n", % "`r"
    If ( 1 == InStr(A_LoopField,Max) )
        var_Output .= "`n" A_LoopField
    Else ; output only those sets of letters that scored the maximum amount of common words
        Break
MsgBox, % ClipBoard := SubStr(var_Output,2) ; the result is also copied to the clipboard


            NORMAL MODE IS INTEGER
            DIMENSION DIVS(20000)
            PRINT COMMENT $ AMICABLE PAIRS$

          R CALCULATE SUM OF DIVISORS OF N
            INTERNAL FUNCTION(N)
            ENTRY TO DIVSUM.
            DS = 0
            THROUGH SUMMAT, FOR DIVC=1, 1, DIVC.GE.N
SUMMAT      WHENEVER N/DIVC*DIVC.E.N, DS = DS+DIVC
            FUNCTION RETURN DS
            END OF FUNCTION

          R CALCULATE SUM OF DIVISORS FOR ALL NUMBERS 1..20000
            THROUGH MEMO, FOR I=1, 1, I.GE.20000
MEMO        DIVS(I) = DIVSUM.(I)

          R FIND ALL MATCHING PAIRS
            THROUGH CHECK, FOR I=1, 1, I.GE.20000
            THROUGH CHECK, FOR J=1, 1, J.GE.I
CHECK       WHENEVER DIVS(I).E.J .AND. DIVS(J).E.I,
          0     PRINT FORMAT AMI,I,J

            VECTOR VALUES AMI = $I6,I6*$
            END OF PROGRAM


with(NumberTheory):
pairs:=[];
for i from 1 to 20000 do
	for j from i+1 to 20000 do
		sum1:=SumOfDivisors(j)-j;
		sum2:=SumOfDivisors(i)-i;
		if sum1=i and sum2=j and i<>j then
			pairs:=[op(pairs),[i,j]];
			printf("%a", pairs);
		end if;
	end do;
end do;
pairs;


amicableQ[n_] :=
 Module[{sum = Total[[email protected]@n]},
  sum != n && n == Total[[email protected]@sum]]

[email protected][Cases[Range[4, 20000], _?([email protected]# &)], 2]


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 longested due to the sort before
        last if find_deranged(@{ $letter_list{$_} });
}


# JUMBLEA.AWK - words with the most duplicate spellings
# syntax: GAWK -f JUMBLEA.AWK UNIXDICT.TXT
{   for (i=1; i<=NF; i++) {
      w = sortstr(toupper($i))
      arr[w] = arr[w] $i " "
      n = gsub(/ /,"&",arr[w])
      if (max_n < n) { max_n = n }
    }
}
END {
    for (w in arr) {
      if (gsub(/ /,"&",arr[w]) == max_n) {
        printf("%s\t%s\n",w,arr[w])
      }
    }
    exit(0)
}
function sortstr(str,  i,j,leng) {
    leng = length(str)
    for (i=2; i<=leng; i++) {
      for (j=i; j>1 && substr(str,j-1,1) > substr(str,j,1); j--) {
        str = substr(str,1,j-2) substr(str,j,1) substr(str,j-1,1) substr(str,j+1)
      }
    }
    return(str)
}


function amicable
    tic
    N=2:1:20000; aN=[];
    N(isprime(N))=[]; %erase prime numbers
    I=1;
    a=N(1); b=sum(pd(a));
    while length(N)>1
        if a==b %erase perfect numbers;
            N(N==a)=[]; a=N(1); b=sum(pd(a));
        elseif b<a %the first member of an amicable pair is abundant not defective
            N(N==a)=[]; a=N(1); b=sum(pd(a));
        elseif ~ismember(b,N) %the other member was previously erased
            N(N==a)=[]; a=N(1); b=sum(pd(a));
        else
            c=sum(pd(b));
            if a==c
                aN(I,:)=[I a b]; I=I+1;
                N(N==b)=[];
            else
                if ~ismember(c,N) %the other member was previously erased
                    N(N==b)=[];
                end
            end
            N(N==a)=[]; a=N(1); b=sum(pd(a));
            clear c
        end
    end
    disp(array2table(aN,'Variablenames',{'N','Amicable1','Amicable2'}))
    toc
end

function D=pd(x)
    K=1:ceil(x/2);
    D=K(~(rem(x, K)));
end


from math import sqrt

const N = 524_000_000.int32

proc sumProperDivisors(someNum: int32, chk4less: bool): int32 =
    result = 1
    let maxPD = sqrt(someNum.float).int32
    let offset = someNum mod 2
    for divNum in countup(2 + offset, maxPD, 1 + offset):
        if someNum mod divNum == 0:
            result += divNum + someNum div divNum
            if chk4less and result >= someNum:
                return 0

for n in countdown(N, 2):
    let m = sumProperDivisors(n, true)
    if m != 0 and n == sumProperDivisors(m, false):
        echo $n, " ", $m


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


OPTION COLLAPSE TRUE

DECLARE idx$ ASSOC STRING

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

    set$ = SORT$(EXPLODE$(w$, 1))

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

    IF MaxCount < total THEN MaxCount = total
NEXT

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

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


      INSTALL @lib$+"SORTLIB"
      sort% = FN_sortinit(0,0)

      REM Count number of words in dictionary:
      nwords% = 0
      dict% = OPENIN("unixdict.txt")
      WHILE NOT EOF#dict%
        word$ = GET$#dict%
        nwords% += 1
      ENDWHILE
      CLOSE #dict%

      REM Create arrays big enough to contain the dictionary:
      DIM dict$(nwords%), sort$(nwords%)

      REM Load the dictionary and sort the characters in the words:
      dict% = OPENIN("unixdict.txt")
      FOR word% = 1 TO nwords%
        word$ = GET$#dict%
        dict$(word%) = word$
        sort$(word%) = FNsortchars(word$)
      NEXT word%
      CLOSE #dict%

      REM Sort arrays using the 'sorted character' words as a key:
      C% = nwords%
      CALL sort%, sort$(1), dict$(1)

      REM Count the longest sets of anagrams:
      max% = 0
      set% = 1
      FOR word% = 1 TO nwords%-1
        IF sort$(word%) = sort$(word%+1) THEN
          set% += 1
        ELSE
          IF set% > max% THEN max% = set%
          set% = 1
        ENDIF
      NEXT word%

      REM Output the results:
      set% = 1
      FOR word% = 1 TO nwords%-1
        IF sort$(word%) = sort$(word%+1) THEN
          set% += 1
        ELSE
          IF set% = max% THEN
            FOR anagram% = word%-max%+1 TO word%
              PRINT dict$(anagram%),;
            NEXT
            PRINT
          ENDIF
          set% = 1
        ENDIF
      NEXT word%
      END

      DEF FNsortchars(word$)
      LOCAL C%, char&()
      DIM char&(LEN(word$))
      $$^char&(0) = word$
      C% = LEN(word$)
      CALL sort%, char&(0)
      = $$^char&(0)


MODULE AmicablePairs;
IMPORT
  Out;
CONST
  max = 20000;

VAR
  i,j: INTEGER;
  pd: ARRAY max + 1 OF LONGINT;

PROCEDURE ProperDivisorsSum(n: LONGINT): LONGINT;
VAR
   i,sum: LONGINT;
BEGIN
  sum := 0;
  IF n > 1 THEN
    INC(sum,1);i := 2;
    WHILE (i < n) DO
      IF (n MOD i) = 0 THEN INC(sum,i) END;
      INC(i)
    END
  END;
  RETURN sum
END ProperDivisorsSum;

BEGIN
  FOR i := 0 TO max DO
    pd[i] := ProperDivisorsSum(i)
  END;

  FOR i := 2 TO max DO
    FOR j := i + 1 TO max DO
      IF (pd[i] = j) & (pd[j] = i) THEN
         Out.Char('[');Out.Int(i,0);Out.Char(',');Out.Int(j,0);Out.Char("]");Out.Ln
      END
    END
  END
END AmicablePairs.


import: mapping

Integer method: properDivs -- []
   #[ self swap mod 0 == ] self 2 / seq filter ;

: amicables
| i j |
   Array new
   20000 loop: i [
      i properDivs sum dup ->j i <= if continue then
      j properDivs sum i <> if continue then
      [ i, j ] over add
      ]
;


/# 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


<?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";
}
?>


words ← •FLines "unixdict.txt"
•Show¨{𝕩/˜(⊢=⌈´)≠¨𝕩} (⊐∧¨)⊸⊔ words


( get$("unixdict.txt",STR):?list
& 1:?product
&   whl
  ' ( @(!list:(%?word:?w) \n ?list)
    & :?sum
    &   whl
      ' ( @(!w:%?let ?w)
        & (!let:~#|str$(N !let))+!sum:?sum
        )
    & !sum^!word*!product:?product
    )
& lst$(product,"product.txt",NEW)
& 0:?max
& :?group
& (   !product
    :   ?
      * ?^(%+%:?exp)
      * ( ?
        &   !exp
          :   ?
            + ( [>!max:[?max&!exp:?group
              | [~<!max&!group !exp:?group
              )
        & ~
        )
  | out$!group
  )
);


let rec isqrt n =
  if n = 1 then 1
  else let _n = isqrt (n - 1) in
    (_n + (n / _n)) / 2

let sum_divs n =
  let sum = ref 1 in
  for d = 2 to isqrt n do
    if (n mod d) = 0 then sum := !sum + (n / d + d);
  done;
  !sum

let () =
  for n = 2 to 20000 do
    let m = sum_divs n in
    if (m > n) then
      if (sum_divs m) = n then Printf.printf "%d %d\n" n m;
  done


for(x=1,20000,my(y=sigma(x)-x); if(y>x && x == sigma(y)-y,print(x" "y)))


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.


(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) ) ) )


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <time.h>

char *sortedWord(const char *word, char *wbuf)
{
    char *p1, *p2, *endwrd;
    char t;
    int swaps;

    strcpy(wbuf, word);
    endwrd = wbuf+strlen(wbuf);
    do {
       swaps = 0;
       p1 = wbuf; p2 = endwrd-1;
       while (p1<p2) {
          if (*p2 > *p1) {
             t = *p2; *p2 = *p1; *p1 = t;
             swaps = 1;
          }
          p1++; p2--;
       }
       p1 = wbuf; p2 = p1+1;
       while(p2 < endwrd) {
           if (*p2 > *p1) {
             t = *p2; *p2 = *p1; *p1 = t;
             swaps = 1;
           }
           p1++; p2++;
       }
    } while (swaps);
    return wbuf;
}

static
short cxmap[] = {
    0x06, 0x1f, 0x4d, 0x0c, 0x5c, 0x28, 0x5d, 0x0e, 0x09, 0x33, 0x31, 0x56,
    0x52, 0x19, 0x29, 0x53, 0x32, 0x48, 0x35, 0x55, 0x5e, 0x14, 0x27, 0x24,
    0x02, 0x3e, 0x18, 0x4a, 0x3f, 0x4c, 0x45, 0x30, 0x08, 0x2c, 0x1a, 0x03,
    0x0b, 0x0d, 0x4f, 0x07, 0x20, 0x1d, 0x51, 0x3b, 0x11, 0x58, 0x00, 0x49,
    0x15, 0x2d, 0x41, 0x17, 0x5f, 0x39, 0x16, 0x42, 0x37, 0x22, 0x1c, 0x0f,
    0x43, 0x5b, 0x46, 0x4b, 0x0a, 0x26, 0x2e, 0x40, 0x12, 0x21, 0x3c, 0x36,
    0x38, 0x1e, 0x01, 0x1b, 0x05, 0x4e, 0x44, 0x3d, 0x04, 0x10, 0x5a, 0x2a,
    0x23, 0x34, 0x25, 0x2f, 0x2b, 0x50, 0x3a, 0x54, 0x47, 0x59, 0x13, 0x57,
   };
#define CXMAP_SIZE (sizeof(cxmap)/sizeof(short))

int Str_Hash( const char *key, int ix_max )
{
   const char *cp;
   short mash;
   int  hash = 33501551;
   for (cp = key; *cp; cp++) {
      mash = cxmap[*cp % CXMAP_SIZE];
      hash = (hash >>4) ^ 0x5C5CF5C ^ ((hash<<1) + (mash<<5));
      hash &= 0x3FFFFFFF;
      }
   return  hash % ix_max;
}

typedef struct sDictWord  *DictWord;
struct sDictWord {
    const char *word;
    DictWord next;
};

typedef struct sHashEntry *HashEntry;
struct sHashEntry {
    const char *key;
    HashEntry next;
    DictWord  words;
    HashEntry link;
    short wordCount;
};

#define HT_SIZE 8192

HashEntry hashTable[HT_SIZE];

HashEntry mostPerms = NULL;

int buildAnagrams( FILE *fin )
{
    char buffer[40];
    char bufr2[40];
    char *hkey;
    int hix;
    HashEntry he, *hep;
    DictWord  we;
    int  maxPC = 2;
    int numWords = 0;

    while ( fgets(buffer, 40, fin)) {
        for(hkey = buffer; *hkey && (*hkey!='\n'); hkey++);
        *hkey = 0;
        hkey = sortedWord(buffer, bufr2);
        hix = Str_Hash(hkey, HT_SIZE);
        he = hashTable[hix]; hep = &hashTable[hix];
        while( he && strcmp(he->key , hkey) ) {
            hep = &he->next;
            he = he->next;
        }
        if ( ! he ) {
            he = malloc(sizeof(struct sHashEntry));
            he->next = NULL;
            he->key = strdup(hkey);
            he->wordCount = 0;
            he->words = NULL;
            he->link = NULL;
            *hep = he;
        }
        we = malloc(sizeof(struct sDictWord));
        we->word = strdup(buffer);
        we->next = he->words;
        he->words = we;
        he->wordCount++;
        if ( maxPC < he->wordCount) {
            maxPC = he->wordCount;
            mostPerms = he;
            he->link = NULL;
        }
        else if (maxPC == he->wordCount) {
            he->link = mostPerms;
            mostPerms = he;
        }

        numWords++;
    }
    printf("%d words in dictionary max ana=%d\n", numWords, maxPC);
    return maxPC;
}

int main( )
{
    HashEntry he;
    DictWord  we;
    FILE *f1;

    f1 = fopen("unixdict.txt","r");
    buildAnagrams(f1);
    fclose(f1);

    f1 = fopen("anaout.txt","w");
//    f1 = stdout;

    for (he = mostPerms; he; he = he->link) {
        fprintf(f1,"%d:", he->wordCount);
        for(we = he->words; we; we = we->next) {
            fprintf(f1,"%s, ", we->word);
        }
        fprintf(f1, "\n");
    }

    fclose(f1);
    return 0;
}


use ntheory qw/divisor_sum/;
for my $x (1..20000) {
  my $y = divisor_sum($x)-$x;
  say "$x $y" if $y > $x && $x == divisor_sum($y)-$y;
}


integer n
for m=1 to 20000 do
    n = sum(factors(m,-1))
    if m<n and m=sum(factors(n,-1)) then ?{m,n} end if
end for


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
}


using System;
using System.IO;
using System.Linq;
using System.Net;
using System.Text.RegularExpressions;

namespace Anagram
{
    class Program
    {
        const string DICO_URL = "http://wiki.puzzlers.org/pub/wordlists/unixdict.txt";

        static void Main( string[] args )
        {
            WebRequest request = WebRequest.Create(DICO_URL);
            string[] words;
            using (StreamReader sr = new StreamReader(request.GetResponse().GetResponseStream(), true)) {
                words = Regex.Split(sr.ReadToEnd(), @"\r?\n");
            }
            var groups = from string w in words
                         group w by string.Concat(w.OrderBy(x => x)) into c
                         group c by c.Count() into d
                         orderby d.Key descending
                         select d;
            foreach (var c in groups.First()) {
                Console.WriteLine(string.Join(" ", c));
            }
        }
    }
}


def sumDivs
    var n
    1 var sum n sqrt
    2 swap 2 tolist
    for
        var d
        n d mod not if
            sum d + n d / + var sum
        endif
    endfor
    sum
enddef

2 20000 2 tolist for
    var i
    i sumDivs var m
    m i > if
        m sumDivs i == if i print "\t" print m print nl endif
    endif
endfor

nl msec print " s" print


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)).


#include <iostream>
#include <fstream>
#include <string>
#include <map>
#include <vector>
#include <algorithm>
#include <iterator>

int main() {
  std::ifstream in("unixdict.txt");
  typedef  std::map<std::string, std::vector<std::string> > AnagramMap;
  AnagramMap anagrams;

  std::string word;
  size_t count = 0;
  while (std::getline(in, word)) {
    std::string key = word;
    std::sort(key.begin(), key.end());
    // note: the [] op. automatically inserts a new value if key does not exist
    AnagramMap::mapped_type & v = anagrams[key];
    v.push_back(word);
    count = std::max(count, v.size());
  }

  in.close();

  for (AnagramMap::const_iterator it = anagrams.begin(), e = anagrams.end();
       it != e; it++)
    if (it->second.size() >= count) {
      std::copy(it->second.begin(), it->second.end(),
                std::ostream_iterator<std::string>(std::cout, ", "));
      std::cout << std::endl;
    }
  return 0;
}


 * foreach loop (two variants)
 * list comprehension
 * while loop.


(de accud (Var Key)
   (if (assoc Key (val Var))
      (con @ (inc (cdr @)))
      (push Var (cons Key 1)) )
   Key )
(de **sum (L)
   (let S 1
      (for I (cdr L)
         (inc 'S (** (car L) I)) )
      S ) )
(de factor-sum (N)
   (if (=1 N)
      0
      (let
         (R NIL
            D 2
            L (1 2 2 . (4 2 4 2 4 6 2 6 .))
            M (sqrt N)
            N1 N
            S 1 )
         (while (>= M D)
            (if (=0 (% N1 D))
               (setq M
                  (sqrt (setq N1 (/ N1 (accud 'R D)))) )
               (inc 'D (pop 'L)) ) )
         (accud 'R N1)
         (for I R
            (setq S (* S (**sum I))) )
         (- S N) ) ) )
(bench
   (for I 20000
      (let X (factor-sum I)
         (and
            (< I X)
            (= I (factor-sum X))
            (println I X) ) ) ) )


*process source xref;
 ami: Proc Options(main);
 p9a=time();
 Dcl (p9a,p9b,p9c) Pic'(9)9';
 Dcl sumpd(20000) Bin Fixed(31);
 Dcl pd(300) Bin Fixed(31);
 Dcl npd     Bin Fixed(31);
 Dcl (x,y)   Bin Fixed(31);

 Do x=1 To 20000;
   Call proper_divisors(x,pd,npd);
   sumpd(x)=sum(pd,npd);
   End;
 p9b=time();
 Put Edit('sum(pd) computed in',(p9b-p9a)/1000,' seconds elapsed')
         (Skip,col(7),a,f(6,3),a);

 Do x=1 To 20000;
   Do y=x+1 To 20000;
     If y=sumpd(x) &
        x=sumpd(y) Then
       Put Edit(x,y,' found after ',elapsed(),' seconds')
               (Skip,2(f(6)),a,f(6,3),a);
     End;
   End;
 Put Edit(elapsed(),' seconds total search time')(Skip,f(6,3),a);

 proper_divisors: Proc(n,pd,npd);
 Dcl (n,pd(300),npd) Bin Fixed(31);
 Dcl (d,delta)       Bin Fixed(31);
 npd=0;
 If n>1 Then Do;
   If mod(n,2)=1 Then  /* odd number  */
     delta=2;
   Else                /* even number */
     delta=1;
   Do d=1 To n/2 By delta;
     If mod(n,d)=0 Then Do;
       npd+=1;
       pd(npd)=d;
       End;
     End;
   End;
 End;

 sum: Proc(pd,npd) Returns(Bin Fixed(31));
 Dcl (pd(300),npd) Bin Fixed(31);
 Dcl sum Bin Fixed(31) Init(0);
 Dcl i   Bin Fixed(31);
 Do i=1 To npd;
   sum+=pd(i);
   End;
 Return(sum);
 End;

 elapsed: Proc Returns(Dec Fixed(6,3));
 p9c=time();
 Return((p9c-p9b)/1000);
 End;
 End;


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


(require '[clojure.java.io :as io])

(def groups
  (with-open [r (io/reader wordfile)]
    (group-by sort (line-seq r))))

(let [wordlists (sort-by (comp - count) (vals groups))
      maxlength (count (first wordlists))]
  (doseq [wordlist (take-while #(= (count %) maxlength) wordlists)]
    (println wordlist))


% Keep a list of anagrams
anagrams = cluster is new, add, largest_size, sets
    anagram_set = struct[letters: string, words: array[string]]
    rep = array[anagram_set]

    new = proc () returns (cvt)
        return(rep$[])
    end new

    % Sort the letters in a string
    sort = proc (s: string) returns (string)
        chars: array[int] := array[int]$fill(0,256,0) % Assuming ASCII here
        for c: char in string$chars(s) do
            i: int := char$c2i(c)
            chars[i] := chars[i] + 1
        end
        sorted: array[char] := array[char]$predict(1,string$size(s))
        for i: int in array[int]$indexes(chars) do
            for j: int in int$from_to(1,chars[i]) do
                array[char]$addh(sorted,char$i2c(i))
            end
        end
        return(string$ac2s(sorted))
    end sort

    % Add a word
    add = proc (a: cvt, s: string)
        letters: string := sort(s)
        as: anagram_set
        begin
            for t_as: anagram_set in rep$elements(a) do
                if t_as.letters = letters then
                    as := t_as
                    exit found
                end
            end
            as := anagram_set${letters: letters, words: array[string]$[]}
            rep$addh(a, as)
        end except when found: end
        array[string]$addh(as.words, s)
    end add

    % Find the size of the largest set
    largest_size = proc (a: cvt) returns (int)
        size: int := 0
        for as: anagram_set in rep$elements(a) do
            cur: int := array[string]$size(as.words)
            if cur > size then size := cur end
        end
        return(size)
    end largest_size

    % Yield all sets of a given size
    sets = iter (a: cvt, s: int) yields (sequence[string])
        for as: anagram_set in rep$elements(a) do
            if array[string]$size(as.words) = s then
                yield(sequence[string]$a2s(as.words))
            end
        end
    end sets
end anagrams

start_up = proc ()
    an: anagrams := anagrams$new()
    dict: stream := stream$open(file_name$parse("unixdict.txt"), "read")
    while true do
        anagrams$add(an, stream$getl(dict))
        except when end_of_file: break end
    end
    stream$close(dict)

    po: stream := stream$primary_output()
    max: int := anagrams$largest_size(an)
    stream$putl(po, "Largest amount of anagrams per set: " || int$unparse(max))
    stream$putl(po, "")

    for words: sequence[string] in anagrams$sets(an, max) do
        for word: string in sequence[string]$elements(words) do
            stream$putleft(po, word, 7)
        end
        stream$putl(po, "")
    end
end start_up


100H:
/* CP/M CALLS */
BDOS: PROCEDURE (FN, ARG); DECLARE FN BYTE, ARG ADDRESS; GO TO 5; END BDOS;
EXIT: PROCEDURE; CALL BDOS(0,0); END EXIT;
PRINT: PROCEDURE (S); DECLARE S ADDRESS; CALL BDOS(9,S); END PRINT;

/* PRINT A NUMBER */
PRINT$NUMBER: PROCEDURE (N);
    DECLARE S (6) BYTE INITIAL ('.....$');
    DECLARE (N, P) ADDRESS, C BASED P BYTE;
    P = .S(5);
DIGIT:
    P = P - 1;
    C = N MOD 10 + '0';
    N = N / 10;
    IF N > 0 THEN GO TO DIGIT;
    CALL PRINT(P);
END PRINT$NUMBER;

/* CALCULATE SUMS OF PROPER DIVISORS */
DECLARE DIV$SUM (20$001) ADDRESS;
DECLARE (I, J) ADDRESS;

DO I=2 TO 20$000; DIV$SUM(I) = 1; END;
DO I=2 TO 10$000;
    DO J = I*2 TO 20$000 BY I;
        DIV$SUM(J) = DIV$SUM(J) + I;
    END;
END;

/* TEST EACH PAIR */
DO I=2 TO 20$000;
    DO J=I+1 TO 20$000;
        IF DIV$SUM(I)=J AND DIV$SUM(J)=I THEN DO;
            CALL PRINT$NUMBER(I);
            CALL PRINT(.', $');
            CALL PRINT$NUMBER(J);
            CALL PRINT(.(13,10,'$'));
        END;
    END;
END;

CALL EXIT;
EOF


function Get-ProperDivisorSum ( [int]$N )
    {
    $Sum = 1
    If ( $N -gt 3 )
        {
        $SqrtN = [math]::Sqrt( $N )
        ForEach ( $Divisor1 in 2..$SqrtN )
            {
            $Divisor2 = $N / $Divisor1
            If ( $Divisor2 -is [int] ) { $Sum += $Divisor1 + $Divisor2 }
            }
        If ( $SqrtN -is [int] ) { $Sum -= $SqrtN }
        }
    return $Sum
    }

function Get-AmicablePairs ( $N = 300 )
    {
    ForEach ( $X in 1..$N )
        {
        $Sum = Get-ProperDivisorSum $X
        If ( $Sum -gt $X -and $X -eq ( Get-ProperDivisorSum $Sum ) )
            {
            "$X, $Sum"
            }
        }
    }

Get-AmicablePairs 20000


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)))


      *> TECTONICS
      *>   wget http://wiki.puzzlers.org/pub/wordlists/unixdict.txt
      *>   or visit https://sourceforge.net/projects/souptonuts/files
      *>   or snag ftp://ftp.openwall.com/pub/wordlists/all.gz
      *>      for a 5 million all language word file (a few phrases)
      *>   cobc -xj anagrams.cob [-DMOSTWORDS -DMOREWORDS -DALLWORDS]
      *> ***************************************************************
       identification division.
       program-id. anagrams.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select words-in
           assign to wordfile
           organization is line sequential
           status is words-status
           .

       REPLACE ==:LETTERS:== BY ==42==.

       data division.
       file section.
       fd words-in record is varying from 1 to :LETTERS: characters
                             depending on word-length.
       01 word-record.
          05 word-data         pic x occurs 0 to :LETTERS: times
                                     depending on word-length.

       working-storage section.
       >>IF ALLWORDS DEFINED
       01 wordfile     constant as "/usr/local/share/dict/all.words".
       01 max-words    constant as 4802100.

       >>ELSE-IF MOSTWORDS DEFINED
       01 wordfile     constant as "/usr/local/share/dict/linux.words".
       01 max-words    constant as 628000.

       >>ELSE-IF MOREWORDS DEFINED
       01 wordfile     constant as "/usr/share/dict/words".
       01 max-words    constant as 100000.

       >>ELSE
       01 wordfile     constant as "unixdict.txt".
       01 max-words    constant as 26000.
       >>END-IF

      *> The 5 million word file needs to restrict the word length
       >>IF ALLWORDS DEFINED
       01 max-letters          constant as 26.
       >>ELSE
       01 max-letters          constant as :LETTERS:.
       >>END-IF

       01 word-length          pic 99 comp-5.
       01 words-status         pic xx.
          88 ok-status         values '00' thru '09'.
          88 eof-status        value '10'.

      *> sortable word by letter table
       01 letter-index         usage index.
       01 letter-table.
          05 letters           occurs 1 to max-letters times
                               depending on word-length
                               ascending key letter
                               indexed by letter-index.
             10 letter         pic x.

      *> table of words
       01 sorted-index         usage index.
       01 word-table.
          05 word-list         occurs 0 to max-words times
                               depending on word-tally
                               ascending key sorted-word
                               indexed by sorted-index.
             10 match-count    pic 999 comp-5.
             10 this-word      pic x(max-letters).
             10 sorted-word    pic x(max-letters).
       01 sorted-display       pic x(10).

       01 interest-table.
          05 interest-list     pic 9(8) comp-5
                               occurs 0 to max-words times
                               depending on interest-tally.

       01 outer                pic 9(8) comp-5.
       01 inner                pic 9(8) comp-5.
       01 starter              pic 9(8) comp-5.
       01 ender                pic 9(8) comp-5.
       01 word-tally           pic 9(8) comp-5.
       01 interest-tally       pic 9(8) comp-5.
       01 tally-display        pic zz,zzz,zz9.

       01 most-matches         pic 99 comp-5.
       01 matches              pic 99 comp-5.
       01 match-display        pic z9.

      *> timing display
       01 time-stamp.
          05 filler            pic x(11).
          05 timer-hours       pic 99.
          05 filler            pic x.
          05 timer-minutes     pic 99.
          05 filler            pic x.
          05 timer-seconds     pic 99.
          05 filler            pic x.
          05 timer-subsec      pic v9(6).
       01 timer-elapsed        pic 9(6)v9(6).
       01 timer-value          pic 9(6)v9(6).
       01 timer-display        pic zzz,zz9.9(6).

      *> ***************************************************************
       procedure division.
       main-routine.

       >>IF ALLWORDS DEFINED
           display "** Words limited to " max-letters " letters **"
       >>END-IF

       perform show-time

       perform load-words
       perform find-most
       perform display-result

       perform show-time
       goback
       .

      *> ***************************************************************
       load-words.
       open input words-in
       if not ok-status then
           display "error opening " wordfile upon syserr
           move 1 to return-code
           goback
       end-if

       perform until exit
           read words-in
           if eof-status then exit perform end-if
           if not ok-status then
               display wordfile " read error: " words-status upon syserr
           end-if

           if word-length equal zero then exit perform cycle end-if

       >>IF ALLWORDS DEFINED
           move min(word-length, max-letters) to word-length
       >>END-IF

           add 1 to word-tally
           move word-record to this-word(word-tally) letter-table
           sort letters ascending key letter
           move letter-table to sorted-word(word-tally)
       end-perform

       move word-tally to tally-display
       display trim(tally-display) " words" with no advancing

       close words-in
       if not ok-status then
           display "error closing " wordfile upon syserr
           move 1 to return-code
       end-if

      *> sort word list by anagram check field
       sort word-list ascending key sorted-word
       .

      *> first entry in a list will end up with highest match count
       find-most.
       perform varying outer from 1 by 1 until outer > word-tally
           move 1 to matches
           add 1 to outer giving starter
           perform varying inner from starter by 1
                   until sorted-word(inner) not equal sorted-word(outer)
               add 1 to matches
           end-perform
           if matches > most-matches then
               move matches to most-matches
               initialize interest-table all to value
               move 0 to interest-tally
           end-if
           move matches to match-count(outer)
           if matches = most-matches then
               add 1 to interest-tally
               move outer to interest-list(interest-tally)
           end-if
       end-perform
       .

      *> only display the words with the most anagrams
       display-result.
       move interest-tally to tally-display
       move most-matches to match-display
       display ", most anagrams: " trim(match-display)
               ", with " trim(tally-display) " set" with no advancing
       if interest-tally not equal 1 then
           display "s" with no advancing
       end-if
       display " of interest"

       perform varying outer from 1 by 1 until outer > interest-tally
           move sorted-word(interest-list(outer)) to sorted-display
           display sorted-display
                   " [" trim(this-word(interest-list(outer)))
              with no advancing
           add 1 to interest-list(outer) giving starter
           add most-matches to interest-list(outer) giving ender
           perform varying inner from starter by 1
               until inner = ender
                   display ", " trim(this-word(inner))
                      with no advancing
           end-perform
           display "]"
       end-perform
       .

      *> elapsed time
       show-time.
       move formatted-current-date("YYYY-MM-DDThh:mm:ss.ssssss")
         to time-stamp
       compute timer-value = timer-hours * 3600 + timer-minutes * 60
                             + timer-seconds + timer-subsec
       if timer-elapsed = 0 then
           display time-stamp
           move timer-value to timer-elapsed
       else
           if timer-value < timer-elapsed then
               add 86400 to timer-value
           end-if
           subtract timer-elapsed from timer-value
           move timer-value to timer-display
           display time-stamp ", " trim(timer-display) " seconds"
       end-if
       .

       end program anagrams.


divisor(N, Divisor) :-
    UpperBound is round(sqrt(N)),
    between(1, UpperBound, D),
    0 is N mod D,
    (
        Divisor = D
    ;
        LargerDivisor is N/D,
        LargerDivisor =\= D,
        Divisor = LargerDivisor
    ).

proper_divisor(N, D) :-
    divisor(N, D),
    D =\= N.

assoc_num_divsSum_in_range(Low, High, Assoc) :-
    findall( Num-DivSum,
             ( between(Low, High, Num),
               aggregate_all( sum(D),
                              proper_divisor(Num, D),
                              DivSum )),
             Pairs ),
    list_to_assoc(Pairs, Assoc).

get_amicable_pair(Assoc, M-N) :-
    gen_assoc(M, Assoc, N),
    M < N,
    get_assoc(N, Assoc, M).

amicable_pairs_under_20000(Pairs) :-
    assoc_num_divsSum_in_range(1,20000, Assoc),
    findall(P, get_amicable_pair(Assoc, P), Pairs).


EnableExplicit

Procedure.i SumProperDivisors(Number)
  If Number < 2 : ProcedureReturn 0 : EndIf
  Protected i, sum = 0
  For i = 1 To Number / 2
    If Number % i = 0
      sum + i
    EndIf
  Next
  ProcedureReturn sum
EndProcedure

Define n, f
Define Dim sum(19999)

If OpenConsole()
  For n = 1 To 19999
    sum(n) = SumProperDivisors(n)
  Next
  PrintN("The pairs of amicable numbers below 20,000 are : ")
  PrintN("")
  For n = 1 To 19998
    f = sum(n)
    If f <= n Or f < 1 Or f > 19999 : Continue : EndIf
    If f = sum(n) And n = sum(f)
      PrintN(RSet(Str(n),5) + " and " + RSet(Str(sum(n)), 5))
    EndIf
  Next
  PrintN("")
  PrintN("Press any key to close the console")
  Repeat: Delay(10) : Until Inkey() <> ""
  CloseConsole()
EndIf


  [ 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 ]


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,])
    }
  }
}


http = require 'http'

show_large_anagram_sets = (word_lst) ->
  anagrams = {}
  max_size = 0

  for word in word_lst
    key = word.split('').sort().join('')
    anagrams[key] ?= []
    anagrams[key].push word
    size = anagrams[key].length
    max_size = size if size > max_size

  for key, variations of anagrams
    if variations.length == max_size
      console.log variations.join ' '

get_word_list = (process) ->
  options =
    host: "wiki.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_large_anagram_sets


from proper_divisors import proper_divs

def amicable(rangemax=20000):
    n2divsum = {n: sum(proper_divs(n)) for n in range(1, rangemax + 1)}
    for num, divsum in n2divsum.items():
        if num < divsum and divsum <= rangemax and n2divsum[divsum] == num:
            yield num, divsum

if __name__ == '__main__':
    for num, divsum in amicable():
        print('Amicable pair: %i and %i With proper divisors:\n    %r\n    %r'
              % (num, divsum, sorted(proper_divs(num)), sorted(proper_divs(divsum))))


  [ properdivisors
    dup size 0 = iff
      [ drop 0 ] done
    behead swap witheach + ] is spd           ( n --> n )

  [ dup dup spd dup spd
    rot = unrot > and ]      is largeamicable ( n --> b )

  [ [] swap times
      [ i^ largeamicable if
        [ i^ dup spd
          swap join
          nested join ] ] ]  is amicables     ( n --> [ )

  20000 amicables witheach [ witheach [ echo sp ] cr ]


#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)


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;
        }
    }
}


F amb(comp, options, prev = ‘’) -> Array[String]
   I options.empty
      R []

   L(opt) options[0]
      // If this is the base call, prev is empty and we need to continue.
      I prev != ‘’ & !comp(prev, opt)
         L.continue

      // Take care of the case where we have no options left.
      I options.len == 1
         R [opt]

      // Traverse into the tree.
      V res = amb(comp, options[1..], opt)

      // If it was a failure, try the next one.
      if !res.empty
         R opt [+] res // We have a match

   R []

V sets = [[‘the’, ‘that’, ‘a’],
          [‘frog’, ‘elephant’, ‘thing’],
          [‘walked’, ‘treaded’, ‘grows’],
          [‘slowly’, ‘quickly’]]

V result = amb((s, t) -> s.last == t[0], sets)
print(result.join(‘ ’))


(defun anagrams (&optional (url "http://wiki.puzzlers.org/pub/wordlists/unixdict.txt"))
  (let ((words (drakma:http-request url :want-stream t))
        (wordsets (make-hash-table :test 'equalp)))
    ;; populate the wordsets and close stream
    (do ((word (read-line words nil nil) (read-line words nil nil)))
        ((null word) (close words))
      (let ((letters (sort (copy-seq word) 'char<)))
        (multiple-value-bind (pair presentp)
            (gethash letters wordsets)
          (if presentp
           (setf (car pair) (1+ (car pair))
                 (cdr pair) (cons word (cdr pair)))
           (setf (gethash letters wordsets)
                 (cons 1 (list word)))))))
    ;; find and return the biggest wordsets
    (loop with maxcount = 0 with maxwordsets = '()
          for pair being each hash-value of wordsets
          if (> (car pair) maxcount)
          do (setf maxcount (car pair)
                   maxwordsets (list (cdr pair)))
          else if (eql (car pair) maxcount)
          do (push (cdr pair) maxwordsets)
          finally (return (values maxwordsets maxcount)))))


divisors <- function (n) {
  Filter( function (m) 0 == n %% m, 1:(n/2) )
}

table = sapply(1:19999, function (n) sum(divisors(n)) )

for (n in 1:19999) {
  m = table[n]
  if ((m > n) && (m < 20000) && (n == table[m]))
    cat(n, " ", m, "\n")
}


#lang racket
(require "proper-divisors.rkt")
(define SCOPE 20000)

(define P
  (let ((P-v (vector)))
    (λ (n)
      (set! P-v (fold-divisors P-v n 0 +))
      (vector-ref P-v n))))

;; returns #f if not an amicable number, amicable pairing otherwise
(define (amicable? n)
  (define m (P n))
  (define m-sod (P m))
  (and (= m-sod n)
       (< m n) ; each pair exactly once, also eliminates perfect numbers
       m))

(void (amicable? SCOPE)) ; prime the memoisation

(for* ((n (in-range 1 (add1 SCOPE)))
       (m (in-value (amicable? n)))
       #:when m)
  (printf #<<EOS
amicable pair: ~a, ~a
  ~a: divisors: ~a
  ~a: divisors: ~a

EOS
          n m n (proper-divisors n)  m (proper-divisors m)))


sub propdivsum (\x) {
    my @l = 1 if x > 1;
    (2 .. x.sqrt.floor).map: -> \d {
        unless x % d { @l.push: d; my \y = x div d; @l.push: y if y != d }
    }
    sum @l
}

(1..20000).race.map: -> $i {
    my $j = propdivsum($i);
    say "$i $j" if $j > $i and $i == propdivsum($j);
}


/*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


with Ada.Strings.Unbounded;  use Ada.Strings.Unbounded;
with Ada.Text_IO;            use Ada.Text_IO;

procedure Test_Amb is
   type Alternatives is array (Positive range <>) of Unbounded_String;

   type Amb (Count : Positive) is record
      This : Positive := 1;
      Left : access Amb;
      List : Alternatives (1..Count);
   end record;

   function Image (L : Amb) return String is
   begin
      return To_String (L.List (L.This));
   end Image;

   function "/" (L, R : String) return Amb is
      Result : Amb (2);
   begin
      Append (Result.List (1), L);
      Append (Result.List (2), R);
      return Result;
   end "/";

   function "/" (L : Amb; R : String) return Amb is
      Result : Amb (L.Count + 1);
   begin
      Result.List (1..L.Count) := L.List ;
      Append (Result.List (Result.Count), R);
      return Result;
   end "/";

   function "=" (L, R : Amb) return Boolean is
      Left : Unbounded_String renames L.List (L.This);
   begin
      return Element (Left, Length (Left)) = Element (R.List (R.This), 1);
   end "=";

   procedure Failure (L : in out Amb) is
   begin
      loop
         if L.This < L.Count then
            L.This := L.This + 1;
         else
            L.This := 1;
            Failure (L.Left.all);
         end if;
         exit when L.Left = null or else L.Left.all = L;
      end loop;
   end Failure;

   procedure Join (L : access Amb; R : in out Amb) is
   begin
      R.Left := L;
      while L.all /= R loop
         Failure (R);
      end loop;
   end Join;

   W_1 : aliased Amb := "the" / "that" / "a";
   W_2 : aliased Amb := "frog" / "elephant" / "thing";
   W_3 : aliased Amb := "walked" / "treaded" / "grows";
   W_4 : aliased Amb := "slowly" / "quickly";
begin
   Join (W_1'Access, W_2);
   Join (W_2'Access, W_3);
   Join (W_3'Access, W_4);
   Put_Line (Image (W_1) & ' ' & Image (W_2) & ' ' & Image (W_3) & ' ' & Image (W_4));
end Test_Amb;


MODULE BbtAnagrams;
IMPORT StdLog,Files,Strings,Args;
CONST
	MAXPOOLSZ = 1024;

TYPE
	Node = POINTER TO LIMITED RECORD;
		count: INTEGER;
		word: Args.String;
		desc: Node;
		next: Node;
	END;

	Pool = POINTER TO LIMITED RECORD
		capacity,max: INTEGER;
		words: POINTER TO ARRAY OF Node;
	END;

	PROCEDURE NewNode(word: ARRAY OF CHAR): Node;
	VAR
		n: Node;
	BEGIN
		NEW(n);n.count := 0;n.word := word$;
		n.desc := NIL;n.next := NIL;
		RETURN n
	END NewNode;

	PROCEDURE Index(s: ARRAY OF CHAR;cap: INTEGER): INTEGER;
	VAR
		i,sum: INTEGER;
	BEGIN
		sum := 0;
		FOR i := 0 TO  LEN(s$) DO
			INC(sum,ORD(s[i]))
		END;
		RETURN sum MOD cap
	END Index;

	PROCEDURE ISort(VAR s: ARRAY OF CHAR);
	VAR
        i, j: INTEGER;
        t: CHAR;
	BEGIN
        FOR i := 0 TO LEN(s$) - 1 DO
			j := i;
			t := s[j];
			WHILE (j > 0) & (s[j -1] > t) DO
					s[j] := s[j - 1];
					DEC(j)
			END;
			s[j] := t
        END
	END ISort;

	PROCEDURE SameLetters(x,y: ARRAY OF CHAR): BOOLEAN;
	BEGIN
        ISort(x);ISort(y);
        RETURN x = y
	END SameLetters;

	PROCEDURE NewPoolWith(cap: INTEGER): Pool;
	VAR
		i: INTEGER;
		p: Pool;
	BEGIN
		NEW(p);
		p.capacity := cap;
		p.max := 0;
		NEW(p.words,cap);
		i := 0;
		WHILE i < p.capacity DO
			p.words[i] := NIL;
			INC(i);
		END;
		RETURN p
	END NewPoolWith;

	PROCEDURE NewPool(): Pool;
	BEGIN
		RETURN NewPoolWith(MAXPOOLSZ);
	END NewPool;

	PROCEDURE (p: Pool) Add(w: ARRAY OF CHAR), NEW;
	VAR
		idx: INTEGER;
		iter,n: Node;
	BEGIN
		idx := Index(w,p.capacity);
		iter := p.words[idx];
		n := NewNode(w);
		WHILE(iter # NIL) DO
			IF SameLetters(w,iter.word) THEN
				INC(iter.count);
				IF iter.count > p.max THEN p.max := iter.count END;
				n.desc := iter.desc;
				iter.desc := n;
				RETURN
			END;
			iter := iter.next
		END;
		ASSERT(iter = NIL);
		n.next := p.words[idx];p.words[idx] := n
	END Add;

	PROCEDURE ShowAnagrams(l: Node);
	VAR
		iter: Node;
	BEGIN
		iter := l;
		WHILE iter # NIL DO
			StdLog.String(iter.word);StdLog.String(" ");
			iter := iter.desc
		END;
		StdLog.Ln
	END ShowAnagrams;

	PROCEDURE (p: Pool) ShowMax(),NEW;
	VAR
		i: INTEGER;
		iter: Node;
	BEGIN
		FOR i := 0 TO LEN(p.words) - 1 DO
			IF p.words[i] # NIL THEN
				iter := p.words^[i];
				WHILE iter # NIL DO
					IF iter.count = p.max THEN
						ShowAnagrams(iter);
					END;
					iter := iter.next
				END
			END
		END
	END ShowMax;

	PROCEDURE GetLine(rd: Files.Reader; OUT str: ARRAY OF CHAR);
	VAR
		i: INTEGER;
		b: BYTE;
	BEGIN
		rd.ReadByte(b);i := 0;
		WHILE (~rd.eof) & (i < LEN(str)) DO
			IF (b = ORD(0DX)) OR (b = ORD(0AX)) THEN str[i] := 0X; RETURN  END;
			str[i] := CHR(b);
			rd.ReadByte(b);INC(i)
		END;
		str[LEN(str) - 1] := 0X
	END GetLine;

	PROCEDURE DoProcess*;
	VAR
		params : Args.Params;
		loc: Files.Locator;
		fd: Files.File;
		rd: Files.Reader;
		line: ARRAY 81 OF CHAR;
		p: Pool;
	BEGIN
		Args.Get(params);
		IF params.argc = 1 THEN
		  loc := Files.dir.This("Bbt");
			fd := Files.dir.Old(loc,params.args[0]$,FALSE);
			StdLog.String("Processing: " + params.args[0]);StdLog.Ln;StdLog.Ln;
			rd := fd.NewReader(NIL);
			p := NewPool();
			REPEAT
				GetLine(rd,line);
				p.Add(line);
			UNTIL rd.eof;
			p.ShowMax()
		ELSE
			StdLog.String("Error: Missing file to process");StdLog.Ln
		END;
	END DoProcess;

END BbtAnagrams.


;- based on Lua code ;-)

sum-of-divisors: func[n /local sum][
    sum: 1
    ; using `to-integer` for compatibility with Rebol2
    for d 2 (to-integer square-root n) 1 [
        if 0 = remainder n d [ sum: n / d + sum + d ]
    ]
    sum
]

for n 2 20000 1 [
    if n < m: sum-of-divisors n [
        if n = sum-of-divisors m [ print [n tab m] ]
    ]
]


let isqrt = (v) => {
  Belt.Float.toInt(
    sqrt(Belt.Int.toFloat(v)))
}

let sum_divs = (n) => {
  let sum = ref(1)
  for d in 2 to isqrt(n) {
    if mod(n, d) == 0 {
      sum.contents = sum.contents + (n / d + d)
    }
  }
  sum.contents
}

{
  for n in 2 to 20000 {
    let m = sum_divs(n)
    if (m > n) {
      if sum_divs(m) == n {
        Printf.printf("%d %d\n", n, m)
      }
    }
  }
}


/*REXX*/

Call time 'R'
Do x=1 To 20000
  pd=proper_divisors(x)
  sumpd.x=sum(pd)
  End
Say 'sum(pd) computed in' time('E') 'seconds'
Call time 'R'
Do x=1 To 20000
  /* If x//1000=0 Then Say x time() */
  Do y=x+1 To 20000
    If y=sumpd.x &,
       x=sumpd.y Then
    Say x y 'found after' time('E') 'seconds'
    End
  End
Say time('E') 'seconds total search time'
Exit

proper_divisors: Procedure
Parse Arg n
Pd=''
If n=1 Then Return ''
If n//2=1 Then  /* odd number  */
  delta=2
Else            /* even number */
  delta=1
Do d=1 To n%2 By delta
  If n//d=0 Then
    pd=pd d
  End
Return space(pd)

sum: Procedure
Parse Arg list
sum=0
Do i=1 To words(list)
  sum=sum+word(list,i)
  End
Return sum


# 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


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


MODE PAGE = FLEX[0]STRING;
MODE YIELDPAGE = PROC(PAGE)VOID;
MODE ITERPAGE = PROC(YIELDPAGE)VOID;

OP INITITERPAGE = (PAGE self)ITERPAGE:
  (YIELDPAGE yield)VOID: # scope violation #
    FOR i TO UPB self DO
      yield(self[i])
    OD;

OP + = (ITERPAGE for strings, PAGE b)ITERPAGE:
  (YIELDPAGE yield)VOID: # scope violation #
    for strings((PAGE amb)VOID:(
      [UPB amb + 1]STRING joined;
      joined[:UPB amb] := amb;
      STRING last string := amb[UPB amb];
      CHAR last char := last string[UPB last string];
      FOR i TO UPB b DO
        IF last char = b[i][1] THEN
          joined[UPB joined] := b[i];
          yield(joined)
        FI
      OD
    ));

OP + = (PAGE a, PAGE b)ITERPAGE: INITITERPAGE a + b;

ITERPAGE gen amb :=
   PAGE("the", "that", "a") +
   PAGE("frog", "elephant", "thing") +
   PAGE("walked", "treaded", "grows") +
   PAGE("slowly", "quickly");

PAGE sep;
#FOR PAGE amb IN # gen amb( # ) DO #
##  (PAGE amb)VOID:
    print((amb[1]+" "+amb[2]+" "+amb[3]+" "+amb[4], new line))
#OD# )


require "http/client"

response = HTTP::Client.get("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt")

if response.body?
  words : Array(String) = response.body.split

  anagram = {} of String => Array(String)

  words.each do |word|
    key = word.split("").sort.join

    if !anagram[key]?
      anagram[key] = [word]
    else
      anagram[key] << word
    end
  end

  count = anagram.values.map { |ana| ana.size }.max
  anagram.each_value { |ana| puts ana if ana.size >= count }
end


size = 18500
for n = 1 to size
    m = amicable(n)
    if m>n and amicable(m)=n
       see "" + n + " and " + m + nl ok
next
see "OK" + nl

func amicable nr
     sum = 1
     for d = 2 to sqrt(nr)
         if nr % d = 0
            sum = sum + d
            sum = sum + nr / d ok
     next
     return sum


h = {}
(1..20_000).each{|n| h[n] = n.proper_divisors.sum }
h.select{|k,v| h[v] == k && k < v}.each do |key,val|  # k<v filters out doubles and perfects
  puts "#{key} and #{val}"
end


size = 18500
for n = 1 to size
    m = amicable(n)
    if m > n and amicable(m) = n then print  n ; " and " ; m
next

function amicable(nr)
     amicable = 1
     for d = 2 to sqr(nr)
         if nr mod d = 0 then amicable = amicable + d + nr / d
     next
 end function


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


//! 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)
    }
}


(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
#include
"share/HATS/atspre_staload_libats_ML.hats"
//
(* ****** ****** *)
//
staload "libats/ML/SATS/monad_list.sats"
staload _ = "libats/ML/DATS/monad_list.dats"
//
(* ****** ****** *)
//
datatype
words =
  | Sing of stringGt(0)
  | Comb of (words, words)
//
(* ****** ****** *)
//
extern
fun words_get_beg(words): char
extern
fun words_get_end(words): char
//
(* ****** ****** *)
//
implement
words_get_beg(w0) =
(
case+ w0 of
| Sing(cs) => cs[0]
| Comb(w1, w2) => words_get_beg(w1)
)
//
implement
words_get_end(w0) =
(
case+ w0 of
| Sing(cs) => cs[pred(length(cs))]
| Comb(w1, w2) => words_get_end(w2)
)
//
(* ****** ****** *)
//
fun
words_comb
(
  w1: words, w2: words
) : list0(words) =
  if (words_get_end(w1)=words_get_beg(w2))
    then list0_sing(Comb(w1, w2)) else list0_nil()
//
(* ****** ****** *)
//
extern
fun
fprint_words: fprint_type(words)
//
overload fprint with fprint_words
//
implement
fprint_words(out, ws) =
(
case+ ws of
| Sing(w) => fprint(out, w)
| Comb(w1, w2) => fprint!(out, w1, ' ', w2)
)
//
implement fprint_val<words> = fprint_words
//
(* ****** ****** *)
//
typedef
a = stringGt(0) and b = words
//
val ws1 =
  $list{a}("this", "that", "a")
val ws1 =
  list_map_fun(ws1, lam(x) => Sing(x))
val ws1 = monad_list_list(list0_of_list_vt(ws1))
//
val ws2 =
  $list{a}("frog", "elephant", "thing")
val ws2 =
  list_map_fun(ws2, lam(x) => Sing(x))
val ws2 = monad_list_list(list0_of_list_vt(ws2))
//
val ws3 =
  $list{a}("walked", "treaded", "grows")
val ws3 =
  list_map_fun(ws3, lam(x) => Sing(x))
val ws3 = monad_list_list(list0_of_list_vt(ws3))
//
val ws4 =
  $list{a}("slowly", "quickly")
val ws4 =
  list_map_fun(ws4, lam(x) => Sing(x))
val ws4 = monad_list_list(list0_of_list_vt(ws4))
//
(* ****** ****** *)
//
val
ws12 =
monad_bind2
  (ws1, ws2, lam (w1, w2) => monad_list_list(words_comb(w1, w2)))
val
ws123 =
monad_bind2
  (ws12, ws3, lam (w12, w3) => monad_list_list(words_comb(w12, w3)))
val
ws1234 =
monad_bind2
  (ws123, ws4, lam (w123, w4) => monad_list_list(words_comb(w123, w4)))
//
(* ****** ****** *)

implement main0 () =
{
  val () = fprintln! (stdout_ref, "ws1234 = ", ws1234)
}

(* ****** ****** *)


set1 := "the that a"
set2 := "frog elephant thing"
set3 := "walked treaded grows"
set4 := "slowly quickly"

MsgBox % amb( "", set1, set2, set3, set4 )
; this takes a total of 17 iterations to complete

amb( char = "", set1 = "", set2 = "", set3 = "", set4 = "" )
{ ; original call to amb must leave char param blank
  Loop, Parse, set1, %A_Space%
    If (char = (idxchar := SubStr(A_LoopField, 1, 1)) && set2 = ""
    || (char = idxchar || char = "") && ((retval:= amb(SubStr(A_LoopField, 0, 1), set2, set3, set4)) != ""))
      Return A_LoopField " " retval
  Return ""
}


import std.stdio, std.algorithm, std.string, std.exception, std.file;

void main() {
    string[][ubyte[]] an;
    foreach (w; "unixdict.txt".readText.splitLines)
        an[w.dup.representation.sort().release.assumeUnique] ~= w;
    immutable m = an.byValue.map!q{ a.length }.reduce!max;
    writefln("%(%s\n%)", an.byValue.filter!(ws => ws.length == m));
}


fn sum_of_divisors(val: u32) -> u32 {
    (1..val/2+1).filter(|n| val % n == 0)
                .fold(0, |sum, n| sum + n)
}

fn main() {
    let iter = (1..20_000).map(|i| (i, sum_of_divisors(i)))
                          .filter(|&(i, div_sum)| i > div_sum);

    for (i, sum1) in iter {
        if sum_of_divisors(sum1) == i {
           println!("{} {}", i, sum1);
        }
    }
}


def properDivisors(n: Int) = (1 to n/2).filter(i => n % i == 0)
val divisorsSum = (1 to 20000).map(i => i -> properDivisors(i).sum).toMap
val result = divisorsSum.filter(v => v._1 < v._2 && divisorsSum.get(v._2) == Some(v._1))

println( result mkString ", " )


(import (scheme base)
        (scheme inexact)
        (scheme write)
        (only (srfi 1) fold))

;; return a list of the proper-divisors of n
(define (proper-divisors n)
  (let ((root (sqrt n)))
    (let loop ((divisors (list 1))
               (i 2))
      (if (> i root)
        divisors
        (loop (if (zero? (modulo n i))
                (if (= (square i) n)
                  (cons i divisors)
                  (append (list i (quotient n i)) divisors))
                divisors)
              (+ 1 i))))))

(define (sum-proper-divisors n)
  (if (< n 2)
    0
    (fold + 0 (proper-divisors n))))

(define *max-n* 20000)

;; hold sums of proper divisors in a cache, to avoid recalculating
(define *cache* (make-vector (+ 1 *max-n*)))
(for-each (lambda (i) (vector-set! *cache* i (sum-proper-divisors i)))
          (iota *max-n* 1))

(define (amicable-pair? i j)
  (and (not (= i j))
       (= i (vector-ref *cache* j))
       (= j (vector-ref *cache* i))))

;; double loop to *max-n*, displaying all amicable pairs
(let loop-i ((i 1))
  (when (<= i *max-n*)
    (let loop-j ((j i))
      (when (<= j *max-n*)
        (when (amicable-pair? i j)
          (display (string-append "Amicable pair: "
                                  (number->string i)
                                  " "
                                  (number->string j)))
          (newline))
        (loop-j (+ 1 j))))
    (loop-i (+ 1 i))))


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)
  }

}


DECLARE (*ambassert)() TYPE NUMBER

FUNCTION amb_recurse$(text$[], nr, total, result$)

    LOCAL ctr
    LOCAL str$, test$

    FOR ctr = 1 TO AMOUNT(text$[nr])
        str$ = APPEND$(result$, 0, TOKEN$(text$[nr], ctr))
        IF nr = total-1 THEN
            IF ambassert(str$) THEN RETURN str$
        ELSE
            test$ = amb_recurse$(text$, nr+1, total, str$)
            IF AMOUNT(test$) = total THEN RETURN test$
        ENDIF
    NEXT

    RETURN ""

ENDFUNC

FUNCTION ambsel$(VAR data$ SIZE dim)

    RETURN IIF$(dim < 2, "ambsel$ needs more than 1 argument", amb_recurse$(data$, 0, dim, ""))

ENDFUNC

FUNCTION this_is_some_constraint(var$)

    DOTIMES AMOUNT(var$)-1
        IF RIGHT$(TOKEN$(var$, _), 1) != LEFT$(TOKEN$(var$, _+1), 1) THEN RETURN FALSE
    DONE

    RETURN TRUE

ENDFUNC

' AMBASSERT: pointing to a constraint function
ambassert = this_is_some_constraint

' AMBSEL$: generate result from arguments in delimited string format
PRINT ambsel$("the that a", "frog elephant thing", "walked treaded grows", "slowly quickly")


( ( Amb
  =   first last list words word solution
    .   !arg:(?first.?list)
      & ( !list:
        |   !list:(.?words) ?list
          &   !words
            :   ?
                %( @(?word:!first ? @?last)
                 & Amb$(!last.!list):?solution
                 & !word !solution:?solution
                 )
                ?
          & !solution
        )
  )
&   Amb
  $ (
    .   (.the that a)
        (.frog elephant thing)
        (.walked treaded grows)
        (.slowly quickly)
    )
)


program AnagramsTest;

{$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 Split(s: string; var Count: Integer; var words: string): Boolean;
var
  sCount: string;
begin
  sCount := s.Substring(0, 4);
  words := s.Substring(5);
  Result := TryStrToInt(sCount, Count);
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;

var
  Dict: TStringList;
  i, j, Count, MaxCount, WordLength, Index: Integer;
  words: string;
  StopWatch: TStopwatch;

begin
  StopWatch := TStopwatch.Create;
  StopWatch.Start;

  Dict := TStringList.Create();
  Dict.LoadFromFile('unixdict.txt');

  Dict.CustomSort(CompareLength);

  Index := 0;
  words := Dict[Index];
  Count := 1;

  while Index + Count < Dict.Count do
  begin
    if IsAnagram(Dict[Index], Dict[Index + Count]) then
    begin
      words := words + ',' + Dict[Index + Count];
      Dict[Index + Count] := '';
      inc(Count);
    end
    else
    begin
      Dict[Index] := format('%.4d', [Count]) + ',' + words;
      inc(Index, Count);
      words := Dict[Index];
      Count := 1;
    end;
  end;

  // The last one not match any one
  if not Dict[Dict.count - 1].IsEmpty then
    Dict.Delete(Dict.count - 1);

  Dict.Sort;

  while Dict[0].IsEmpty do
    Dict.Delete(0);

  StopWatch.Stop;

  Writeln(Format('Time pass: %d ms [i7-4500U Windows 7]', [StopWatch.ElapsedMilliseconds]));

  Split(Dict[Dict.count - 1], MaxCount, words);
  writeln(#10'The anagrams that contain the most words, has ', MaxCount, ' words:'#10);
  writeln('Words found:'#10);

  Writeln('  ', words);

  for i := Dict.Count - 2 downto 0 do
  begin
    Split(Dict[i], Count, words);
    if Count = MaxCount then
      Writeln('  ', words)
    else
      Break;
  end;

  Dict.Free;
  Readln;
end.


func propdivsum(n) {
    n.sigma - n
}

for i in (1..20000) {
    var j = propdivsum(i)
    say "#{i} #{j}" if (j>i && i==propdivsum(j))
}


import func Darwin.sqrt

func sqrt(x:Int) -> Int { return Int(sqrt(Double(x))) }

func properDivs(n: Int) -> [Int] {

    if n == 1 { return [] }

    var result = [Int]()

    for div in filter (1...sqrt(n), { n % $0 == 0 }) {

        result.append(div)

        if n/div != div && n/div != n { result.append(n/div) }
    }

    return sorted(result)

}

func sumDivs(n:Int) -> Int {

    struct Cache { static var sum = [Int:Int]() }

    if let sum = Cache.sum[n] { return sum }

    let sum = properDivs(n).reduce(0) { $0 + $1 }

    Cache.sum[n] = sum

    return sum
}

func amicable(n:Int, m:Int) -> Bool {

    if n == m { return false }

    if sumDivs(n) != m || sumDivs(m) != n { return false }

    return true
}

var pairs = [(Int, Int)]()

for n in 1 ..< 20_000 {
    for m in n+1 ... 20_000 {
        if amicable(n, m) {
            pairs.append(n, m)
            println("\(n, m)")
        }
    }
}