/* ARM assembly Raspberry PI  */
/*  program anaderan.s   */

 /* REMARK 1 : this program use routines in a include file
   see task Include a file language arm assembly
   for the routine affichageMess conversion10
   see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */
/************************************/
/* Constantes                       */
/************************************/
.include "../constantes.inc"

.equ MAXI,         50000
.equ BUFFERSIZE,   300000
.equ READ, 3                            @ system call
.equ OPEN, 5                            @ system call
.equ CLOSE, 6                           @ system call
.equ O_RDWR,  0x0002                    @ open for reading and writing

/*********************************/
/* Structures                    */
/*********************************/
/* this structure has size multiple de 4 */
    .struct  0
Word_Ptr_buffer:                           @ pointer word buffer
    .struct  Word_Ptr_buffer + 4
Word_Ptr_sorted:                           @ pointer word sorted letters
    .struct  Word_Ptr_sorted + 4
Word_length:                               @ word length
    .struct  Word_length + 4
Word_top:                                  @ top
    .struct  Word_top + 4
Word_end:
/*********************************/
/* Initialized data              */
/*********************************/
.data
szFileName:           .asciz "./unixdict.txt"
//szFileName:           .asciz "./listwordT.txt"
szMessErreur:         .asciz "FILE ERROR."
szMessStart:          .asciz "Program 32 bits start.\n"
szCarriageReturn:     .asciz "\n"
szMessSpace:          .asciz " "

ptBuffer1:            .int sBuffer1
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
tbStWords:                  .skip Word_end * MAXI
iNBword:                    .skip 4
sBuffer:                    .skip BUFFERSIZE
sBuffer1:                   .skip BUFFERSIZE

/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                      @ entry of program
    ldr r0,iAdrszMessStart
    bl affichageMess
    mov r4,#0              @ loop indice
    ldr r0,iAdrszFileName  @ file name
    mov r1,#O_RDWR         @ flags
    mov r2,#0              @ mode
    mov r7,#OPEN           @
    svc 0
    cmp r0,#0              @ error open
    ble 99f
    mov r8,r0              @ FD save Fd
    ldr r1,iAdrsBuffer     @ buffer address
    ldr r2,iSizeBuf        @ buffersize
    mov r7, #READ
    svc 0
    cmp r0,#0              @ error read ?
    blt 99f
    mov r5,r0              @ save size read bytes
    ldr r4,iAdrsBuffer     @ buffer address
    ldr r0,iAdrsBuffer     @ start word address
    mov r2,#0
    mov r1,#0              @ word length
1:
    cmp r2,r5
    bge 2f
    ldrb r3,[r4,r2]
    cmp r3,#0xD            @ end word ?
    addne r1,r1,#1         @ increment word length
    addne r2,r2,#1         @ increment indice
    bne 1b                 @ and loop
    mov r3,#0
    strb r3,[r4,r2]        @ store final zero
    bl anaWord             @ sort word letters
    add r2,r2,#2           @ jump OD and 0A
    add r0,r4,r2           @ new address begin word
    mov r1,#0              @ init length
    b 1b                   @ and loop

