Module AmbFunction {
      Function Amb (failure) {
            // get an array of s items, return an array of 1 item
            // we do this so we forget the type of element
            getitem=lambda (n, c) -> {
                  dim z(1) :link c to c()
                  stock c(n) keep 1, z(0)  // copy from c(n) to z(0) one item
                  =z()
            }
            read a
            c1=lambda a, getitem (i, &any,  &ret) ->{
                  any=getitem(i, a)
                  ret=any
                  =true
            }
            m=stack.size
            if m=0 then Error "At least two arrays needed"
            c=c1
            while m>1 {
                  read b
                  c1=lambda c2=c, j=0, m=len(a), b, failure, getitem (i, &any,  &ret) ->{
                        any=getitem(i, b)
                        ret=(,) :  ok=false :  anyother=(,)
                        do
                              if c2(j, &anyother,  &ret) then
                                    if not failure(any, anyother) then
                                          ok=true
                                          ret=cons(ret, any)
                                    end if
                              end if
                              j++
                        until ok or j=m
                        if j=m then j=0
                        =ok
                  }
                  c=c1 :  a=b :  m--
            }
            read b
            amb1=lambda c2=c, j=0, m=len(a), b, failure, getitem (&ret) ->{
                  ret=(,) :  ok=false: anyother=(,)
                  k=each(b)
                  while k
                        any=getitem(k^, b)
                        do
                              if c2(j, &anyother,  &ret) then
                                    if not failure(any, anyother) then
                                          ok=true
                                          ret=cons(ret, any)
                                    end if
                              end if
                              j++
                        until ok or j=m
                        if j=m then j=0
                        if ok then exit
                  end while
                  =ok
            }
            ret=(,)
            if amb1(&ret) then =ret else =(,)  ' default return value
      }

      a=(1, 2, 3)
      b=(7, 6, 4, 5)
      failure=lambda  (a,b)->{
            =a#val(0)*b#val(0)<>8
      }
      Print amb(failure, a, b)#str$()
      a=("the", "that", "a")
      b=("frog", "elephant", "thing")
      c=("walked", "treaded", "grows")
      d=("slowly", "quickly")
      failure=lambda  (a,b)->{
            =left$(a#val$(0),1)<>right$(b#val$(0),1)
      }
      Print amb(failure, a, b, c, d)#str$()
}
AmbFunction


F pdsum(n)
   R sum((1 .. (n + 1) I/ 2).filter(x -> @n % x == 0 & @n != x))

F aliquot(n, maxlen = 16, maxterm = 2 ^ 30)
   I n == 0
      R (‘terminating’, [0])
   V s = [n]
   V slen = 1
   V new = n
   L slen <= maxlen & new < maxterm
      new = pdsum(s.last)
      I new C s
         I s[0] == new
            I slen == 1
               R (‘perfect’, s)
            E I slen == 2
               R (‘amicable’, s)
            E
               R (‘sociable of length #.’.format(slen), s)
         E I s.last == new
            R (‘aspiring’, s)
         E
            R (‘cyclic back to #.’.format(new), s)
      E I new == 0
         R (‘terminating’, s [+] [0])
      E
         s.append(new)
         slen++
   L.was_no_break
      R (‘non-terminating’, s)

L(n) 1..10
   V (cls, seq) = aliquot(n)
   print(‘#.: #.’.format(cls, seq))
print()
L(n) [11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488]
   V (cls, seq) = aliquot(n)
   print(‘#.: #.’.format(cls, seq))


-module(rbtree).
-export([insert/3, find/2]).

% Node structure: { Key, Value, Color, Smaller, Bigger }

find(_, nil) ->
  not_found;
find(Key, { Key, Value, _, _, _ }) ->
  { found, { Key, Value } };
find(Key, { Key1, _, _, Left, _ }) when Key < Key1 ->
  find(Key, Left);
find(Key, { Key1, _, _, _, Right }) when Key > Key1 ->
  find(Key, Right).

insert(Key, Value, Tree) ->
  make_black(ins(Key, Value, Tree)).

ins(Key, Value, nil) ->
  { Key, Value, r, nil, nil };
ins(Key, Value, { Key, _, Color, Left, Right }) ->
  { Key, Value, Color, Left, Right };
ins(Key, Value, { Ky, Vy, Cy, Ly, Ry }) when Key < Ky ->
  balance({ Ky, Vy, Cy, ins(Key, Value, Ly), Ry });
ins(Key, Value, { Ky, Vy, Cy, Ly, Ry }) when Key > Ky ->
  balance({ Ky, Vy, Cy, Ly, ins(Key, Value, Ry) }).

make_black({ Key, Value, _, Left, Right }) ->
  { Key, Value, b, Left, Right }.

balance({ Kx, Vx, b, Lx, { Ky, Vy, r, Ly, { Kz, Vz, r, Lz, Rz } } }) ->
  { Ky, Vy, r, { Kx, Vx, b, Lx, Ly }, { Kz, Vz, b, Lz, Rz } };
balance({ Kx, Vx, b, Lx, { Ky, Vy, r, { Kz, Vz, r, Lz, Rz }, Ry } }) ->
  { Kz, Vz, r, { Kx, Vx, b, Lx, Lz }, { Ky, Vy, b, Rz, Ry } };
balance({ Kx, Vx, b, { Ky, Vy, r, { Kz, Vz, r, Lz, Rz }, Ry }, Rx }) ->
  { Ky, Vy, r, { Kz, Vz, b, Lz, Rz }, { Kx, Vx, b, Ry, Rx } };
balance({ Kx, Vx, b, { Ky, Vy, r, Ly, { Kz, Vz, r, Lz, Rz } }, Rx }) ->
  { Kz, Vz, r, { Ky, Vy, b, Ly, Lz }, { Kx, Vx, b, Rz, Rx } };
balance(T) ->
  T.


local(
	anagrams	= map,
	words		= include_url('http://wiki.puzzlers.org/pub/wordlists/unixdict.txt')->split('\n'),
	key,
	max		= 0,
	findings	= array
)

with word in #words do {
	#key = #word -> split('') -> sort& -> join('')
	if(not(#anagrams >> #key)) => {
		#anagrams -> insert(#key = array)
	}
	#anagrams -> find(#key) -> insert(#word)
}
with ana in #anagrams
let ana_size = #ana -> size
do {
	if(#ana_size > #max) => {
		#findings = array(#ana -> join(', '))
		#max = #ana_size
	else(#ana_size == #max)
		#findings -> insert(#ana -> join(', '))
	}
}

#findings -> join('<br />\n')


' count the word list
open "unixdict.txt" for input as #1
while not(eof(#1))
    line input #1,null$
    numWords=numWords+1
wend
close #1

'import to an array appending sorted letter set
open "unixdict.txt" for input as #1
dim wordList$(numWords,3)
dim chrSort$(45)
wordNum=1
while wordNum<numWords
    line input #1,actualWord$
    wordList$(wordNum,1)=actualWord$
    wordList$(wordNum,2)=sorted$(actualWord$)
    wordNum=wordNum+1
wend

'sort on letter set
sort wordList$(),1,numWords,2

'count and store number of anagrams found
wordNum=1
startPosition=wordNum
numAnagrams=0
currentChrSet$=wordList$(wordNum,2)
while wordNum < numWords
    while currentChrSet$=wordList$(wordNum,2)
        numAnagrams=numAnagrams+1
        wordNum=wordNum+1
    wend
    for n= startPosition to startPosition+numAnagrams
        wordList$(n,3)=right$("0000"+str$(numAnagrams),4)+wordList$(n,2)
    next
    startPosition=wordNum
    numAnagrams=0
    currentChrSet$=wordList$(wordNum,2)
wend

'sort on number of anagrams+letter set
sort wordList$(),numWords,1,3

'display the top anagram sets found
wordNum=1
while wordNum<150
    currentChrSet$=wordList$(wordNum,2)
    print "Anagram set";
    while currentChrSet$=wordList$(wordNum,2)
        print " : ";wordList$(wordNum,1);
        wordNum=wordNum+1
    wend
    print
    currentChrSet$=wordList$(wordNum,2)
wend

close #1
end

function sorted$(w$)
    nchr=len(w$)
    for chr = 1 to nchr
        chrSort$(chr)=mid$(w$,chr,1)
    next
    sort chrSort$(),1,nchr
    sorted$=""
    for chr = 1 to nchr
        sorted$=sorted$+chrSort$(chr)
    next
end function


:- module amb.
:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is cc_multi.
:- implementation.
:- import_module list, string, char, int.

main(!IO) :-
        ( solution(S) -> io.write_string(S, !IO), io.nl(!IO)
        ; io.write_string("No solutions found :-(\n", !IO) ).

:- pred solution(string::out) is nondet.
solution(S) :-
        member(A, ["the", "that", "a"]),
        member(N, ["frog", "elephant", "thing"]),
        member(V, ["walked", "treaded", "grows"]),
        member(E, ["slowly", "quickly"]),
        S = join_list(" ", [A, N, V, E]),
        rule1(A, N), rule1(N, V), rule1(V, E).

:- pred rule1(string::in, string::in) is semidet.
rule1(A, B) :- last_char(A) = C, first_char(B, C, _).

:- func last_char(string::in) = (char::out) is semidet.
last_char(S) = C :- index(S, length(S) - 1, C).


 /* REXX **************************************************************
 * 25.08.2013 Walter Pachl derived from REXX version 2
 *********************************************************************/
 w=''
 l=0
 mm=0
 mkset(1,'the that a if',w,mm,l)
 mkset(2,'frog elephant thing',w,mm,l)
 mkset(3,'walked treaded grows trots',w,mm,l)
 mkset(4,'slowly quickly',w,mm,l)
 show(w,mm,l)

 Loop i=1 to 3                         /* loop over sets             */
   k=i+1                               /* the following set          */
   Loop ii=1 To 10                     /* loop over elements in set k*/
     If w[i,ii].words=i Then Do        /* a sentence part found      */
       Loop jj=1 To 10                 /* loop over following words  */
         If w[i,ii].right(1)=w[k,jj].left(1) Then Do  /* fitting     */
           ns=w[i,ii]' 'w[k,jj]        /* build new sentence (part)  */
           If ns.words=k Then          /* 'complete' part            */
             add(w,k,ns)               /* add to set k               */
           End
         End
       End
     End
   End
 Say 'Results:'
 Loop jj=1 To 10                       /* show the results           */
   If w[4,jj].words=4 Then
     Say '-->' w[4,jj]
   End

 method add(w,k,s) public static
 /*********************************************************************
 * add a fitting sentence (part) s to set w[k,*]
 *********************************************************************/
   Loop i=1 To 10 While w[k,i]>''      /* look for an empty slot     */
     End
   w[k,i]=s                            /* add the sentence (part)    */
   Return

 method mkset(n,arg,smp,mm,l) public static
 /*********************************************************************
 * create set smp[n,*] from data in arg
 * mm[0] maximum number of elements in any set
 * l[n] maximum word length in set n
 *********************************************************************/
  loop i = 1 to arg.words
    smp[n,i] = arg.word(i)
    If smp[n,i].length>l[n] Then
      l[n]=smp[n,i].length
    end
  if i-1>mm[0] Then Do
    mm[0]=i-1
    End
  return

 method show(w,mm,l) public static
 /*********************************************************************
 * show the input
 *********************************************************************/
   Say 'Input:'
   Loop j=1 To mm[0]                   /* output lines               */
     ol=''
     Loop i=1 To 4
       ol=ol w[i,j].left(l[i])
       End
     Say ol.strip
     End;
   say ''
   Return


/* ARM assembly AARCH64 Raspberry PI 3B or android 64 bits */
/* program aliquotSeq64.s   */

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

.equ MAXINUM,      10
.equ MAXI,         16
.equ NBDIVISORS,   1000

/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szMessStartPgm:          .asciz "Program 64 bits start \n"
szMessEndPgm:            .asciz "Program normal end.\n"
szMessErrorArea:         .asciz "\033[31mError : area divisors too small.\033[0m \n"
szMessError:             .asciz "\033[31m\nError  !!!\033[0m \n"
szMessErrGen:            .asciz "\033[31mError end program.\033[0m \n"
szMessOverflow:          .asciz "\033[31mOverflow function isPrime.\033[0m \n"

szCarriageReturn:        .asciz "\n"
szLibPerf:               .asciz "Perfect       \n"
szLibAmic:               .asciz "Amicable      \n"
szLibSoc:                .asciz "Sociable      \n"
szLibAspi:               .asciz "Aspiring      \n"
szLibCycl:               .asciz "Cyclic        \n"
szLibTerm:               .asciz "Terminating   \n"
szLibNoTerm:             .asciz "No terminating\n"

/* datas message display */
szMessResult:            .asciz " @ "
szMessResHead:            .asciz "Number @ :"

.align 4
tbNumber:                 .quad 11,12,28,496,220,1184,12496,1264460,790,909,562,1064,1488
                          .equ NBNUMBER,  (. - tbNumber ) / 8

/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss
.align 4
sZoneConv:               .skip 24
tbZoneDecom:             .skip 8 * NBDIVISORS       // facteur 4 octets
tbNumberSucc:            .skip 8 * MAXI
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main
main:                               // program start
    ldr x0,qAdrszMessStartPgm       // display start message
    bl affichageMess

    mov x4,#1
1:
    mov x0,x4                       //  number
    bl aliquotClassif               // aliquot classification
    cmp x0,#-1                      // error ?
    beq 99f
    add x4,x4,#1
    cmp x4,#MAXINUM
    ble 1b

    ldr x5,qAdrtbNumber             // number array
    mov x4,#0
2:
    ldr x0,[x5,x4,lsl #3]           // load a number
    bl aliquotClassif               // aliquot classification
    cmp x0,#-1                      // error ?
    beq 99f
    add x4,x4,#1                    // next number
    cmp x4,#NBNUMBER                // maxi ?
    blt 2b                          // no -> loop

    ldr x0,qAdrszMessEndPgm         // display end message
    bl affichageMess
    b 100f
99:                                 // display error message
    ldr x0,qAdrszMessError
    bl affichageMess
100:                                // standard end of the program
    mov x0, #0                      // return code
    mov x8, #EXIT                   // request to exit program
    svc 0                           // perform system call
qAdrszMessStartPgm:        .quad szMessStartPgm
qAdrszMessEndPgm:          .quad szMessEndPgm
qAdrszMessError:           .quad szMessError
qAdrszCarriageReturn:      .quad szCarriageReturn
qAdrtbZoneDecom:           .quad tbZoneDecom
qAdrszMessResult:          .quad szMessResult
qAdrsZoneConv:             .quad sZoneConv
qAdrtbNumber:              .quad tbNumber
/******************************************************************/
/*     function aliquot classification                            */
/******************************************************************/
/* x0 contains number */
aliquotClassif:
    stp x4,lr,[sp,-16]!        // save  registres
    stp x5,x6,[sp,-16]!        // save  registres
    stp x7,x8,[sp,-16]!        // save  registres
    mov x5,x0                    // save number
    ldr x1,qAdrsZoneConv
    bl conversion10              // convert ascii string
    strb wzr,[x1,x0]
    ldr x0,qAdrszMessResHead
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc        // put in head message
    bl affichageMess             // and display
    mov x0,x5                    // restaur number
    ldr x7,qAdrtbNumberSucc      // number successif array
    mov x4,#0                    // counter number successif
1:
    mov x6,x0                    // previous number
    ldr x1,qAdrtbZoneDecom
    bl decompFact                // create area of divisors
    cmp x0,#0                    // error ?
    blt 99f
    sub x3,x1,x6                 // sum
    mov x0,x3
    ldr x1,qAdrsZoneConv
    bl conversion10              // convert ascii string
    strb wzr,[x1,x0]
    ldr x0,qAdrszMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc        // and put in message
    bl affichageMess
    cmp x3,#0                    // sum = zero
    bne 11f
    ldr x0,qAdrszLibTerm         // terminating
    bl affichageMess
    b 100f
11:
    cmp x5,x3                    // compare number and sum
    bne 4f
    cmp x4,#0                    // first loop ?
    bne 2f
    ldr x0,qAdrszLibPerf         // perfect
    bl affichageMess
    b 100f
2:
    cmp x4,#1                    // second loop ?
    bne 3f
    ldr x0,qAdrszLibAmic         // amicable
    bl affichageMess
    b 100f
3:                               // other loop
    ldr x0,qAdrszLibSoc          // sociable
    bl affichageMess
    b 100f

4:
    cmp x6,x3                 // compare sum and (sum - 1)
    bne 5f
    ldr x0,qAdrszLibAspi      // aspirant
    bl affichageMess
    b 100f
5:
    cmp x3,#1                 // if one ,no search in array
    beq 7f
    mov x2,#0                 // search indice
6:                            // search number in array
    ldr x9,[x7,x2,lsl #3]
    cmp x9,x3                 // equal ?
    beq 8f                    // yes -> cycling
    add x2,x2,#1              // increment indice
    cmp x2,x4                 // end ?
    blt 6b                    // no -> loop
7:
    cmp x4,#MAXI
    blt 10f
    ldr x0,qAdrszLibNoTerm    // no terminating
    bl affichageMess
    b 100f
8:                            // cycling
    ldr x0,qAdrszLibCycl
    bl affichageMess
    b 100f

10:
    str x3,[x7,x4,lsl #3]     // store new sum in array
    add x4,x4,#1              // increment counter
    mov x0,x3                 // new number = new sum
    b 1b                      // and loop

99:                           // display error
    ldr x0,qAdrszMessError
    bl affichageMess
    mov x0,-1
100:
    ldp x7,x8,[sp],16          // restaur des  2 registres
    ldp x5,x6,[sp],16          // restaur des  2 registres
    ldp x4,lr,[sp],16          // restaur des  2 registres
    ret
qAdrszMessResHead: .quad szMessResHead
qAdrszLibPerf:     .quad szLibPerf
qAdrszLibAmic:     .quad szLibAmic
qAdrszLibSoc:      .quad szLibSoc
qAdrszLibCycl:     .quad szLibCycl
qAdrszLibAspi:     .quad szLibAspi
qAdrszLibNoTerm:   .quad szLibNoTerm
qAdrszLibTerm:     .quad szLibTerm
qAdrtbNumberSucc:  .quad tbNumberSucc
/******************************************************************/
/*     decomposition en facteur                                               */
/******************************************************************/
/* x0 contient le nombre à decomposer */
/* x1 contains factor area address */
decompFact:
    stp x3,lr,[sp,-16]!          // save  registres
    stp x4,x5,[sp,-16]!          // save  registres
    stp x6,x7,[sp,-16]!          // save  registres
    stp x8,x9,[sp,-16]!          // save  registres
    stp x10,x11,[sp,-16]!        // save  registres
    mov x5,x1
    mov x1,x0
    cmp x0,1
    beq 100f
    mov x8,x0                    // save number
    bl isPrime                   // prime ?
    cmp x0,#1
    beq 98f                      // yes is prime
    mov x1,#1
    str x1,[x5]                  // first factor
    mov x12,#1                   // divisors sum
    mov x4,#1                    // indice divisors table
    mov x1,#2                    // first divisor
    mov x6,#0                    // previous divisor
    mov x7,#0                    // number of same divisors
2:
    mov x0,x8                    // dividende
    udiv x2,x0,x1                //  x1 divisor x2 quotient x3 remainder
    msub x3,x2,x1,x0
    cmp x3,#0
    bne 5f                       // if remainder <> zero  -> no divisor
    mov x8,x2                    // else quotient -> new dividende
    cmp x1,x6                    // same divisor ?
    beq 4f                       // yes
    mov x7,x4                    // number factors in table
    mov x9,#0                    // indice
21:
    ldr x10,[x5,x9,lsl #3 ]      // load one factor
    mul x10,x1,x10               // multiply
    str x10,[x5,x7,lsl #3]       // and store in the table
    adds x12,x12,x10
    bcs 99f
    add x7,x7,#1                 // and increment counter
    add x9,x9,#1
    cmp x9,x4
    blt 21b
    mov x4,x7
    mov x6,x1                    // new divisor
    b 7f
4:                               // same divisor
    sub x9,x4,#1
    mov x7,x4
41:
    ldr x10,[x5,x9,lsl #3 ]
    cmp x10,x1
    sub x13,x9,1
    csel x9,x13,x9,ne
    bne 41b
    sub x9,x4,x9
42:
    ldr  x10,[x5,x9,lsl #3 ]
    mul x10,x1,x10
    str x10,[x5,x7,lsl #3]       // and store in the table
    adds x12,x12,x10
    bcs 99f
    add x7,x7,#1                 // and increment counter
    add x9,x9,#1
    cmp x9,x4
    blt 42b
    mov x4,x7
    b 7f                         // and loop

    /* not divisor -> increment next divisor */
5:
    cmp x1,#2                    // if divisor = 2 -> add 1
    add x13,x1,#1                // add 1
    add x14,x1,#2                // else add 2
    csel x1,x13,x14,eq
    b 2b

    /* divisor -> test if new dividende is prime */
7:
    mov x3,x1                    // save divisor
    cmp x8,#1                    // dividende = 1 ? -> end
    beq 10f
    mov x0,x8                    // new dividende is prime ?
    mov x1,#0
    bl isPrime                   // the new dividende is prime ?
    cmp x0,#1
    bne 10f                      // the new dividende is not prime

    cmp x8,x6                    // else dividende is same divisor ?
    beq 9f                       // yes
    mov x7,x4                    // number factors in table
    mov x9,#0                    // indice
71:
    ldr x10,[x5,x9,lsl #3 ]      // load one factor
    mul x10,x8,x10               // multiply
    str x10,[x5,x7,lsl #3]       // and store in the table
    adds x12,x12,x10
    bcs 99f
    add x7,x7,#1                 // and increment counter
    add x9,x9,#1
    cmp x9,x4
    blt 71b
    mov x4,x7
    mov x7,#0
    b 11f
9:
    sub x9,x4,#1
    mov x7,x4
91:
    ldr x10,[x5,x9,lsl #3 ]
    cmp x10,x8
    sub x13,x9,#1
    csel x9,x13,x9,ne
    bne 91b
    sub x9,x4,x9
92:
    ldr  x10,[x5,x9,lsl #3 ]
    mul x10,x8,x10
    str x10,[x5,x7,lsl #3]       // and store in the table
    adds x12,x12,x10
    bcs 99f                      // overflow
    add x7,x7,#1                 // and increment counter
    add x9,x9,#1
    cmp x9,x4
    blt 92b
    mov x4,x7
    b 11f

10:
    mov x1,x3                    // current divisor = new divisor
    cmp x1,x8                    // current divisor  > new dividende ?
    ble 2b                       // no -> loop

    /* end decomposition */
11:
    mov x0,x4                    // return number of table items
    mov x1,x12                   // return sum
    mov x3,#0
    str x3,[x5,x4,lsl #3]        // store zéro in last table item
    b 100f

98:
    add x1,x8,1
    mov x0,#0                   // return code
    b 100f
99:
    ldr x0,qAdrszMessError
    bl   affichageMess
    mov x0,#-1                  // error code
    b 100f

100:
    ldp x10,x11,[sp],16          // restaur des  2 registres
    ldp x8,x9,[sp],16          // restaur des  2 registres
    ldp x6,x7,[sp],16          // restaur des  2 registres
    ldp x4,x5,[sp],16          // restaur des  2 registres
    ldp x3,lr,[sp],16          // restaur des  2 registres
    ret                        // retour adresse lr x30
qAdrszMessErrGen:          .quad szMessErrGen
/***************************************************/
/*   Verification si un nombre est premier         */
/***************************************************/
/* x0 contient le nombre à verifier */
/* x0 retourne 1 si premier  0 sinon */
isPrime:
    stp x1,lr,[sp,-16]!        // save  registres
    stp x2,x3,[sp,-16]!        // save  registres
    mov x2,x0
    sub x1,x0,#1
    cmp x2,0
    beq 99f                    // retourne zéro
    cmp x2,2                   // pour 1 et 2 retourne 1
    ble 2f
    mov x0,#2
    bl moduloPux64
    bcs 100f                   // erreur overflow
    cmp x0,#1
    bne 99f                    // Pas premier
    cmp x2,3
    beq 2f
    mov x0,#3
    bl moduloPux64
    blt 100f                   // erreur overflow
    cmp x0,#1
    bne 99f

    cmp x2,5
    beq 2f
    mov x0,#5
    bl moduloPux64
    bcs 100f                   // erreur overflow
    cmp x0,#1
    bne 99f                    // Pas premier

    cmp x2,7
    beq 2f
    mov x0,#7
    bl moduloPux64
    bcs 100f                   // erreur overflow
    cmp x0,#1
    bne 99f                    // Pas premier

    cmp x2,11
    beq 2f
    mov x0,#11
    bl moduloPux64
    bcs 100f                   // erreur overflow
    cmp x0,#1
    bne 99f                    // Pas premier

    cmp x2,13
    beq 2f
    mov x0,#13
    bl moduloPux64
    bcs 100f                   // erreur overflow
    cmp x0,#1
    bne 99f                    // Pas premier
2:
    cmn x0,0                   // carry à zero pas d'erreur
    mov x0,1                   // premier
    b 100f
99:
    cmn x0,0                   // carry à zero pas d'erreur
    mov x0,#0                  // Pas premier
100:
    ldp x2,x3,[sp],16          // restaur des  2 registres
    ldp x1,lr,[sp],16          // restaur des  2 registres
    ret                        // retour adresse lr x30

/**************************************************************/
/********************************************************/
/*   Calcul modulo de b puissance e modulo m  */
/*    Exemple 4 puissance 13 modulo 497 = 445         */
/********************************************************/
/* x0  nombre  */
/* x1 exposant */
/* x2 modulo   */
moduloPux64:
    stp x1,lr,[sp,-16]!        // save  registres
    stp x3,x4,[sp,-16]!        // save  registres
    stp x5,x6,[sp,-16]!        // save  registres
    stp x7,x8,[sp,-16]!        // save  registres
    stp x9,x10,[sp,-16]!        // save  registres
    cbz x0,100f
    cbz x1,100f
    mov x8,x0
    mov x7,x1
    mov x6,1                   // resultat
    udiv x4,x8,x2
    msub x9,x4,x2,x8           // contient le reste
1:
    tst x7,1
    beq 2f
    mul x4,x9,x6
    umulh x5,x9,x6
    mov x6,x4
    mov x0,x6
    mov x1,x5
    bl divisionReg128U
    cbnz x1,99f                // overflow
    mov x6,x3
2:
    mul x8,x9,x9
    umulh x5,x9,x9
    mov x0,x8
    mov x1,x5
    bl divisionReg128U
    cbnz x1,99f                // overflow
    mov x9,x3
    lsr x7,x7,1
    cbnz x7,1b
    mov x0,x6                  // result
    cmn x0,0                   // carry à zero pas d'erreur
    b 100f
99:
    ldr x0,qAdrszMessOverflow
    bl  affichageMess
    cmp x0,0                   // carry à un car erreur
    mov x0,-1                  // code erreur

100:
    ldp x9,x10,[sp],16          // restaur des  2 registres
    ldp x7,x8,[sp],16          // restaur des  2 registres
    ldp x5,x6,[sp],16          // restaur des  2 registres
    ldp x3,x4,[sp],16          // restaur des  2 registres
    ldp x1,lr,[sp],16          // restaur des  2 registres
    ret                        // retour adresse lr x30
qAdrszMessOverflow:         .quad  szMessOverflow
/***************************************************/
/*   division d un nombre de 128 bits par un nombre de 64 bits */
/***************************************************/
/* x0 contient partie basse dividende */
/* x1 contient partie haute dividente */
/* x2 contient le diviseur */
/* x0 retourne partie basse quotient */
/* x1 retourne partie haute quotient */
/* x3 retourne le reste */
divisionReg128U:
    stp x6,lr,[sp,-16]!        // save  registres
    stp x4,x5,[sp,-16]!        // save  registres
    mov x5,#0                  // raz du reste R
    mov x3,#128                // compteur de boucle
    mov x4,#0                  // dernier bit
1:
    lsl x5,x5,#1               // on decale le reste de 1
    tst x1,1<<63               // test du bit le plus à gauche
    lsl x1,x1,#1               // on decale la partie haute du quotient de 1
    beq 2f
    orr  x5,x5,#1              // et on le pousse dans le reste R
2:
    tst x0,1<<63
    lsl x0,x0,#1               // puis on decale la partie basse
    beq 3f
    orr x1,x1,#1               // et on pousse le bit de gauche dans la partie haute
3:
    orr x0,x0,x4               // position du dernier bit du quotient
    mov x4,#0                  // raz du bit
    cmp x5,x2
    blt 4f
    sub x5,x5,x2                // on enleve le diviseur du reste
    mov x4,#1                   // dernier bit à 1
4:
                               // et boucle
    subs x3,x3,#1
    bgt 1b
    lsl x1,x1,#1               // on decale le quotient de 1
    tst x0,1<<63
    lsl x0,x0,#1              // puis on decale la partie basse
    beq 5f
    orr x1,x1,#1
5:
    orr x0,x0,x4                  // position du dernier bit du quotient
    mov x3,x5
100:
    ldp x4,x5,[sp],16          // restaur des  2 registres
    ldp x6,lr,[sp],16          // restaur des  2 registres
    ret                        // retour adresse lr x30

/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


BEGIN
    # aliquot sequence classification                                         #
    # maximum sequence length we consider                                     #
    INT max sequence length = 16;
    # possible classifications                                                #
    STRING         perfect classification    = "perfect        ";
    STRING        amicable classification    = "amicable       ";
    STRING        sociable classification    = "sociable       ";
    STRING        aspiring classification    = "aspiring       ";
    STRING          cyclic classification    = "cyclic         ";
    STRING     terminating classification    = "terminating    ";
    STRING non terminating classification    = "non terminating";
    # structure to hold an aliquot sequence and its classification            #
    MODE ALIQUOT = STRUCT( STRING                              classification
                         , [ 1 : max sequence length ]LONG INT sequence
                         , INT                                 length
                         );
    # maximum value for sequence elements - if any element is more than this, #
    # we assume it is non-teriminating                                        #
    LONG INT max element = 140 737 488 355 328;
    # returns the sum of the proper divisors of n                             #
    OP DIVISORSUM = ( LONG INT n )LONG INT:
       BEGIN
            LONG INT abs n = ABS n;
            IF abs n < 2 THEN
                0 # -1, 0 and 1 have no proper divisors                       #
            ELSE
                # have a number with possible divisors                        #
               LONG INT result := 1; # 1 is always a divisor                  #
               # a FOR loop counter can only be an INT, hence the WHILE loop  #
               LONG INT d      := ENTIER long sqrt( abs n );
               WHILE d > 1 DO
                   IF abs n MOD d = 0 THEN
                       # found another divisor                                #
                       result +:= d;
                       IF d * d /= abs n THEN
                           # add the other divisor                            #
                           result +:= abs n OVER d
                       FI
                   FI;
                   d -:= 1
               OD;
               result
            FI
       END # DIVISORSUM # ;
    # generates the aliquot sequence of the number k and its classification   #
    # at most max elements of the sequence are considered                     #
    OP CLASSIFY = ( LONG INT k )ALIQUOT :
       BEGIN
           ALIQUOT result;
           classification OF result := "non-terminating";
           INT lb = LWB sequence OF result;
           INT ub = UPB sequence OF result;
           ( sequence OF result )[ lb ] := k; # the first element is always k #
           length     OF result         := 1;
           FOR i FROM lb + 1 TO ub DO
               ( sequence OF result )[ i ] := 0
           OD;
           BOOL classified := FALSE;
           LONG INT prev k := k;
           FOR i FROM lb + 1 TO ub WHILE NOT classified DO
               length OF result +:= 1;
               LONG INT next k := ( sequence OF result )[ i ] := DIVISORSUM prev k;
               classified := TRUE;
               IF   next k = 0 THEN # the sequence terminates                 #
                    classification OF result := terminating classification
               ELIF next k > max element THEN # the sequence gets too large   #
                    classification OF result := non terminating classification
               ELIF next k = k THEN # the sequence that returns to k          #
                   classification OF result
                       := IF   i = lb + 1 THEN  perfect classification
                          ELIF i = lb + 2 THEN amicable classification
                          ELSE                 sociable classification
                          FI
               ELIF next k = prev k THEN # the sequence repeats with non-k    #
                   classification OF result := aspiring classification
               ELSE # check for repeating sequence with a period more than 1  #
                   classified := FALSE;
                   FOR prev pos FROM lb TO i - 2 WHILE NOT classified DO
                       IF classified := ( sequence OF result )[ prev pos ] = next k THEN
                           # found a repeatition                              #
                           classification OF result := cyclic classification
                       FI
                   OD
               FI;
               prev k := next k
           OD;
           result
       END # CLASSIFY # ;
    # test cases as per the task                                              #
    []LONG INT test cases =
        (   1,    2,   3,   4,   5,    6,     7,       8,   9,  10
        ,  11,   12,  28, 496, 220, 1184, 12496, 1264460, 790, 909
        , 562, 1064, 1488
        ,  15355717786080
        );
    FOR i FROM LWB test cases TO UPB test cases DO
        LONG INT k   := test cases[ i ];
        ALIQUOT  seq  = CLASSIFY k;
        print( ( whole( k, -14 ), ": ", classification OF seq, ":" ) );
        FOR e FROM LWB sequence OF seq + 1 TO length OF seq DO
            print( ( " ", whole( ( sequence OF seq )[ e ], 0 ) ) )
        OD;
        print( ( newline ) )
    OD
END


// Pattern Matching. Nigel Galloway: January 15th., 2021
type colour= |Red |Black
type rbT<'N>= |Empty |N of colour * rbT<'N> * rbT<'N> * 'N
let repair=function |Black,N(Red,N(Red,ll,lr,lv),rl,v),rr,rv
                    |Black,N(Red,ll,N(Red,lr,rl,v),lv),rr,rv
                    |Black,ll,N(Red,N(Red,lr,rl,v),rr,rv),lv
                    |Black,ll,N(Red,lr,N(Red,rl,rr,rv),v),lv->N(Red,N(Black,ll,lr,lv),N(Black,rl,rr,rv),v)
                    |i,g,e,l->N(i,g,e,l)
let insert item rbt = let rec insert=function
                        |Empty->N(Red,Empty,Empty,item)
                        |N(i,g,e,l) as node->if item>l then repair(i,g,insert e,l) elif item<l then repair(i,insert g,e,l) else node
                      match insert rbt with N(_,g,e,l)->N(Black,g,e,l) |_->Empty


package main

import "fmt"

type Color string

const (
    R Color = "R"
    B       = "B"
)

type Tree interface {
    ins(x int) Tree
}

type E struct{}

func (_ E) ins(x int) Tree {
    return T{R, E{}, x, E{}}
}

func (_ E) String() string {
    return "E"
}

type T struct {
    cl Color
    le Tree
    aa int
    ri Tree
}

func (t T) balance() Tree {
    if t.cl != B {
        return t
    }
    le, leIsT := t.le.(T)
    ri, riIsT := t.ri.(T)
    var lele, leri, rile, riri T
    var leleIsT, leriIsT, rileIsT, ririIsT bool
    if leIsT {
        lele, leleIsT = le.le.(T)
    }
    if leIsT {
        leri, leriIsT = le.ri.(T)
    }
    if riIsT {
        rile, rileIsT = ri.le.(T)
    }
    if riIsT {
        riri, ririIsT = ri.ri.(T)
    }
    switch {
    case leIsT && leleIsT && le.cl == R && lele.cl == R:
        _, t2, z, d := t.destruct()
        _, t3, y, c := t2.(T).destruct()
        _, a, x, b := t3.(T).destruct()
        return T{R, T{B, a, x, b}, y, T{B, c, z, d}}
    case leIsT && leriIsT && le.cl == R && leri.cl == R:
        _, t2, z, d := t.destruct()
        _, a, x, t3 := t2.(T).destruct()
        _, b, y, c := t3.(T).destruct()
        return T{R, T{B, a, x, b}, y, T{B, c, z, d}}
    case riIsT && rileIsT && ri.cl == R && rile.cl == R:
        _, a, x, t2 := t.destruct()
        _, t3, z, d := t2.(T).destruct()
        _, b, y, c := t3.(T).destruct()
        return T{R, T{B, a, x, b}, y, T{B, c, z, d}}
    case riIsT && ririIsT && ri.cl == R && riri.cl == R:
        _, a, x, t2 := t.destruct()
        _, b, y, t3 := t2.(T).destruct()
        _, c, z, d := t3.(T).destruct()
        return T{R, T{B, a, x, b}, y, T{B, c, z, d}}
    default:
        return t
    }
}

func (t T) ins(x int) Tree {
    switch {
    case x < t.aa:
        return T{t.cl, t.le.ins(x), t.aa, t.ri}.balance()
    case x > t.aa:
        return T{t.cl, t.le, t.aa, t.ri.ins(x)}.balance()
    default:
        return t
    }
}

func (t T) destruct() (Color, Tree, int, Tree) {
    return t.cl, t.le, t.aa, t.ri
}

func (t T) String() string {
    return fmt.Sprintf("T(%s, %v, %d, %v)", t.cl, t.le, t.aa, t.ri)
}

func insert(tr Tree, x int) Tree {
    t := tr.ins(x)
    switch t.(type) {
    case T:
        tt := t.(T)
        _, a, y, b := tt.destruct()
        return T{B, a, y, b}
    case E:
        return E{}
    default:
        return nil
    }
}

func main() {
    var tr Tree = E{}
    for i := 1; i <= 16; i++ {
        tr = insert(tr, i)
    }
    fmt.Println(tr)
}


on mouseUp
   put mostCommonAnagrams(url "http://wiki.puzzlers.org/pub/wordlists/unixdict.txt")
end mouseUp

function mostCommonAnagrams X
   put 0 into maxCount
   repeat for each word W in X
      get sortChars(W)
      put W & comma after A[it]
      add 1 to C[it]
      if C[it] >= maxCount then
         if C[it] > maxCount then
            put C[it] into maxCount
            put char 1 to -2 of A[it] into winnerList
         else
            put cr & char 1 to -2 of A[it] after winnerList
         end if
      end if
   end repeat
   return winnerList
end mostCommonAnagrams

function sortChars X
   get charsToItems(X)
   sort items of it
   return itemsToChars(it)
end sortChars

function charsToItems X
   repeat for each char C in X
      put C & comma after R
   end repeat
   return char 1 to -2 of R
end charsToItems

function itemsToChars X
   replace comma with empty in X
   return X
end itemsToChars


function sort(word)
  local bytes = {word:byte(1, -1)}
  table.sort(bytes)
  return string.char(table.unpack(bytes))
end

-- Read in and organize the words.
-- word_sets[<alphabetized_letter_list>] = {<words_with_those_letters>}
local word_sets = {}
local max_size = 0
for word in io.lines('unixdict.txt') do
  local key = sort(word)
  if word_sets[key] == nil then word_sets[key] = {} end
  table.insert(word_sets[key], word)
  max_size = math.max(max_size, #word_sets[key])
end

-- Print out the answer sets.
for _, word_set in pairs(word_sets) do
  if #word_set == max_size then
    for _, word in pairs(word_set) do io.write(word .. ' ') end
    print('')  -- Finish with a newline.
  end
end


import sugar, strutils

proc amb(comp: proc(a, b: string): bool,
         options: seq[seq[string]],
         prev: string = ""): seq[string] =

  if options.len == 0: return @[]

  for opt in options[0]:
    # If this is the base call, prev is nil and we need to continue.
    if prev.len != 0 and not comp(prev, opt): continue

    # Take care of the case where we have no options left.
    if options.len == 1: return @[opt]

    # Traverse into the tree.
    let res = amb(comp, options[1..options.high], opt)

    # If it was a failure, try the next one.
    if res.len > 0: return opt & res    # We have a match.

  return @[]

const sets = @[@["the", "that", "a"],
               @["frog", "elephant", "thing"],
               @["walked", "treaded", "grows"],
               @["slowly", "quickly"]]

let result = amb((s, t: string) => (s[s.high] == t[0]), sets)
if result.len == 0:
  echo "No matches found!"
else:
  echo result.join " "


let set_1 = ["the"; "that"; "a"]
let set_2 = ["frog"; "elephant"; "thing"]
let set_3 = ["walked"; "treaded"; "grows"]
let set_4 = ["slowly"; "quickly"]

let combs ll =
  let rec aux acc = function
  | [] -> (List.map List.rev acc)
  | hd::tl ->
      let acc =
        List.fold_left
          (fun _ac l ->
            List.fold_left (fun _ac v -> (v::l)::_ac) _ac hd
          ) [] acc
      in
      aux acc tl
  in
  aux [[]] ll

let last s = s.[pred(String.length s)]
let joined a b = (last a = b.[0])

let rec test = function
  | a::b::tl -> (joined a b) && (test (b::tl))
  | _ -> true

let print_set set =
  List.iter (Printf.printf " %s") set;
  print_newline();
;;

let () =
  let sets = combs [set_1; set_2; set_3; set_4] in
  let sets = List.filter test sets in
  List.iter print_set sets;
;;


on aliquotSum(n)
    if (n < 2) then return 0
    set sum to 1
    set sqrt to n ^ 0.5
    set limit to sqrt div 1
    if (limit = sqrt) then
        set sum to sum + limit
        set limit to limit - 1
    end if
    repeat with i from 2 to limit
        if (n mod i is 0) then set sum to sum + i + n div i
    end repeat

    return sum
end aliquotSum

on aliquotSequence(k, maxLength, maxN)
    -- Generate the sequence within the specified limitations.
    set sequence to {k}
    set n to k
    repeat (maxLength - 1) times
        set n to aliquotSum(n)
        set repetition to (sequence contains n)
        if (repetition) then exit repeat
        set end of sequence to n
        if ((n = 0) or (n > maxN)) then exit repeat
    end repeat
    -- Analyse it.
    set sequenceLength to (count sequence)
    if (sequenceLength is 1) then
        set classification to "perfect"
    else if (n is 0) then
        set classification to "terminating"
    else if (n = k) then
        if (sequenceLength is 2) then
            set classification to "amicable"
        else
            set classification to "sociable"
        end if
    else if (repetition) then
        if (sequence ends with n) then
            set classification to "aspiring"
        else
            set classification to "cyclic"
        end if
    else
        set classification to "non-terminating"
    end if

    return {sequence:sequence, classification:classification}
end aliquotSequence

-- Task code:
local output, maxLength, maxN, spacing, astid, k
set output to {""}
set {maxLength, maxN} to {16, 2 ^ 47}
set spacing to "                    "
set astid to AppleScript's text item delimiters
set AppleScript's text item delimiters to ", "
repeat with k in {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, ¬
    11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488, 1.535571778608E+13}
    set thisResult to aliquotSequence(k's contents, maxLength, maxN)
    set end of output to text -18 thru -1 of (spacing & k) & ":  " & ¬
        text 1 thru 17 of (thisResult's classification & spacing) & thisResult's sequence
end repeat
set AppleScript's text item delimiters to linefeed
set output to output as text
set AppleScript's text item delimiters to astid
return output


data Color = R | B
data Tree a = E | T Color (Tree a) a (Tree a)

balance :: Color -> Tree a -> a -> Tree a -> Tree a
balance B (T R (T R a x b) y c          ) z d                               = T R (T B a x b) y (T B c z d)
balance B (T R a           x (T R b y c)) z d                               = T R (T B a x b) y (T B c z d)
balance B a                               x (T R (T R b y c) z d          ) = T R (T B a x b) y (T B c z d)
balance B a                               x (T R b           y (T R c z d)) = T R (T B a x b) y (T B c z d)
balance col a x b = T col a x b

insert :: Ord a => a -> Tree a -> Tree a
insert x s = T B a y b where
  ins E          =  T R E x E
  ins s@(T col a y b)
    | x < y      =  balance col (ins a) y b
    | x > y      =  balance col a y (ins b)
    | otherwise  =  s
  T _ a y b = ins s


insert=:{{
  'R';'';y;a:
:
  if. 0=#y do. insert x
  elseif. 0=L.y do. x insert insert y
  else.
    'C e K w'=. y
    select. *x - K
      case. _1 do. balance C;(x insert e);K;<w
      case.  0 do. y
      case.  1 do. balance C;e;K;<x insert w
    end.
  end.
}}

NB. C: color, e: east, K: key, w: west
NB. two cascaded reds under a black become two black siblings under a red
balance=: {{
  'C e K w'=. y
  if. #e do.
    'eC ee eK ew'=. e
    if. 'R'=eC do.
      if. #ee do.
        'eeC eee eeK eew'=. ee NB. ((eee eeK eew) eK ew) K w   =>  (eee eeK eew) eK (ew K w)
        if. 'R'=eeC do. 'R';('B';eee;eeK;<eew);eK;<'B';ew;K;<w return. end. end.
      if. #ew do.
        'ewC ewe ewK eww'=. ew NB. (ee ek (ewe ewK eww)) K w  =>  (ee ek ewe) ewK (eww K w)
        if. 'R'=ewC do. 'R';('B';ee;eK;<ewe);ewK;<'B';eww;K;<w return. end. end. end. end.
  if. #w do.
    'wC we wK ww'=. w
    if. 'R'=wC do.
      if. #we do.
        'weC wee weK wew'=. we NB. e K ((wee weK wew) wK ww)  =>  (e K wee) weK (wew wK ww)
        if. 'R'=weC do. 'R';('B';e;K;<wee);weK;<'B';wew;wK;<ww return. end. end.
      if. #ww do.
        'wwC wwe wwK www'=. ww NB. e K (we wK (wwe wwK www))  =>  (e K we) wK (wwe wwK www)
        if. 'R'=wwC do. 'R';('B';e;K;<we);wK;<'B';wwe;wwK;<www return. end. end. end. end.
  y
}}


words := HTTP:-Get( "http://wiki.puzzlers.org/pub/wordlists/unixdict.txt" )[2]: # ignore errors
use StringTools, ListTools in
  T := Classify( Sort, map( Trim, Split( words ) ) )
end use:
L := convert( T, 'list' ):
m := max( map( nops, L ) ); # what is the largest set?
A := select( s -> evalb( nops( s ) = m ), L ); # get the maximal sets of anagrams


DEF VAR cset AS CHAR EXTENT 4 INIT [
   "the,that,a",
   "frog,elephant,thing",
   "walked,treaded,grows",
   "slowly,quickly"
].

FUNCTION getAmb RETURNS CHARACTER (
   i_cwords AS CHAR,
   i_iset   AS INT
):

   DEF VAR cresult   AS CHAR.
   DEF VAR ii        AS INT.
   DEF VAR cword     AS CHAR.

   DO ii = 1 TO NUM-ENTRIES( cset [ i_iset ] ) WHILE NUM-ENTRIES( cresult, " " ) < EXTENT( cset ):

      cword = ENTRY( ii, cset[ i_iset ] ).
      IF i_cwords = "" OR
         SUBSTRING( i_cwords, LENGTH( i_cwords ), 1 ) = SUBSTRING( cword, 1, 1 )
      THEN DO:
         IF i_iset = EXTENT ( cset ) THEN
            cresult = i_cwords + " " + cword.
         ELSE
            cresult = getAmb( i_cwords + " " + cword, i_iset + 1 ).
      END.

   END.

   RETURN cresult.

END FUNCTION. /* getAmb */

MESSAGE getAmb( "", 1 ) VIEW-AS ALERT-BOX.


declare

  fun {Amb Xs}
     case Xs of nil then fail
     [] [X] then X
     [] X|Xr then
        choice X
        [] {Amb Xr}
        end
     end
  end

  fun {Example}
     W1 = {Amb ["the" "that" "a"]}
     W2 = {Amb ["frog" "elephant" "thing"]}
     W3 = {Amb ["walked" "treaded" "grows"]}
     W4 = {Amb ["slowly" "quickly"]}
  in
     {List.last W1 W2.1}
     {List.last W2 W3.1}
     {List.last W3 W4.1}
     W1#" "#W2#" "#W3#" "#W4
  end

in

  {ForAll {SearchAll Example} System.showInfo}


/* ARM assembly Raspberry PI  */
/* program aliquotSeq.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 MAXINUM,      10
.equ MAXI,         16
.equ NBDIVISORS,   1000

/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szMessStartPgm:          .asciz "Program start \n"
szMessEndPgm:            .asciz "Program normal end.\n"
szMessErrorArea:         .asciz "\033[31mError : area divisors too small.\033[0m \n"
szMessError:             .asciz "\033[31mError  !!!\033[0m \n"
szMessErrGen:            .asciz "Error end program.\033[0m \n"

szCarriageReturn:        .asciz "\n"
szLibPerf:               .asciz "Perfect       \n"
szLibAmic:               .asciz "Amicable      \n"
szLibSoc:                .asciz "Sociable      \n"
szLibAspi:               .asciz "Aspiring      \n"
szLibCycl:               .asciz "Cyclic        \n"
szLibTerm:               .asciz "Terminating   \n"
szLibNoTerm:             .asciz "No terminating\n"

/* datas message display */
szMessResult:            .asciz " @ "
szMessResHead:            .asciz "Number @ :"

.align 4
tbNumber:                 .int 11,12,28,496,220,1184,12496,1264460,790,909,562,1064,1488
                          .equ NBNUMBER,  (. - tbNumber ) / 4

/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss
.align 4
sZoneConv:               .skip 24
tbZoneDecom:             .skip 4 * NBDIVISORS       // facteur 4 octets
tbNumberSucc:            .skip 4 * MAXI
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main
main:                               @ program start
    ldr r0,iAdrszMessStartPgm       @ display start message
    bl affichageMess

    mov r4,#1
1:
    mov r0,r4                       @  number
    bl aliquotClassif               @ aliquot classification
    cmp r0,#-1                      @ error ?
    beq 99f
    add r4,r4,#1
    cmp r4,#MAXINUM
    ble 1b

    ldr r5,iAdrtbNumber             @ number array
    mov r4,#0
2:
    ldr r0,[r5,r4,lsl #2]           @ load a number
    bl aliquotClassif               @ aliquot classification
    cmp r0,#-1                      @ error ?
    beq 99f
    add r4,r4,#1                    @ next number
    cmp r4,#NBNUMBER                @ maxi ?
    blt 2b                          @ no -> loop

    ldr r0,iAdrszMessEndPgm         @ display end message
    bl affichageMess
    b 100f
99:                                 @ display error message
    ldr r0,iAdrszMessError
    bl affichageMess
100:                                @ standard end of the program
    mov r0, #0                      @ return code
    mov r7, #EXIT                   @ request to exit program
    svc 0                           @ perform system call
iAdrszMessStartPgm:        .int szMessStartPgm
iAdrszMessEndPgm:          .int szMessEndPgm
iAdrszMessError:           .int szMessError
iAdrszCarriageReturn:      .int szCarriageReturn
iAdrtbZoneDecom:           .int tbZoneDecom
iAdrszMessResult:          .int szMessResult
iAdrsZoneConv:             .int sZoneConv
iAdrtbNumber:              .int tbNumber
/******************************************************************/
/*     function aliquot classification                            */
/******************************************************************/
/* r0 contains number */
aliquotClassif:
    push {r3-r8,lr}              @ save  registers
    mov r5,r0                    @ save number
    ldr r1,iAdrsZoneConv
    bl conversion10              @ convert ascii string
    mov r2,#0
    strb r2,[r1,r0]
    ldr r0,iAdrszMessResHead
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc        @ put in head message
    bl affichageMess             @ and display
    mov r0,r5                    @ restaur number
    ldr r7,iAdrtbNumberSucc      @ number successif array
    mov r4,#0                    @ counter number successif
1:
    mov r6,r0                    @ previous number
    ldr r1,iAdrtbZoneDecom
    bl decompFact                @ create area of divisors
    cmp r0,#0                    @ error ?
    blt 99f
    sub r3,r1,r6                 @ sum
    mov r0,r3
    ldr r1,iAdrsZoneConv
    bl conversion10              @ convert ascii string
    mov r2,#0
    strb r2,[r1,r0]
    ldr r0,iAdrszMessResult
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc        @ and put in message
    bl affichageMess
    cmp r3,#0                    @ sum = zero
    bne 11f
    ldr r0,iAdrszLibTerm         @ terminating
    bl affichageMess
    b 100f
11:
    cmp r5,r3                    @ compare number and sum
    bne 4f
    cmp r4,#0                    @ first loop ?
    bne 2f
    ldr r0,iAdrszLibPerf         @ perfect
    bl affichageMess
    b 100f
2:
    cmp r4,#1                    @ second loop ?
    bne 3f
    ldr r0,iAdrszLibAmic         @ amicable
    bl affichageMess
    b 100f
3:                               @ other loop
    ldr r0,iAdrszLibSoc          @ sociable
    bl affichageMess
    b 100f

4:
    cmp r6,r3                 @ compare sum and (sum - 1)
    bne 5f
    ldr r0,iAdrszLibAspi      @ aspirant
    bl affichageMess
    b 100f
5:
    cmp r3,#1                 @ if one ,no search in array
    beq 7f
    mov r2,#0                 @ search indice
6:                            @ search number in array
    ldr r8,[r7,r2,lsl #2]
    cmp r8,r3                 @ equal ?
    beq 8f                    @ yes -> cycling
    add r2,r2,#1              @ increment indice
    cmp r2,r4                 @ end ?
    blt 6b                    @ no -> loop
7:
    cmp r4,#MAXI
    blt 10f
    ldr r0,iAdrszLibNoTerm    @ no terminating
    bl affichageMess
    b 100f
8:                            @ cycling
    ldr r0,iAdrszLibCycl
    bl affichageMess
    b 100f

10:
    str r3,[r7,r4,lsl #2]     @ store new sum in array
    add r4,r4,#1              @ increment counter
    mov r0,r3                 @ new number = new sum
    b 1b                      @ and loop

99:                           @ display error
    ldr r0,iAdrszMessError
    bl affichageMess
100:
    pop {r3-r8,lr}            @ restaur registers
    bx lr
iAdrszMessResHead: .int szMessResHead
iAdrszLibPerf:     .int szLibPerf
iAdrszLibAmic:     .int szLibAmic
iAdrszLibSoc:      .int szLibSoc
iAdrszLibCycl:     .int szLibCycl
iAdrszLibAspi:     .int szLibAspi
iAdrszLibNoTerm:   .int szLibNoTerm
iAdrszLibTerm:     .int szLibTerm
iAdrtbNumberSucc:  .int tbNumberSucc
/******************************************************************/
/*     factor decomposition                                               */
/******************************************************************/
/* r0 contains number */
/* r1 contains address of divisors area */
/* r0 return divisors items in array    */
/* r1 return the sum of divisors  */
decompFact:
    push {r3-r12,lr}              @ save  registers
    cmp r0,#1
    moveq r1,#1
    beq 100f
    mov r5,r1
    mov r8,r0                    @ save number
    bl isPrime                   @ prime ?
    cmp r0,#1
    beq 98f                      @ yes is prime
    mov r1,#1
    str r1,[r5]                  @ first factor
    mov r12,#1                   @ divisors sum
    mov r10,#1                   @ indice divisors table
    mov r9,#2                    @ first divisor
    mov r6,#0                    @ previous divisor
    mov r7,#0                    @ number of same divisors

    /*  division loop  */
2:
    mov r0,r8                    @ dividende
    mov r1,r9                    @ divisor
    bl division                  @ r2 quotient r3 remainder
    cmp r3,#0
    beq 3f                       @ if remainder  zero  ->  divisor

        /* not divisor -> increment next divisor */
    cmp r9,#2                    @ if divisor = 2 -> add 1
    addeq r9,#1
    addne r9,#2                  @ else add 2
    b 2b

       /* divisor   compute the new factors of number */
3:
    mov r8,r2                    @ else quotient -> new dividende
    cmp r9,r6                    @ same divisor ?
    beq 4f                       @ yes

    mov r0,r5                    @ table address
    mov r1,r10                   @ number factors in table
    mov r2,r9                    @ divisor
    mov r3,r12                   @ somme
    mov r4,#0
    bl computeFactors
    cmp r0,#-1
    beq 100f
    mov r10,r1
    mov r12,r0
    mov r6,r9                    @ new divisor
    b 7f

4:                               @ same divisor
    sub r7,r10,#1
5:                              @ search in table the first use of divisor
    ldr r3,[r5,r7,lsl #2 ]
    cmp r3,r9
    subne r7,#1
    bne 5b
                                 @ and compute new factors after factors
    sub r4,r10,r7                @ start indice
    mov r0,r5
    mov r1,r10
    mov r2,r9                    @ divisor
    mov r3,r12
    bl computeFactors
    cmp r0,#-1
    beq 100f
    mov r12,r0
    mov r10,r1

    /* divisor -> test if new dividende is prime */
7:
    cmp r8,#1                    @ dividende = 1 ? -> end
    beq 10f
    mov r0,r8                    @ new dividende is prime ?
    mov r1,#0
    bl isPrime                   @ the new dividende is prime ?
    cmp r0,#1
    bne 10f                      @ the new dividende is not prime

    cmp r8,r6                    @ else dividende is same divisor ?
    beq 8f                       @ yes

    mov r0,r5
    mov r1,r10
    mov r2,r8
    mov r3,r12
    mov r4,#0
    bl computeFactors
    cmp r0,#-1
    beq 100f
    mov r12,r0
    mov r10,r1
    mov r7,#0
    b 11f
8:
    sub r7,r10,#1
9:
    ldr r3,[r5,r7,lsl #2 ]
    cmp r3,r8
    subne r7,#1
    bne 9b

    mov r0,r5
    mov r1,r10
    sub r4,r10,r7
    mov r2,r8
    mov r3,r12
    bl computeFactors
    cmp r0,#-1
    beq 100f
    mov r12,r0
    mov r10,r1

    b 11f

10:
    cmp r9,r8                    @ current divisor  > new dividende ?
    ble 2b                       @ no -> loop

    /* end decomposition */
11:
    mov r0,r10                  @ return number of table items
    mov r1,r12                  @ return sum
    mov r3,#0
    str r3,[r5,r10,lsl #2]      @ store zéro in last table item
    b 100f

98:                             @ prime number
    add r1,r8,#1
    mov r0,#0                   @ return code
    b 100f
99:
    ldr r0,iAdrszMessError
    bl   affichageMess
    mov r0,#-1                  @ error code
    b 100f
100:
    pop {r3-r12,pc}             @ restaur registers
/******************************************************************/
/*    compute all factors                                         */
/******************************************************************/

/*   r0 table factors address */
/*   r1 number factors in table */
/*   r2 new divisor */
/*   r3 sum  */
/*   r4 start indice */
/*   r0 return sum */
/*   r1 return number factors in table */
computeFactors:
    push {r2-r6,lr}              @ save registers
    mov r6,r1                    @ number factors in table
1:
    ldr r5,[r0,r4,lsl #2 ]       @ load one factor
    mul r5,r2,r5                 @ multiply
    str r5,[r0,r1,lsl #2]        @ and store in the table

    adds r3,r5
    movcs r0,#-1                 @ overflow
    bcs 100f
    add r1,r1,#1                 @ and increment counter
    add r4,r4,#1
    cmp r4,r6
    blt 1b
    mov r0,r3                    @ factors sum
100:                             @ fin standard de la fonction
    pop {r2-r6,pc}               @ restaur des registres
/***************************************************/
/*   check if a number is prime              */
/***************************************************/
/* r0 contains the number            */
/* r0 return 1 if prime  0 else */
isPrime:
    push {r1-r6,lr}    @ save registers
    cmp r0,#0
    beq 90f
    cmp r0,#17
    bhi 1f
    cmp r0,#3
    bls 80f            @ for 1,2,3 return prime
    cmp r0,#5
    beq 80f            @ for 5 return prime
    cmp r0,#7
    beq 80f            @ for 7 return prime
    cmp r0,#11
    beq 80f            @ for 11 return prime
    cmp r0,#13
    beq 80f            @ for 13 return prime
    cmp r0,#17
    beq 80f            @ for 17 return prime
1:
    tst r0,#1          @ even ?
    beq 90f            @ yes -> not prime
    mov r2,r0          @ save number
    sub r1,r0,#1       @ exposant n - 1
    mov r0,#3          @ base
    bl moduloPuR32     @ compute base power n - 1 modulo n
    cmp r0,#1
    bne 90f            @ if <> 1  -> not prime

    mov r0,#5
    bl moduloPuR32
    cmp r0,#1
    bne 90f

    mov r0,#7
    bl moduloPuR32
    cmp r0,#1
    bne 90f

    mov r0,#11
    bl moduloPuR32
    cmp r0,#1
    bne 90f

    mov r0,#13
    bl moduloPuR32
    cmp r0,#1
    bne 90f

    mov r0,#17
    bl moduloPuR32
    cmp r0,#1
    bne 90f
80:
    mov r0,#1        @ is prime
    b 100f
90:
    mov r0,#0        @ no prime
100:                 @ fin standard de la fonction
    pop {r1-r6,pc}   @ restaur des registres
/********************************************************/
/*   Calcul modulo de b puissance e modulo m  */
/*    Exemple 4 puissance 13 modulo 497 = 445         */
/*                                             */
/********************************************************/
/* r0  nombre  */
/* r1 exposant */
/* r2 modulo   */
/* r0 return result  */
moduloPuR32:
    push {r1-r7,lr}    @ save registers
    cmp r0,#0          @ verif <> zero
    beq 100f
    cmp r2,#0          @ verif <> zero
    beq 100f           @ TODO: v鲩fier les cas d erreur
1:
    mov r4,r2          @ save modulo
    mov r5,r1          @ save exposant
    mov r6,r0          @ save base
    mov r3,#1          @ start result

    mov r1,#0          @ division de r0,r1 par r2
    bl division32R
    mov r6,r2          @ base <- remainder
2:
    tst r5,#1          @  exposant even or odd
    beq 3f
    umull r0,r1,r6,r3
    mov r2,r4
    bl division32R
    mov r3,r2          @ result <- remainder
3:
    umull r0,r1,r6,r6
    mov r2,r4
    bl division32R
    mov r6,r2          @ base <- remainder

    lsr r5,#1          @ left shift 1 bit
    cmp r5,#0          @ end ?
    bne 2b
    mov r0,r3
100:                   @ fin standard de la fonction
    pop {r1-r7,pc}     @ restaur des registres

/***************************************************/
/*   division number 64 bits in 2 registers by number 32 bits */
/***************************************************/
/* r0 contains lower part dividende   */
/* r1 contains upper part dividende   */
/* r2 contains divisor   */
/* r0 return lower part quotient    */
/* r1 return upper part quotient    */
/* r2 return remainder               */
division32R:
    push {r3-r9,lr}    @ save registers
    mov r6,#0          @ init upper upper part remainder  !!
    mov r7,r1          @ init upper part remainder with upper part dividende
    mov r8,r0          @ init lower part remainder with lower part dividende
    mov r9,#0          @ upper part quotient
    mov r4,#0          @ lower part quotient
    mov r5,#32         @ bits number
1:                     @ begin loop
    lsl r6,#1          @ shift upper upper part remainder
    lsls r7,#1         @ shift upper  part remainder
    orrcs r6,#1
    lsls r8,#1         @ shift lower  part remainder
    orrcs r7,#1
    lsls r4,#1         @ shift lower part quotient
    lsl r9,#1          @ shift upper part quotient
    orrcs r9,#1
                       @ divisor sustract  upper  part remainder
    subs r7,r2
    sbcs  r6,#0        @ and substract carry
    bmi 2f             @ n駡tive ?

                       @ positive or equal
    orr r4,#1          @ 1 -> right bit quotient
    b 3f
2:                     @ negative
    orr r4,#0          @ 0 -> right bit quotient
    adds r7,r2         @ and restaur remainder
    adc  r6,#0
3:
    subs r5,#1         @ decrement bit size
    bgt 1b             @ end ?
    mov r0,r4          @ lower part quotient
    mov r1,r9          @ upper part quotient
    mov r2,r7          @ remainder
100:                   @ function end
    pop {r3-r9,pc}     @ restaur registers

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


# bindings($x) attempts to match . and $x structurally on the
# assumption that . is free of JSON objects, and that any objects in
# $x will have distinct, singleton keys that are to be interpreted as
# variables.  These variables will match the corresponding entities in
# . if . and $x can be structurally matched.
#
# If . and $x cannot be matched, then null is returned;
# otherwise, if $x contains no objects, {} is returned;
# finally, if . and $x can be structurally matched, a composite object containing the bindings
# will be returned.
# Output: null (failure to match) or a single JSON object giving the bindings if any.
def bindings($x):
   if $x == . then {}  # by assumption, no bindings are necessary
   elif ($x|type) == "object"
   then ($x|keys) as $keys
   | if ($keys|length) == 1 then {($keys[0]): .} else "objects should be singletons"|error end
   elif type != ($x|type) then null
   elif type == "array"
   then if length != ($x|length) then null
        else . as $in
        | reduce range(0;length) as $i ({};
            if . == null then null
            else ($in[$i] | bindings($x[$i]) ) as $m
            | if $m == null then null else . + $m end
            end)
	end
   else null
   end ;


import Base.length

abstract type AbstractColoredNode end

struct RedNode <: AbstractColoredNode end; const R = RedNode()
struct BlackNode <: AbstractColoredNode end; const B = BlackNode()
struct Empty end; const E = Empty()
length(e::Empty) = 1

function balance(b::BlackNode, v::Vector, z, d)
    if v[1] == R
        if length(v[2]) == 4 && v[2][1] == R
            return [R, [B, v[2][2], v[2][3], v[2][4]], v[3], [B, v[4], z, d]]
        elseif length(v[4]) == 4 && v[4][1] == R
            return [R, [B, v[2], v[3], v[4][2]], v[4][3], [B, v[4][4], z, d]]
        end
    end
    [b, v, z, d]
end

function balance(b::BlackNode, a, x, v::Vector)
    if v[1] == R
        if length(v[2]) == 4 && v[2][1] == R
            return [R, [B, a, x, v[2][2]], v[2][3], [B, v[2][4], v[3], v[4]]]
        elseif length(v[4]) == 4 && v[4][1] == R
            return [R, [B, a, x, v[2]], v[3], [B, v[4][2], v[4][3], v[4][4]]]
        end
    end
    [b, a, x, v]
end

function balance(b::BlackNode, a::Vector, x, v::Vector)
    if v[1] == R
        if length(v[2]) == 4 && v[2][1] == R
            return [R, [B, a, x, v[2][2]], v[2][3], [B, v[2][4], v[3], v[4]]]
        elseif length(v[4]) == 4 && v[4][1] == R
            return [R, [B, a, x, v[2]], v[3], [B, v[4][2], v[4][3], v[4][4]]]
        end
    end
    [b, a, x, v]
end

balance(node, l, a, r) = [node, l, a, r]

function ins(v::Vector, x::Number)
    if length(v) == 4
        if x < v[3]
            return balance(v[1], ins(v[2], x), v[3], v[4])
        elseif x > v[3]
            return balance(v[1], v[2], v[3], ins(v[4], x))
        end
    end
    v
end

ins(t, a) = [R, E, a, E]

insert(v, a) = (t = ins(v, a); t[1] = B; t)

function testRB()
    t = E
    for i in rand(collect(1:20), 10)
        t = insert(t, i)
    end
    println(replace(string(t), r"lackNode\(\)|edNode\(\)|Any|mpty\(\)" => ""))
end

testRB()


// version 1.1.51

import Color.*

enum class Color { R, B }

sealed class Tree<A : Comparable> {

    fun insert(x: A): Tree {
        val t = ins(x)
        return when (t) {
            is T -> {
                val (_, a, y, b) = t
                T(B, a, y, b)
            }

            is E -> E()
        }
    }

    abstract fun ins(x: A): Tree
}

class E<A : Comparable> : Tree() {

    override fun ins(x: A): Tree = T(R, E(), x, E())

    override fun toString() = "E"
}

data class T<A : Comparable>(
    val cl: Color,
    val le: Tree,
    val aa: A,
    val ri: Tree
) : Tree() {

    private fun balance(): Tree {
        if (cl != B) return this
        val res =
            if (le is T && le.le is T && le.cl == R && le.le.cl == R) {
               val (_, t, z, d) = this
               val (_, t2, y, c) = t as T
               val (_, a, x, b) = t2 as T
               T(R, T(B, a, x, b), y, T(B, c, z, d))
            }
            else if (le is T && le.ri is T && le.cl == R && le.ri.cl == R) {
               val (_, t, z, d) = this
               val (_, a, x, t2) = t as T
               val (_, b, y, c) = t2 as T
               T(R, T(B, a, x, b), y, T(B, c, z, d))
            }
            else if (ri is T && ri.le is T && ri.cl == R && ri.le.cl == R) {
               val (_, a, x, t) = this
               val (_, t2, z, d) = t as T
               val (_, b, y, c) = t2 as T
               T(R, T(B, a, x, b), y, T(B, c, z, d))
            }
            else if (ri is T && ri.ri is T && ri.cl == R && ri.ri.cl == R) {
               val (_, a, x, t) = this
               val (_, b, y, t2) = t as T
               val (_, c, z, d) = t2 as T
               T(R, T(B, a, x, b), y, T(B, c, z, d))
            }
            else this
        return res
    }

    override fun ins(x: A): Tree = when (x.compareTo(aa)) {
        -1   -> T(cl, le.ins(x), aa, ri).balance()
        +1   -> T(cl, le, aa, ri.ins(x)).balance()
        else -> this
    }

    override fun toString() = "T($cl, $le, $aa, $ri)"
}

fun main(args: Array<String>) {
    var tree: Tree<Int> = E()
    for (i in 1..16) {
        tree = tree.insert(i)
    }
    println(tree)
}


read_file(name) := block([file, s, L], file: openr(name), L: [],
while stringp(s: readline(file)) do L: cons(s, L), close(file), L)$

u: read_file("C:/my/mxm/unixdict.txt")$

v: map(lambda([s], [ssort(s), s]), u)$

w: sort(v, lambda([x, y], orderlessp(x[1], y[1])))$

ana(L) := block([m, n, p, r, u, v, w],
L: endcons(["", ""], L),
n: length(L),
r: "",
m: 0,
v: [ ],
w: [ ],
for i from 1 thru n do (
   u: L[i],
   if r = u[1] then (
      w: cons(u[2], w)
   ) else (
      p: length(w),
      if p >= m then (
         if p > m then (m: p, v: []),
         v: cons(w, v)
      ),
      w: [u[2]],
      r: u[1]
   )
),
v)$

ana(w);
/* [["evil", "levi", "live", "veil", "vile"],
    ["elan", "lane", "lean", "lena", "neal"],
    ["alger", "glare", "lager", "large", "regal"],
    ["angel", "angle", "galen", "glean", "lange"],
    ["caret", "carte", "cater", "crate", "trace"],
    ["abel", "able", "bale", "bela", "elba"]] */


Amb(V)={
	amb(vector(#V,i,vector(#V[i],j,Vec(V[i][j]))),[])
};
amb(V,s)={
	if (#V == 0, return(concat(s)));
	my(v=V[1],U=vecextract(V,2^#V-2),t,final=if(#s,s[#s]));
	if(#s, s = concat(s,[" "]));
	for(i=1,#v,
		if ((#s == 0 || final == v[i][1]),
			t = amb(U, concat(s, v[i]));
			if (t, return(t))
		)
	);
	0
};
Amb([["the","that","a"],["frog","elephant","thing"],["walked","treaded","grows"],["slowly","quickly"]])


#!/bin/gawk -f
function sumprop(num,   i,sum,root) {
if (num == 1) 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
}
function class(k,    oldk,newk,seq){
# first term
oldk = k
seq = " "
# second term
newk = sumprop(oldk)
oldk = newk
seq = seq " " newk
if (newk == 0) return "terminating " seq
if (newk == k) return "perfect " seq
#  third term
newk = sumprop(oldk)
oldk = newk
seq = seq " " newk
if (newk == 0) return "terminating " seq
if (newk == k) return "amicable " seq
for (t=4; t<17; t++) {
newk = sumprop(oldk)
seq = seq " " newk
if (newk == 0) return "terminating " seq
if (newk == k) return "sociable (period " t-1 ") "seq
if (newk == oldk) return "aspiring " seq
if (index(seq," " newk " ") > 0) return "cyclic (at " newk ") " seq
if (newk > 140737488355328) return "non-terminating (term > 140737488355328) " seq
oldk = newk
}
return "non-terminating (after 16 terms)  " seq
}
BEGIN{
print "Number classification sequence"
for (j=1; j < 11; j++)
    {
    print j,class(j)}
    print 11,class(11)
    print 12,class(12)
    print 28,class(28)
    print 496,class(496)
    print 220,class(220)
    print 1184,class(1184)
    print 12496,class(12496)
    print 1264460,class(1264460)
    print 790,class(790)
    print 909,class(909)
    print 562,class(562)
    print 1064,class(1064)
    print 1488,class(1488)
    print 15355717786080,class(15355717786080)

}


import fusion/matching
{.experimental: "caseStmtMacros".}

type
  Colour = enum Empty, Red, Black
  RBTree[T] = ref object
    colour: Colour
    left, right: RBTree[T]
    value: T

proc `[]`[T](r: RBTree[T], idx: static[FieldIndex]): auto =
  ## enables tuple syntax for unpacking and matching
  when idx == 0: r.colour
  elif idx == 1: r.left
  elif idx == 2: r.value
  elif idx == 3: r.right

template B[T](l: untyped, v: T, r): RBTree[T] =
  RBTree[T](colour: Black, left: l, value: v, right: r)

template R[T](l: untyped, v: T, r): RBTree[T] =
  RBTree[T](colour: Red, left: l, value: v, right: r)

template balImpl[T](t: typed): untyped =
  case t
  of (colour: Red | Empty): discard
  of (Black, (Red, (Red, @a, @x, @b), @y, @c), @z, @d) |
    (Black, (Red, @a, @x, (Red, @b, @y, @c)), @z, @d) |
    (Black, @a, @x, (Red, (Red, @b, @y, @c), @z, @d)) |
    (Black, @a, @x, (Red, @b, @y, (Red, @c, @z, @d))):
    t = R(B(a, x, b), y, B(c, z, d))

proc balance*[T](t: var RBTree[T]) = balImpl[T](t)

template insImpl[T](t, x: typed): untyped =
  template E: RBTree[T] = RBTree[T]()
  case t
  of (colour: Empty): t = R(E, x, E)
  of (value: > x): t.left.ins(x); t.balance()
  of (value: < x): t.right.ins(x); t.balance()

proc insert*[T](tt: var RBTree[T], xx: T) =
  proc ins(t: var RBTree[T], x: T) = insImpl[T](t, x)
  tt.ins(xx)
  tt.colour = Black


type color = R | B
type 'a tree = E | T of color * 'a tree * 'a * 'a tree

(** val balance : color * 'a tree * 'a * 'a tree -> 'a tree *)
let balance = function
  | B, T (R, T (R,a,x,b), y, c), z, d
  | B, T (R, a, x, T (R,b,y,c)), z, d
  | B, a, x, T (R, T (R,b,y,c), z, d)
  | B, a, x, T (R, b, y, T (R,c,z,d)) -> T (R, T (B,a,x,b), y, T (B,c,z,d))
  | col, a, x, b                      -> T (col, a, x, b)

(** val insert : 'a -> 'a tree -> 'a tree *)
let insert x s =
  let rec ins = function
    | E                  -> T (R,E,x,E)
    | T (col,a,y,b) as s ->
	if x < y then
	  balance (col, ins a, y, b)
	else if x > y then
	  balance (col, a, y, ins b)
	else
	  s
  in let T (_,a,y,b) = ins s
  in T (B,a,y,b)


Anagrams	New ii,file,longest,most,sorted,word
	Set file="unixdict.txt"
	Open file:"r" Use file
	For  Quit:$ZEOF  DO
	. New char,sort
	. Read word Quit:word=""
	. For ii=1:1:$Length(word) Do
	. . Set char=$ASCII(word,ii)
	. . If char>64,char<91 Set char=char+32
	. . Set sort(char)=$Get(sort(char))+1
	. . Quit
	. Set (sorted,char)="" For  Set char=$Order(sort(char)) Quit:char=""  Do
	. . For ii=1:1:sort(char) Set sorted=sorted_$Char(char)
	. . Quit
	. Set table(sorted,word)=1
	. Quit
	Close file
	Set sorted="" For  Set sorted=$Order(table(sorted)) Quit:sorted=""  Do
	. Set ii=0,word="" For  Set word=$Order(table(sorted,word)) Quit:word=""  Set ii=ii+1
	. Quit:ii<2
	. Set most(ii,sorted)=1
	. Quit
	Write !,"The anagrams with the most variations:"
	Set ii=$Order(most(""),-1)
	Set sorted="" For  Set sorted=$Order(most(ii,sorted)) Quit:sorted=""  Do
	. Write ! Set word="" For  Set word=$Order(table(sorted,word)) Quit:word=""  Write "  ",word
	. Quit
	Write !,"The longest anagrams:"
	Set ii=$Order(longest(""),-1)
	Set sorted="" For  Set sorted=$Order(longest(ii,sorted)) Quit:sorted=""  Do
	. Write ! Set word="" For  Set word=$Order(table(sorted,word)) Quit:word=""  Write "  ",word
	. Quit
	Quit

Do Anagrams


/* NetRexx */
options replace format comments java crossref symbols nobinary

class RAnagramsV01 public

  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  method runSample(arg) public signals MalformedURLException, IOException
    parse arg localFile .
    isr = Reader
    if localFile = '' then do
      durl = URL("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt")
      dictFrom = durl.toString()
      isr = InputStreamReader(durl.openStream())
      end
    else do
      dictFrom = localFile
      isr = FileReader(localFile)
      end
    say 'Searching' dictFrom 'for anagrams'
    dictionaryReader = BufferedReader(isr)

    anagrams = Map HashMap()
    aWord = String
    count = 0
    loop label w_ forever
      aWord = dictionaryReader.readLine()
      if aWord = null then leave w_
      chars = aWord.toCharArray()
      Arrays.sort(chars)
      key = String(chars)
      if (\anagrams.containsKey(key)) then do
        anagrams.put(key, ArrayList())
        end
      (ArrayList anagrams.get(key)).add(Object aWord)
      count = Math.max(count, (ArrayList anagrams.get(key)).size())
      end w_
    dictionaryReader.close

    ani = anagrams.values().iterator()
    loop label a_ while ani.hasNext()
      ana = ani.next()
      if (ArrayList ana).size() >= count then do
        say ana
        end
      end a_

    return

  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  method main(args = String[]) public static

    arg = Rexx(args)
    Do
      ra = RAnagramsV01()
      ra.runSample(arg)
    Catch ex = Exception
      ex.printStackTrace()
    End

    return


use strict;
use warnings;

use constant EXIT_FAILURE => 1;
use constant EXIT_SUCCESS => 0;

sub amb {
   exit(EXIT_FAILURE) if !@_;
   for my $word (@_) {
      my $pid = fork;
      die $! unless defined $pid;
      return $word if !$pid;
      my $wpid = waitpid $pid, 0;
      die $! unless $wpid == $pid;
      exit(EXIT_SUCCESS) if $? == EXIT_SUCCESS;
   }
   exit(EXIT_FAILURE);
}

sub joined {
   my ($join_a, $join_b) = @_;
   substr($join_a, -1) eq substr($join_b, 0, 1);
}

my $w1 = amb(qw(the that a));
my $w2 = amb(qw(frog elephant thing));
my $w3 = amb(qw(walked treaded grows));
my $w4 = amb(qw(slowly quickly));

amb() unless joined $w1, $w2;
amb() unless joined $w2, $w3;
amb() unless joined $w3, $w4;

print "$w1 $w2 $w3 $w4\n";
exit(EXIT_SUCCESS);


# Rosetta Code problem: http://rosettacode.org/wiki/Aliquot_sequence_classifications
# by Jjuanhdez, 06/2022

global limite
limite = 20000000

dim nums = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488}

for n = 0 to nums[?]-1
    print "Number "; nums[n]; " : ";
    call PrintAliquotClassifier(nums[n])
next n
print
print "Program normal end."
end

function PDtotal (n)
    total = 0
    for y = 2 to n
        if (n mod y) = 0 then total += (n / y)
    next y
    return total
end function

subroutine PrintAliquotClassifier (K)
    longit = 52: n = K: clase = 0: priorn = 0: inc = 0
    dim Aseq(longit)

    for element = 2 to longit
        Aseq[element] = PDtotal(n)
        n = int(Aseq[element])
        print n; " ";
        begin case
            case n = 0
                print " Terminating": clase = 1: exit for
            case n = K and element = 2
                print " Perfect"    : clase = 2: exit for
            case n = K and element = 3
                print " Amicable": clase = 3: exit for
            case n = K and element > 3
                print " Sociable": clase = 4: exit for
            case n <> K and Aseq[element - 1] = Aseq[element]
                print " Aspiring": clase = 5: exit for
            case n <> K and Aseq[element - 2] = n
                print " Cyclic": clase = 6: exit for
        end case

        if n > priorn then priorn = n: inc += 1 else inc = 0: priorn = 0
        if inc = 11 or n > limite then exit for
    next element
    if clase = 0 then print " non-terminating"
end subroutine


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

unsigned long long bruteForceProperDivisorSum(unsigned long long n){
	unsigned long long i,sum = 0;

	for(i=1;i<(n+1)/2;i++)
		if(n%i==0 && n!=i)
			sum += i;

	return sum;
}

void printSeries(unsigned long long* arr,int size,char* type){
	int i;

	printf("\nInteger : %llu, Type : %s, Series : ",arr[0],type);

	for(i=0;i<size-1;i++)
		printf("%llu, ",arr[i]);
	printf("%llu",arr[i]);
}

void aliquotClassifier(unsigned long long n){
	unsigned long long arr[16];
	int i,j;

	arr[0] = n;

	for(i=1;i<16;i++){
		arr[i] = bruteForceProperDivisorSum(arr[i-1]);

		if(arr[i]==0||arr[i]==n||(arr[i]==arr[i-1] && arr[i]!=n)){
			printSeries(arr,i+1,(arr[i]==0)?"Terminating":(arr[i]==n && i==1)?"Perfect":(arr[i]==n && i==2)?"Amicable":(arr[i]==arr[i-1] && arr[i]!=n)?"Aspiring":"Sociable");
			return;
		}

		for(j=1;j<i;j++){
			if(arr[j]==arr[i]){
				printSeries(arr,i+1,"Cyclic");
				return;
			}
		}
	}

	printSeries(arr,i+1,"Non-Terminating");
}

void processFile(char* fileName){
	FILE* fp = fopen(fileName,"r");
	char str[21];

	while(fgets(str,21,fp)!=NULL)
		aliquotClassifier(strtoull(str,(char**)NULL,10));

	fclose(fp);
}

int main(int argC,char* argV[])
{
    if(argC!=2)
		printf("Usage : %s <positive integer>",argV[0]);
	else{
		if(strchr(argV[1],'.')!=NULL)
			processFile(argV[1]);
		else
			aliquotClassifier(strtoull(argV[1],(char**)NULL,10));
	}
	return 0;
}


fun {Balance Col A X B}
   case Col#A#X#B
   of b#t(r t(r A X B) Y C         )#Z#D                            then t(r t(b A X B) Y t(b C Z D))
   [] b#t(r A          X t(r B Y C))#Z#D                            then t(r t(b A X B) Y t(b C Z D))
   [] b#A                           #X#t(r t(r B Y C) Z D)          then t(r t(b A X B) Y t(b C Z D))
   [] b#A                           #X#t(r B          Y t(r C Z D)) then t(r t(b A X B) Y t(b C Z D))
   else t(Col A X B)
   end
end

fun {Insert X S}
   fun {Ins S}
      case S of e then t(r e X e)
      [] t(Col A Y B) then
	 if X < Y then {Balance Col {Ins A} Y B}
	 elseif X > Y then {Balance Col A Y {Ins B}}
	 else S
	 end
      end
   end
   t(_ A Y B) = {Ins S}
in
   t(b A Y B)
end


;;;	Get the words as a list, splitting at newline
(setq data
	(parse (get-url "http://wiki.puzzlers.org/pub/wordlists/unixdict.txt")
	"\n"))
;
;;;	Replace each word with a list of its key (list of sorted chars) and itself
;;;	For example "hello" –> (("e" "h" "l" "l" "o") "hello")
(setq data (map (fn(x) (list (sort (explode x)) x)) data))
;
;;;	Sort on the keys (data is modified); (x 0) is the same as (first x)
(sort data (fn(x y) (> (x 0)(y 0))))
;
;;;	Return a list of lists of words with the same key
;;;	An empty list at the head is inconsequential
(define (group-by-key)
	(let (temp '() res '() oldkey '())
		(dolist (x data)
			(if (= (x 0) oldkey)
				(push (x 1) temp)
				(begin
					(push temp res)
					(setq temp (list (x 1)) oldkey (x 0)))))
		(push temp res)
		res))
;
;;;	Print out only groups of more than 4 words
(map println (filter (fn(x) (> (length x) 4)) (group-by-key)))


function amb1(sequence sets, object res=0, integer idx=1)
    integer ch = 0,
            pass = 0
    if idx>length(sets) then
        pass = 1
    else
        if res=0 then
            res = repeat(0,length(sets))
        else
            res = deep_copy(res)
            ch = sets[idx-1][res[idx-1]][$]
        end if
        for k=1 to length(sets[idx]) do
            if ch=0 or sets[idx][k][1]=ch then
                res[idx] = k
                {pass,res} = amb1(sets,res,idx+1)
                if pass then exit end if
            end if
        end for
    end if
    return {pass,res}
end function

sequence sets = {{"the","that","a"},
                 {"frog","elephant","thing"},
                 {"walked","treaded","grows"},
                 {"slowly","quickly"}}
{integer pass, sequence res} = amb1(sets)
if pass then
    puts(1,"success: ")
    for i=1 to length(sets) do
        res[i] = sets[i][res[i]]
    end for
    ?res
else
    puts(1,"failure\n")
end if


#include <cstdint>
#include <iostream>
#include <string>

using integer = uint64_t;

// See https://en.wikipedia.org/wiki/Divisor_function
integer divisor_sum(integer n) {
    integer total = 1, power = 2;
    // Deal with powers of 2 first
    for (; n % 2 == 0; power *= 2, n /= 2)
        total += power;
    // Odd prime factors up to the square root
    for (integer p = 3; p * p <= n; p += 2) {
        integer sum = 1;
        for (power = p; n % p == 0; power *= p, n /= p)
            sum += power;
        total *= sum;
    }
    // If n > 1 then it's prime
    if (n > 1)
        total *= n + 1;
    return total;
}

// See https://en.wikipedia.org/wiki/Aliquot_sequence
void classify_aliquot_sequence(integer n) {
    constexpr int limit = 16;
    integer terms[limit];
    terms[0] = n;
    std::string classification("non-terminating");
    int length = 1;
    for (int i = 1; i < limit; ++i) {
        ++length;
        terms[i] = divisor_sum(terms[i - 1]) - terms[i - 1];
        if (terms[i] == n) {
            classification =
                (i == 1 ? "perfect" : (i == 2 ? "amicable" : "sociable"));
            break;
        }
        int j = 1;
        for (; j < i; ++j) {
            if (terms[i] == terms[i - j])
                break;
        }
        if (j < i) {
            classification = (j == 1 ? "aspiring" : "cyclic");
            break;
        }
        if (terms[i] == 0) {
            classification = "terminating";
            break;
        }
    }
    std::cout << n << ": " << classification << ", sequence: " << terms[0];
    for (int i = 1; i < length && terms[i] != terms[i - 1]; ++i)
        std::cout << ' ' << terms[i];
    std::cout << '\n';
}

int main() {
    for (integer i = 1; i <= 10; ++i)
        classify_aliquot_sequence(i);
    for (integer i : {11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562,
                      1064, 1488})
        classify_aliquot_sequence(i);
    classify_aliquot_sequence(15355717786080);
    classify_aliquot_sequence(153557177860800);
    return 0;
}


--
-- demo\rosetta\Pattern_matching.exw
-- =================================
--
-- 1). Lightly modified copy of demo\rosetta\VisualiseTree.exw

with javascript_semantics

-- To the theme tune of the Milk Tray Ad iyrt,
-- All because the Windows console hates utf8:
constant TL = '\#DA', -- aka '┌'
         VT = '\#B3', -- aka '│'
         BL = '\#C0', -- aka '└'
         HZ = '\#C4', -- aka '─'
         HS = "\#C4"  -- (string version of HZ)

function w1252_to_utf8(string s)
    if platform()!=WINDOWS then
        s = substitute_all(s,{ TL, VT, BL, HZ},
                             {"┌","│","└","─"})
    end if
    return s
end function
--</hates utf8>

procedure visualise_tree(object tree, string root=HS)
    if atom(tree) then
        puts(1,"<empty>\n")
    else
        object {colour,left,v,right} = tree
        integer g = root[$]
        if sequence(left) then
            root[$] = iff(g=TL or g=HZ?' ':VT)
            visualise_tree(left,root&TL)
        end if
        root[$] = g
        printf(1,"%s%s%v\n",{w1252_to_utf8(root),colour,v})
        if sequence(right) then
            root[$] = iff(g=TL?VT:' ')
            visualise_tree(right,root&BL)
        end if
    end if
end procedure
--</copy VisualiseTree>

-- 2). Imagine the following is in a file, say algebraic_data_types.e - not quite generic enough
--      for inclusion in builtins, but not exactly difficult to copy/maintain per-project either.

function match_one(sequence key, object t)
    sequence res = {}
    if sequence(t)
    and length(key)==length(t) then
        for i=1 to length(key) do
            object ki = key[i], ti = t[i]
            if sequence(ki) and not string(ki) then
                sequence r2 = match_one(ki,ti)
                if r2={} then res = {} exit end if
                res &= r2
            else
                if ki=0 then
                    res = append(res,ti)
                else
                    if ki!=ti then res = {} exit end if
                end if
            end if
        end for
    end if
    return res
end function

/*global*/ function match_algebraic(sequence set, t)
    sequence s
    for i=1 to length(set) do
        s = match_one(set[i],t)
        if length(s) then exit end if
    end for
    return s
end function
--</algebraic_data_types.e>

-- 3). The actual task

constant B = "B", R = "R"

function balance(sequence t)
    sequence s = match_algebraic({{B,{R,{R,0,0,0},0,0},0,0},
                                  {B,{R,0,0,{R,0,0,0}},0,0},
                                  {B,0,0,{R,{R,0,0,0},0,0}},
                                  {B,0,0,{R,0,0,{R,0,0,0}}}},t)
    if length(s) then
        object {a,x,b,y,c,z,d} = s
        t = {R,{B,a,x,b},y,{B,c,z,d}}
    end if
    return t
end function

function ins(object tree, object leaf)
    if tree=NULL then
        tree = {R,NULL,leaf,NULL}
    else
        object {c,l,k,r} = tree
        if leaf!=k then
            if leaf<k then l = ins(l,leaf)
                      else r = ins(r,leaf)
            end if
            tree = balance({c,l,k,r})
        end if
    end if
    return tree
end function

function tree_insert(object tree, object leaf)
    tree = ins(tree,leaf)
    tree[1] = B
    return tree
end function

sequence stuff = shuffle(tagset(10))
object tree = NULL
for i=1 to length(stuff) do
    tree = tree_insert(tree,stuff[i])
end for
visualise_tree(tree)

?"done"
{} = wait_key()


import tables, strutils, algorithm

proc main() =
    var
        count    = 0
        anagrams = initTable[string, seq[string]]()

    for word in "unixdict.txt".lines():
        var key = word
        key.sort(cmp[char])
        anagrams.mgetOrPut(key, newSeq[string]()).add(word)
        count = max(count, anagrams[key].len)

    for _, v in anagrams:
        if v.len == count:
            v.join(" ").echo

main()


MODULE Anagrams;
IMPORT Files,Out,In,Strings;
CONST
	MAXPOOLSZ = 1024;

TYPE
	String = ARRAY 80 OF CHAR;

	Node = POINTER TO NodeDesc;
	NodeDesc = RECORD;
		count: INTEGER;
		word: String;
		desc: Node;
		next: Node;
	END;

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

	PROCEDURE InitNode(n: Node);
	BEGIN
		n^.count := 0;
		n^.word := "";
		n^.desc := NIL;
		n^.next := NIL;
	END InitNode;

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

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

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

	PROCEDURE InitPool(p:Pool);
	BEGIN
		InitPoolWith(p,MAXPOOLSZ);
	END InitPool;

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

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

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

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

	PROCEDURE DoProcess(fnm: ARRAY OF CHAR);
	VAR
		stdinBck,istream: Files.File;
		line: String;
		p: Pool;
	BEGIN
		istream := Files.Open(fnm,"r");
		stdinBck := Files.stdin;
		Files.stdin := istream;
		NEW(p);InitPool(p);
		WHILE In.Done DO
			In.Line(line);
			p.Add(line);
		END;
		Files.stdin := stdinBck;
		Files.Close(istream);
		p^.ShowMax();
	END DoProcess;

BEGIN
	DoProcess("unixdict.txt");
END Anagrams.


go ?=>
  % select which version of amb/2 and joins/2 to test
  member(Amb,[amb,amb2]),
  member(Joins,[joins,join2]),
  println([amb=Amb,joins=Joins]),
  test_amb(amb,joins, Word1,Word2,Word3,Word4),
  println([Word1, Word2, Word3, Word4]),
  nl,
  fail, % get other solutions
  nl.
go => true.

% Test a combination of amb and joins
test_amb(Amb,Joins, Word1,Word2,Word3,Word4) =>
  call(Amb, Word1, ["the","that","a"]),
  call(Amb, Word2, ["frog","elephant","thing"]),
  call(Amb, Word3, ["walked","treaded","grows"]),
  call(Amb, Word4, ["slowly","quickly"]),
  call(Joins, Word1, Word2),
  call(Joins, Word2, Word3),
  call(Joins, Word3, Word4).

% Based on the Prolog solution.
amb(E, [E|_]).
amb(E, [_|ES]) :- amb(E, ES).

joins(Left, Right) =>
  append(_, [T], Left),
  append([R], _, Right),
  ( T != R -> amb(_, [])
  ; true ).

% Another approach, using member/2 for
% generating the words.
amb2([],[]).
amb2(Word,Words) :- member(Word,Words).

joins2(Word1,Word2) :- Word1.last() = Word2.first().


(be amb (@E @Lst)
   (lst @E @Lst) )

(be joins (@Left @Right)
   (^ @T (last (chop (-> @Left))))
   (^ @R (car (chop (-> @Right))))
   (or
      ((equal @T @R))
      ((amb @ NIL)) ) )  # Explicitly using amb fail as required

(be ambExample ((@Word1 @Word2 @Word3 @Word4))
  (amb @Word1 ("the" "that" "a"))
  (amb @Word2 ("frog" "elephant" "thing"))
  (amb @Word3 ("walked" "treaded" "grows"))
  (amb @Word4 ("slowly" "quickly"))
  (joins @Word1 @Word2)
  (joins @Word2 @Word3)
  (joins @Word3 @Word4) )


% This program uses the 'bigint' cluster from PCLU's 'misc.lib'

% Remove leading and trailing whitespace (bigint$unparse adds a lot)
strip = proc (s: string) returns (string)
    ac = array[char]
    sc = sequence[char]
    cs: ac := string$s2ac(s)
    while ~ac$empty(cs) cand ac$bottom(cs)=' ' do ac$reml(cs) end
    while ~ac$empty(cs) cand ac$top(cs)=' ' do ac$remh(cs) end
    % There's a bug in ac2s that makes it not return all elements
    % This is a workaround
    return(string$sc2s(sc$a2s(cs)))
end strip

divisor_sum = proc (n: bigint) returns (bigint)
    own zero: bigint := bigint$i2bi(0)
    own one: bigint := bigint$i2bi(1)
    own two: bigint := bigint$i2bi(2)
    own three: bigint := bigint$i2bi(3)

    total: bigint := one
    power: bigint := two
    while n//two=zero do
        total := total + power
        power := power * two
        n := n / two
    end
    p: bigint := three
    while p*p <= n do
        sum: bigint := one
        power := p
        while n//p = zero do
            sum := sum + power
            power := power * p
            n := n/p
        end
        total := total * sum
        p := p + two
    end
    if n>one then total := total * (n+one) end
    return(total)
end divisor_sum

classify_aliquot_sequence = proc (n: bigint)
    LIMIT = 16
    abi = array[bigint]
    own zero: bigint := bigint$i2bi(0)
    po: stream := stream$primary_output()

    terms: array[bigint] := abi$predict(0,LIMIT)
    abi$addh(terms, n)

    classification: string := "non-terminating"
    for i: int in int$from_to(1, limit-1) do
        abi$addh(terms, divisor_sum(abi$top(terms)) - abi$top(terms))
        if abi$top(terms) = n then
            if i=1 then classification := "perfect"
            elseif i=2 then classification := "amicable"
            else classification := "sociable"
            end
            break
        end
        j: int := 1
        while j<i cand terms[i] ~= terms[i-j] do j := j+1 end
        if j<i then
            if j=1 then classification := "aspiring"
            else classification := "cyclic"
            end
            break
        end
        if abi$top(terms) = zero then
            classification := "terminating"
            break
        end
    end

    stream$puts(po, strip(bigint$unparse(n)) || ": " || classification || ", sequence: "
                 || strip(bigint$unparse(terms[0])))
    for i: int in int$from_to(1, abi$high(terms)) do
        if terms[i] = terms[i-1] then break end
        stream$puts(po, " " || strip(bigint$unparse(terms[i])))
    end
    stream$putl(po, "")
end classify_aliquot_sequence

start_up = proc ()
    for i: int in int$from_to(1, 10) do
        classify_aliquot_sequence(bigint$i2bi(i))
    end
    for i: int in array[int]$elements(array[int]$
        [11,12,28,496,220,1184,12496,1264460,790,909,562,1064,1488]) do
        classify_aliquot_sequence(bigint$i2bi(i))
    end
    classify_aliquot_sequence(bigint$parse("15355717786080"))
    classify_aliquot_sequence(bigint$parse("153557177860800"))
end start_up


(defparameter *nlimit* 16)
(defparameter *klimit* (expt 2 47))
(defparameter *asht* (make-hash-table))
(load "proper-divisors")

(defun ht-insert (v n)
  (setf (gethash v *asht*) n))

(defun ht-find (v n)
   (let ((nprev (gethash v *asht*)))
    (if nprev (- n nprev) nil)))

(defun ht-list ()
  (defun sort-keys (&optional (res '()))
    (maphash #'(lambda (k v) (push (cons k v) res)) *asht*)
    (sort (copy-list res) #'< :key (lambda (p) (cdr p))))
  (let ((sorted (sort-keys)))
    (dotimes (i (length sorted)) (format t "~A " (car (nth i sorted))))))

(defun aliquot-generator (K1)
  "integer->function::fn to generate aliquot sequence"
  (let ((Kn K1))
    #'(lambda () (setf Kn (reduce #'+ (proper-divisors-recursive Kn) :initial-value 0)))))

(defun aliquot (K1)
  "integer->symbol|nil::classify aliquot sequence"
  (defun aliquot-sym (Kn n)
    (let* ((period (ht-find Kn n))
           (sym (if period
                    (cond ; period event
                     ((= Kn K1)
                      (case period (1 'PERF) (2 'AMIC) (otherwise 'SOCI)))
                     ((= period 1) 'ASPI)
                     (t 'CYCL))
                    (cond ; else check for limit event
                     ((= Kn 0) 'TERM)
                     ((> Kn *klimit*) 'TLIM)
                     ((= n *nlimit*) 'NLIM)
                     (t nil)))))
      ;; if period event store the period, if no event insert the value
      (if sym (when period (setf (symbol-plist sym) (list period)))
          (ht-insert Kn n))
      sym))

  (defun aliquot-str (sym &optional (period 0))
    (case sym (TERM "terminating") (PERF "perfect") (AMIC "amicable") (ASPI "aspiring")
      (SOCI (format nil "sociable (period ~A)" (car (symbol-plist sym))))
      (CYCL (format nil "cyclic (period ~A)" (car (symbol-plist sym))))
      (NLIM (format nil "non-terminating (no classification before added term limit of ~A)" *nlimit*))
      (TLIM (format nil "non-terminating (term threshold of ~A exceeded)" *klimit*))
      (otherwise "unknown")))

  (clrhash *asht*)
  (let ((fgen (aliquot-generator K1)))
    (setf (symbol-function 'aliseq) #'(lambda () (funcall fgen))))
  (ht-insert K1 0)
  (do* ((n 1 (1+ n))
        (Kn (aliseq) (aliseq))
        (alisym (aliquot-sym Kn n) (aliquot-sym Kn n)))
       (alisym (format t "~A:" (aliquot-str alisym)) (ht-list) (format t "~A~%" Kn) alisym)))

(defun main ()
  (princ "The last item in each sequence triggers classification.") (terpri)
  (dotimes (k 10)
    (aliquot (+ k 1)))
  (dolist (k '(11 12 28 496 220 1184 12496 1264460 790 909 562 1064 1488 15355717786080))
    (aliquot k)))