2:
    mov r3,#0              @ last word
    strb r3,[r4,r2]
    bl anaWord

    mov r0,r8              @ file Fd
    mov r7, #CLOSE
    svc 0
    cmp r0,#0              @ error close ?
    blt 99f

    ldr r0,iAdrtbStWords   @ array structure words address
    mov r1,#0              @ first indice
    ldr r2,iAdriNBword
    ldr r2,[r2]            @ last indice
    bl triRapide           @ quick sort
    ldr r4,iAdrtbStWords   @ array structure words address

    mov r0,r4
    mov r9,r2                     @ size word array
    mov r8,#0                     @ indice first occurence
    ldr r3,[r4,#Word_Ptr_sorted]  @ load first value
    mov r2,#1                     @ loop indice
    mov r10,#Word_end             @ words structure size
    mov r12,#0                    @ max word length
3:                                @ begin loop
    mla r7,r2,r10,r4              @ compute array index
    ldr r5,[r7,#Word_Ptr_sorted]  @ load next value
    mov r0,r3
    mov r1,r5
    bl comparStrings
    cmp r0,#0                     @ sorted strings equal ?
    bne 4f
    mla r11,r8,r10,r4
    ldr r0,[r11,#Word_Ptr_buffer] @ address word 1
    ldr r1,[r7,#Word_Ptr_buffer]  @ address word 2
    bl controlLetters
    cmp r0,#0                     @ not ok ?
    beq 5f
    mov r0,#1                     @ letters ok
    str r0,[r7,#Word_top]         @ store top in first occurence
    str r0,[r11,#Word_top]        @ store top in current occurence
    ldr r0,[r7,#Word_length]      @ word length
    cmp r0,r12                    @ compare maxi
    movgt r12,r0                  @ yes  length word -> value max
    b 5f
4:                                @ no
    mov r0,r8
    add r8,r8,#1                  @ init index  new first occurence
    mla r11,r8,r10,r4             @ compute array index
    ldr r3,[r11,#Word_Ptr_sorted] @ init value new first occurence
    mov r2,r0                     @ reprise au debut de la sequence
5:
    add r2,r2,#1                  @ increment indice
    cmp r2,r9                     @ end word array ?
    blt 3b                        @ no -> loop

    mov r2,#0                     @ raz indice
    ldr r4,iAdrtbStWords          @ array structure words address
6:                                @ begin display loop
    mla r11,r2,r10,r4             @ compute array index
    ldr r6,[r11,#Word_top]        @ load top
    cmp r6,#0                     @ top ok ?
    beq 7f
    ldr r6,[r11,#Word_length]     @ load length
    cmp r6,r12                    @ compare maxi
    bne 7f
    ldr r0,[r11,#Word_Ptr_buffer] @ load address first word
    bl affichageMess              @ display first word
    add r2,r2,#1                  @ increment indice

    mla r11,r2,r10,r4             @ compute array index
    ldr r6,[r11,#Word_top]        @ load top
    cmp r6,#0                     @ top ok ?
    beq 7f
    ldr r0,iAdrszMessSpace
    bl affichageMess
    ldr r0,[r11,#Word_Ptr_buffer] @ load address other word
    bl affichageMess              @ display second word

    ldr r0,iAdrszCarriageReturn
    bl affichageMess
7:
    add r2,r2,#1                  @ increment indice
    cmp r2,r9                     @ maxi ?
    blt 6b                        @ no -> loop

    b 100f
99:                               @ display error
    ldr r1,iAdrszMessErreur
    bl displayError

100:                              @ standard end of the program
    mov r0, #0                    @ return code
    mov r7, #EXIT                 @ request to exit program
    svc #0                        @ perform the system call
iAdrszCarriageReturn:        .int szCarriageReturn
iAdrszFileName:              .int szFileName
iAdrszMessErreur:            .int szMessErreur
iAdrsBuffer:                 .int sBuffer
iSizeBuf:                    .int BUFFERSIZE
iAdrszMessSpace:             .int szMessSpace
iAdrtbStWords:               .int tbStWords
iAdrszMessStart:             .int szMessStart
/******************************************************************/
/*     analizing word                                   */
/******************************************************************/
/*  r0  word address */
/*  r1 word length   */
anaWord:
    push {r1-r6,lr}
    mov r5,r0
    mov r6,r1
    //ldr r1,iAdrptTabBuffer
    ldr r1,iAdrtbStWords
    ldr r2,iAdriNBword
    ldr r3,[r2]
    mov r4,#Word_end
    mla r1,r3,r4,r1
    str r0,[r1,#Word_Ptr_buffer]
    mov r0,#0
    str r0,[r1,#Word_top]
    str r6,[r1,#Word_length]
    ldr r4,iAdrptBuffer1
    ldr r0,[r4]
    add r6,r6,r0
    add r6,r6,#1
    str r6,[r4]
    str r0,[r1,#Word_Ptr_sorted]

    add r3,r3,#1
    str r3,[r2]
    mov r1,r0
    mov r0,r5
    bl triLetters         @ sort word letters
    mov r2,#0
100:
    pop {r1-r6,pc}
iAdriNBword:            .int iNBword
iAdrptBuffer1:          .int ptBuffer1
/******************************************************************/
/*     sort word letters                                  */
/******************************************************************/
/* r0  address begin word */
/* r1  address recept array */
triLetters:
    push {r1-r7,lr}
    mov r2,#0
1:
    ldrb r3,[r0,r2]         @ load letter
    cmp r3,#0               @ end word ?
    beq 6f
    cmp r2,#0               @ first letter ?
    bne 2f
    strb r3,[r1,r2]         @ yes store in first position
    add r2,r2,#1            @ increment indice
    b 1b                    @ and loop
2:
    mov r4,#0
3:                          @ begin loop to search insertion position
    ldrb r5,[r1,r4]         @ load letter
    cmp r3,r5               @ compare
    blt 4f                  @ to low -> insertion
    add r4,r4,#1            @ increment indice
    cmp r4,r2               @ compare to letters number in place
    blt 3b                  @ search loop
    strb r3,[r1,r2]         @ else store in last position
    add r2,r2,#1
    b 1b                    @ and loop
4:                          @ move first letters in one position
    sub r6,r2,#1            @ start indice
5:
    ldrb r5,[r1,r6]         @ load letter
    add r7,r6,#1            @ store indice - 1
    strb r5,[r1,r7]         @ store letter
    sub r6,r6,#1            @ decrement indice
    cmp r6,r4               @ end ?
    bge 5b                  @ no loop
    strb r3,[r1,r4]         @ else store letter in free position
    add r2,r2,#1
    b 1b                    @ and loop
6:
    mov r3,#0               @ final zéro
    strb r3,[r1,r2]
100:
    pop {r1-r7,pc}
/******************************************************************/
/*     control letters                                  */
/******************************************************************/
/* r0  address  word 1*/
/* r1  address  word 2 */
controlLetters:
    push {r1-r4,lr}
    mov r2,#0
1:
    ldrb r3,[r0,r2]      @ load a letter
    cmp r3,#0            @ end word ?
    moveq r0,#1          @  yes it is OK
    beq 100f
    ldrb r4,[r1,r2]      @ load a letter word 2 same position
    cmp r3,r4            @ equal ?
    moveq r0,#0          @ yes -> not good
    beq 100f
    add r2,r2,#1
    b 1b
100:
    pop {r1-r4,pc}
/***************************************************/
/*   Appel récursif Tri Rapide quicksort           */
/***************************************************/
/* r0 contains the address of table */
/* r1 contains index of first item  */
/* r2 contains the number of elements  > 0  */
triRapide:
    push {r2-r5,lr}         @ save registers
    sub r2,#1               @ last item index
    cmp r1,r2               @ first > last ?
    bge 100f                @ yes -> end
    mov r4,r0               @ save r0
    mov r5,r2               @ save r2
    bl partition1           @ cutting into 2 parts
    mov r2,r0               @ index partition
    mov r0,r4               @ table address
    bl triRapide            @ sort lower part
    mov r0,r4               @ table address
    add r1,r2,#1            @ index begin = index partition + 1
    add r2,r5,#1            @ number of elements
    bl triRapide            @ sort higter part

 100:                       @ end function
    pop {r2-r5,lr}          @ restaur  registers
    bx lr                   @ return

/******************************************************************/
/*      Partition table elements                                */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains index of first item  */
/* r2 contains index of last item   */
partition1:
    push {r1-r9,lr}        @ save registers
    mov r8,r0               @ save address table 2
    mov r7,r2
    mov r9,#Word_end
    mla r3,r7,r9,r8
    ldr r6,[r3,#Word_Ptr_sorted]  @ load string address last index
    mov r4,r1               @ init with first index
    mov r5,r1               @ init with first index
1:                          @ begin loop
    mla r3,r5,r9,r8
    ldr r0,[r3,#Word_Ptr_sorted]   @ load current string address
    mov r1,r6                      @ first string address
    bl comparStrings
    cmp r0,#0
    bge 2f
    mov r0,r8                @ current string < first string
    mov r1,r4                @ swap array
    mov r2,r5
    bl swapWord
    add r4,r4,#1             @ and increment index 1
2:
    add r5,r5,#1             @ increment index 2
    cmp r5,r7                @ end ?
    blt 1b                   @ no -> loop

    mov r0,r8                @ and swap array
    mov r1,r4
    mov r2,r7
    bl swapWord

    mov r0,r4                @ return index partition
100:
    pop {r1-r9,lr}
    bx lr
/******************************************************************/
/*      Swap table elements                                */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains index 1  */
/* r2 contains index  2   */
swapWord:
    push {r1-r6,lr}        @ save registers
    mov r3,#Word_end
    mla r4,r1,r3,r0        @ compute array index
    mla r5,r2,r3,r0
    mov r6,#0
1:
    ldr r2,[r4,r6]         @ load 4 bytes
    ldr r3,[r5,r6]
    str r2,[r5,r6]         @ store 4 bytes
    str r3,[r4,r6]
    add r6,r6,#4           @ increment 4 bytes
    cmp r6,#Word_end       @ structure size is multiple to 4
    blt 1b
100:
    pop {r1-r6,pc}
/************************************/
/* Strings case sensitive comparisons  */
/************************************/
/* r0 et r1 contains the address of strings */
/* return 0 in r0 if equals */
/* return -1 if string r0 < string r1 */
/* return 1  if string r0 > string r1 */
comparStrings:
    push {r1-r4}      @ save des registres
    mov r2,#0         @ counter
1:
    ldrb r3,[r0,r2]   @ byte string 1
    ldrb r4,[r1,r2]   @ byte string 2
    cmp r3,r4
    movlt r0,#-1      @ small
    movgt r0,#1       @ greather
    bne 100f          @ not equals
    cmp r3,#0         @ 0 end string
    moveq r0,#0       @ equals
    beq 100f          @ end string
    add r2,r2,#1      @ else add 1 in counter
    b 1b              @ and loop
100:
    pop {r1-r4}
    bx lr

/***************************************************/
/*      ROUTINES INCLUDE                           */
/***************************************************/
.include "../affichage.inc"


PROGRAM ALMOST_PRIME

!
! for rosettacode.org
!

!$INTEGER

PROCEDURE KPRIME(N,K->KP)
  LOCAL P,F
  FOR P=2 TO 999 DO
      EXIT IF NOT((F<K) AND (P*P<=N))
      WHILE (N MOD P)=0 DO
         N/=P
         F+=1
      END WHILE
  END FOR
  KP=(F-(N>1)=K)
END PROCEDURE

BEGIN
  PRINT(CHR$(12);)  !CLS
  FOR K=1 TO 5 DO
     PRINT("k =";K;":";)
     C=0
     FOR I=2 TO 999 DO
        EXIT IF NOT(C<10)
        KPRIME(I,K->KP)
        IF KP THEN
            PRINT(I;)
            C+=1
        END IF
     END FOR
     PRINT
  END FOR
END PROGRAM


let rec genFactor (f, n) =
    if f > n then None
    elif n % f = 0 then Some (f, (f, n/f))
    else genFactor (f+1, n)

let factorsOf (num) =
    Seq.unfold (fun (f, n) -> genFactor (f, n)) (2, num)

let kFactors k = Seq.unfold (fun n ->
    let rec loop m =
        if Seq.length (factorsOf m) = k then m
        else loop (m+1)
    let next = loop n
    Some(next, next+1)) 2

[1 .. 5]
|> List.iter (fun k ->
        printfn "%A" (Seq.take 10 (kFactors k) |> Seq.toList))


isDeranged?: function [p][
    [a,b]: p
    loop 0..dec size a 'i [
        if a\[i] = b\[i] [return false]
    ]
    return true
]

wordset: map read.lines relative "unixdict.txt" => strip

anagrams: #[]

loop wordset 'word [
    anagram: sort to [:char] word
    unless key? anagrams anagram ->
        anagrams\[anagram]: new []

    anagrams\[anagram]: anagrams\[anagram] ++ word
]

deranged: select values anagrams 'anagram [ 2 = size anagram]

maxDeranged: ["" ""]

loop deranged 'd [
    if (size first d) > size first maxDeranged [
        pair: @[first d, last d]
        if isDeranged? pair [
            maxDeranged: pair
        ]
    ]
]

print maxDeranged


Time := A_TickCount
SetWorkingDir %A_ScriptDir%  ; Ensures a consistent starting directory.
SetBatchLines   -1
Loop, Read, unixdict.txt
	StrOut .= StrLen(A_LoopReadLine) - 2 . "," . A_LoopReadLine . "`n"
Sort StrOut, N R
Loop, Parse, StrOut, `n, `r
{
	StringSplit, No_Let, A_Loopfield, `,
	if ( old1 = no_let1 )
		string .= old2 "`n"
	if ( old1 != no_let1 )
	{
		string := trim(string old2)
		if ( old2 != "" )
			Loop, Parse, string, `n, `r  ; Specifying `n prior to `r allows both Windows and Unix files to be Parsed.
				line_number := A_Index
		if ( line_number > 1 )
		{
			Loop, Parse, string, `n, `r
			{
				StringSplit, newstr, A_Loopfield, `, ; break the string based on Comma
				Loop, Parse, newstr2
					k .= A_LoopField " "
				Sort k, D%A_Space%
				k := RegExReplace( k, "\s", "" )
				file .= "`r`n" k . "," . newstr1 . "," . newstr2
				k =
			}
			Sort File
			Loop, Parse, File, `n, `r
			{
				if ( A_Loopfield != "" )
				{
					StringSplit, T_C, A_Loopfield, `,
					if ( old = T_C1 )
					{
						Loop, 1
						{
							Loop % T_C2
								if (SubStr(T_C3, A_Index, 1) = SubStr(old3, A_Index, 1))
									break 2
							Time := (A_tickcount - Time)/1000
							MsgBox % T_C3 " " old3 " in " Time . " seconds."
							ExitApp
						}
					}
					old := T_C1, old3 := T_C3
				}
			}
			file =
		}
		string =
	}
	old1 := no_let1, old2 := A_Loopfield
}


USING: formatting fry kernel lists lists.lazy locals
math.combinatorics math.primes.factors math.ranges sequences ;
IN: rosetta-code.almost-prime

: k-almost-prime? ( n k -- ? )
    '[ factors _ <combinations> [ product ] map ]
    [ [ = ] curry ] bi any? ;

:: first10 ( k -- seq )
    10 0 lfrom [ k k-almost-prime? ] lfilter ltake list>array ;

5 [1,b] [ dup first10 "K = %d: %[%3d, %]\n" printf ] each


program almost_prime
    use iso_fortran_env, only: output_unit
    implicit none

    integer :: i, c, k

    do k = 1, 5
        write(output_unit,'(A3,x,I0,x,A1,x)', advance="no") "k =", k, ":"
        i = 2
        c = 0
        do
            if (c >= 10) exit

            if (kprime(i, k)) then
                write(output_unit,'(I0,x)', advance="no") i
                c = c + 1
            end if
            i = i + 1
        end do
        write(output_unit,*)
    end do
contains
    pure function kprime(n, k)
        integer, intent(in) :: n, k
        logical             :: kprime
        integer             :: p, f, i

        kprime = .false.

        f = 0
        i = n

        do p = 2, n
            do
                if (modulo(i, p) /= 0) exit

                if (f == k) return
                f = f + 1
                i = i / p
            end do
        end do

        kprime = f==k
    end function kprime
end program almost_prime


#!/bin/gawk -f
BEGIN{
FS=""
wordcount = 0
maxlength = 0

}
# hash generates the sorted sequence of characters in a word,
# so that the hashes for a pair of anagrams will be the same.
# Example: hash meat = aemt and hash team = aemt
function hash(myword, i,letters,myhash){
  split(myword,letters,"")
  asort(letters)
  for (i=1;i<=length(myword);i++) myhash=myhash letters[i]
  return myhash
}
# deranged checks two anagrems for derangement
function deranged(worda, wordb,  a,b,i,n,len){
  n=0
  len=split(worda,a,"")
  split(wordb,b,"")
  for (i=len; i>=1; i--){
      if (a[i] == b[i]) n = n+1
  }
  return n==0
}

# field separator null makes gawk split input record character by character.
# the split function works the same way
{
  wordcount = wordcount + 1
  fullword[wordcount]=$0
  bylength[length($0)]=bylength[length($0)]  wordcount "|"
  if (length($0) > maxlength) maxlength = length($0)
}

END{
 for (len=maxlength; len>1; len--){
  numwords=split(bylength[len],words,"|")
  split("",hashed)
 split("",anagrams)
  for (i=1;i<=numwords;i++){
#   make lists of anagrams in hashed
      myword = fullword[words[i]]
      myhash = hash(myword)
      hashed[myhash] = hashed[myhash] myword " "
  }
# check anagrams for derangement
 for (myhash in hashed){
     n = split(hashed[myhash],anagrams," ")
     for (i=1; i< n; i++)
         for (j=i+1; j<=n; j++){
             if(deranged(anagrams[i],anagrams[j])) found = found anagrams[i] " " anagrams[j] " "
          }
  }
 if (length(found) > 0 ) print "deranged: " found
  if (length(found) > 0) exit
 }
}


' FB 1.05.0 Win64

Function kPrime(n As Integer, k As Integer) As Boolean
   Dim f As Integer = 0
   For i As Integer = 2 To n
     While n Mod i = 0
       If f = k Then Return false
       f += 1
       n \= i
     Wend
   Next
   Return f = k
End Function

Dim As Integer i, c, k
For k = 1 To 5
  Print "k = "; k; " : ";
  i = 2
  c = 0
  While c < 10
    If kPrime(i, k) Then
      Print Using "### "; i;
      c += 1
    End If
    i += 1
  Wend
  Print
Next

Print
Print "Press any key to quit"
Sleep


for k = 1 to 5
{
   n=2
   count = 0
   print["k=$k:"]
   do
   {
      if length[factorFlat[n]] == k
      {
         print[" $n"]
         count = count + 1
      }
      n = n + 1
   } while count < 10

   println[]
}


DECLARE idx$ ASSOC STRING

FUNCTION Deranged(a$, b$)
    FOR i = 1 TO LEN(a$)
        IF MID$(a$, i, 1) = MID$(b$, i, 1) THEN RETURN FALSE
    NEXT
    RETURN TRUE
END FUNCTION

FOR w$ IN LOAD$(DIRNAME$(ME$) & "/unixdict.txt") STEP NL$
    set$ = EXTRACT$(SORT$(EXPLODE$(w$, 1)), " ")
    idx$(set$) = APPEND$(idx$(set$), 0, w$)
NEXT

FOR w$ IN OBTAIN$(idx$)
    FOR x = 1 TO AMOUNT(idx$(w$))
        FOR y = x+1 TO AMOUNT(idx$(w$))
            IF Deranged(TOKEN$(idx$(w$), x), TOKEN$(idx$(w$), y)) AND LEN(TOKEN$(idx$(w$), x)) > current THEN
                current = LEN(TOKEN$(idx$(w$), x))
                an1$ = TOKEN$(idx$(w$), x)
                an2$ = TOKEN$(idx$(w$), y)
            END IF
        NEXT
    NEXT
NEXT

PRINT "Maximum deranged anagrams: ", an1$, " and ", an2$

PRINT NL$, "Total time: ", TIMER, " msecs.", NL$


let kprime(n: i32, k: i32): bool =
  let (p,f) = (2, 0)
  let (n,_,f) = loop (n, p, f) while f < k && p*p <= n do
    let (n,f) = loop (n, f) while 0 == n % p do
      (n/p, f+1)
    in (n, p+1, f)
  in f + (if n > 1 then 1 else 0) == k

let main(m: i32): [][]i32 =
  let f k =
    let ps = replicate 10 0
    let (_,_,ps) = loop (i,c,ps) = (2,0,ps) while c < 10 do
      if kprime(i,k) then
        unsafe let ps[c] = i
               in (i+1, c+1, ps)
      else (i+1, c, ps)
    in ps
  in map f (1...m)


package main

import "fmt"

func kPrime(n, k int) bool {
    nf := 0
    for i := 2; i <= n; i++ {
        for n%i == 0 {
            if nf == k {
                return false
            }
            nf++
            n /= i
        }
    }
    return nf == k
}

func gen(k, n int) []int {
    r := make([]int, n)
    n = 2
    for i := range r {
        for !kPrime(n, k) {
            n++
        }
        r[i] = n
        n++
    }
    return r
}

func main() {
    for k := 1; k <= 5; k++ {
        fmt.Println(k, gen(k, 10))
    }
}


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

      DIM dict$(26000), sort$(26000), indx%(26000)

      REM Load the dictionary:
      dict% = OPENIN("C:\unixdict.txt")
      IF dict%=0 ERROR 100, "No dictionary file"
      index% = 0
      REPEAT
        index% += 1
        dict$(index%) = GET$#dict%
        indx%(index%) = index%
      UNTIL EOF#dict%
      CLOSE #dict%
      Total% = index%

      TIME = 0
      REM Sort the letters in each word:
      FOR index% = 1 TO Total%
        sort$(index%) = FNsortstring(dict$(index%))
      NEXT

      REM Sort the sorted words:
      C% = Total%
      CALL Sort%, sort$(1), indx%(1)

      REM Find anagrams and deranged anagrams:
      maxlen% = 0
      maxidx% = 0
      FOR index% = 1 TO Total%-1
        IF sort$(index%) = sort$(index%+1) THEN
          One$ = dict$(indx%(index%))
          Two$ = dict$(indx%(index%+1))
          FOR c% = 1 TO LEN(One$)
            IF MID$(One$,c%,1) = MID$(Two$,c%,1) EXIT FOR
          NEXT
          IF c%>LEN(One$) IF c%>maxlen% maxlen% = c% : maxidx% = index%
        ENDIF
      NEXT

      PRINT "The longest deranged anagrams are '" dict$(indx%(maxidx%));
      PRINT "' and '" dict$(indx%(maxidx%+1)) "'"
      PRINT "(taking " ; TIME/100 " seconds)"
      END

      DEF FNsortstring(A$)
      LOCAL C%, a&()
      C% = LEN(A$)
      DIM a&(C%)
      $$^a&(0) = A$
      CALL Sort%, a&(0)
      = $$^a&(0)


  get$("unixdict.txt",STR):?wordList
& 1:?product
& :?unsorted
&   whl
  ' ( @(!wordList:(%?word:?letterString) \n ?wordList)
    & :?letterSum
    &   whl
      ' ( @(!letterString:%?letter ?letterString)
        &   (!letter:~#|str$(N !letter))+!letterSum
          : ?letterSum
        )
    & !letterSum^!word !unsorted:?unsorted
    )
& ( mergeSort
  =   newL L first second
    .   !arg:?L
      &   whl
        ' ( !L:% %
          & :?newL
          &   whl
            ' ( !L:%?first %?second ?L
              & !first*!second !newL:?newL
              )
          & !L !newL:?L
          )
      & !L
  )
& mergeSort$!unsorted:?product
& 0:?maxLength:?oldMaxLength
& :?derangedAnagrams
& ( deranged
  =   nextLetter Atail Btail
    .   !arg
      : ( (.)
        |   ( @(?:%@?nextLetter ?Atail)
            . @(?:(%@:~!nextLetter) ?Btail)
            )
          & deranged$(!Atail.!Btail)
        )
  )
& (   !product
    :   ?
      *   ?
        ^ ( %+%
          : @(%:? ([~<!maxLength:[?maxLength))+?
          :   ?
            + %@?anagramA
            + ?
            + %@?anagramB
            + ( ?
              & deranged$(!anagramA.!anagramB)
              &     (!anagramA.!anagramB)
                    (   !maxLength:>!oldMaxLength:?oldMaxLength
                      &
                    | !derangedAnagrams
                    )
                : ?derangedAnagrams
              & ~
              )
          )
      * ?
  | out$!derangedAnagrams
  );


 public class almostprime
{
public static boolean kprime(int n,int k)
  {
    int i,div=0;
     for(i=2;(i*i <= n) && (div<k);i++)
      {
        while(n%i==0)
          {
            n = n/i;
            div++;
          }
      }
   return div + ((n > 1)?1:0) == k;
  }
  public static void main(String[] args)
    {
      int i,l,k;
       for(k=1;k<=5;k++)
        {
          println("k = " + k + ":");
           l = 0;
            for(i=2;l<10;i++)
              {
                if(kprime(i,k))
                {
                  print(i + " ");
                  l++;
                }
              }
          println();
        }
     }
}


10  'Almost prime
20  FOR K% = 1 TO 5
30   PRINT "k = "; K%; ":";
40   LET I% = 2
50   LET C% = 0
60   WHILE C% < 10
70    LET AN% = I%: GOSUB 1000
80    IF ISKPRIME <> 0 THEN PRINT USING " ###"; I%;: LET C% = C% + 1
90    LET I% = I% + 1
100  WEND
110  PRINT
120 NEXT K%
130 END

995  ' Check if n (AN%) is a k (K%) prime
1000 LET F% = 0
1010 FOR J% = 2 TO AN%
1020  WHILE AN% MOD J% = 0
1030   IF F% = K% THEN LET ISKPRIME = 0: RETURN
1040   LET F% = F% + 1
1050   LET AN% = AN% \ J%
1060  WEND
1070 NEXT J%
1080 LET ISKPRIME = (F% = K%)
1090 RETURN


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <sys/types.h>
#include <fcntl.h>
#include <sys/stat.h>

// Letter lookup by frequency.  This is to reduce word insertion time.
const char *freq = "zqxjkvbpygfwmucldrhsnioate";
int char_to_idx[128];

// Trie structure of sorts
struct word {
	const char *w;
	struct word *next;
};

union node {
	union node *down[10];
	struct word *list[10];
};

int deranged(const char *s1, const char *s2)
{
	int i;
	for (i = 0; s1[i]; i++)
		if (s1[i] == s2[i]) return 0;
	return 1;
}

int count_letters(const char *s, unsigned char *c)
{
	int i, len;
	memset(c, 0, 26);
	for (len = i = 0; s[i]; i++) {
		if (s[i] < 'a' || s[i] > 'z')
			return 0;
		len++, c[char_to_idx[(unsigned char)s[i]]]++;
	}
	return len;
}

const char * insert(union node *root, const char *s, unsigned char *cnt)
{
	int i;
	union node *n;
	struct word *v, *w = 0;

	for (i = 0; i < 25; i++, root = n) {
		if (!(n = root->down[cnt[i]]))
			root->down[cnt[i]] = n = calloc(1, sizeof(union node));
	}

	w = malloc(sizeof(struct word));
	w->w = s;
	w->next = root->list[cnt[25]];
	root->list[cnt[25]] = w;

	for (v = w->next; v; v = v->next) {
		if (deranged(w->w, v->w))
			return v->w;
	}
	return 0;
}

int main(int c, char **v)
{
	int i, j = 0;
	char *words;
	struct stat st;

	int fd = open(c < 2 ? "unixdict.txt" : v[1], O_RDONLY);
	if (fstat(fd, &st) < 0) return 1;

	words = malloc(st.st_size);
	read(fd, words, st.st_size);
	close(fd);

	union node root = {{0}};
	unsigned char cnt[26];
	int best_len = 0;
	const char *b1, *b2;

	for (i = 0; freq[i]; i++)
		char_to_idx[(unsigned char)freq[i]] = i;

	/* count words, change newline to null */
	for (i = j = 0; i < st.st_size; i++) {
		if (words[i] != '\n') continue;
		words[i] = '\0';

		if (i - j > best_len) {
			count_letters(words + j, cnt);
			const char *match = insert(&root, words + j, cnt);

			if (match) {
				best_len = i - j;
				b1 = words + j;
				b2 = match;
			}
		}

		j = ++i;
	}

	if (best_len) printf("longest derangement: %s %s\n", b1, b2);

	return 0;
}


isPrime :: Integral a => a -> Bool
isPrime n = not $ any ((0 ==) . (mod n)) [2..(truncate $ sqrt $ fromIntegral n)]

primes :: [Integer]
primes = filter isPrime [2..]

isKPrime :: (Num a, Eq a) => a -> Integer -> Bool
isKPrime 1 n = isPrime n
isKPrime k n = any (isKPrime (k - 1)) sprimes
  where
    sprimes = map fst $ filter ((0 ==) . snd) $ map (divMod n) $ takeWhile (< n) primes

kPrimes :: (Num a, Eq a) => a -> [Integer]
kPrimes k = filter (isKPrime k) [2..]

main :: IO ()
main = flip mapM_ [1..5] $ \k ->
  putStrLn $ "k = " ++ show k ++ ": " ++ (unwords $ map show (take 10 $ kPrimes k))


public static void Main()
{
    var lookupTable = File.ReadLines("unixdict.txt").ToLookup(line => AnagramKey(line));
    var query = from a in lookupTable
        orderby a.Key.Length descending
        let deranged = FindDeranged(a)
        where deranged != null
        select deranged[0] + " " + deranged[1];
    Console.WriteLine(query.FirstOrDefault());
}

static string AnagramKey(string word) => new string(word.OrderBy(c => c).ToArray());

static string[] FindDeranged(IEnumerable<string> anagrams) => (
    from first in anagrams
    from second in anagrams
    where !second.Equals(first)
        && Enumerable.Range(0, first.Length).All(i => first[i] != second[i])
    select new [] { first, second })
    .FirstOrDefault();


link "factors"

procedure main()
    every writes(k := 1 to 5,": ") do
        every writes(right(genKap(k),5)\10|"\n")
end

procedure genKap(k)
    suspend (k = *factors(n := seq(q)), n)
end


#include <algorithm>
#include <fstream>
#include <functional>
#include <iostream>
#include <map>
#include <numeric>
#include <set>
#include <string>

bool is_deranged(const std::string& left, const std::string& right)
{
    return (left.size() == right.size()) &&
        (std::inner_product(left.begin(), left.end(), right.begin(), 0, std::plus<int>(), std::equal_to<char>()) == 0);
}

int main()
{
    std::ifstream input("unixdict.txt");
    if (!input) {
        std::cerr << "can't open input file\n";
        return EXIT_FAILURE;
    }

    typedef std::set<std::string> WordList;
    typedef std::map<std::string, WordList> AnagraMap;
    AnagraMap anagrams;

    std::pair<std::string, std::string> result;
    size_t longest = 0;

    for (std::string value; input >> value; /**/) {
        std::string key(value);
        std::sort(key.begin(), key.end());

        if (longest < value.length()) { // is it a long candidate?
            if (0 < anagrams.count(key)) { // is it an anagram?
                for (const auto& prior : anagrams[key]) {
                    if (is_deranged(prior, value)) { // are they deranged?
                        result = std::make_pair(prior, value);
                        longest = value.length();
                    }
                }
            }
        }
        anagrams[key].insert(value);
    }

    std::cout << result.first << ' ' << result.second << '\n';
    return EXIT_SUCCESS;
}


public class AlmostPrime {
    public static void main(String[] args) {
        for (int k = 1; k <= 5; k++) {
            System.out.print("k = " + k + ":");

            for (int i = 2, c = 0; c < 10; i++) {
                if (kprime(i, k)) {
                    System.out.print(" " + i);
                    c++;
                }
            }

            System.out.println("");
        }
    }

    public static boolean kprime(int n, int k) {
        int f = 0;
        for (int p = 2; f < k && p * p <= n; p++) {
            while (n % p == 0) {
                n /= p;
                f++;
            }
        }
        return f + ((n > 1) ? 1 : 0) == k;
    }
}


function almostPrime (n, k) {
    var divisor = 2, count = 0
    while(count < k + 1 && n != 1) {
        if (n % divisor == 0) {
            n = n / divisor
            count = count + 1
        } else {
            divisor++
        }
    }
    return count == k
}

for (var k = 1; k <= 5; k++) {
    document.write("<br>k=", k, ": ")
    var count = 0, n = 0
    while (count <= 10) {
        n++
        if (almostPrime(n, k)) {
            document.write(n, " ")
            count++
        }
    }
}


F sum_proper_divisors(n)
   R I n < 2 {0} E sum((1 .. n I/ 2).filter(it -> (@n % it) == 0))

L(n) 1..20000
   V m = sum_proper_divisors(n)
   I m > n & sum_proper_divisors(m) == n
      print(n"\t"m)


(->> (slurp "unixdict.txt") ; words
     (re-seq #"\w+")        ; |
     (group-by sort)        ; anagrams
     vals                   ; |
     (filter second)        ; |
     (remove #(some true? (apply map = %))) ; deranged
     (sort-by #(count (first %)))
     last
     prn)


# Recent versions of jq (version > 1.4) have the following definition of "until":
def until(cond; next):
  def _until:
    if cond then . else (next|_until) end;
  _until;

# relatively_prime(previous) tests whether the input integer is prime
# relative to the primes in the array "previous":
def relatively_prime(previous):
  . as $in
  | (previous|length) as $plen
  # state: [found, ix]
  |  [false, 0]
  | until( .[0] or .[1] >= $plen;
           [ ($in % previous[.[1]]) == 0, .[1] + 1] )
  | .[0] | not ;

# Emit a stream in increasing order of all primes (from 2 onwards)
# that are less than or equal to mx:
def primes(mx):

  # The helper function, next, has arity 0 for tail recursion optimization;
  # it expects its input to be the array of previously found primes:
  def next:
     . as $previous
     | ($previous | .[length-1]) as $last
     | if ($last >= mx) then empty
       else ((2 + $last)
       | until( relatively_prime($previous) ; . + 2)) as $nextp
       | if $nextp <= mx
         then $nextp, (( $previous + [$nextp] ) | next)
	 else empty
         end
       end;
  if mx <= 1 then empty
  elif mx == 2 then 2
  else (2, 3, ( [2,3] | next))
  end
;

# Return an array of the distinct prime factors of . in increasing order
def prime_factors:

  # Return an array of prime factors of . given that "primes"
  # is an array of relevant primes:
  def pf(primes):
    if . <= 1 then []
    else . as $in
    | if ($in | relatively_prime(primes)) then [$in]
      else reduce primes[] as $p
             ([];
              if ($in % $p) != 0 then .
 	      else . + [$p] +  (($in / $p) | pf(primes))
	      end)
      end
      | unique
    end;

  if . <= 1 then []
  else . as $in
  | pf( [ primes( (1+$in) | sqrt | floor)  ] )
  end;

# Return an array of prime factors of . repeated according to their multiplicities:
def prime_factors_with_multiplicities:
  # Emit p according to the multiplicity of p
  # in the input integer assuming p > 1
  def multiplicity(p):
    if   .  < p     then empty
    elif . == p     then p
    elif (. % p) == 0 then
       ((./p) | recurse( if (. % p) == 0 then (. / p) else empty end) | p)
    else empty
    end;

  if . <= 1 then []
  else . as $in
  | prime_factors as $primes
  | if ($in|relatively_prime($primes)) then [$in]
    else reduce $primes[]  as $p
           ([];
            if ($in % $p) == 0 then . + [$in|multiplicity($p)] else . end )
    end
  end;


using Primes

isalmostprime(n::Integer, k::Integer) = sum(values(factor(n))) == k

function almostprimes(N::Integer, k::Integer) # return first N almost-k primes
    P = Vector{typeof(k)}(undef,N)
    i = 0; n = 2
    while i < N
        if isalmostprime(n, k) P[i += 1] = n end
        n += 1
    end
    return P
end

for k in 1:5
    println("$k-Almost-primes: ", join(almostprimes(10, k), ", "), "...")
end


fun Int.k_prime(x: Int): Boolean {
    var n = x
    var f = 0
    var p = 2
    while (f < this && p * p <= n) {
        while (0 == n % p) { n /= p; f++ }
        p++
    }
    return f + (if (n > 1) 1 else 0) == this
}

fun Int.primes(n : Int) : List<Int> {
    var i = 2
    var list = mutableListOf<Int>()
    while (list.size < n) {
        if (k_prime(i)) list.add(i)
        i++
    }
    return list
}

fun main(args: Array<String>) {
    for (k in 1..5)
        println("k = $k: " + k.primes(10))
}


	org	100h
	;;;	Calculate proper divisors of 2..20000
	lxi	h,pdiv + 4	; 2 bytes per entry
	lxi	d,19999		; [2 .. 20000] means 19999 entries
	lxi	b,1		; Initialize each entry to 1
init:	mov	m,c
	inx	h
	mov	m,b
	inx	h
	dcx	d
	mov	a,d
	ora	e
	jnz	init
	lxi	b,1		; BC = outer loop variable
iouter:	inx	b
	lxi	h,-10001	; Are we there yet?
	dad	b
	jc	idone		; If so, we've calculated all of them
	mov	h,b
	mov	l,c
	dad	h
	xchg			; DE = inner loop variable
iinner:	push	d		; save DE
	xchg
	dad 	h		; calculate *pdiv[DE]
	lxi	d,pdiv
	dad	d
	mov	e,m		; DE = pdiv[DE]
	inx	h
	mov	d,m
	xchg			; pdiv[DE] += BC
	dad 	b
	xchg			; store it back
	mov	m,d
	dcx	h
	mov	m,e
	pop	h		; restore DE (into HL)
	dad	b		; add BC
	lxi	d,-20001	; are we there yet?
	dad	d
	jc	iouter		; then continue with outer loop
	lxi	d,20001		; otherwise continue with inner loop
	dad	d
	xchg
	jmp	iinner
idone:	lxi	b,1		; BC = outer loop variable
touter:	inx	b
	lxi	h,-20001	; Are we there yet?
	dad	b
	rc			; If so, stop
	mov	d,b		; DE = outer loop variable
	mov	e,c
tinner:	inx	d
	lxi	h,-20001	; Are we there yet?
	dad	d
	jc	touter		; If so continue with outer loop
	push	d		; Store the variables
	push	b
	mov	h,b		; find *pdiv[BC]
	mov	l,c
	dad 	b
	lxi	b,pdiv
	dad	b
	mov	a,m		; Compare low byte (to E)
	cmp	e
	jnz	tnext1		; Not equal = not amicable
	inx	h
	mov	a,m
	cmp	d		; Compare high byte (to B)
	jnz	tnext1		; Not equal = not amicable
	pop	b		; Restore BC
	xchg			; find *pdiv[DE]
	dad	h
	lxi	d,pdiv
	dad	d
	mov	a,m		; Compare low byte (to C)
	cmp	c
	jnz	tnext2		; Not equal = not amicable
	inx	h
	mov	a,m		; Compare high byte (to B)
	cmp 	b
	jnz	tnext2		; Not equal = not amicable
	pop	d		; Restore DE
	push	d		; Save them both on the stack again
	push	b
	push 	d
	mov	h,b		; Print the first number
	mov	l,c
	call	prhl
	pop 	h		; And the second number
	call	prhl
	lxi	d,nl		; And a newline
	mvi	c,9
	call 	5
tnext1:	pop	b		; Restore B
tnext2:	pop	d		; Restore D
	jmp	tinner		; Continue
	;;;	Print the number in HL
prhl:	lxi	d,nbuf		; Store buffer pointer on stack
	push 	d
	lxi	b,-10		; Divisor
pdgt:	lxi	d,-1		; Quotient
pdivlp:	inx	d
	dad	b
	jc	pdivlp
	mvi	a,'0'+10	; Make ASCII digit
	add	l
	pop	h		; Store in output buffer
	dcx	h
	mov	m,a
	push	h
	xchg			; Keep going with rest of number
	mov	a,h		; if not zero
	ora	l
	jnz	pdgt
	mvi	c,9		; CP/M call to print string
	pop	d		; Get buffer pointer
	jmp	5
	db	'*****'
nbuf:	db	' $'
nl:	db	13,10,'$'
pdiv:	equ	$		; base


LIMIT:	equ	20000		; Maximum value
	cpu	8086
	org	100h
section	.text
	mov	ax,final	; Set DS and ES to point just beyond the
	mov	cl,4		; program. We're just going to assume MS-DOS
	shr	ax,cl		; gave us enough memory. (Generally the case,
	inc	ax		; a .COM gets a 64K segment and we need ~40K.)
	mov	cx,cs
	add	ax,cx
	mov	ds,ax
	mov	es,ax
calc:	mov	ax,1		; Calculate proper divisors for 2..20000
	mov	di,4		; Initially, set each entry to 1.
	mov	cx,LIMIT-1	; 2 to 20000 inclusive = 19999 entries
	rep	stosw
	mov	ax,2		; AX = outer loop counter
	mov	cl,2
	mov	dx,LIMIT*2	; Keep inner loop limit ready in DX
	mov	bp,LIMIT/2	; And outer loop limit in BP
.outer:	mov	bx,ax		; BX = inner loop counter (multiplied by two)
	shl	bx,cl		; Each entry is 2 bytes wide
.inner:	add	[bx],ax		; divsum[BX/2] += AX
	add	bx,ax		; Advance to next entry
	add	bx,ax		; Twice, because each entry is 2 bytes wide
	cmp 	bx,dx		; Are we there yet?
	jbe	.inner 		; If not, keep going
	inc	ax
	cmp	ax,bp		; Is the outer loop done yet?
	jbe	.outer		; If not, keep going
show:	mov	dx,LIMIT	; Keep limit ready in DX
	mov	ax,2		; AX = outer loop counter
	mov	si,4		; SI = address for outer loop
.outer:	mov	cx,ax		; CX = inner loop counter
	inc	cx
	mov	di,cx		; DI = address for inner loop
	shl	di,1
	mov	bx,[si]		; Preload divsum[AX]
.inner: cmp	cx,bx		; CX == divsum[AX]?
	jne	.next		; If not, the pair is not amicable
	cmp	ax,[di]		; AX == divsum[CX]?
	jne	.next		; If not, the pair is not amicable
	push	ax		; Keep the registers
	push 	bx
	push	cx
	push 	dx
	push	cx		; And CX twice because we need to print it
	call	prax		; Print the first number
	pop	ax
	call	prax		; And the second number
	mov	dx,nl		; And a newline
	call	pstr
	pop	dx		; Restore the registers
	pop 	cx
	pop 	bx
	pop	ax
.next:	inc	di		; Increment inner loop variable and address
	inc	di		; Address twice because each entry has 2 bytes
	inc	cx
	cmp	cx,dx		; Are we done yet?
	jbe	.inner		; If not, keep going
	inc	si		; Increment outer loop variable and address
	inc	si		; Address twice because each entry has 2 bytes
	inc	ax
	cmp	ax,dx		; Are we done yet?
	jbe	.outer		; If not, keep going.
	ret
	;;;	Print the number in AX. Destroys AX, BX, CX, DX.
prax:	mov	cx,10		; Divisor
	mov	bx,nbuf		; Buffer pointer
.digit:	xor 	dx,dx
	div	cx		; Divide by 10 and extract digit
	add	dl,'0'		; Add ASCII 0 to digit
	dec	bx
	mov	[cs:bx],dl 	; Store in string
	test	ax,ax		; Any more?
	jnz	.digit		; If so, keep going
	mov	dx,bx		; If not, print the result
	;;;	Print string from CS.
pstr:	push	ds		; Save DS
	mov	ax,cs		; Set DS to CS
	mov	ds,ax
	mov	ah,9		; Print string using MS-DOS
	int	21h
	pop	ds		; Restore DS
	ret
	db	'*****'
nbuf:	db	' $'
nl:	db	13,10,'$'
final:	equ	$


      ******************************************************************
      * COBOL solution to Anagrams Deranged challange
      * The program was run on OpenCobolIDE
      * Input data is stored in file 'Anagrams.txt' on my PC
      ******************************************************************
       IDENTIFICATION DIVISION.
       PROGRAM-ID. DERANGED.

       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT IN-FILE ASSIGN TO 'C:\Both\Rosetta\Anagrams.txt'
               ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.
       FILE SECTION.
       FD IN-FILE.
       01 IN-RECORD                PIC X(22).

       WORKING-STORAGE SECTION.
       01  SWITCHES.
           05 WS-EOF               PIC X       VALUE 'N'.
           05 WS-FND               PIC X       VALUE 'N'.
           05 WS-EXIT              PIC X       VALUE 'N'.

       01 COUNTERS.
           05 WS-TOT-RECS          PIC 9(5)    COMP-3  VALUE 0.
           05 WS-SEL-RECS          PIC 9(5)    COMP-3  VALUE 0.
           05 WT-REC-NBR           PIC 9(5)    COMP-3  VALUE 0.

      * Extra byte to guarentee a space at end - needed in sort logic.
       01 WS-WORD-TEMP             PIC X(23).
       01 FILLER REDEFINES WS-WORD-TEMP.
           05   WS-LETTER  OCCURS 23 TIMES PIC X.
       77  WS-LETTER-HLD           PIC X.

       77  WS-WORD-IN              PIC X(22).
       77  WS-WORD-KEY             PIC X(22).

       01 WS-WORD-TABLE.
           05 WT-RECORD OCCURS 0 to 24000 TIMES
                   DEPENDING ON WT-REC-NBR
                   DESCENDING KEY IS WT-WORD-LEN
                   INDEXED BY WT-IDX.
               10 WT-WORD-KEY         PIC X(22).
               10 WT-WORD-LEN         PIC 9(2).
               10 WT-ANAGRAM-CNT      PIC 9(5) COMP-3.
               10 WT-ANAGRAMS OCCURS 6 TIMES.
                   15 WT-ANAGRAM      PIC X(22).

       01 WS-WORD-TEMP1             PIC X(22).
       01 FILLER REDEFINES WS-WORD-TEMP1.
           05   WS-LETTER1  OCCURS 22 TIMES PIC X.

       01 WS-WORD-TEMP2             PIC X(22).
       01 FILLER REDEFINES WS-WORD-TEMP2.
           05   WS-LETTER2  OCCURS 22 TIMES PIC X.

       77  WS-I                    PIC 99999  COMP-3.
       77  WS-J                    PIC 99999  COMP-3.
       77  WS-K                    PIC 99999  COMP-3.
       77  WS-L                    PIC 99999  COMP-3.
       77  WS-BEG                  PIC 99999  COMP-3.
       77  WS-MAX                  PIC 99999  COMP-3.

       PROCEDURE DIVISION.
       000-MAIN.
           PERFORM 100-INITIALIZE.
           PERFORM 200-PROCESS-RECORD
               UNTIL WS-EOF = 'Y'.
           SORT WT-RECORD ON DESCENDING KEY WT-WORD-LEN.
           PERFORM 500-FIND-DERANGED.
           PERFORM 900-TERMINATE.
           STOP RUN.

       100-INITIALIZE.
           OPEN INPUT IN-FILE.
           PERFORM 150-READ-RECORD.

       150-READ-RECORD.
           READ IN-FILE INTO WS-WORD-IN
               AT END
                   MOVE 'Y' TO WS-EOF
               NOT AT END
                   COMPUTE WS-TOT-RECS = WS-TOT-RECS + 1
           END-READ.

       200-PROCESS-RECORD.
           IF WS-WORD-IN IS ALPHABETIC
               COMPUTE WS-SEL-RECS = WS-SEL-RECS + 1
               MOVE WS-WORD-IN TO WS-WORD-TEMP
               PERFORM 300-SORT-WORD
               MOVE WS-WORD-TEMP TO WS-WORD-KEY
               PERFORM 400-ADD-TO-TABLE
           END-IF.

           PERFORM 150-READ-RECORD.

      * bubble sort:
       300-SORT-WORD.
           PERFORM VARYING WS-MAX FROM 1 BY 1
               UNTIL WS-LETTER(WS-MAX) = SPACE
           END-PERFORM.

           PERFORM VARYING WS-I FROM 1 BY 1 UNTIL WS-I = WS-MAX
               PERFORM VARYING WS-J FROM WS-I BY 1
                 UNTIL WS-J > WS-MAX - 1
                   IF WS-LETTER(WS-J) < WS-LETTER(WS-I) THEN
                       MOVE WS-LETTER(WS-I)  TO WS-LETTER-HLD
                       MOVE WS-LETTER(WS-J)  TO WS-LETTER(WS-I)
                       MOVE WS-LETTER-HLD    TO WS-LETTER(WS-J)
                   END-IF
               END-PERFORM
           END-PERFORM.

       400-ADD-TO-TABLE.
           SET WT-IDX TO 1.
           SEARCH WT-RECORD
               AT END
                   PERFORM 420-ADD-RECORD
               WHEN WT-WORD-KEY(WT-IDX) = WS-WORD-KEY
                   PERFORM 440-UPDATE-RECORD
           END-SEARCH.

       420-ADD-RECORD.
           ADD 1 To WT-REC-NBR.
           MOVE WS-WORD-KEY TO WT-WORD-KEY(WT-REC-NBR).
           COMPUTE WT-WORD-LEN(WT-REC-NBR) = WS-MAX - 1.
           MOVE 1 TO WT-ANAGRAM-CNT(WT-REC-NBR).
           MOVE WS-WORD-IN TO
               WT-ANAGRAM(WT-REC-NBR, WT-ANAGRAM-CNT(WT-REC-NBR)).

       440-UPDATE-RECORD.
           ADD 1 TO WT-ANAGRAM-CNT(WT-IDX).
           MOVE WS-WORD-IN TO
               WT-ANAGRAM(WT-IDX, WT-ANAGRAM-CNT(WT-IDX)).

       500-FIND-DERANGED.
           PERFORM VARYING WS-I FROM 1 BY 1
             UNTIL WS-I > WT-REC-NBR OR WS-FND = 'Y'
               PERFORM VARYING WS-J FROM 1 BY 1
                 UNTIL WS-J > WT-ANAGRAM-CNT(WS-I) - 1 OR WS-FND = 'Y'
                   COMPUTE WS-BEG = WS-J + 1
                   PERFORM VARYING WS-K FROM WS-BEG BY 1
                     UNTIL WS-K > WT-ANAGRAM-CNT(WS-I) OR WS-FND = 'Y'
                       MOVE WT-ANAGRAM(WS-I, WS-J) TO WS-WORD-TEMP1
                       MOVE WT-ANAGRAM(WS-I, WS-K) To WS-WORD-TEMP2
                       PERFORM 650-CHECK-DERANGED
                   END-PERFORM
               END-PERFORM
           END-PERFORM.

           650-CHECK-DERANGED.
               MOVE 'N' TO WS-EXIT.
               PERFORM VARYING WS-L FROM 1 BY 1
                   UNTIL WS-L > WT-WORD-LEN(WS-I) OR WS-EXIT = 'Y'
                       IF WS-LETTER1(WS-L) = WS-LETTER2(WS-L)
                           MOVE 'Y' TO WS-EXIT
               END-PERFORM.
               IF WS-EXIT = 'N'
                   DISPLAY WS-WORD-TEMP1(1:WT-WORD-LEN(WS-I))
                   ' '
                   WS-WORD-TEMP2
                   MOVE 'Y' TO WS-FND
               END-IF.

       900-TERMINATE.
           DISPLAY 'RECORDS READ: ' WS-TOT-RECS.
           DISPLAY 'RECORDS SELECTED ' WS-SEL-RECS.
           DISPLAY 'RECORD KEYS: ' WT-REC-NBR.
           CLOSE IN-FILE.

      *>   OUTPUT:

      *>      excitation intoxicate
      *>      RECORDS READ: 25104
      *>      RECORDS SELECTED 24978
      *>      RECORD KEYS: 23441

      *>   BUBBLE SORT REFERENCE:
      *>   https://mainframegeek.wordpress.com/tag/bubble-sort-in-cobol


' Almost prime
for k = 1 to 5
    print "k = "; k; ":";
    i = 2
    c = 0
    while c < 10
        if kPrime(i, k) then
            print " "; using("###", i);
            c = c + 1
        end if
        i = i + 1
    wend
    print
next k
end

function kPrime(n, k)
    f = 0
    for i = 2 to n
    while n mod i = 0
        if f = k then kPrime = 0: exit function
        f = f + 1
        n = int(n / i)
    wend
    next i
    kPrime = abs(f = k)
end function


-- Returns boolean indicating whether n is k-almost prime
function almostPrime (n, k)
    local divisor, count = 2, 0
    while count < k + 1 and n ~= 1 do
        if n % divisor == 0 then
            n = n / divisor
            count = count + 1
        else
            divisor = divisor + 1
        end
    end
    return count == k
end

-- Generates table containing first ten k-almost primes for given k
function kList (k)
    local n, kTab = 2^k, {}
    while #kTab < 10 do
        if almostPrime(n, k) then
            table.insert(kTab, n)
        end
        n = n + 1
    end
    return kTab
end

-- Main procedure, displays results from five calls to kList()
for k = 1, 5 do
    io.write("k=" .. k .. ": ")
    for _, v in pairs(kList(k)) do
        io.write(v .. ", ")
    end
    print("...")
end


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program amicable64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

.equ NMAXI,      20000
.equ TABMAXI,      100

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:        .asciz " @ : @\n"
szCarriageReturn:   .asciz "\n"
szMessErr1:         .asciz "Array too small !!"
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:                  .skip 24
tResult:                    .skip 8 * TABMAXI
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                             // entry of program
    ldr x3,qNMaxi                 // load limit
    mov x4,#2                     // number begin
1:
    mov x0,x4                     // number
    bl decFactor                  // compute sum factors
    cmp x0,x4                     // equal ?
    beq 2f
    mov x2,x0                     // factor sum 1
    bl decFactor
    cmp x0,x4                     // equal number ?
    bne 2f
    mov x0,x4                     // yes -> search in array
    mov x1,x2                     // and store sum
    bl searchRes
    cmp x0,#0                     // find ?
    bne 2f                        // yes
    mov x0,x4                     // no -> display number ans sum
    mov x1,x2
    bl displayResult
2:
    add x4,x4,#1                     // increment number
    cmp x4,x3                     // end ?
    ble 1b

100:                              // standard end of the program
    mov x0, #0                    // return code
    mov x8, #EXIT                 // request to exit program
    svc #0                        // perform the system call
qAdrszCarriageReturn:        .quad szCarriageReturn
qNMaxi:                      .quad NMAXI
/***************************************************/
/*   display message number                        */
/***************************************************/
/* x0 contains number 1           */
/* x1 contains number 2               */
displayResult:
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    mov x2,x1
    ldr x1,qAdrsZoneConv
    bl conversion10               // call décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv          // insert conversion in message
    bl strInsertAtCharInc
    mov x3,x0
    mov x0,x2
    ldr x1,qAdrsZoneConv
    bl conversion10               // call décimal conversion
    mov x0,x3
    ldr x1,qAdrsZoneConv          // insert conversion in message
    bl strInsertAtCharInc

    bl affichageMess              // display message
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
qAdrsMessResult:     .quad sMessResult
qAdrsZoneConv:       .quad sZoneConv
/***************************************************/
/*   compute factors sum                        */
/***************************************************/
/* x0 contains the number            */
decFactor:
    stp x1,lr,[sp,-16]!       // save  registers
    stp x2,x3,[sp,-16]!       // save  registers
    stp x4,x5,[sp,-16]!       // save  registers
    mov x4,#1                 // init sum
    mov x1,#2                 // start factor -> divisor
1:
    udiv x2,x0,x1
    msub x3,x2,x1,x0          // remainder
    cmp x1,x2                 // divisor > quotient ?
    bgt 3f
    cmp x3,#0                 // remainder = 0 ?
    bne 2f
    add x4,x4,x1              // add divisor to sum
    cmp x1,x2                 // divisor = quotient ?
    beq 3f                    // yes -> end
    add x4,x4,x2              // no -> add quotient to sum
2:
    add x1,x1,#1              // increment factor
    b 1b                      // and loop
3:
    mov x0,x4                 // return sum
    ldp x4,x5,[sp],16         // restaur  2 registers
    ldp x2,x3,[sp],16         // restaur  2 registers
    ldp x1,lr,[sp],16         // restaur  2 registers
    ret                       // return to address lr x30
/***************************************************/
/*   search and store result in array                        */
/***************************************************/
/* x0 contains the number            */
/* x1 contains factors sum           */
/* x0 return 1 if find 0 else  -1 if error      */
searchRes:
    stp x1,lr,[sp,-16]!       // save  registers
    stp x2,x3,[sp,-16]!       // save  registers
    stp x4,x5,[sp,-16]!       // save  registers
    ldr x4,qAdrtResult        // array address
    mov x2,#0                 // indice begin
1:
    ldr x3,[x4,x2,lsl #3]     // load one result array
    cmp x3,#0                 // if 0 store new result
    beq 2f
    cmp x3,x0                 // equal ?
    beq 3f                    // find -> return 1
    add x2,x2,#1              // increment indice
    cmp x2,#TABMAXI           // maxi array ?
    blt 1b
    ldr x0,qAdrszMessErr1     // error
    bl affichageMess
    mov x0,#-1
    b 100f
2:
    str x1,[x4,x2,lsl #3]
    mov x0,#0                 // not find -> store and retun 0
    b 100f
3:
    mov x0,#1
100:
    ldp x4,x5,[sp],16         // restaur  2 registers
    ldp x2,x3,[sp],16         // restaur  2 registers
    ldp x1,lr,[sp],16         // restaur  2 registers
    ret                       // return to address lr x30
qAdrtResult:            .quad tResult
qAdrszMessErr1:         .quad szMessErr1
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


INCLUDE "H6:SIEVE.ACT"

CARD FUNC SumDivisors(CARD x)
  CARD i,max,sum

  sum=1 i=2 max=x
  WHILE i<max
  DO
    IF x MOD i=0 THEN
      max=x/i
      IF i<max THEN
        sum==+i+max
      ELSEIF i=max THEN
        sum==+i
      FI
    FI
    i==+1
  OD
RETURN (sum)

PROC Main()
  DEFINE MAXNUM="20000"
  BYTE ARRAY primes(MAXNUM+1)
  CARD m,n

  Put(125) PutE() ;clear the screen
  Sieve(primes,MAXNUM+1)
  FOR m=1 TO MAXNUM-1
  DO
    IF primes(m)=0 THEN
      n=SumDivisors(m)
      IF n<MAXNUM AND primes(n)=0 AND n>m THEN
        IF m=SumDivisors(n) THEN
          PrintF("%U %U%E",m,n)
        FI
      FI
    FI
  OD
RETURN


with Ada.Text_IO, Generic_Divisors; use Ada.Text_IO;

procedure Amicable_Pairs is

   function Same(P: Positive) return Positive is (P);

   package Divisor_Sum is new Generic_Divisors
     (Result_Type => Natural, None => 0, One => Same, Add =>  "+");

   Num2 : Integer;
begin
   for Num1 in 4 .. 20_000 loop
      Num2 := Divisor_Sum.Process(Num1);
      if Num1 < Num2 then
	 if Num1 = Divisor_Sum.Process(Num2) then
	   Put_Line(Integer'Image(Num1) & "," & Integer'Image(Num2));
	 end if;
      end if;
   end loop;
end Amicable_Pairs;


http = require 'http'

is_derangement = (word1, word2) ->
  for c, i in word1
    return false if c == word2[i]
  true

show_longest_derangement = (word_lst) ->
  anagrams = {}
  max_len = 0

  for word in word_lst
    continue if word.length < max_len
    key = word.split('').sort().join('')
    if anagrams[key]
      for prior in anagrams[key]
        if is_derangement(prior, word)
          max_len = word.length
          result = [prior, word]
    else
      anagrams[key] = []
    anagrams[key].push word

  console.log "Longest derangement: #{result.join ' '}"

get_word_list = (process) ->
  options =
    host: "www.puzzlers.org"
    path: "/pub/wordlists/unixdict.txt"

  req = http.request options, (res) ->
    s = ''
    res.on 'data', (chunk) ->
      s += chunk
    res.on 'end', ->
      process s.split '\n'
  req.end()

get_word_list show_longest_derangement


AlmostPrimes:=proc(k, numvalues::posint:=10)
    local aprimes, i, intfactors;
    aprimes := Array([]);
    i := 0;

    do
        i := i + 1;
        intfactors := ifactors(i)[2];
        intfactors := [seq(seq(intfactors[i][1], j=1..intfactors[i][2]),i = 1..numelems(intfactors))];
        if numelems(intfactors) = k then
            ArrayTools:-Append(aprimes,i);
        end if;
    until numelems(aprimes) = 10:
    aprimes;
end proc:
<seq( AlmostPrimes(i), i = 1..5 )>;


            NORMAL MODE IS INTEGER

            INTERNAL FUNCTION(NN,KK)
            ENTRY TO KPRIME.
            F = 0
            N = NN
            THROUGH SCAN, FOR P=2, 1, F.GE.KK .OR. P*P.G.N
DIV         WHENEVER N.E.N/P*P
                N = N/P
                F = F+1
                TRANSFER TO DIV
            END OF CONDITIONAL
SCAN        CONTINUE
            WHENEVER N.G.1, F = F+1
            FUNCTION RETURN F.E.KK
            END OF FUNCTION

            VECTOR VALUES KFMT = $5(S1,2HK=,I1,S1)*$
            VECTOR VALUES PFMT = $5(I4,S1)*$
            PRINT FORMAT KFMT, 1, 2, 3, 4, 5

            DIMENSION KPR(50)
            THROUGH FNDKPR, FOR K=1, 1, K.G.5
            C=0
            THROUGH FNDKPR, FOR I=2, 1, C.GE.10
            WHENEVER KPRIME.(I,K)
                KPR(C*5+K) = I
                C = C+1
            END OF CONDITIONAL
FNDKPR      CONTINUE

            THROUGH OUT, FOR C=0, 1, C.GE.10
OUT         PRINT FORMAT PFMT, KPR(C*5+1), KPR(C*5+2), KPR(C*5+3),
          0                    KPR(C*5+4), KPR(C*5+5)

            END OF PROGRAM


kprimes[k_,n_] :=
  (* generates a list of the n smallest k-almost-primes *)
  Module[{firstnprimes, runningkprimes = {}},
  firstnprimes = Prime[Range[n]];
  runningkprimes = firstnprimes;
  Do[
   runningkprimes =
     Outer[Times, firstnprimes , runningkprimes ] // Flatten // Union  // Take[#, n] & ;
   (* only keep lowest n numbers in our running list *)
   , {i, 1, k - 1}];
  runningkprimes
  ]
(* now to create table with n=10 and k ranging from 1 to 5 *)
Table[Flatten[{"k = " <> ToString[i] <> ": ", kprimes[i, 10]}], {i,1,5}] // TableForm


begin

comment - return n mod m;
integer procedure mod(n, m);
  value n, q; integer n, m;
begin
  mod := n - m * entier(n / m);
end;

comment - return sum of the proper divisors of n;
integer procedure sumf(n);
  value n; integer n;
begin
  integer sum, f1, f2;
  sum := 1;
  f1 := 2;
  for f1 := f1 while (f1 * f1) <= n do
    begin
      if mod(n, f1) = 0 then
        begin
           sum := sum + f1;
           f2 := n / f1;
           if f2 > f1 then sum := sum + f2;
        end;
      f1 := f1 + 1;
  end;
  sumf := sum;
end;

comment - main program begins here;
integer a, b, found;
outstring(1,"Searching up to 20000 for amicable pairs\n");
found := 0;
for a := 2 step 1 until 20000 do
  begin
    b := sumf(a);
    if b > a then
       begin
         if a = sumf(b) then
            begin
              found := found + 1;
              outinteger(1,a);
              outinteger(1,b);
              outstring(1,"\n");
            end;
       end;
  end;
outinteger(1,found);
outstring(1,"pairs were found");

end


# returns the sum of the proper divisors of n                     #
# if n = 1, 0 or -1, we return 0                                  #
PROC sum proper divisors = ( INT n )INT:
     BEGIN
         INT result := 0;
         INT abs n = ABS n;
         IF abs n > 1 THEN
             FOR d FROM ENTIER sqrt( abs n ) BY -1 TO 2 DO
                 IF abs n MOD d = 0 THEN
                     # found another divisor                      #
                     result +:= d;
                     IF d * d /= n THEN
                         # include the other divisor              #
                         result +:= n OVER d
                     FI
                 FI
             OD;
             # 1 is always a proper divisor of numbers > 1        #
             result +:= 1
         FI;
         result
     END # sum proper divisors # ;

# construct a table of the sum of the proper divisors of numbers  #
# up to 20 000                                                    #
INT max number = 20 000;
[ 1 : max number ]INT proper divisor sum;
FOR n TO UPB proper divisor sum DO proper divisor sum[ n ] := sum proper divisors( n ) OD;

# returns TRUE if n1 and n2 are an amicable pair FALSE otherwise  #
#         n1 and n2 are amicable if the sum of the proper diviors #
#         n1 = n2 and the sum of the proper divisors of n2 = n1   #
PROC is an amicable pair = ( INT n1, n2 )BOOL:
     ( proper divisor sum[ n1 ] = n2 AND proper divisor sum[ n2 ] = n1 );

# find the amicable pairs up to 20 000                            #
FOR p1 TO max number DO
    FOR p2 FROM p1 + 1 TO max number DO
        IF is an amicable pair( p1, p2 ) THEN
            print( ( whole( p1, -6 ), " and ", whole( p2, -6 ), " are an amicable pair", newline ) )
        FI
    OD
OD


(defun read-words (file)
  (with-open-file (stream file)
    (loop with w = "" while w collect (setf w (read-line stream nil)))))

(defun deranged (a b)
  (loop for ac across a for bc across b always (char/= ac bc)))

(defun longest-deranged (file)
  (let ((h (make-hash-table :test #'equal))
	(wordlist (sort (read-words file)
			#'(lambda (x y) (> (length x) (length y))))))
    (loop for w in wordlist do
	  (let* ((ws (sort (copy-seq w) #'char<))
		 (l (gethash ws h)))
	    (loop for w1 in l do
		  (if (deranged w w1)
		    (return-from longest-deranged (list w w1))))
	    (setf (gethash ws h) (cons w l))))))

(format t "~{~A~%~^~}" (longest-deranged "unixdict.txt"))


MODULE AlmostPrime;
FROM FormatString IMPORT FormatString;
FROM Terminal IMPORT WriteString,WriteLn,ReadChar;

PROCEDURE KPrime(n,k : INTEGER) : BOOLEAN;
VAR p,f : INTEGER;
BEGIN
    f := 0;
    p := 2;
    WHILE (f<k) AND (p*p<=n) DO
        WHILE n MOD p = 0 DO
            n := n DIV p;
            INC(f)
        END;
        INC(p)
    END;
    IF n>1 THEN
        RETURN f+1 = k
    END;
    RETURN f = k
END KPrime;

VAR
    buf : ARRAY[0..63] OF CHAR;
    i,c,k : INTEGER;
BEGIN
    FOR k:=1 TO 5 DO
        FormatString("k = %i:", buf, k);
        WriteString(buf);

        i:=2;
        c:=0;
        WHILE c<10 DO
            IF KPrime(i,k) THEN
                FormatString(" %i", buf, i);
                WriteString(buf);
                INC(c)
            END;
            INC(i)
        END;

        WriteLn;
    END;

    ReadChar;
END AlmostPrime.


10 REM Almost prime
20 FOR K=1 TO 5
30 PRINT "k =";STR$(K);":";
40 I=2
50 C=0
60 IF C>=10 THEN 110
70 AN=I:GOSUB 1000
80 IF ISKPRIME=0 THEN 90
82 REM Print I in 4 fields
84 S$=STR$(I)
86 PRINT SPC(4-LEN(S$));S$;
88 C=C+1
90 I=I+1
100 GOTO 60
110 PRINT
120 NEXT K
130 END
995 REM Check if N (AN) is a K prime
1000 F=0
1010 FOR J=2 TO AN
1020 IF INT(AN/J)*J<>AN THEN 1070
1030 IF F=K THEN ISKPRIME=0:RETURN
1040 F=F+1
1050 AN=INT(AN/J)
1060 GOTO 1020
1070 NEXT J
1080 ISKPRIME=(F=K)
1090 RETURN


100 DECLARE EXTERNAL FUNCTION sum_proper_divisors
110 CLEAR
120 !
130 DIM f(20001)      ! sum of proper factors for each n
140 FOR i=1 TO 20000
150    LET f(i)=sum_proper_divisors(i)
160 NEXT i
170 ! look for pairs
180 FOR i=1 TO 20000
190    FOR j=i+1 TO 20000
200       IF f(i)=j AND i=f(j) THEN
210          PRINT "Amicable pair ";i;" ";j
220       END IF
230    NEXT j
240 NEXT i
250 !
260 PRINT
270 PRINT "-- found all amicable pairs"
280 END
290 !
300 ! Compute the sum of proper divisors of given number
310 !
320 EXTERNAL FUNCTION sum_proper_divisors(n)
330 !
340 IF n>1 THEN ! n must be 2 or larger
350    LET sum=1 ! start with 1
360    LET root=SQR(n)    ! note that root is an integer
370    ! check possible factors, up to sqrt
380    FOR i=2 TO root
390       IF MOD(n,i)=0 THEN
400          LET sum=sum+i     ! i is a factor
410          IF i*i<>n THEN    ! check i is not actual square root of n
420             LET sum=sum+n/i  ! so n/i will also be a factor
430          END IF
440       END IF
450    NEXT i
460 END IF
470 LET sum_proper_divisors = sum
480 END FUNCTION


-- AMICABLE PAIRS ------------------------------------------------------------

-- amicablePairsUpTo :: Int -> Int
on amicablePairsUpTo(max)

    -- amicable :: [Int] -> Int -> Int -> [Int] -> [Int]
    script amicable
        on |λ|(a, m, n, lstSums)
            if (m > n) and (m ≤ max) and ((item m of lstSums) = n) then
                a & [[n, m]]
            else
                a
            end if
        end |λ|
    end script

    -- divisorsSummed :: Int -> Int
    script divisorsSummed
        -- sum :: Int -> Int -> Int
        script sum
            on |λ|(a, b)
                a + b
            end |λ|
        end script

        on |λ|(n)
            foldl(sum, 0, properDivisors(n))
        end |λ|
    end script

    foldl(amicable, {}, ¬
        map(divisorsSummed, enumFromTo(1, max)))
end amicablePairsUpTo

-- TEST ----------------------------------------------------------------------
on run

    amicablePairsUpTo(20000)

end run

-- PROPER DIVISORS -----------------------------------------------------------

-- properDivisors :: Int -> [Int]
on properDivisors(n)

    -- isFactor :: Int -> Bool
    script isFactor
        on |λ|(x)
            n mod x = 0
        end |λ|
    end script

    -- integerQuotient :: Int -> Int
    script integerQuotient
        on |λ|(x)
            (n / x) as integer
        end |λ|
    end script

    if n = 1 then
        {1}
    else
        set realRoot to n ^ (1 / 2)
        set intRoot to realRoot as integer
        set blnPerfectSquare to intRoot = realRoot

        -- Factors up to square root of n,
        set lows to filter(isFactor, enumFromTo(1, intRoot))

        -- and quotients of these factors beyond the square root,
        -- excluding n itself (last item)
        items 1 thru -2 of (lows & map(integerQuotient, ¬
            items (1 + (blnPerfectSquare as integer)) thru -1 of reverse of lows))
    end if
end properDivisors

-- GENERIC FUNCTIONS ---------------------------------------------------------

-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
    if m > n then
        set d to -1
    else
        set d to 1
    end if
    set lst to {}
    repeat with i from m to n by d
        set end of lst to i
    end repeat
    return lst
end enumFromTo

-- filter :: (a -> Bool) -> [a] -> [a]
on filter(f, xs)
    tell mReturn(f)
        set lst to {}
        set lng to length of xs
        repeat with i from 1 to lng
            set v to item i of xs
            if |λ|(v, i, xs) then set end of lst to v
        end repeat
        return lst
    end tell
end filter

-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldl

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn


void main() {
    import std.stdio, std.file, std.algorithm, std.string, std.array;

    string[][dstring] anags;
    foreach (const w; "unixdict.txt".readText.split)
        anags[w.array.sort().release.idup] ~= w;

    anags
    .byValue
    .map!(words => words.cartesianProduct(words)
                   .filter!q{ a[].equal!q{ a != b }})
    .join
    .minPos!q{ a[0].length > b[0].length }[0]
    .writeln;
}


proc prime(k: int, listLen: int): seq[int] =
 result = @[]
 var
  test: int = 2
  curseur: int = 0
 while curseur < listLen:
  var
   i: int = 2
   compte = 0
   n = test
  while i <= n:
   if (n mod i)==0:
    n = n div i
    compte += 1
   else:
    i += 1
  if compte == k:
   result.add(test)
   curseur += 1
  test += 1

for k in 1..5:
 echo "k = ",k," : ",prime(k,10)


/* ARM assembly Raspberry PI or android with termux */
/*  program amicable.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 NMAXI,      20000
.equ TABMAXI,      100

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:        .asciz " @ : @\n"
szCarriageReturn:   .asciz "\n"
szMessErr1:         .asciz "Array too small !!"
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:                  .skip 24
tResult:                    .skip 4 * TABMAXI
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                             @ entry of program
    ldr r3,iNMaxi                 @ load limit
    mov r4,#2                     @ number begin
1:
    mov r0,r4                     @ number
    bl decFactor                  @ compute sum factors
    cmp r0,r4                     @ equal ?
    beq 2f
    mov r2,r0                     @ factor sum 1
    bl decFactor
    cmp r0,r4                     @ equal number ?
    bne 2f
    mov r0,r4                     @ yes -> search in array
    mov r1,r2                     @ and store sum
    bl searchRes
    cmp r0,#0                     @ find ?
    bne 2f                        @ yes
    mov r0,r4                     @ no -> display number ans sum
    mov r1,r2
    bl displayResult
2:
    add r4,#1                     @ increment number
    cmp r4,r3                     @ end ?
    ble 1b

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
iNMaxi:                       .int NMAXI
/***************************************************/
/*   display message number                        */
/***************************************************/
/* r0 contains number 1           */
/* r1 contains number 2               */
displayResult:
    push {r1-r3,lr}               @ save registers
    mov r2,r1
    ldr r1,iAdrsZoneConv
    bl conversion10               @ call décimal conversion
    ldr r0,iAdrsMessResult
    ldr r1,iAdrsZoneConv          @ insert conversion in message
    bl strInsertAtCharInc
    mov r3,r0
    mov r0,r2
    ldr r1,iAdrsZoneConv
    bl conversion10               @ call décimal conversion
    mov r0,r3
    ldr r1,iAdrsZoneConv          @ insert conversion in message
    bl strInsertAtCharInc

    bl affichageMess              @ display message
    pop {r1-r3,pc}                @ restaur des registres
iAdrsMessResult:     .int sMessResult
iAdrsZoneConv:       .int sZoneConv
/***************************************************/
/*   compute factors sum                        */
/***************************************************/
/* r0 contains the number            */
decFactor:
    push {r1-r5,lr}           @ save registers
    mov r5,#1                 @ init sum
    mov r4,r0                 @ save number
    mov r1,#2                 @ start factor -> divisor
1:
    mov r0,r4                 @ dividende
    bl division
    cmp r1,r2                 @ divisor > quotient ?
    bgt 3f
    cmp r3,#0                 @ remainder = 0 ?
    bne 2f
    add r5,r5,r1              @ add divisor to sum
    cmp r1,r2                 @ divisor = quotient ?
    beq 3f                    @ yes -> end
    add r5,r5,r2              @ no -> add quotient to sum
2:
    add r1,r1,#1              @ increment factor
    b 1b                      @ and loop
3:
    mov r0,r5                 @ return sum
    pop {r1-r5,pc}            @ restaur registers
/***************************************************/
/*   search and store result in array                        */
/***************************************************/
/* r0 contains the number            */
/* r1 contains factors sum           */
/* r0 return 1 if find 0 else  -1 if error      */
searchRes:
    push {r1-r4,lr}              @ save registers
    ldr r4,iAdrtResult           @ array address
    mov r2,#0                    @ indice begin
1:
    ldr r3,[r4,r2,lsl #2]        @ load one result array
    cmp r3,#0                    @ if 0 store new result
    beq 2f
    cmp r3,r0                    @ equal ?
    moveq r0,#1                  @ find -> return 1
    beq 100f
    add r2,r2,#1                 @ increment indice
    cmp r2,#TABMAXI              @ maxi array ?
    blt 1b
    ldr r0,iAdrszMessErr1        @ error
    bl affichageMess
    mov r0,#-1
    b 100f
2:
    str r1,[r4,r2,lsl #2]
    mov r0,#0                   @ not find -> store and retun 0
100:
    pop {r1-r4,pc}              @ restaur registers
iAdrtResult:            .int tResult
iAdrszMessErr1:         .int szMessErr1
/***************************************************/
/*      ROUTINES INCLUDE                           */
/***************************************************/
.include "../affichage.inc"


program Anagrams_Deranged;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  System.Classes,
  System.Diagnostics;

function Sort(s: string): string;
var
  c: Char;
  i, j, aLength: Integer;
begin
  aLength := s.Length;

  if aLength = 0 then
    exit('');

  Result := s;

  for i := 1 to aLength - 1 do
    for j := i + 1 to aLength do
      if result[i] > result[j] then
      begin
        c := result[i];
        result[i] := result[j];
        result[j] := c;
      end;
end;

function IsAnagram(s1, s2: string): Boolean;
begin
  if s1.Length <> s2.Length then
    exit(False);

  Result := Sort(s1) = Sort(s2);

end;

function CompareLength(List: TStringList; Index1, Index2: Integer): Integer;
begin
  result := List[Index1].Length - List[Index2].Length;
  if Result = 0 then
    Result := CompareText(Sort(List[Index2]), Sort(List[Index1]));
end;

function IsDerangement(word1, word2: string): Boolean;
var
  i: Integer;
begin
  for i := 1 to word1.Length do
    if word1[i] = word2[i] then
      exit(False);
  Result := True;
end;

var
  Dict: TStringList;
  Count, Index: Integer;
  words: string;
  StopWatch: TStopwatch;

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

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

  Dict.CustomSort(CompareLength);

  Index := Dict.Count - 1;
  words := '';
  Count := 1;

  while Index - Count >= 0 do
  begin
    if IsAnagram(Dict[Index], Dict[Index - Count]) then
    begin
      if IsDerangement(Dict[Index], Dict[Index - Count]) then
      begin
        words := Dict[Index] + ' - ' + Dict[Index - Count];
        Break;
      end;
      Inc(Count);
    end
    else
    begin
      Dec(Index, Count);
      Count := 1;
    end;
  end;

  StopWatch.Stop;

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

  writeln(#10'Longest derangement words are:'#10#10, words);

  Dict.Free;
  Readln;
end.


: kprime?( n k -- b )
| i |
   0 2 n for: i [
      while( n i /mod swap 0 = ) [ ->n 1+ ] drop
      ]
   k ==
;

: table( k -- [] )
| l |
   Array new dup ->l
   2 while (l size 10 <>) [ dup k kprime? if dup l add then 1+ ]
   drop
;


almost(k)=my(n); for(i=1,10,while(bigomega(n++)!=k,); print1(n", "));
for(k=1,5,almost(k);print)


program AlmostPrime;
{$IFDEF FPC}
  {$Mode Delphi}
{$ENDIF}
uses
  primtrial;
var
  i,K,cnt : longWord;
BEGIN
  K := 1;
  repeat
    cnt := 0;
    i := 2;
    write('K=',K:2,':');
    repeat
      if isAlmostPrime(i,K) then
      Begin
        write(i:6,' ');
        inc(cnt);
      end;
      inc(i);
    until cnt = 9;
    writeln;
    inc(k);
  until k > 10;
END.


properDivs: function [x] ->
    (factors x) -- x

amicable: function [x][
    y: sum properDivs x
    if and? x = sum properDivs y
            x <> y
        -> return @[x,y]
    return ø
]

amicables: []

loop 1..20000 'n [
    am: amicable n
    if am <> ø
        -> 'amicables ++ @[sort am]
]

print unique amicables


(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
#include
"share/HATS/atspre_staload_libats_ML.hats"
//
(* ****** ****** *)
//
fun
sum_list_vt
  (xs: List_vt(int)): int =
(
  case+ xs of
  | ~list_vt_nil() => 0
  | ~list_vt_cons(x, xs) => x + sum_list_vt(xs)
)
//
(* ****** ****** *)

fun
propDivs
(
  x0: int
) : List0_vt(int) =
  loop(x0, 2, list_vt_sing(1)) where
{
//
fun
loop
(
x0: int, i: int, res: List0_vt(int)
) : List0_vt(int) =
(
if
(i * i) > x0
then list_vt_reverse(res)
else
(
  if x0 % i != 0
    then
      loop(x0, i+1, res)
    // end of [then]
    else let
      val res =
        cons_vt(i, res)
      // end of [val]
      val res =
      (
        if i * i = x0 then res else cons_vt(x0 / i, res)
      ) : List0_vt(int) // end of [val]
    in
      loop(x0, i+1, res)
    end // end of [else]
  // end of [if]
)
) (* end of [loop] *)
//
} // end of [propDivs]

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

fun
sum_propDivs(x: int): int = sum_list_vt(propDivs(x))

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

val
theNat2 = auxmain(2) where
{
fun
auxmain
(
 n: int
) : stream_vt(int) = $ldelay(stream_vt_cons(n, auxmain(n+1)))
}

(* ****** ****** *)
//
val
theAmicable =
(
stream_vt_takeLte(theNat2, 20000)
).filter()
(
lam x =>
let
  val x2 = sum_propDivs(x)
in x < x2 && x = sum_propDivs(x2) end
)
//
(* ****** ****** *)

val () =
theAmicable.foreach()
(
  lam x => println! ("(", x, ", ", sum_propDivs(x), ")")
)

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

implement main0 () = ()

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


(lib 'hash)
(lib 'struct)
(lib 'sql)
(lib 'words)

(define H (make-hash))

(define (deranged w1 w2)
	(for ((a w1) (b w2))
		#:break (string=? a b) => #f
		#t))

(define (anagrams (normal) (name) (twins))
(for ((w *words*))
	(set! name (word-name w))
	(set! normal (list->string (list-sort string<? (string->list name))))
	(set! twins (or (hash-ref H normal) null))
	#:continue (member name twins)
	#:when  (or (null? twins)  (for/or ((anagram twins)) (deranged name anagram)))
	(hash-set H normal (cons name twins))))

(define (task (lmin 8))
(anagrams)
(for ((lw (hash-values H))) ;; lw = list of words
	#:continue (= (length lw) 1)
	#:continue (< (string-length (first lw)) lmin)
	(set! lmin (string-length (first lw)))
	(write lmin) (for-each write lw)
	(writeln)))


use ntheory qw/factor/;
sub almost {
  my($k,$n) = @_;
  my $i = 1;
  map { $i++ while scalar factor($i) != $k; $i++ } 1..$n;
}
say "$_ : ", join(" ", almost($_,10)) for 1..5;


/# Rosetta Code problem: http://rosettacode.org/wiki/Almost_prime
by Galileo, 06/2022 #/

include ..\Utilitys.pmt

def test tps over mod not enddef

def kprime?
    >ps >ps
    0 ( 2 tps ) for
        test while
            tps over / int ps> drop >ps
            swap 1 + swap
        test endwhile
        drop
    endfor
    ps> drop
    ps> ==
enddef

5 for >ps
    2 ( )
    len 10 < while over tps kprime? if over 0 put endif swap 1 + swap len 10 < endwhile
    nip ps> drop
endfor

pstack


go =>
  N = 10,
  Ps = primes(100).take(N),
  println(1=Ps),
  T = Ps,
  foreach(K in 2..5)
    T := mul_take(Ps,T,N),
    println(K=T)
  end,
  nl,
  foreach(K in 6..25)
    T := mul_take(Ps,T,N),
    println(K=T)
  end,
  nl.

% take first N values of L1 x L2
mul_take(L1,L2,N) = [I*J : I in L1, J in L2, I<=J].sort_remove_dups().take(N).

take(L,N) = [L[I] : I in 1..N].


SetBatchLines -1
Loop, 20000
{
	m := A_index

	; Getting factors
	loop % floor(sqrt(m))
	{
		if ( mod(m, A_index) = 0 )
		{
			if ( A_index ** 2 == m )
			{
				sum += A_index
				continue
			} else if ( A_index != 1 )
			{
				sum += A_index + m//A_index
			} else if ( A_index = 1 )
			{
				sum += A_index
			}
		}
	} ; Factors obtained

	; Checking factors of sum
	if ( sum > 1 )
	{
		loop % floor(sqrt(sum))
		{
			if ( mod(sum, A_index) = 0 )
			{
				if ( A_index ** 2 == sum )
				{
					sum2 += A_index
					continue
				} else if ( A_index != 1 )
				{
					sum2 += A_index + sum//A_index
				} else if ( A_index = 1 )
				{
					sum2 += A_index
				}
			}
		}
		if ( m = sum2 ) && ( m != sum ) && ( m < sum )
			final .= m . ":" . sum . "`n"
	} ; Checked

	sum := 0
	sum2 := 0
}
MsgBox % final
ExitApp


#!/bin/awk -f
function sumprop(num,   i,sum,root) {
if (num < 2) return 0
sum=1
root=sqrt(num)
for ( i=2; i < root; i++) {
    if (num % i == 0 )
        {
          sum = sum + i + num/i
          }
     }
     if (num % root == 0)
        {
         sum = sum + root
         }
 return sum
 }

BEGIN{
limit=20000
print "Amicable pairs < ",limit
for (n=1; n < limit+1; n++)
    {
    m=sumprop(n)
    if (n == sumprop(m) && n < m) print n,m
    }
}
}


class
	ANAGRAMS_DERANGED

create
	make

feature

	make
			-- Longest deranged anagram.
		local
			deranged_anagrams: LINKED_LIST [STRING]
			count: INTEGER
		do
			read_wordlist
			across
				words as wo
			loop
				deranged_anagrams := check_list_for_deranged (wo.item)
				if not deranged_anagrams.is_empty and deranged_anagrams [1].count > count then
					count := deranged_anagrams [1].count
				end
				wo.item.wipe_out
				wo.item.append (deranged_anagrams)
			end
			across
				words as wo
			loop
				across
					wo.item as w
				loop
					if w.item.count = count then
						io.put_string (w.item + "%T")
						io.new_line
					end
				end
			end
		end

	original_list: STRING = "unixdict.txt"

feature {NONE}

	check_list_for_deranged (list: LINKED_LIST [STRING]): LINKED_LIST [STRING]
			-- Deranged anagrams in 'list'.
		do
			create Result.make
			across
				1 |..| list.count as i
			loop
				across
					(i.item + 1) |..| list.count as j
				loop
					if check_for_deranged (list [i.item], list [j.item]) then
						Result.extend (list [i.item])
						Result.extend (list [j.item])
					end
				end
			end
		end

	check_for_deranged (a, b: STRING): BOOLEAN
			-- Are 'a' and 'b' deranged anagrams?
		local
			n: INTEGER
		do
			across
				1 |..| a.count as i
			loop
				if a [i.item] = b [i.item] then
					n := n + 1
				end
			end
			Result := n = 0
		end

	read_wordlist
			-- Hashtable 'words' with alphabetically sorted Strings used as key.
		local
			l_file: PLAIN_TEXT_FILE
			sorted: STRING
			empty_list: LINKED_LIST [STRING]
		do
			create l_file.make_open_read_write (original_list)
			l_file.read_stream (l_file.count)
			wordlist := l_file.last_string.split ('%N')
			l_file.close
			create words.make (wordlist.count)
			across
				wordlist as w
			loop
				create empty_list.make
				sorted := sort_letters (w.item)
				words.put (empty_list, sorted)
				if attached words.at (sorted) as ana then
					ana.extend (w.item)
				end
			end
		end

	wordlist: LIST [STRING]

	sort_letters (word: STRING): STRING
			--Alphabetically sorted.
		local
			letters: SORTED_TWO_WAY_LIST [STRING]
		do
			create letters.make
			create Result.make_empty
			across
				1 |..| word.count as i
			loop
				letters.extend (word.at (i.item).out)
			end
			across
				letters as s
			loop
				Result.append (s.item)
			end
		end

	words: HASH_TABLE [LINKED_LIST [STRING], STRING]

end


almost_prime: procedure options(main);
    kprime: procedure(nn, k) returns(bit);
        declare (n, nn, k, p, f) fixed;
        f = 0;
        n = nn;
        do p=2 repeat(p+1) while(f<k & p*p <= n);
            do n=n repeat(n/p) while(mod(n,p) = 0);
                f = f+1;
            end;
        end;
        return(f + (n>1) = k);
    end kprime;

    declare (i, c, k) fixed;
    do k=1 to 5;
        put edit('k = ',k,':') (A,F(1),A);
        c = 0;
        do i=2 repeat(i+1) while(c<10);
            if kprime(i,k) then do;
                put edit(i) (F(4));
                c = c+1;
            end;
        end;
        put skip;
    end;
end almost_prime;


function SumProperDivisors(number)
	if number < 2 then return 0
	sum = 0
	for i = 1 to number \ 2
		if number mod i = 0 then sum += i
	next i
	return sum
end function

dim sum(20000)
for n = 1 to 19999
	sum[n] = SumProperDivisors(n)
next n

print "The pairs of amicable numbers below 20,000 are :"
print

for n = 1 to 19998
	f = sum[n]
	if f <= n or f < 1 or f > 19999 then continue for
	if f = sum[n] and n = sum[f] then
		print rjust(string(n), 5); " and "; sum[n]
	end if
next n
end


get "libhdr"

manifest $(
    MAXIMUM = 20000
$)

// Calculate proper divisors for 1..N
let propDivSums(n) = valof
$(  let v = getvec(n)
    for i = 1 to n do v!i := 1
    for i = 2 to n/2 do
    $(  let j = i*2
        while j < n do
        $(  v!j := v!j + i
            j := j + i
        $)
    $)
    resultis v
$)

// Are A and B an amicable pair, given the list of sums of proper divisors?
let amicable(pdiv, a, b) = a = pdiv!b & b = pdiv!a

let start() be
$(  let pds = propDivSums(MAXIMUM)
    for x = 1 to MAXIMUM do
        for y = x+1 to MAXIMUM do
            if amicable(pds, x, y) do
                writef("%N, %N*N", x, y)
$)


defmodule Anagrams do
  def deranged(fname) do
    File.read!(fname)
    |> String.split
    |> Enum.map(fn word -> to_charlist(word) end)
    |> Enum.group_by(fn word -> Enum.sort(word) end)
    |> Enum.filter(fn {_,words} -> length(words) > 1 end)
    |> Enum.sort_by(fn {key,_} -> -length(key) end)
    |> Enum.find(fn {_,words} -> find_derangements(words) end)
  end

  defp find_derangements(words) do
    comb(words,2) |> Enum.find(fn [a,b] -> deranged?(a,b) end)
  end

  defp deranged?(a,b) do
    Enum.zip(a, b) |> Enum.all?(fn {chr_a,chr_b} -> chr_a != chr_b end)
  end

  defp comb(_, 0), do: [[]]
  defp comb([], _), do: []
  defp comb([h|t], m) do
    (for l <- comb(t, m-1), do: [h|l]) ++ comb(t, m)
  end
end

case Anagrams.deranged("/work/unixdict.txt") do
  {_, words} -> IO.puts "Longest derangement anagram: #{inspect words}"
  _          -> IO.puts "derangement anagram: nothing"
end


-module( anagrams_deranged ).
-export( [task/0, words_from_url/1] ).

task() ->
       find_unimplemented_tasks:init_http(),
       Words = words_from_url( "http://www.puzzlers.org/pub/wordlists/unixdict.txt" ),
       Anagram_dict = anagrams:fetch( Words, dict:new() ),
       Deranged_anagrams = deranged_anagrams( Anagram_dict ),
       {_Length, Longest_anagrams} = dict:fold( fun keep_longest/3, {0, []}, Deranged_anagrams ),
       Longest_anagrams.

words_from_url( URL ) ->
	{ok, {{_HTTP, 200, "OK"}, _Headers, Body}} = httpc:request( URL ),
	string:tokens( Body, "\n" ).

deranged_anagrams( Dict ) ->
        Deranged_dict = dict:map( fun deranged_words/2, Dict ),
        dict:filter( fun is_anagram/2, Deranged_dict ).

deranged_words( _Key, [H | T] ) ->
        [{H, X} || X <- T, is_deranged_word(H, X)].

keep_longest( _Key, [{One, _} | _]=New, {Length, Acc} ) ->
        keep_longest_new( erlang:length(One), Length, New, Acc ).

keep_longest_new( New_length, Acc_length, New, _Acc ) when New_length > Acc_length ->
        {New_length, New};
keep_longest_new( New_length, Acc_length, New, Acc ) when New_length =:= Acc_length ->
        {Acc_length, Acc ++ New};
keep_longest_new( _New_length, Acc_length, _New, Acc ) ->
        {Acc_length, Acc}.

is_anagram( _Key, [] ) -> false;
is_anagram( _Key, _Value ) -> true.

is_deranged_word( Word1, Word2 ) ->
        lists:all( fun is_deranged_char/1, lists:zip(Word1, Word2) ).

is_deranged_char( {One, Two} ) -> One =/= Two.


100H:
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$NUMBER: PROCEDURE (N);
    DECLARE S (4) BYTE INITIAL ('...$');
    DECLARE P ADDRESS, (N, C BASED P) BYTE;
    P = .S(3);
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;

KPRIME: PROCEDURE (N, K) BYTE;
    DECLARE (N, K, P, F) BYTE;
    F = 0;
    P = 2;
    DO WHILE F < K AND P*P <= N;
        DO WHILE N MOD P = 0;
            N = N/P;
            F = F+1;
        END;
        P = P+1;
    END;
    IF N > 1 THEN F = F + 1;
    RETURN F = K;
END KPRIME;

DECLARE (I, C, K) BYTE;
DO K=1 TO 5;
    CALL PRINT(.'K = $');
    CALL PRINT$NUMBER(K);
    CALL PRINT(.':$');

    C = 0;
    I = 2;
    DO WHILE C < 10;
        IF KPRIME(I, K) THEN DO;
            CALL PRINT(.' $');
            CALL PRINT$NUMBER(I);
            C = C+1;
        END;
        I = I+1;
    END;
    CALL PRINT(.(13,10,'$'));
END;
CALL EXIT;
EOF


sequence res = columnize({tagset(5)}) -- ie {{1},{2},{3},{4},{5}}
integer n = 2, found = 0
while found<50 do
    integer l = length(prime_factors(n,true))
    if l<=5 and length(res[l])<=10 then
        res[l] &= n
        found += 1
    end if
    n += 1
end while
string fmt = "k = %d: "&join(repeat("%4d",10))&"\n"
for i=1 to 5 do
    printf(1,fmt,res[i])
end for


#include <stdio.h>
#include <stdlib.h>

typedef unsigned int uint;

int main(int argc, char **argv)
{
  uint top = atoi(argv[1]);
  uint *divsum = malloc((top + 1) * sizeof(*divsum));
  uint pows[32] = {1, 0};

  for (uint i = 0; i <= top; i++) divsum[i] = 1;

  // sieve
  // only sieve within lower half , the modification starts at 2*p
  for (uint p = 2; p+p <= top; p++) {
    if (divsum[p] > 1) {
      divsum[p] -= p;// subtract number itself from divisor sum ('proper')
      continue;}     // p not prime

    uint x; // highest power of p we need
    //checking x <= top/y instead of x*y <= top to avoid overflow
    for (x = 1; pows[x - 1] <= top/p; x++)
      pows[x] = p*pows[x - 1];

    //counter where n is not a*p with a = ?*p, useful for most p.
    //think of p>31 seldom divisions or p>sqrt(top) than no division is needed
    //n = 2*p, so the prime itself is left unchanged => k=p-1
    uint k= p-1;
    for (uint n = p+p; n <= top; n += p) {
      uint s=1+pows[1];
      k--;
      // search the right power only if needed
      if ( k==0) {
        for (uint i = 2; i < x && !(n%pows[i]); s += pows[i++]);
        k = p; }
      divsum[n] *= s;
    }
  }

  //now correct the upper half
  for (uint p = (top >> 1)+1; p <= top; p++) {
    if (divsum[p] > 1){
      divsum[p] -= p;}
  }

  uint cnt = 0;
  for (uint a = 1; a <= top; a++) {
    uint b = divsum[a];
    if (b > a && b <= top && divsum[b] == a){
      printf("%u %u\n", a, b);
      cnt++;}
  }
  printf("\nTop %u count : %u\n",top,cnt);
  return 0;
}


open System;

let keyIsSortedWord = Seq.sort >> Seq.toArray >> String
let isDeranged = Seq.forall2 (<>)

let rec pairs acc l = function
| [] -> acc
| x::rtail ->
    pairs (acc @ List.fold (fun acc y -> (y, x)::acc) [] l) (x::l) rtail

[<EntryPoint>]
let main args =
    System.IO.File.ReadAllLines("unixdict.txt")
    |> Seq.groupBy keyIsSortedWord
    |> Seq.fold (fun (len, found) (key, words) ->
        if String.length key < len || Seq.length words < 2 then (len, found)
        else
            let d = List.filter (fun (a, b) -> isDeranged a b) (pairs [] [] (List.ofSeq words))
            if List.length d = 0 then (len, found)
            elif String.length key = len then (len, found @ d)
            else (String.length key, d)
    ) (0, [])
    |> snd
    |> printfn "%A"
    0


(de factor (N)
   (make
      (let
         (D 2
            L (1 2 2 . (4 2 4 2 4 6 2 6 .))
            M (sqrt N) )
         (while (>= M D)
            (if (=0 (% N D))
               (setq M
                  (sqrt (setq N (/ N (link D)))) )
               (inc 'D (pop 'L)) ) )
         (link N) ) ) )

(de almost (N)
   (let (X 2  Y 0)
      (make
         (loop
            (when (and (nth (factor X) N) (not (cdr @)))
               (link X)
               (inc 'Y) )
            (T (= 10 Y) 'done)
            (inc 'X) ) ) ) )

(for I 5
   (println I '-> (almost I) ) )

(bye)


# Converted from C
kprime = (n, k):
  p = 2, f = 0
  while (f < k && p*p <= n):
    while (0 == n % p):
      n /= p
      f++.
    p++.
  n = if (n > 1): 1.
      else: 0.
  f + n == k.

1 to 5 (k):
  "k = " print, k print, ":" print
  i = 2, c = 0
  while (c < 10):
    if (kprime(i, k)): " " print, i print, c++.
    i++
  .
  "" say.


% almostPrime(K, +Take, List) succeeds if List can be unified with the
% first Take K-almost-primes.
% Notice that K need not be specified.
% To avoid having to cache or recompute the first Take primes, we define
% almostPrime/3 in terms of almostPrime/4 as follows:
%
almostPrime(K, Take, List) :-
  % Compute the list of the first Take primes:
  nPrimes(Take, Primes),
  almostPrime(K, Take, Primes, List).

almostPrime(1, Take, Primes, Primes).

almostPrime(K, Take, Primes, List) :-
  generate(2, K),  % generate K >= 2
  K1 is K - 1,
  almostPrime(K1, Take, Primes, L),
  multiplylist( Primes, L, Long),
  sort(Long, Sorted), % uniquifies
  take(Take, Sorted, List).


using System;
using System.Collections.Generic;
using System.Linq;

namespace RosettaCode.AmicablePairs
{
    internal static class Program {
        private const int Limit = 20000;

        private static void Main()
        {
            foreach (var pair in GetPairs(Limit))
            {
                Console.WriteLine("{0} {1}", pair.Item1, pair.Item2);
            }
        }

        private static IEnumerable<Tuple<int, int>> GetPairs(int max)
        {
            List<int> divsums =
                Enumerable.Range(0, max + 1).Select(i => ProperDivisors(i).Sum()).ToList();
            for(int i=1; i<divsums.Count; i++) {
                int sum = divsums[i];
                if(i < sum && sum <= divsums.Count && divsums[sum] == i) {
                    yield return new Tuple<int, int>(i, sum);
                }
            }
        }

        private static IEnumerable<int> ProperDivisors(int number)
        {
            return
                Enumerable.Range(1, number / 2)
                    .Where(divisor => number % divisor == 0);
        }
    }
}


#include <vector>
#include <unordered_map>
#include <iostream>

int main() {
    std::vector<int> alreadyDiscovered;
    std::unordered_map<int, int> divsumMap;
    int count = 0;

    for (int N = 1; N <= 20000; ++N)
    {
        int divSumN = 0;

        for (int i = 1; i <= N / 2; ++i)
        {
            if (fmod(N, i) == 0)
            {
                divSumN += i;
            }
        }

        // populate map of integers to the sum of their proper divisors
        if (divSumN != 1) // do not include primes
            divsumMap[N] = divSumN;

        for (std::unordered_map<int, int>::iterator it = divsumMap.begin(); it != divsumMap.end(); ++it)
        {
            int M = it->first;
            int divSumM = it->second;
            int divSumN = divsumMap[N];

            if (N != M && divSumM == N && divSumN == M)
            {
                // do not print duplicate pairs
                if (std::find(alreadyDiscovered.begin(), alreadyDiscovered.end(), N) != alreadyDiscovered.end())
                    break;

                std::cout << "[" << M << ", " << N << "]" << std::endl;

                alreadyDiscovered.push_back(M);
                alreadyDiscovered.push_back(N);
                count++;
            }
        }
    }

    std::cout << count << " amicable pairs discovered" << std::endl;
}


USING: assocs fry io.encodings.utf8 io.files kernel math
math.combinatorics sequences sorting strings ;
IN: rosettacode.deranged-anagrams

: derangement? ( str1 str2 -- ? ) [ = not ] 2all? ;
: derangements ( seq -- seq )
    2 [ first2 derangement? ] filter-combinations ;

: parse-dict-file ( path -- hash )
    utf8 file-lines
    H{ } clone [
        '[
            [ natural-sort >string ] keep
            _ [ swap suffix  ] with change-at
        ] each
    ] keep ;

: anagrams ( hash -- seq ) [ nip length 1 > ] assoc-filter values ;

: deranged-anagrams ( path -- seq )
    parse-dict-file anagrams [ derangements ] map concat ;

: longest-deranged-anagrams ( path -- anagrams )
    deranged-anagrams [ first length ] sort-with last ;