main =>
    T = e,
    foreach (X in 1..10)
        insert(X,T,T1),
        T := T1
    end,
    output(T,0).

insert(X,S,R) =>
    ins(X,S,R1),
    R1 = $t(_,A,Y,B),
    R = $t(b,A,Y,B).

ins(X,e,R) => R = $t(r,e,X,e).
ins(X,t(C,A,Y,B),R), X < Y => ins(X,A,Ao), balance(C,Ao,Y,B,R).
ins(X,t(C,A,Y,B),R), X > Y => ins(X,B,Bo), balance(C,A,Y,Bo,R).
ins(_X,T,R) => R = T.

balance(C,A,X,B,S) :- (bal(C,A,X,B,T) -> S = T ; S = $t(C,A,X,B)).

bal(b, t(r,t(r,A,X,B),Y,C), Z, D, R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)).
bal(b, t(r,A,X,t(r,B,Y,C)), Z, D, R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)).
bal(b, A, X, t(r,t(r,B,Y,C),Z,D), R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)).
bal(b, A, X, t(r,B,Y,t(r,C,Z,D)), R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)).

output(e,Indent) => printf("%*w\n",Indent,e).
output(t(C,A,Y,B),Indent) =>
    output(A,Indent+6),
    printf("%*w[%w]\n",Indent,C,Y),
    output(B,Indent+6).


(be color (R))
(be color (B))

(be tree (@ E))
(be tree (@P (T @C @L @X @R))
   (color @C)
   (tree @P @L)
   (call @P @X)
   (tree @P @R) )

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

(be balance (@C @A @X @B @S)
   (bal @C @A @X @B @S)
   T )
(be balance (@C @A @X @B (T @C @A @X @B)))

(be ins (@X E (T R E @X E)))
(be ins (@X (T @C @A @Y @B) @R)
   (^ @ (> (-> @Y) (-> @X)))
   (ins @X @A @Ao)
   (balance @C @Ao @Y @B @R)
   T )
(be ins (@X (T @C @A @Y @B) @R)
   (^ @ (> (-> @X) (-> @Y)))
   (ins @X @B @Bo)
   (balance @C @A @Y @Bo @R)
   T )
(be ins (@X (T @C @A @Y @B) (T @C @A @Y @B)))

(be insert (@X @S (T B @A @Y @B))
   (ins @X @S (T @ @A @Y @B)) )


color(r).
color(b).

tree(_,e).
tree(P,t(C,L,X,R)) :- color(C), tree(P,L), call(P,X), tree(P,R).

bal(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))).
bal(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))).
bal(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))).
bal(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(C,A,X,B,S) :- ( bal(C,A,X,B,T) -> S = T ; S = t(C,A,X,B) ).

ins(X,e,t(r,e,X,e)).
ins(X,t(C,A,Y,B),R) :- ( X < Y -> ins(X,A,Ao), balance(C,Ao,Y,B,R)
                       ; X > Y -> ins(X,B,Bo), balance(C,A,Y,Bo,R)
                       ; X = Y -> R = t(C,A,Y,B)
                       ).

insert(X,S,t(b,A,Y,B)) :- ins(X,S,t(_,A,Y,B)).


from __future__ import annotations
from enum import Enum
from typing import NamedTuple
from typing import Optional

class Color(Enum):
    B = 0
    R = 1

class Tree(NamedTuple):
    color: Color
    left: Optional[Tree]
    value: int
    right: Optional[Tree]

    def insert(self, val: int) -> Tree:
        return self._insert(val).make_black()

    def _insert(self, val: int) -> Tree:
        match compare(val, self.value):
            case _ if self == EMPTY:
                return Tree(Color.R, EMPTY, val, EMPTY)
            case -1:
                assert self.left is not None
                return Tree(
                    self.color, self.left._insert(val), self.value, self.right
                ).balance()
            case 1:
                assert self.right is not None
                return Tree(
                    self.color, self.left, self.value, self.right._insert(val)
                ).balance()
            case _:
                return self

    def balance(self) -> Tree:
        match self:
            case (Color.B, (Color.R, (Color.R, a, x, b), y, c), z, d):
                return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d))
            case (Color.B, (Color.R, a, x, (Color.R, b, y, c)), z, d):
                return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d))
            case (Color.B, a, x, (Color.R, (Color.R, b, y, c), z, d)):
                return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d))
            case (Color.B, a, x, (Color.R, b, y, (Color.R, c, z, d))):
                return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d))
            case _:
                return self

    def make_black(self) -> Tree:
        return self._replace(color=Color.B)

    def __str__(self) -> str:
        if self == EMPTY:
            return "[]"
        return f"[{'R' if self.color == Color.R else 'B'}{self.value}]"

    def print(self, indent: int = 0) -> None:
        if self != EMPTY:
            assert self.right is not None
            self.right.print(indent + 1)

        print(f"{' ' * indent * 4}{self}")

        if self != EMPTY:
            assert self.left is not None
            self.left.print(indent + 1)

EMPTY = Tree(Color.B, None, 0, None)

def compare(x: int, y: int) -> int:
    if x > y:
        return 1
    if x < y:
        return -1
    return 0

def main():
    tree = EMPTY
    for i in range(1, 17):
        tree = tree.insert(i)
    tree.print()

if __name__ == "__main__":
    main()


use HTTP;
use Collection;

class Anagrams {
  function : Main(args : String[]) ~ Nil {
    lines := HttpClient->New()->Get("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt");
    anagrams := StringMap->New();
    count := 0;
    if(lines->Size() = 1) {
      line := lines->Get(0)->As(String);
      words := line->Split("\n");
      each(i : words) {
        word := words[i]->Trim();
        key := String->New(word->ToCharArray()->Sort());
        list := anagrams->Find(key)->As(Vector);
        if(list = Nil) {
          list := Vector->New();
          anagrams->Insert(key, list);
        };
        list->AddBack(word);
        count := count->Max(list->Size());
      };

      lists := anagrams->GetValues();
      each(i : lists) {
        list := lists->Get(i)->As(Vector);
        if(list->Size() >= count) {
          '['->Print();
          each(j : list) {
            list->Get(j)->As(String)->Print();
            if(j + 1 < list->Size()) {
              ','->Print();
            };
          };
          ']'->PrintLine();
        };
      };
    };
  }
}


*process or(!) source attributes xref;
 amb: Proc Options(main);
 /*********************************************************************
 * 25.08.2013 Walter Pachl
 *********************************************************************/
 Dcl w(4,10) Char(40) Var
     Init('the','that','a','if',(6)(1)' ',
          'frog','elephant','thing',(7)(1)' ',
          'walked','treaded','grows','trots',(6)(1)' ',
          'slowly','quickly',(8)(1)' ');
 Dcl ns Char(40) Var;
 Dcl (i,k,j,ii,jj,m,n) Bin Fixed(31);
 n=hbound(w,1);                        /* number of sets             */
 m=hbound(w,2);                        /* max number of words in set */
 Call show;                            /* show the input             */
 Do i=1 To n-1;                        /* loop over sets             */
   k=i+1;                              /* the following set          */
   Do ii=1 To m;                       /* loop over elements in set k*/
     If words(w(i,ii))=i Then Do;      /* a sentence part found      */
       Do jj=1 To m;                   /* loop over following words  */
         If right(w(i,ii),1)=left(w(k,jj),1) Then Do; /* fitting     */
           ns=w(i,ii)!!' '!!w(k,jj);   /* build new sentence (part)  */
           If words(ns)=k Then         /* 'complete' part            */
             Call add(k,ns);           /* add to set k               */
         End;
       End;
     End;
   End;
 Do jj=1 To m;                         /* show the results           */
   If words(w(4,jj))=4 Then
     put edit('--> ',w(4,jj))(Skip,a,a);
   End;

 add: Proc(ni,s);
 /*********************************************************************
 * add a sentence (part) to set ni
 *********************************************************************/
 Dcl (i,ni) Bin Fixed(31);
 Dcl s  Char(40) Var;
 Do i=1 To m While(w(ni,i)>'');        /* look for an empty slot     */
   End;
 w(ni,i)=s;                            /* add the sentence (part)    */
 End;

 words: Proc(s) Returns(Bin Fixed(31));
 /*********************************************************************
 * return the number of blank separated words in s
 *********************************************************************/
 Dcl s  Char(40) Var;
 Dcl nw Bin Fixed(31) Init(0);
 Dcl i  Bin Fixed(31) Init(1);
 If s>'' Then Do;
   nw=1;
   Do i=1 To length(s);
     If substr(s,i,1)=' ' Then
       nw+=1;
     End;
   End;
 Return(nw);
 End;

 show: Proc;
 /*********************************************************************
 * show the input sets
 *********************************************************************/
 Dcl (i,j,mm) Bin Fixed(31) Init(0);
 Dcl l(4) Bin Fixed(31) Init((4)0);
 Do i=1 To n;
   Do j=1 To m;
     If w(i,j)>'' Then Do;
       mm=max(mm,j);               /* max number of words in any set */
       l(i)=max(l(i),length(w(i,j)));  /* max word length in set i   */
       End;
     End;
   End;
 Put Edit('Input:')(Skip,a);
 Do j=1 To mm;                         /* output lines               */
   Put Skip;
   Do i=1 To n;
     Put Edit(w(i,j),' ')(a(l(i)),a);
     End;
   End;
 Put Skip;
 End;

 End;


import std.stdio, std.range, std.algorithm, std.typecons, std.conv;

auto properDivisors(in ulong n) pure nothrow @safe /*@nogc*/ {
    return iota(1UL, (n + 1) / 2 + 1).filter!(x => n % x == 0 && n != x);
}

enum pDivsSum = (in ulong n) pure nothrow @safe /*@nogc*/ =>
    n.properDivisors.sum;

auto aliquot(in ulong n,
             in size_t maxLen=16,
             in ulong maxTerm=2UL^^47) pure nothrow @safe {
    if (n == 0)
        return tuple("Terminating", [0UL]);
    ulong[] s = [n];
    size_t sLen = 1;
    ulong newN = n;

    while (sLen <= maxLen && newN < maxTerm) {
        newN = s.back.pDivsSum;
        if (s.canFind(newN)) {
            if (s[0] == newN) {
                if (sLen == 1) {
                    return tuple("Perfect", s);
                } else if (sLen == 2) {
                    return tuple("Amicable", s);
                } else
                    return tuple(text("Sociable of length ", sLen), s);
            } else if (s.back == newN) {
                return tuple("Aspiring", s);
            } else
                return tuple(text("Cyclic back to ", newN), s);
        } else if (newN == 0) {
            return tuple("Terminating", s ~ 0);
        } else {
            s ~= newN;
            sLen++;
        }
    }

    return tuple("Non-terminating", s);
}

void main() {
    foreach (immutable n; 1 .. 11)
        writefln("%s: %s", n.aliquot[]);
    writeln;
    foreach (immutable n; [11, 12, 28, 496, 220, 1184,  12496, 1264460,
                           790, 909, 562, 1064, 1488])
        writefln("%s: %s", n.aliquot[]);
}


#lang racket

;; Using short names to make the code line up nicely
(struct N (color left value right) #:prefab)

(define (balance t)
  (match t
    [(N 'B (N 'R (N 'R a x b) y c) z d) (N 'R (N 'B a x b) y (N 'B c z d))]
    [(N 'B (N 'R a x (N 'R b y c)) z d) (N 'R (N 'B a x b) y (N 'B c z d))]
    [(N 'B a x (N 'R (N 'R b y c) z d)) (N 'R (N 'B a x b) y (N 'B c z d))]
    [(N 'B a x (N 'R b y (N 'R c z d))) (N 'R (N 'B a x b) y (N 'B c z d))]
    [else t]))

(define (insert x s)
  (define (ins t)
    (match t
      ['empty (N 'R 'empty x 'empty)]
      [(N c l v r) (cond [(< x v) (balance (N c (ins l) v r))]
                         [(> x v) (balance (N c l v (ins r)))]
                         [else t])]))
  (match (ins s) [(N _ l v r) (N 'B l v r)]))

(define (visualize t0)
  (let loop ([t t0] [last? #t] [indent '()])
    (define (I mid last) (cond [(eq? t t0) ""] [last? mid] [else last]))
    (for-each display (reverse indent))
    (printf "~a~a[~a]\n" (I "\\-" "+-") (N-value t) (N-color t))
    (define subs (filter N? (list (N-left t) (N-right t))))
    (for ([s subs] [n (in-range (sub1 (length subs)) -1 -1)])
      (loop s (zero? n) (cons (I "  " "| ") indent)))))

(visualize (for/fold ([t 'empty]) ([i 16]) (insert i t)))


enum RedBlack <R B>;

multi balance(B,[R,[R,$a,$x,$b],$y,$c],$z,$d) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] }
multi balance(B,[R,$a,$x,[R,$b,$y,$c]],$z,$d) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] }
multi balance(B,$a,$x,[R,[R,$b,$y,$c],$z,$d]) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] }
multi balance(B,$a,$x,[R,$b,$y,[R,$c,$z,$d]]) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] }

multi balance($col, $a, $x, $b) { [$col, $a, $x, $b] }

multi ins( $x, @s [$col, $a, $y, $b] ) {
    when $x before $y     { balance $col, ins($x, $a), $y, $b }
    when $x after $y      { balance $col, $a, $y, ins($x, $b) }
    default               { @s }
}
multi ins( $x, Any:U ) { [R, Any, $x, Any] }

multi insert( $x, $s ) {
    [B, |ins($x,$s)[1..3]];
}

sub MAIN {
    my $t = Any;
    $t = insert($_, $t) for (1..10).pick(*);
    say $t.gist;
}


let explode str =
  let l = ref [] in
  let n = String.length str in
  for i = n - 1 downto 0 do
    l := str.[i] :: !l
  done;
  (!l)

let implode li =
  let n = List.length li in
  let s = String.create n in
  let i = ref 0 in
  List.iter (fun c -> s.[!i] <- c; incr i) li;
  (s)

let () =
  let h = Hashtbl.create 3571 in
  let ic = open_in "unixdict.txt" in
  try while true do
    let w = input_line ic in
    let k = implode (List.sort compare (explode w)) in
    let l =
      try Hashtbl.find h k
      with Not_found -> []
    in
    Hashtbl.replace h k (w::l);
  done with End_of_file -> ();
  let n = Hashtbl.fold (fun _ lw n -> max n (List.length lw)) h 0 in
  Hashtbl.iter (fun _ lw ->
    if List.length lw >= n then
    ( List.iter (Printf.printf " %s") lw;
      print_newline () )
  ) h


amb(E, [E|_]).
amb(E, [_|ES]) :- amb(E, ES).

joins(Left, Right) :-
  append(_, [T], Left),
  append([R], _, Right),
  ( T \= R -> amb(_, [])  % (explicitly using amb fail as required)
  ; true ).

amb_example([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).


;; implementation of Floyd algorithm to find cycles in a graph
;; see Wikipedia https://en.wikipedia.org/wiki/Cycle_detection
;; returns (cycle-length cycle-starter steps)
;; steps = 0 if no cycle found
;; it's all about a tortoise  🐢 running at speed f(x) after a hare 🐰 at speed f(f (x))
;; when they meet, a cycle is found

(define (floyd f x0 steps maxvalue)
	(define lam 1) ; cycle length
	(define tortoise (f x0))
	(define hare (f (f x0)))

	;; cyclic  ? yes if steps > 0
	(while (and (!= tortoise hare) (> steps 0))
		(set!-values (tortoise hare) (values (f tortoise) (f (f hare))))
		#:break (and (> hare maxvalue) (set! steps 0))
		(set! steps (1- steps)))

	;; first repetition = cycle starter
	(set! tortoise x0)
	(while (and (!= tortoise hare) (> steps 0))
		(set!-values (tortoise hare) (values (f tortoise) (f hare))))

	;; length of shortest cycle
	(set! hare (f tortoise))
	(while (and (!= tortoise hare) (> steps 0))
		(set! hare (f hare))
		(set! lam (1+ lam)))
	(values lam tortoise steps))

;; find cycle and classify
(define (taxonomy n (steps 16) (maxvalue 140737488355328))
	  (define-values (cycle starter steps) (floyd sum-divisors n steps maxvalue))
	 (write  n
	 (cond
	    (( = steps 0) 'non-terminating)
	    (( = starter 0) 'terminating)
	    ((and (= starter n) (= cycle 1)) 'perfect)
	    ((and (= starter n) (= cycle 2)) 'amicable)
            ((= starter n)  'sociable )
	    ((= cycle 1)  'aspiring )
	    (else 'cyclic)))

	(aliquote n starter)
	)

;; print sequence
(define (aliquote x0  (starter -1) (end -1 )(n 8))
  (for ((i n))
    (write x0)
    (set! x0 (sum-divisors x0))
    #:break (and (= x0 end) (write x0))
    (when (= x0 starter) (set! end starter)))
    (writeln ...))


// Literal
rascal>123 := 123
bool: true

// VariableDeclaration
rascal>if(str S := "abc")
>>>>>>>   println("Match succeeds, S == \"<S>\"");
Match succeeds, S == "abc"
ok

// MultiVariable
rascal>if([10, N*, 50] := [10, 20, 30, 40, 50])
>>>>>>>   println("Match succeeds, N == <N>");
Match succeeds, N == [20,30,40]
ok

// Variable
rascal>N = 10;
int: 10
rascal>N := 10;
bool: true
rascal>N := 20;
bool: false

// Set and List
rascal>if({10, set[int] S, 50} := {50, 40, 30, 20, 10})
>>>>>>>   println("Match succeeded, S = <S>");
Match succeeded, S = {30,40,20}
ok

rascal>for([L1*, L2*] := [10, 20, 30, 40, 50])
>>>>>>>    println("<L1> and <L2>");
[] and [10,20,30,40,50]
[10] and [20,30,40,50]
[10,20] and [30,40,50]
[10,20,30] and [40,50]
[10,20,30,40] and [50]
[10,20,30,40,50] and []
list[void]: []

// Descendant
rascal>T = red(red(black(leaf(1), leaf(2)), black(leaf(3), leaf(4))), black(leaf(5), leaf(4)));
rascal>for(/black(_,leaf(4)) := T)
>>>>>>>    println("Match!");
Match!
Match!
list[void]: []

rascal>for(/black(_,leaf(int N)) := T)
>>>>>>>    println("Match <N>");
Match 2
Match 4
Match 4
list[void]: []

rascal>for(/int N := T)
>>>>>>>    append N;
list[int]: [1,2,3,4,5,4]

// Labelled
rascal>for(/M:black(_,leaf(4)) := T)
>>>>>>>    println("Match <M>");
Match black(leaf(3),leaf(4))
Match black(leaf(5),leaf(4))
list[void]: []


/*REXX pgm builds a red/black tree (with verification & validation), balanced as needed.*/
parse arg nodes '/' insert                       /*obtain optional arguments from the CL*/
if  nodes=''  then nodes =  13.8.17  8.1.11  17.15.25  1.6  25.22.27   /*default nodes. */
if insert=''  then insert=  22.44    44.66                             /*   "   inserts.*/
top= .                                           /*define the default for the  TOP  var.*/
call Dnodes nodes                                /*define nodes, balance them as added. */
call Dnodes insert                               /*insert   "       "      "   " needed.*/
call Lnodes                                      /*list the nodes  (with indentations). */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
err:    say;              say '***error***: '   arg(1);         say;              exit 13
/*──────────────────────────────────────────────────────────────────────────────────────*/
Dnodes: arg $d;   do j=1  for words($d);   t= word($d, j)     /*color: encoded into L.  */
                  parse var  t   p   '.'   a   "."   b   '.'   x   1  .  .  .  xx
                  call Vnodes p a b
                  if x\==''   then call err "too many nodes specified: "   xx
                  if p\==top  then if @.p==.  then call err "node isn't defined: "  p
                  if p ==top  then do;  !.p=1;  L.1=p;  end   /*assign the top node.    */
                  @.p= a b;   n= !.p + 1                      /*assign node; bump level.*/
                  if a\==''   then do;  !.a= n;    @.a=;    maxL= max(maxL, !.a);    end
                  if b\==''   then do;  !.b= n;    @.b=;    maxL= max(maxL, !.b);    end
                  L.n= space(L.n a b)                         /*append to the level list*/
                  end   /*j*/
        return
/*──────────────────────────────────────────────────────────────────────────────────────*/
Lnodes:           do L=1  for  maxL;  w= length(maxL);  rb= word('(red) (black)', 1+L//2)
                  say "level:"   right(L, w)   left('', L+L)   " ───► "   rb    ' '   L.L
                  end   /*lev*/
        return
/*──────────────────────────────────────────────────────────────────────────────────────*/
Vnodes: arg $v;   do v=1  for words($v);      y= word($v, v)
                  if \datatype(y, 'W')   then call err "node isn't a whole number: "   y
                  y= y / 1                                /*normalize Y int.: no LZ, dot*/
                  if top==.  then do;  LO=y;  top=y;    HI=y;   L.=;   @.=;  maxL=1;   end
                                       LO= min(LO, y);  HI= max(HI, y)
                  if @.y\==.  &  @.y\==''  then call err "node is already defined: "   y
                  end   /*v*/
        return


import: mapping
import: collect
import: quicksort

: anagrams
| m |
   "unixdict.txt" File new groupBy( #sort )
   dup sortBy( #[ second size] ) last second size ->m
   filter( #[ second size m == ] )
   apply ( #[ second .cr ] )
;


-- This assumes you've already downloaded the following file and placed it
-- in the current directory: http://wiki.puzzlers.org/pub/wordlists/unixdict.txt

-- There are several different ways of reading the file.  I chose the
-- supplier method just because I haven't used it yet in any other examples.
source = .stream~new('unixdict.txt')~supplier
-- this holds our mappings of the anagrams
anagrams = .directory~new
count = 0    -- this is used to keep track of the maximums

loop while source~available
    word = source~item
    -- this produces a string consisting of the characters in sorted order
    -- Note: the ~~ used to invoke sort makes that message return value be
    -- the target array.  The sort method does not normally have a return value.
    key = word~makearray('')~~sort~tostring("l", "")

    -- make sure we have an accumulator collection for this key
    list = anagrams[key]
    if list == .nil then do
       list = .array~new
       anagrams[key] = list
    end
    -- this word is now associate with this key
    list~append(word)
    -- and see if this is a new highest count
    count = max(count, list~items)
    source~next
end

loop letters over anagrams
    list = anagrams[letters]
    if list~items >= count then
        say letters":" list~makestring("l", ", ")
end


Procedure Words_Ok(String1.s, String2.s)
  If Mid(String1,Len(String1),1)=Mid(String2,1,1)
    ProcedureReturn #True
  EndIf
  ProcedureReturn #False
EndProcedure

Procedure.s Amb(Array A.s(1), Array B.s(1), Array C.s(1), Array D.s(1))
  Protected a, b, c, d
  For a=0 To ArraySize(A())
    For b=0 To ArraySize(B())
      For c=0 To ArraySize(C())
        For d=0 To ArraySize(D())
          If Words_Ok(A(a),B(b)) And Words_Ok(B(b),C(c)) And Words_Ok(C(c),D(d))
            ProcedureReturn A(a)+" "+B(b)+" "+C(c)+" "+D(d)
          EndIf
        Next
      Next
    Next
  Next
  ProcedureReturn ""   ; Empty string, e.g. fail
EndProcedure

If OpenConsole()
  Define Text.s
  Dim Set1.s(2)
  Dim Set2.s(2)
  Dim Set3.s(2)
  Dim Set4.s(1)

  Set1(0)="the":    set1(1)="that":     set1(2)="a"
  Set2(0)="frog":   set2(1)="elephant": set2(2)="thing"
  Set3(0)="walked": set3(1)="treaded":  set3(2)="grows"
  Set4(0)="slowly": set4(1)="quickly"

  text=Amb(set1(),set2(),Set3(),set4())
  If Text<>""
    PrintN("Correct sentence would be,"+#CRLF$+Text)
  Else
    PrintN("Failed to fine a correct sentence.")
  EndIf
  PrintN(#CRLF$+#CRLF$+"Press ENTER to exit."): Input()
  CloseConsole()
EndIf


defmodule Proper do
  def divisors(1), do: []
  def divisors(n), do: [1 | divisors(2,n,:math.sqrt(n))] |> Enum.sort

  defp divisors(k,_n,q) when k>q, do: []
  defp divisors(k,n,q) when rem(n,k)>0, do: divisors(k+1,n,q)
  defp divisors(k,n,q) when k * k == n, do: [k | divisors(k+1,n,q)]
  defp divisors(k,n,q)                , do: [k,div(n,k) | divisors(k+1,n,q)]
end

defmodule Aliquot do
  def sequence(n, maxlen\\16, maxterm\\140737488355328)
  def sequence(0, _maxlen, _maxterm), do: "terminating"
  def sequence(n, maxlen, maxterm) do
    {msg, s} = sequence(n, maxlen, maxterm, [n])
    {msg, Enum.reverse(s)}
  end

  defp sequence(n, maxlen, maxterm, s) when length(s) < maxlen and n < maxterm do
    m = Proper.divisors(n) |> Enum.sum
    cond do
      m in s ->
        case {m, List.last(s), hd(s)} do
          {x,x,_} ->
            case length(s) do
              1 -> {"perfect", s}
              2 -> {"amicable", s}
              _ -> {"sociable of length #{length(s)}", s}
            end
          {x,_,x} -> {"aspiring", [m | s]}
          _       -> {"cyclic back to #{m}", [m | s]}
        end
      m == 0 -> {"terminating", [0 | s]}
      true -> sequence(m, maxlen, maxterm, [m | s])
    end
  end
  defp sequence(_, _, _, s), do: {"non-terminating", s}
end

Enum.each(1..10, fn n ->
  {msg, s} = Aliquot.sequence(n)
  :io.fwrite("~7w:~21s: ~p~n", [n, msg, s])
end)
IO.puts ""
[11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488, 15355717786080]
|> Enum.each(fn n ->
     {msg, s} = Aliquot.sequence(n)
     if n<10000000, do: :io.fwrite("~7w:~21s: ~p~n", [n, msg, s]),
                  else: :io.fwrite("~w: ~s: ~p~n", [n, msg, s])
   end)


USING: combinators combinators.short-circuit formatting kernel
literals locals math math.functions math.primes.factors
math.ranges namespaces pair-rocket sequences sets ;
FROM: namespaces => set ;
IN: rosetta-code.aliquot

SYMBOL: terms
CONSTANT: 2^47 $[ 2 47 ^ ]
CONSTANT: test-cases {
    11 12 28 496 220 1184 12496 1264460 790
    909 562 1064 1488 15355717786080
}

: next-term ( n -- m ) dup divisors sum swap - ;

: continue-aliquot? ( hs term -- hs term ? )
    {
        [ terms get 15 < ]
        [ swap in? not   ]
        [ nip zero? not  ]
        [ nip 2^47 <     ]
    } 2&& ;

: next-aliquot ( hs term -- hs next-term term )
    [ swap [ adjoin    ] keep ]
    [ dup  [ next-term ] dip  ] bi terms inc ;

: aliquot ( k -- seq )
    0 terms set HS{ } clone swap
    [ continue-aliquot? ] [ next-aliquot ] produce
    [ drop ] 2dip swap suffix ;

: non-terminating? ( seq -- ? )
    { [ length 15 > ] [ [ 2^47 > ] any? ] } 1|| ;

:: classify ( seq -- classification-str )
    {
        [ seq non-terminating? ] => [ "non-terminating" ]
        [ seq last zero?       ] => [ "terminating"     ]
        [ seq length 2 =       ] => [ "perfect"         ]
        [ seq length 3 =       ] => [ "amicable"        ]
        [ seq first seq last = ] => [ "sociable"        ]
        [ seq 2 tail* first2 = ] => [ "aspiring"        ]
        [ "cyclic" ]
    } cond ;

: .classify ( k -- )
    dup aliquot [ classify ] keep "%14u: %15s: %[%d, %]\n"
    printf ;

: main ( -- )
    10 [1,b] test-cases append [ .classify ] each ;

MAIN: main


#![feature(box_patterns, box_syntax)]
use self::Color::*;
use std::cmp::Ordering::*;

enum Color {R,B}

type Link<T> = Option<Box<N<T>>>;
struct N<T> {
    c: Color,
    l: Link<T>,
    val: T,
    r: Link<T>,
}

impl<T: Ord> N<T> {
    fn balance(col: Color, n1: Link<T>, z: T, n2: Link<T>) -> Link<T> {
        Some(box
             match (col,n1,n2) {
                   (B, Some(box N {c: R, l: Some(box N {c: R, l: a, val: x, r: b}), val: y, r: c}), d)
                |  (B, Some(box N {c: R, l: a, val: x, r: Some (box N {c: R, l: b, val: y, r: c})}), d)
                => N {c: R, l: Some(box N {c: B, l: a, val: x, r: b}), val: y, r: Some(box N {c: B, l: c, val: z, r: d})},
                   (B, a, Some(box N {c: R, l: Some(box N {c: R, l: b, val: y, r: c}), val: v, r: d}))
                |  (B, a, Some(box N {c: R, l: b, val: y, r: Some(box N {c: R, l: c, val: v, r: d})}))
                => N {c: R, l: Some(box N {c: B, l: a, val: z, r: b}), val: y, r: Some(box N {c: B, l: c, val: v, r: d})},
                (col, a, b) => N {c: col, l: a, val: z, r: b},
        })
    }
    fn insert(x: T, n: Link<T>) -> Link<T> {
        match n {
            None => Some(box N { c: R, l: None, val: x, r: None }),
            Some(n) =>  {
                let n = *n;
                let N {c: col, l: a, val: y, r: b} = n;
                match x.cmp(&y) {
                    Greater => Self::balance(col, a,y,Self::insert(x,b)),
                    Less    => Self::balance(col, Self::insert(x,a),y,b),
                    Equal   => Some(box N {c: col, l: a, val: y, r: b})
                }
            }
        }
    }
}


class RedBlackTree[A](implicit ord: Ordering[A]) {
  sealed abstract class Color
  case object R extends Color
  case object B extends Color

  sealed abstract class Tree {
    def insert(x: A): Tree = ins(x) match {
      case T(_, a, y, b) => T(B, a, y, b)
      case E             => E
    }
    def ins(x: A): Tree
  }

  case object E extends Tree {
    override def ins(x: A): Tree = T(R, E, x, E)
  }

  case class T(c: Color, left: Tree, a: A, right: Tree) extends Tree {
    private def balance: Tree = (c, left, a, right) match {
      case (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))
      case (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))
      case (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))
      case (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))
      case _ => this
    }

    override def ins(x: A): Tree = ord.compare(x, a) match {
      case -1 => T(c, left ins x, a, right      ).balance
      case  1 => T(c, left,       a, right ins x).balance
      case  0 => this
    }
  }
}


declare
  %% Helper function
  fun {ReadLines Filename}
     File = {New class $ from Open.file Open.text end init(name:Filename)}
  in
     for collect:C break:B do
	case {File getS($)} of false then {File close} {B}
	[] Line then {C Line}
        end
     end
  end

  %% Groups anagrams by using a mutable dictionary
  %% with sorted words as keys
  WordDict = {Dictionary.new}
  for Word in {ReadLines "unixdict.txt"}  do
     Keyword = {String.toAtom {Sort Word Value.'<'}}
  in
     WordDict.Keyword := Word|{CondSelect WordDict Keyword nil}
  end
  Sets = {Dictionary.items WordDict}

  %% Filter such that only the largest sets remain
  MaxSetSize = {FoldL {Map Sets Length} Max 0}
  LargestSets = {Filter Sets fun {$ S} {Length S} == MaxSetSize end}
in
  %% Display result (make sure strings are shown as string, not as number lists)
  {Inspector.object configureEntry(widgetShowStrings true)}
  {Inspect LargestSets}


import itertools as _itertools

class Amb(object):
    def __init__(self):
        self._names2values   = {}       # set of values for each global name
        self._func           = None     # Boolean constraint function
        self._valueiterator  = None     # itertools.product of names values
        self._funcargnames   = None     # Constraint parameter names

    def __call__(self, arg=None):
        if hasattr(arg, '__code__'):
            ##
            ## Called with a constraint function.
            ##
            globls = arg.__globals__ if hasattr(arg, '__globals__') else arg.func_globals
            # Names used in constraint
            argv = arg.__code__.co_varnames[:arg.__code__.co_argcount]
            for name in argv:
                if name not in self._names2values:
                    assert name in globls, \
                           "Global name %s not found in function globals" % name
                    self._names2values[name] = globls[name]
            # Gather the range of values of all names used in the constraint
            valuesets = [self._names2values[name] for name in argv]
            self._valueiterator = _itertools.product(*valuesets)
            self._func = arg
            self._funcargnames = argv
            return self
        elif arg is not None:
            ##
            ## Assume called with an iterable set of values
            ##
            arg = frozenset(arg)
            return arg
        else:
            ##
            ## blank call tries to return next solution
            ##
            return self._nextinsearch()

    def _nextinsearch(self):
        arg = self._func
        globls = arg.__globals__
        argv = self._funcargnames
        found = False
        for values in self._valueiterator:
            if arg(*values):
                # Set globals.
                found = True
                for n, v in zip(argv, values):
                    globls[n] = v
                break
        if not found: raise StopIteration
        return values

    def __iter__(self):
        return self

    def __next__(self):
        return self()
    next = __next__ # Python 2

if __name__ == '__main__':
    if True:
        amb = Amb()

        print("\nSmall Pythagorean triples problem:")
        x = amb(range(1,11))
        y = amb(range(1,11))
        z = amb(range(1,11))

        for _dummy in amb( lambda x, y, z: x*x + y*y == z*z ):
            print ('%s %s %s' % (x, y, z))

    if True:
        amb = Amb()

        print("\nRosetta Code Amb problem:")
        w1 = amb(["the", "that", "a"])
        w2 = amb(["frog", "elephant", "thing"])
        w3 = amb(["walked", "treaded", "grows"])
        w4 = amb(["slowly", "quickly"])

        for _dummy in amb( lambda w1, w2, w3, w4: \
                             w1[-1] == w2[0] and \
                             w2[-1] == w3[0] and \
                             w3[-1] == w4[0] ):
            print ('%s %s %s %s' % (w1, w2, w3, w4))

    if True:
        amb = Amb()

        print("\nAmb problem from "
            "http://www.randomhacks.net/articles/2005/10/11/amb-operator:")
        x = amb([1, 2, 3])
        y = amb([4, 5, 6])

        for _dummy in amb( lambda x, y: x * y != 8 ):
            print ('%s %s' % (x, y))


function raiseTo( bas as ulongint, power as ulongint ) as ulongint
    dim as ulongint result = 1, i
    for i = 1 to power
        result*=bas
    next i
    return result
end function

function properDivisorSum( n as ulongint ) as ulongint
	dim as ulongint prod = 1, temp = n, i = 3, count = 0
	while n mod 2 = 0
		count += 1
		n /= 2
	wend
	if count<>0 then prod *= (raiseTo(2,count + 1) - 1)
	while i*i <= n
		count = 0
		while n mod i = 0
			count += 1
			n /= i
		wend
		if count = 1 then
			prod *= (i+1)
		elseif count > 1 then
			prod *= ((raiseTo(i,count + 1) - 1)/(i-1))
	    end if
    i += 2
	wend
	if n>2 then	prod *= (n+1)
	return prod - temp
end function

sub printSeries( arr() as ulongint ptr, size as integer, ty as string)
	dim as integer i
	dim as string outstr = "Integer: "+str(arr(0))+", Type: "+ty+", Series: "
	for i=0 to size-2
		outstr = outstr + str(arr(i))+", "
    next i
	outstr = outstr + str(arr(i))
	print outstr
end sub

sub aliquotClassifier(n as ulongint)
	dim as ulongint arr(0 to 15)
	dim as integer i, j
	dim as string ty = "Sociable"
    arr(0) = n
    for i = 1 to 15
		arr(i) = properDivisorSum(arr(i-1))
		if arr(i)=0 orelse arr(i)=n orelse (arr(i) = arr(i-1) and arr(i)<>n) then
		    if arr(i) = 0 then
		        ty = "Terminating"
		    elseif arr(i) = n and i = 1 then
		        ty = "Perfect"
		    elseif arr(i) = n and i = 2 then
		        ty = "Amicable"
		    elseif arr(i) = arr(i-1) and arr(i)<>n then
		        ty = "Aspiring"
		    end if
			printSeries(arr(),i+1,ty)
			return
		end if
		for j = 1 to i-1
			if arr(j) = arr(i) then
				printSeries(arr(),i+1,"Cyclic")
				return
			end if
		next j
	next i
	printSeries(arr(),i+1,"Non-Terminating")
end sub

dim as ulongint nums(0 to 22) = {_
    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 as ubyte = 0 to 22
    aliquotClassifier(nums(n))
next n


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

(** val balance = fn : color * 'a tree * 'a * 'a tree -> 'a tree *)
fun 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)

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


enum Color { case R, B }
enum Tree<A> {
  case E
  indirect case T(Color, Tree<A>, A, Tree<A>)
}

func balance<A>(input: (Color, Tree<A>, A, Tree<A>)) -> Tree<A> {
  switch input {
  case let (.B, .T(.R, .T(.R,a,x,b), y, c), z, d): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d))
  case let (.B, .T(.R, a, x, .T(.R,b,y,c)), z, d): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d))
  case let (.B, a, x, .T(.R, .T(.R,b,y,c), z, d)): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d))
  case let (.B, a, x, .T(.R, b, y, .T(.R,c,z,d))): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d))
  case let (col, a, x, b)                        : return .T(col, a, x, b)
  }
}

func insert<A : Comparable>(x: A, s: Tree<A>) -> Tree<A> {
  func ins(s: Tree<A>) -> Tree<A> {
    switch s {
    case     .E           : return .T(.R,.E,x,.E)
    case let .T(col,a,y,b):
      if x < y {
        return balance((col, ins(a), y, b))
      } else if x > y {
        return balance((col, a, y, ins(b)))
      } else {
        return s
      }
    }
  }
  switch ins(s) {
  case let .T(_,a,y,b): return .T(.B,a,y,b)
  case     .E:
    assert(false)
    return .E
  }
}


processor RedBlackTree
  data node <{VOID}|{colour: <='black'|='red'>, left: <node>, right: <node>, value: <> VOID}> local
  @: {};
  sink insert
    templates balance
      when <{colour: <='black'>, left: <{ colour: <='red'> left: <{colour: <='red'>}>}>}>
        do { colour: 'red',
          left: { $.left.left..., colour: 'black'},
          value: $.left.value,
          right: { $..., left: $.left.right }} !
      when <{colour: <='black'>, left: <{ colour: <='red'> right: <{colour: <='red'>}>}>}>
        do { colour: 'red',
          left: { $.left..., colour: 'black', right: $.left.right.left},
          value: $.left.right.value,
          right: { $..., left: $.left.right.right }} !
      when <{colour: <='black'>, right: <{ colour: <='red'> left: <{colour: <='red'>}>}>}>
        do { colour: 'red',
          left: { $..., right: $.right.left.left},
          value: $.right.left.value,
          right: { $.right..., colour: 'black', left: $.right.left.right }} !
      when <{colour: <='black'>, right: <{ colour: <='red'> right: <{colour: <='red'>}>}>}>
        do { colour: 'red',
          left: { $..., right: $.right.left},
          value: $.right.value,
          right: { $.right.right..., colour: 'black' }} !
      otherwise $ !
    end balance
    templates ins&{into:}
      when <?($into <={}>)> do { colour: 'red', left: {}, value: $, right: {}} !
      when <..$into.value::raw> do { $into..., left: $ -> ins&{into: $into.left}} -> balance !
      otherwise { $into..., right: $ -> ins&{into: $into.right}} -> balance !
    end ins
    @RedBlackTree: { $ -> ins&{into: [email protected]} ..., colour: 'black'};
  end insert
  source toString
    '[email protected];' !
  end toString
end RedBlackTree

def tree: $RedBlackTree;
1..5 -> \('$tree::toString;$#10;' -> !OUT::write $ -> !tree::insert \) -> !VOID
$tree::toString -> !OUT::write


# From http://wiki.tcl.tk/9547
package require Tcl         8.5
package provide datatype    0.1

namespace eval ::datatype {
    namespace export define match matches
    namespace ensemble create

    # Datatype definitions
    proc define {type = args} {
        set ns [uplevel 1 { namespace current }]
        foreach cons [split [join $args] |] {
            set name [lindex $cons 0]
            set args [lrange $cons 1 end]
            proc $ns\::$name $args [format {
                lreplace [info level 0] 0 0 %s
            } [list $name]]
        }
        return $type
    }

    # Pattern matching
    # matches pattern value envVar --
    #   Returns 1 if value matches pattern, else 0
    #   Binds match variables in envVar
    proc matches {pattern value envVar} {
        upvar 1 $envVar env
        if {[var? $pattern]} { return [bind env $pattern $value] }
        if {[llength $pattern] != [llength $value]} { return 0 }
        if {[lindex $pattern 0] ne [lindex $value 0]} { return 0 }
        foreach pat [lrange $pattern 1 end] val [lrange $value 1 end] {
            if {![matches $pat $val env]} { return 0 }
        }
        return 1
    }
    # A variable starts with lower-case letter or _. _ is a wildcard.
    proc var? term { string match {[a-z_]*} $term }
    proc bind {envVar var value} {
        upvar 1 $envVar env
        if {![info exists env]} { set env [dict create] }
        if {$var eq "_"} { return 1 }
        dict set env $var $value
        return 1
    }
    proc match args {
        #puts "MATCH: $args"
        set values [lrange $args 0 end-1]
        set choices [lindex $args end]
        append choices \n [list return -code error -level 2 "no match for $values"]
        set f [list values $choices [namespace current]]
        lassign [apply $f $values] env body
        #puts "RESULT: $env -> $body"
        dict for {k v} $env { upvar 1 $k var; set var $v }
        catch { uplevel 1 $body } msg opts
        dict incr opts -level
        return -options $opts $msg
    }
    proc case args {
        upvar 1 values values
        set patterns [lrange $args 0 end-2]
        set body [lindex $args end]
        set env [dict create]
        if {[llength $patterns] != [llength $values]} { return }
        foreach pattern $patterns value $values {
            if {![matches $pattern $value env]} { return }
        }
        return -code return [list $env $body]
    }
    proc default body { return -code return [list {} $body] }
}


Program Anagrams;

// assumes a local file

uses
  classes, math;

var
  i, j, k, maxCount: integer;
  sortedString:      string;
  WordList:          TStringList;
  SortedWordList:    TStringList;
  AnagramList:       array of TStringlist;

begin
  WordList := TStringList.Create;
  WordList.LoadFromFile('unixdict.txt');
  for i := 0 to WordList.Count - 1 do
  begin
    setLength(sortedString,Length(WordList.Strings[i]));
    sortedString[1] := WordList.Strings[i][1];

    // sorted assign
    j := 2;
    while j <=  Length(WordList.Strings[i]) do
    begin
      k := j - 1;
      while (WordList.Strings[i][j] < sortedString[k]) and (k > 0) do
      begin
        sortedString[k+1] := sortedString[k];
        k := k - 1;
      end;
      sortedString[k+1] :=  WordList.Strings[i][j];
      j := j + 1;
    end;

    // create the stringlists of the sorted letters and
    // the list of the original words
    if not assigned(SortedWordList) then
    begin
      SortedWordList := TStringList.Create;
      SortedWordList.append(sortedString);
      setlength(AnagramList,1);
      AnagramList[0] := TStringList.Create;
      AnagramList[0].append(WordList.Strings[i]);
    end
    else
    begin
      j := 0;
      while sortedString <> SortedWordList.Strings[j] do
      begin
        inc(j);
        if j = (SortedWordList.Count) then
        begin
          SortedWordList.append(sortedString);
          setlength(AnagramList,length(AnagramList) + 1);
          AnagramList[j] := TStringList.Create;
 	  break;
        end;
      end;
      AnagramList[j].append(WordList.Strings[i]);
    end;
  end;

  maxCount := 1;
  for i := 0 to length(AnagramList) - 1 do
    maxCount := max(maxCount, AnagramList[i].Count);

  // create output
  writeln('The largest sets of words have ', maxCount, ' members:');
  for i := 0 to length(AnagramList) - 1 do
  begin
    if AnagramList[i].Count = maxCount then
    begin
      write('"', SortedWordList.strings[i], '": ');
      for j := 0 to AnagramList[i].Count - 2 do
        write(AnagramList[i].strings[j], ', ');
      writeln(AnagramList[i].strings[AnagramList[i].Count - 1]);
    end;
  end;

  // Cleanup
  WordList.Destroy;
  SortedWordList.Destroy;
  for i := 0 to length(AnagramList) - 1 do
    AnagramList[i].Destroy;

end.


checkSentence <- function(sentence){
# Input: character vector
# Output: whether the sentence formed by the elements of the vector is valid
  for (index in 1:(length(sentence)-1)){
    first.word  <- sentence[index]
    second.word <- sentence[index+1]

    last.letter  <- substr(first.word, nchar(first.word), nchar(first.word))
    first.letter <- substr(second.word, 1, 1)

    if (last.letter != first.letter){ return(FALSE) }
  }
  return(TRUE)
}

amb <- function(sets){
# Input: list of character vectors containing all sets to consider
# Output: list of character vectors that are valid
  all.paths      <- apply(expand.grid(sets), 2, as.character)
  all.paths.list <- split(all.paths, 1:nrow(all.paths))
  winners        <- all.paths.list[sapply(all.paths.list, checkSentence)]
  return(winners)
}


#lang racket

;; A quick `amb' implementation (same as in the Twelve Statements task)
(define failures null)

(define (fail)
  (if (pair? failures) ((first failures)) (error "no more choices!")))

(define (amb/thunks choices)
  (let/cc k (set! failures (cons k failures)))
  (if (pair? choices)
    (let ([choice (first choices)]) (set! choices (rest choices)) (choice))
    (begin (set! failures (rest failures)) (fail))))

(define-syntax-rule (amb E ...) (amb/thunks (list (lambda () E) ...)))

(define (assert condition) (unless condition (fail)))

;; Problem solution

(define (joins? left right)
  (regexp-match? #px"(.)\0\\1" (~a left "\0" right)))

(let ([result (list (amb "the" "that" "a")
                    (amb "frog" "elephant" "thing")
                    (amb "walked" "treaded" "grows")
                    (amb "slowly" "quickly"))])
  (for ([x result] [y (cdr result)]) (assert (joins? x y)))
  result)
;; -> '("that" "thing" "grows" "slowly")


package main

import (
    "fmt"
    "math"
    "strings"
)

const threshold = uint64(1) << 47

func indexOf(s []uint64, search uint64) int {
    for i, e := range s {
        if e == search {
            return i
        }
    }
    return -1
}

func contains(s []uint64, search uint64) bool {
    return indexOf(s, search) > -1
}

func maxOf(i1, i2 int) int {
    if i1 > i2 {
        return i1
    }
    return i2
}

func sumProperDivisors(n uint64) uint64 {
    if n < 2 {
        return 0
    }
    sqrt := uint64(math.Sqrt(float64(n)))
    sum := uint64(1)
    for i := uint64(2); i <= sqrt; i++ {
        if n % i != 0 {
            continue
        }
        sum += i + n / i
    }
    if sqrt * sqrt == n {
        sum -= sqrt
    }
    return sum
}

func classifySequence(k uint64) ([]uint64, string) {
    if k == 0 {
        panic("Argument must be positive.")
    }
    last := k
    var seq []uint64
    seq = append(seq, k)
    for {
        last = sumProperDivisors(last)
        seq = append(seq, last)
        n := len(seq)
        aliquot := ""
        switch {
        case last == 0:
            aliquot = "Terminating"
        case n == 2 && last == k:
            aliquot = "Perfect"
        case n == 3 && last == k:
            aliquot = "Amicable"
        case n >= 4 && last == k:
            aliquot = fmt.Sprintf("Sociable[%d]", n - 1)
        case last == seq[n - 2]:
            aliquot = "Aspiring"
        case contains(seq[1 : maxOf(1, n - 2)], last):
            aliquot = fmt.Sprintf("Cyclic[%d]", n - 1 - indexOf(seq[:], last))
        case n == 16 || last > threshold:
            aliquot = "Non-Terminating"
        }
        if aliquot != "" {
            return seq, aliquot
        }
    }
}

func joinWithCommas(seq []uint64) string {
    res := fmt.Sprint(seq)
    res = strings.Replace(res, " ", ", ", -1)
    return res
}

func main() {
    fmt.Println("Aliquot classifications - periods for Sociable/Cyclic in square brackets:\n")
    for k := uint64(1); k <= 10; k++ {
        seq, aliquot := classifySequence(k)
        fmt.Printf("%2d: %-15s %s\n", k, aliquot, joinWithCommas(seq))
    }
    fmt.Println()

    s := []uint64{
        11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488,
    }
    for _, k := range s {
        seq, aliquot := classifySequence(k)
        fmt.Printf("%7d: %-15s %s\n",  k, aliquot, joinWithCommas(seq))
    }
    fmt.Println()

    k := uint64(15355717786080)
    seq, aliquot := classifySequence(k)
    fmt.Printf("%d: %-15s %s\n", k, aliquot, joinWithCommas(seq))
}


var R = "R"
var B = "B"

class Tree {
    ins(x) {}    // overridden by child classes

    insert(x) {  // inherited by child classes
        var t = ins(x)
        if (t.type == T) return T.new(B, t.le, t.aa, t.ri)
        if (t.type == E) return E.new()
        return null
    }
}

class T is Tree {
    construct new(cl, le, aa, ri) {
        _cl = cl  // color
        _le = le  // Tree
        _aa = aa  // integer
        _ri = ri  // Tree
    }

    cl { _cl }
    le { _le }
    aa { _aa }
    ri { _ri }

    balance() {
        if (_cl != B) return this

        var le2 = _le.type == T ? _le : null
        var lele
        var leri
        if (le2) {
            lele = _le.le.type == T ? _le.le : null
            leri = _le.ri.type == T ? _le.ri : null
        }
        var ri2 = _ri.type == T ? _ri : null
        var rile
        var riri
        if (ri2) {
            rile = _ri.le.type == T ? _ri.le : null
            riri = _ri.ri.type == T ? _ri.ri : null
        }

        if (le2 && lele && le2.cl == R && lele.cl == R) {
            var t = le2.le
            return T.new(R, T.new(B, t.le, t.aa, t.ri), le2.aa, T.new(B, le2.ri, _aa, _ri))
        }
        if (le2 && leri && le2.cl == R && leri.cl == R) {
            var t = le2.ri
            return T.new(R, T.new(B, le2.le, le2.aa, t.le), t.aa, T.new(B, t.ri, _aa, _ri))
        }
        if (ri2 && rile && ri2.cl == R && rile.cl == R) {
            var t = ri2.ri
            return T.new(R, T.new(B, _le, _aa, t.le), t.aa, T.new(B, t.ri, ri2.aa, ri2.ri))
        }
        if (ri2 && riri && ri2.cl == R && riri.cl == R) {
            var t = ri2.ri
            return T.new(R, T.new(B, _le, _aa, ri2.le), ri2.aa, T.new(B, t.le, t.aa, t.ri))
        }
        return this
    }

    ins(x) {
        if (x < _aa) return T.new(_cl, _le.ins(x), _aa, _ri).balance()
        if (x > _aa) return T.new(_cl, _le, _aa, _ri.ins(x)).balance()
        return this
    }

    toString { "T(%(_cl), %(_le), %(_aa), %(_ri))" }
}

class E is Tree {
    construct new() {}

    ins(x) { T.new(R, E.new(), x, E.new()) }

    toString { "E" }
}

var tr = E.new()
for (i in 1..16) tr = tr.insert(i)
System.print(tr)


use List::Util 'max';

my @words = split "\n", do { local( @ARGV, $/ ) = ( 'unixdict.txt' ); <> };
my %anagram;
for my $word (@words) {
    push @{ $anagram{join '', sort split '', $word} }, $word;
}

my $count = max(map {scalar @$_} values %anagram);
for my $ana (values %anagram) {
    print "@$ana\n" if @$ana == $count;
}


#| an array of four words, that have more possible values.
#| Normally we would want `any' to signify we want any of the values, but well negate later and thus we need `all'
my @a =
(all «the that a»),
(all «frog elephant thing»),
(all «walked treaded grows»),
(all «slowly quickly»);

sub test (Str $l, Str $r) {
    $l.ends-with($r.substr(0,1))
}

(sub ($w1, $w2, $w3, $w4){
  # return if the values are false
  return unless [and] test($w1, $w2), test($w2, $w3),test($w3, $w4);
  # say the results. If there is one more Container layer around them this doesn't work, this is why we need the arguments here.
  say "$w1 $w2 $w3 $w4"
})(|@a); # supply the array as argumetns


divisors :: (Integral a) => a -> [a]
divisors n = filter ((0 ==) . (n `mod`)) [1 .. (n `div` 2)]

data Class
  = Terminating
  | Perfect
  | Amicable
  | Sociable
  | Aspiring
  | Cyclic
  | Nonterminating
  deriving (Show)

aliquot :: (Integral a) => a -> [a]
aliquot 0 = [0]
aliquot n = n : (aliquot $ sum $ divisors n)

classify :: (Num a, Eq a) => [a] -> Class
classify []             = Nonterminating
classify [0]            = Terminating
classify [_]            = Nonterminating
classify [a,b]
  | a == b              = Perfect
  | b == 0              = Terminating
  | otherwise           = Nonterminating
classify x@(a:b:c:_)
  | a == b              = Perfect
  | a == c              = Amicable
  | a `elem` (drop 1 x) = Sociable
  | otherwise           =
    case classify (drop 1 x) of
      Perfect  -> Aspiring
      Amicable -> Cyclic
      Sociable -> Cyclic
      d        -> d

main :: IO ()
main = do
  let cls n = let ali = take 16 $ aliquot n in (classify ali, ali)
  mapM_ (print . cls) $ [1..10] ++
    [11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488]


var object:Object = new Object();
object.foo = "bar";


integer fn = open("demo/unixdict.txt","r")
sequence words = {}, anagrams = {}, last="", letters
object word
integer maxlen = 1

while 1 do
    word = trim(gets(fn))
    if atom(word) then exit end if
    if length(word) then
        letters = sort(word)
        words = append(words, {letters, word})
    end if
end while
close(fn)

words = sort(words)
for i=1 to length(words) do
    {letters,word} = words[i]
    if letters=last then
        anagrams[$] = append(anagrams[$],word)
        if length(anagrams[$])>maxlen then
            maxlen = length(anagrams[$])
        end if
    else
        last = letters
        anagrams = append(anagrams,{word})
    end if
end for

puts(1,"\nMost anagrams:\n")
for i=1 to length(anagrams) do
    last = anagrams[i]
    if length(last)=maxlen then
        printf(1,"%s\n",{join(last,", ")})
    end if
end for


Red ["Amb operator"]

findblock: function [
	blk [block!]
][
	foreach w blk [
		if all [word? w block? get w] [return w]
		if block? w [findblock w]
	]
]

amb: function [
	cond [block!]
][
	either b: findblock cond [
		foreach a get b [
			cond2: replace/all/deep copy/deep cond b a
			if amb cond2 [set b a return true]]
	][do cond]
]

; examples

x: [1 2 3 4]
y: [4 5 6]
z: [5 2]
print amb [x * y * z = 8]
print [x y z]

a: ["the" "that" "a"]
b: ["frog" "elephant" "thing"]
c: ["walked" "treaded" "grows"]
d: ["slowly" "quickly"]
print amb [
	all [
		equal? last a first b
		equal? last b first c
		equal? last c first d
	]
]
print [a b c d]


/*REXX program  demonstrates  the   Amd   operator,   choosing a  word  from each  set. */
               @.1 = "the     that      a"
               @.2 = "frog    elephant  thing"
               @.3 = "walked  treaded   grows"
               @.4 = "slowly  quickly"
               @.0 = 4                           /*define the number of sets being ised.*/
call Amb 1                                       /*find all word combinations that works*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
Amb: procedure expose @.;   parse arg # x;     arg . u       /*ARG uppercases U value.  */
     if #>@.0  then do;  y= word(u, 1)                       /*Y:  is a  uppercased  U. */
                                       do n=2  to words(u);                ?= word(u, n)
                                       if left(?, 1) \== right(y, 1)  then return;    y= ?
                                       end   /*n*/
                         say strip(x)                        /*¬show superfluous blanks.*/
                    end
       do j=1  for words(@.#);  call Amb #+1 x word(@.#, j) /*gen all combos recursively*/
       end   /*j*/;             return


proper_divisors=: [: */@>@}:@,@{ [: (^ [email protected]>:)&.>/ 2 p: x:
aliquot=: +/@proper_divisors ::0:
rc_aliquot_sequence=: aliquot^:(i.16)&>
rc_classify=: 3 :0
      if. 16 ~:# y                 do. ' invalid        '
  elseif. 6 > {: y                 do. ' terminate      '
  elseif. (+./y>2^47) +. 16 = #~.y do. ' non-terminating'
  elseif. 1=#~. y                  do. ' perfect        '
  elseif. 8= st=. {.#/.~ y         do. ' amicable       '
  elseif. 1 < st                   do. ' sociable       '
  elseif. =/_2{. y                 do. ' aspiring       '
  elseif. 1                        do. ' cyclic         '
  end.
)
rc_display_aliquot_sequence=: (rc_classify,' ',":)@:rc_aliquot_sequence


import java.util.ArrayList;
import java.util.Arrays;
import java.util.List;
import java.util.stream.LongStream;

public class AliquotSequenceClassifications {

    private static Long properDivsSum(long n) {
        return LongStream.rangeClosed(1, (n + 1) / 2).filter(i -> n % i == 0 && n != i).sum();
    }

    static boolean aliquot(long n, int maxLen, long maxTerm) {
        List<Long> s = new ArrayList<>(maxLen);
        s.add(n);
        long newN = n;

        while (s.size() <= maxLen && newN < maxTerm) {

            newN = properDivsSum(s.get(s.size() - 1));

            if (s.contains(newN)) {

                if (s.get(0) == newN) {

                    switch (s.size()) {
                        case 1:
                            return report("Perfect", s);
                        case 2:
                            return report("Amicable", s);
                        default:
                            return report("Sociable of length " + s.size(), s);
                    }

                } else if (s.get(s.size() - 1) == newN) {
                    return report("Aspiring", s);

                } else
                    return report("Cyclic back to " + newN, s);

            } else {
                s.add(newN);
                if (newN == 0)
                    return report("Terminating", s);
            }
        }

        return report("Non-terminating", s);
    }

    static boolean report(String msg, List<Long> result) {
        System.out.println(msg + ": " + result);
        return false;
    }

    public static void main(String[] args) {
        long[] arr = {
                11, 12, 28, 496, 220, 1184, 12496, 1264460,
                790, 909, 562, 1064, 1488};

        LongStream.rangeClosed(1, 10).forEach(n -> aliquot(n, 16, 1L << 47));
        System.out.println();
        Arrays.stream(arr).forEach(n -> aliquot(n, 16, 1L << 47));
    }
}


with Ada.Text_IO;  use Ada.Text_IO;

procedure Dynamic is
   package Abstract_Class is
      type Class is limited interface;
      function Boo (X : Class) return String is abstract;
   end Abstract_Class;
   use Abstract_Class;

   package Base_Class is
      type Base is new Class with null record;
      overriding function Boo (X : Base) return String;
   end Base_Class;

   package body Base_Class is
      function Boo (X : Base) return String is
      begin
         return "I am Class";
      end Boo;
   end Base_Class;
   use Base_Class;

   E : aliased Base;  -- An instance of Base

begin
   -- Gone run-time
   declare
      type Monkey_Patch (Root : access Base) is new Class with record
         Foo : Integer := 1;
      end record;
      overriding function Boo (X : Monkey_Patch) return String;
      function Boo (X : Monkey_Patch) return String is
      begin -- Delegation to the base
         return X.Root.Boo;
      end Boo;
      EE : Monkey_Patch (E'Access); -- Extend E
   begin
      Put_Line (EE.Boo & " with" & Integer'Image (EE.Foo));
   end;
end Dynamic;


define :myClass [name,surname][]

myInstance: to :myClass ["John" "Doe"]
print myInstance

myInstance\age: 35
print myInstance


      INSTALL @lib$+"CLASSLIB"

      REM Create a base class with no members:
      DIM class{method}
      PROC_class(class{})

      REM Instantiate the class:
      PROC_new(myobject{}, class{})

      REM Add a member at run-time:
      member$ = "mymember#"
      PROCaddmember(myobject{}, member$, 8)

      REM Test that the member can be accessed:
      PROCassign("myobject." + member$, "PI")
      PRINT EVAL("myobject." + member$)
      END

      DEF PROCaddmember(RETURN obj{}, mem$, size%)
      LOCAL D%, F%, P%
      DIM D% DIM(obj{}) + size% - 1, F% LEN(mem$) + 8
      P% = !^obj{} + 4
      WHILE !P% : P% = !P% : ENDWHILE : !P% = F%
      $$(F%+4) = mem$ : F%!(LEN(mem$) + 5) = DIM(obj{})
      !(^obj{} + 4) = D%
      ENDPROC

      DEF PROCassign(v$, n$)
      IF EVAL("FNassign(" + v$ + "," + n$ + ")")
      ENDPROC
      DEF FNassign(RETURN n, v) : n = v : = 0


( ( struktuur
  = (aMember=) (aMethod=.!(its.aMember))
  )
& new$struktuur:?object
& out$"Object as originally created:"
& lst$object
& A value:?(object..aMember)
& !object:(=?originalMembersAndMethods)
&     new
    $ (
      ' ( (anotherMember=)
          (anotherMethod=.!(its.anotherMember))
          ()$originalMembersAndMethods
        )
      )
  : ?object
&   out
  $ "
Object with additional member and method and with 'aMember' already set to some interesting value:"
& lst$object
& some other value:?(object..anotherMember)
& out$"
Call both methods and output their return values."
& out$("aMember contains:" (object..aMethod)$)
& out$("anotherMember contains:" (object..anotherMethod)$)
&);


include ..\Utilitys.pmt

"unixdict.txt" "r" fopen var f

( )

true while
    f fgets
    dup -1 == if
        drop
        f fclose
        false
    else
        -1 del
        dup sort swap 2 tolist 0 put
        true
    endif
endwhile

sort

"" var prev
( ) var prov
( ) var res
0 var maxlen

len for
    get 1 get dup prev != if
        res prov len maxlen > if len var maxlen endif
        0 put var res ( ) var prov
    endif
    var prev
    2 get nip
    prov swap 0 put var prov
endfor

res

len for
    get len maxlen == if ? else drop endif
endfor


<?php
$words = explode("\n", file_get_contents('http://wiki.puzzlers.org/pub/wordlists/unixdict.txt'));
foreach ($words as $word) {
    $chars = str_split($word);
    sort($chars);
    $anagram[implode($chars)][] = $word;
}

$best = max(array_map('count', $anagram));
foreach ($anagram as $ana)
    if (count($ana) == $best)
        print_r($ana);
?>


# Project : Amb

set1 = ["the","that","a"]
set2 = ["frog","elephant","thing"]
set3 = ["walked","treaded","grows"]
set4 = ["slowly","quickly"]
text = amb(set1,set2,set3,set4)
if text != ""
   see "Correct sentence would be: " + nl  + text + nl
else
   see "Failed to fine a correct sentence."
ok

func wordsok(string1, string2)
       if substr(string1,len(string1),1) = substr(string2,1,1)
          return true
       ok
       return false

func amb(a,b,c,d)
       for a2 = 1 to len(a)
            for b2 =1 to len(b)
                 for c2 = 1 to len(c)
                      for d2 = 1 to len(d)
                           if wordsok(a[a2],b[b2]) and wordsok(b[b2],c[c2]) and wordsok(c[c2],d[d2])
                              return a[a2]+" "+b[b2]+" "+c[c2]+" "+d[d2]
                           ok
                      next
                 next
            next
       next
       return ""


require "continuation"

class Amb
  class ExhaustedError < RuntimeError; end

  def initialize
    @fail = proc { fail ExhaustedError, "amb tree exhausted" }
  end

  def choose(*choices)
    prev_fail = @fail
    callcc { |sk|
      choices.each { |choice|
	callcc { |fk|
	  @fail = proc {
	    @fail = prev_fail
	    fk.call(:fail)
	  }
	  if choice.respond_to? :call
	    sk.call(choice.call)
	  else
	    sk.call(choice)
	  end
	}
      }
      @fail.call
    }
  end

  def failure
    choose
  end

  def assert(cond)
    failure unless cond
  end
end

A = Amb.new
w1 = A.choose("the", "that", "a")
w2 = A.choose("frog", "elephant", "thing")
w3 = A.choose("walked", "treaded", "grows")
w4 = A.choose("slowly", "quickly")

A.choose() unless w1[-1] == w2[0]
A.choose() unless w2[-1] == w3[0]
A.choose() unless w3[-1] == w4[0]

puts w1, w2, w3, w4


# "until" is available in more recent versions of jq
# than jq 1.4
def until(cond; next):
  def _until:
    if cond then . else (next|_until) end;
  _until;

# unordered
def proper_divisors:
  . as $n
  | if $n > 1 then 1,
      ( range(2; 1 + (sqrt|floor)) as $i
        | if ($n % $i) == 0 then $i,
            (($n / $i) | if . == $i then empty else . end)
          else empty
          end)
    else empty
    end;

# sum of proper divisors, or 0
def pdsum:
  [proper_divisors] | add // 0;

# input is n
# maxlen defaults to 16;
# maxterm defaults to 2^47
def aliquot(maxlen; maxterm):
  (maxlen // 15) as $maxlen
  | (maxterm // 40737488355328) as $maxterm
  | if . == 0 then "terminating at 0"
    else
    # [s, slen, new] = [[n], 1, n]
    [ [.], 1, .]
    | until( type == "string" or .[1] > $maxlen or .[2] > $maxterm;
             .[0] as $s | .[1] as $slen
             | ($s | .[length-1] | pdsum) as $new
             | if ($s|index($new)) then
                 if $s[0] == $new then
                     if $slen == 1 then "perfect \($s)"
                     elif $slen == 2 then "amicable: \($s)"
                     else "sociable of length \($slen): \($s)"
		     end
                 elif ($s | .[length-1]) == $new then "aspiring: \($s)"
                 else "cyclic back to \($new): \($s)"
		 end
               elif $new == 0 then "terminating: \($s + [0])"
               else [ ($s + [$new]), ($slen + 1), $new ]
               end )
    | if type == "string" then . else "non-terminating: \(.[0])" end
    end;

def task:
  def pp: "\(.): \(aliquot(null;null))";
     (range(1; 11) | pp),
     "",
     ((11, 12, 28, 496, 220, 1184, 12496, 1264460,
      790, 909, 562, 1064, 1488, 15355717786080) | pp);

task


function aliquotclassifier{T<:Integer}(n::T)
    a = T[n]
    b = divisorsum(a[end])
    len = 1
    while len < 17 && !(b in a) && 0 < b && b < 2^47+1
        push!(a, b)
        b = divisorsum(a[end])
        len += 1
    end
    if b in a
        1 < len || return ("Perfect", a)
        if b == a[1]
            2 < len || return ("Amicable", a)
            return ("Sociable", a)
        elseif b == a[end]
            return ("Aspiring", a)
        else
            return ("Cyclic", push!(a, b))
        end
    end
    push!(a, b)
    b != 0 || return ("Terminating", a)
    return ("Non-terminating", a)
end


// ----------------------------------------------------------------------------------------------
//
//  Program.cs - DynamicClassVariable
//
//     Mikko Puonti, 2013
//
// ----------------------------------------------------------------------------------------------

using System;
using System.Dynamic;

namespace DynamicClassVariable
{
    internal static class Program
    {
        #region Static Members

        private static void Main()
        {
            // To enable late binding, we must use dynamic keyword
            // ExpandoObject readily implements IDynamicMetaObjectProvider which allows us to do some dynamic magic
            dynamic sampleObj = new ExpandoObject();
            // Adding a new property
            sampleObj.bar = 1;
            Console.WriteLine( "sampleObj.bar = {0}", sampleObj.bar );

            // We can also add dynamically methods and events to expando object
            // More information: http://msdn.microsoft.com/en-us/library/system.dynamic.expandoobject.aspx
            // This sample only show very small part of dynamic language features - there is lot's more

            Console.WriteLine( "< Press any key >" );
            Console.ReadKey();
        }

        #endregion
    }
}


# CoffeeScript is dynamic, just like the Javascript it compiles to.
# You can dynamically add attributes to objects.

# First create an object very simply.
e = {}
e.foo = "bar"
e.yo = -> "baz"
console.log e.foo, e.yo()

# CS also has class syntax to instantiate objects, the details of which
# aren't shown here.  The mechanism to add members is the same, though.
class Empty
  # empty class

e = new Empty()
e.foo = "bar"
e.yo = -> "baz"
console.log e.foo, e.yo()


(defun augment-instance-with-slots (instance slots)
  (change-class instance
                (make-instance 'standard-class
                  :direct-superclasses (list (class-of instance))
                  :direct-slots slots)))


struct Dynamic(T) {
    private T[string] vars;

    @property T opDispatch(string key)() pure nothrow {
        return vars[key];
    }

    @property void opDispatch(string key, U)(U value) pure nothrow {
        vars[key] = value;
    }
}

void main() {
    import std.variant, std.stdio;

    // If the type of the attributes is known at compile-time:
    auto d1 = Dynamic!double();
    d1.first = 10.5;
    d1.second = 20.2;
    writeln(d1.first, " ", d1.second);

    // If the type of the attributes is mixed:
    auto d2 = Dynamic!Variant();
    d2.a = "Hello";
    d2.b = 11;
    d2.c = ['x':2, 'y':4];
    d2.d = (int x) => x ^^ 3;
    writeln(d2.a, " ", d2.b, " ", d2.c);
    immutable int x = d2.b.get!int;
}


go =>
   Dict = new_map(),
   foreach(Line in read_file_lines("unixdict.txt"))
      Sorted = Line.sort(),
      Dict.put(Sorted, Dict.get(Sorted,"") ++ [Line] )
   end,
   MaxLen = max([Value.length : _Key=Value in Dict]),
   println(maxLen=MaxLen),
   foreach(_Key=Value in Dict, Value.length == MaxLen)
      println(Value)
   end,
   nl.


(flip
   (by length sort
      (by '((L) (sort (copy L))) group
         (in "unixdict.txt" (make (while (line) (link @)))) ) ) )


use std::ops::Add;
struct Amb<'a> {
    list: Vec<Vec<&'a str>>,
}
fn main() {
    let amb = Amb {
        list: vec![
            vec!["the", "that", "a"],
            vec!["frog", "elephant", "thing"],
            vec!["walked", "treaded", "grows"],
            vec!["slowly", "quickly"],
        ],
    };
    match amb.do_amb(0, 0 as char) {
        Some(text) => println!("{}", text),
        None => println!("Nothing found"),
    }
}
impl<'a> Amb<'a> {
    fn do_amb(&self, level: usize, last_char: char) -> Option<String> {
        if self.list.is_empty() {
            panic!("No word list");
        }
        if self.list.len() <= level {
            return Some(String::new());
        }
        let mut res = String::new();
        let word_list = &self.list[level];
        for word in word_list {
            if word.chars().next().unwrap() == last_char || last_char == 0 as char {
                res = res.add(word).add(" ");
                let answ = self.do_amb(level + 1, word.chars().last().unwrap());
                match answ {
                    Some(x) => {
                        res = res.add(&x);
                        return Some(res);
                    }
                    None => res.clear(),
                }
            }
        }
        None
    }
}


object Amb {

  def amb(wss: List[List[String]]): Option[String] = {
    def _amb(ws: List[String], wss: List[List[String]]): Option[String] = wss match {
      case Nil => ((Some(ws.head): Option[String]) /: ws.tail)((a, w) => a match {
        case Some(x) => if (x.last == w.head) Some(x + " " + w) else None
        case None => None
      })
      case ws1 :: wss1 => ws1.flatMap(w => _amb(w :: ws, wss1)).headOption
    }
    _amb(Nil, wss.reverse)
  }

  def main(args: Array[String]) {
    println(amb(List(List("the", "that", "a"),
                     List("frog", "elephant", "thing"),
                     List("walked", "treaded", "grows"),
                     List("slowly", "quickly"))))
  }
}


// version 1.1.3

data class Classification(val sequence: List<Long>, val aliquot: String)

const val THRESHOLD = 1L shl 47

fun sumProperDivisors(n: Long): Long {
    if (n < 2L) return 0L
    val sqrt = Math.sqrt(n.toDouble()).toLong()
    var sum = 1L + (2L..sqrt)
        .filter { n % it == 0L }
        .map { it + n / it }
        .sum()
    if (sqrt * sqrt == n) sum -= sqrt
    return sum
}

fun classifySequence(k: Long): Classification {
    require(k > 0)
    var last = k
    val seq = mutableListOf(k)
    while (true) {
        last = sumProperDivisors(last)
        seq.add(last)
        val n = seq.size
        val aliquot = when {
            last == 0L                  -> "Terminating"
            n == 2 && last == k         -> "Perfect"
            n == 3 && last == k         -> "Amicable"
            n >= 4 && last == k         -> "Sociable[${n - 1}]"
            last == seq[n - 2]          -> "Aspiring"
            last in seq.slice(1..n - 3) -> "Cyclic[${n - 1 - seq.indexOf(last)}]"
            n == 16 || last > THRESHOLD -> "Non-Terminating"
            else                        -> ""
        }
        if (aliquot != "") return Classification(seq, aliquot)
    }
}

fun main(args: Array<String>) {
    println("Aliqot classifications - periods for Sociable/Cyclic in square brackets:\n")
    for (k in 1L..10) {
        val (seq, aliquot) = classifySequence(k)
        println("${"%2d".format(k)}: ${aliquot.padEnd(15)} $seq")
    }

    val la = longArrayOf(
        11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488
    )
    println()

    for (k in la) {
        val (seq, aliquot) = classifySequence(k)
        println("${"%7d".format(k)}: ${aliquot.padEnd(15)} $seq")
    }

    println()

    val k = 15355717786080L
    val (seq, aliquot) = classifySequence(k)
    println("$k: ${aliquot.padEnd(15)} $seq")
}


import extensions;

class Extender : BaseExtender
{
    prop object foo;

    constructor(object)
    {
        theObject := object
    }
}

public program()
{
    var object := 234;

    // extending an object with a field
    object := new Extender(object);

    object.foo := "bar";

    console.printLine(object,".foo=",object.foo);

    console.readChar()
}


vect = [ 'alpha', 'beta', 'gamma' ]
vect.dump = function ()
  for n in [0: self.len()]
    > @"$(n): ", self[n]
  end
end
vect += 'delta'
vect.dump()


#APPTYPE CONSOLE

CLASS Growable

	PRIVATE:

	DIM instructions AS STRING = "Sleep(1)"
	:ExecCode
	DIM dummy AS INTEGER = EXECLINE(instructions, 1)

	PUBLIC:

	METHOD Absorb(code AS STRING)
		instructions = code
		GOTO ExecCode
	END METHOD

	METHOD Yield() AS VARIANT
		RETURN result
	END METHOD

END CLASS

DIM Sponge AS NEW Growable()

Sponge.Absorb("DIM b AS VARIANT = 1234567890: DIM result AS VARIANT = b")
PRINT Sponge.Yield()
Sponge.Absorb("b = ""Hello world!"": result = b")
PRINT Sponge.Yield()

PAUSE


include FMS-SI.f
include FMS-SILib.f

\ We can add any number of variables at runtime by adding
\ objects of any type to an instance at run time.  The added
\ objects are then accessible via an index number.

:class foo
  object-list inst-objects \ a dynamically growable object container
  :m init: inst-objects init: ;m
  :m add: ( obj -- ) inst-objects add: ;m
  :m at: ( idx -- obj ) inst-objects at: ;m
;class

foo foo1

: main
  heap> string foo1 add:
  heap> fvar   foo1 add:

  s" Now is the time " 0 foo1 at: !:
  3.14159e             1 foo1 at: !:

  0 foo1 at: p: \ send the print message to indexed object 0
  1 foo1 at: p: \ send the print message to indexed object 1
;

main \ => Now is the time 3.14159


' Class ... End Class
' Esta característica aún no está implementada en el compilador.


/* Search a list of words, finding those having the same letters. */

word_test: proc options (main);
   declare words (50000) character (20) varying,
           frequency (50000) fixed binary;
   declare word character (20) varying;
   declare (i, k, wp, most) fixed binary (31);

   on endfile (sysin) go to done;

   words = ''; frequency = 0;
   wp = 0;
   do forever;
      get edit (word) (L);
      call search_word_list (word);
   end;

done:
   put skip list ('There are ' || wp || ' words');
   most = 0;
   /* Determine the word(s) having the greatest number of anagrams. */
   do i = 1 to wp;
      if most < frequency(i) then most = frequency(i);
   end;
   put skip edit ('The following word(s) have ', trim(most), ' anagrams:') (a);
   put skip;
   do i = 1 to wp;
      if most = frequency(i) then put edit (words(i)) (x(1), a);
   end;

search_word_list: procedure (word) options (reorder);
   declare word character (*) varying;
   declare i fixed binary (31);

   do i = 1 to wp;
      if length(words(i)) = length(word) then
         if is_anagram(word, words(i)) then
            do;
               frequency(i) = frequency(i) + 1;
               return;
            end;
   end;
   /* The word does not exist in the list, so add it. */
   if wp >= hbound(words,1) then return;
   wp = wp + 1;
   words(wp) = word;
   frequency(wp) = 1;
   return;
end search_word_list;

/* Returns true if the words are anagrams, otherwise returns false. */
is_anagram: procedure (word1, word2) returns (bit(1)) options (reorder);
   declare (word1, word2) character (*) varying;
   declare tword character (20) varying, c character (1);
   declare (i, j) fixed binary;

   tword = word2;
   do i = 1 to length(word1);
      c = substr(word1, i, 1);
      j = index(tword, c);
      if j = 0 then return ('0'b);
      substr(tword, j, 1) = ' ';
   end;
   return ('1'b);
end is_anagram;

end word_test;


output =
  readFileLines("unixdict.txt")
  |> reduce(logWord, {})
  |> vals
  |> getMax
  |> printLines

logWord(dict, word) =
  (dict with $[chars] = [word] ++ getDefault(dict, [], chars))
  where chars = sort(word)

getMax(groups) =
  groups |> filter(g => length(g) == maxLength)
  where maxLength = groups |> map(length) |> maximum


(define fail
  (lambda ()
    (error "Amb tree exhausted")))

(define-syntax amb
  (syntax-rules ()
    ((AMB) (FAIL))                      ; Two shortcuts.
    ((AMB expression) expression)

    ((AMB expression ...)
     (LET ((FAIL-SAVE FAIL))
       ((CALL-WITH-CURRENT-CONTINUATION ; Capture a continuation to
          (LAMBDA (K-SUCCESS)           ;   which we return possibles.
            (CALL-WITH-CURRENT-CONTINUATION
              (LAMBDA (K-FAILURE)       ; K-FAILURE will try the next
                (SET! FAIL K-FAILURE)   ;   possible expression.
                (K-SUCCESS              ; Note that the expression is
                 (LAMBDA ()             ;   evaluated in tail position
                   expression))))       ;   with respect to AMB.
            ...
            (SET! FAIL FAIL-SAVE)      ; Finally, if this is reached,
            FAIL-SAVE)))))))            ;   we restore the saved FAIL.

(let ((w-1 (amb "the" "that" "a"))
      (w-2 (amb "frog" "elephant" "thing"))
      (w-3 (amb "walked" "treaded" "grows"))
      (w-4 (amb "slowly" "quickly")))
  (define (joins? left right)
    (equal? (string-ref left (- (string-length left) 1)) (string-ref right 0)))
  (if (joins? w-1 w-2) '() (amb))
  (if (joins? w-2 w-3) '() (amb))
  (if (joins? w-3 w-4) '() (amb))
  (list w-1 w-2 w-3 w-4))


print "ROSETTA CODE - Aliquot sequence classifications"
[Start]
input "Enter an integer: "; K
K=abs(int(K)): if K=0 then goto [Quit]
call PrintAS K
goto [Start]

[Quit]
print "Program complete."
end

sub PrintAS K
    Length=52
    dim Aseq(Length)
    n=K: class=0
    for element=2 to Length
        Aseq(element)=PDtotal(n)
        print Aseq(element); " ";
        select case
            case Aseq(element)=0
                print " terminating": class=1: exit for
            case Aseq(element)=K and element=2
                print " perfect": class=2: exit for
            case Aseq(element)=K and element=3
                print " amicable": class=3: exit for
            case Aseq(element)=K and element>3
                print " sociable": class=4: exit for
            case Aseq(element)<>K and Aseq(element-1)=Aseq(element)
                print " aspiring": class=5: exit for
            case Aseq(element)<>K and Aseq(element-2)= Aseq(element)
                print " cyclic": class=6: exit for
        end select
        n=Aseq(element)
        if n>priorn then priorn=n: inc=inc+1 else inc=0: priorn=0
        if inc=11 or n>30000000 then exit for
    next element
    if class=0 then print " non-terminating"
end sub

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


package main

import (
    "bufio"
    "fmt"
    "log"
    "os"
)

type SomeStruct struct {
    runtimeFields map[string]string
}

func check(err error) {
    if err != nil {
        log.Fatal(err)
    }
}

func main() {
    ss := SomeStruct{make(map[string]string)}
    scanner := bufio.NewScanner(os.Stdin)
    fmt.Println("Create two fields at runtime: ")
    for i := 1; i <= 2; i++ {
        fmt.Printf("  Field #%d:\n", i)
        fmt.Print("       Enter name  : ")
        scanner.Scan()
        name := scanner.Text()
        fmt.Print("       Enter value : ")
        scanner.Scan()
        value := scanner.Text()
        check(scanner.Err())
        ss.runtimeFields[name] = value
        fmt.Println()
    }
    for {
        fmt.Print("Which field do you want to inspect ? ")
        scanner.Scan()
        name := scanner.Text()
        check(scanner.Err())
        value, ok := ss.runtimeFields[name]
        if !ok {
            fmt.Println("There is no field of that name, try again")
        } else {
            fmt.Printf("Its value is '%s'\n", value)
            return
        }
    }
}


class A {
    final x = { it + 25 }
    private map = new HashMap()
    Object get(String key) { map[key] }
    void set(String key, Object value) { map[key] = value }
}


link ximage

procedure main()
   c1 := foo(1,2)                            # instance of foo
   write("c1:\n",ximage(c1))
   c1 := extend(c1,["c","d"],[8,9])          # 2 new fields
   write("new c1:\n",ximage(c1))
   c1 := extend(c1,["e"],[7])                # 1 more
   write("newest c1:\n",ximage(c1))
end

class foo(a,b)                               # dummy class
end

procedure extend(instance,newvars,newvals)   #: extend a class instance
   every put(f := [],fieldnames(instance))   # copy existing fieldnames
   c := ["tempconstructor"] ||| f            # new constructor
   every put(c,!newvars)                     # append new vars
   t := constructor!c                        # new constructor
   x := t()                                  # new instance
   every x[v := !f] := instance[v]           # same as old instance
   x.__s := x                                # new self
   if \newvals then
      every i := 1 to min(*newvars,*newvals) do
         x[newvars[i]] := newvals[i]         # add new vars = values
   return x
end


$c = New-Object Net.WebClient
$words = -split ($c.DownloadString('http://wiki.puzzlers.org/pub/wordlists/unixdict.txt'))
$top_anagrams = $words `
    | ForEach-Object {
          $_ | Add-Member -PassThru NoteProperty Characters `
                   (-join (([char[]] $_) | Sort-Object))
      } `
    | Group-Object Characters `
    | Group-Object Count `
    | Sort-Object Count `
    | Select-Object -First 1

$top_anagrams.Group | ForEach-Object { $_.Group -join ', ' }


$ include "seed7_05.s7i";

const type: setListType is array array string;

const func array string: amb (in string: word1, in setListType: listOfSets) is func
  result
    var array string: ambResult is 0 times "";
  local
    var string: word2 is "";
  begin
    for word2 range listOfSets[1] do
      if length(ambResult) = 0 and word1[length(word1) len 1] = word2[1 len 1] then
        if length(listOfSets) = 1 then
          ambResult := [] (word1) & [] (word2);
        else
          ambResult := amb(word2, listOfSets[2 ..]);
          if length(ambResult) <> 0 then
            ambResult := [] (word1) & ambResult;
          end if;
        end if;
      end if;
    end for;
  end func;

const func array string: amb (in setListType: listOfSets) is func
  result
    var array string: ambResult is 0 times "";
  local
    var string: word1 is "";
  begin
    for word1 range listOfSets[1] do
      if length(ambResult) = 0 then
        ambResult := amb(word1, listOfSets[2 ..]);
      end if;
    end for;
  end func;

const proc: main is func
  local
    var array string: ambResult is 0 times "";
    var string: word is "";
  begin
    ambResult := amb([] ([] ("the", "that", "a"),
                         [] ("frog", "elephant", "thing"),
                         [] ("walked", "treaded", "grows"),
                         [] ("slowly", "quickly")));
    for word range ambResult do
      write(word <& " ");
    end for;
    writeln;
  end func;


program amb;

sets := unstr('[{the that a} {frog elephant thing} {walked treaded grows} {slowly quickly}]');

words := [amb(words): words in sets];
if exists lWord = words(i), rWord in {words(i+1)} |
          lWord(#lWord) /= rWord(1) then
  fail;
end if;

proc amb(words);
  return arb {word in words | ok};
end proc;

end program;


seq[n_] :=
  NestList[If[# == 0, 0,
     DivisorSum[#, # &, Function[div, div != #]]] &, n, 16];
class[seq_] :=
  Which[Length[seq] < 2, "Non-terminating", MemberQ[seq, 0],
   "Terminating", seq[[1]] == seq[[2]], "Perfect",
   Length[seq] > 2 && seq[[1]] == seq[[3]], "Amicable",
   Length[seq] > 3 && MemberQ[seq[[4 ;;]], seq[[1]]], "Sociable",
   MatchQ[class[Rest[seq]], "Perfect" | "Aspiring"], "Aspiring",
   MatchQ[class[Rest[seq]], "Amicable" | "Sociable" | "Cyclic"],
   "Cyclic", True, "Non-terminating"];
notate[seq_] :=
  Which[seq == {}, {},
   MemberQ[Rest[seq],
    seq[[1]]], {Prepend[TakeWhile[Rest[seq], # != seq[[1]] &],
     seq[[1]]]}, True, Prepend[notate[Rest[seq]], seq[[1]]]];
Print[{#, class[seq[#]], notate[seq[#]] /. {0} -> 0}] & /@ {1, 2, 3, 4, 5, 6, 7,
   8, 9, 10, 11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909,
   562, 1064, 1488, 15355717786080};


import math
import strformat
from strutils import addSep
import times

type

  # Classification categories.
  Category = enum
    Unknown
    Terminating = "terminating"
    Perfect = "perfect"
    Amicable = "amicable"
    Sociable = "sociable"
    Aspiring = "aspiring"
    Cyclic = "cyclic"
    NonTerminating = "non-terminating"

  # Aliquot sequence.
  AliquotSeq = seq[int]

const Limit = 2^47    # Limit beyond which the category is considered to be "NonTerminating".

#---------------------------------------------------------------------------------------------------

proc sumProperDivisors(n: int): int =
  ## Compute the sum of proper divisors.*

  if n == 1: return 0
  result = 1
  for d in 2..sqrt(n.toFloat).int:
    if n mod d == 0:
      inc result, d
      if n div d != d:
        inc result, n div d

#---------------------------------------------------------------------------------------------------

iterator aliquotSeq(n: int): int =
  ## Yield the elements of the aliquot sequence of "n".
  ## Stopped if the current value is null or equal to "n".

  var k = n
  while true:
    k = sumProperDivisors(k)
    yield k

#---------------------------------------------------------------------------------------------------

proc `$`(a: AliquotSeq): string =
  ## Return the representation of an allquot sequence.

  for n in a:
    result.addSep(", ", 0)
    result.addInt(n)

#---------------------------------------------------------------------------------------------------

proc classification(n: int): tuple[cat: Category, values: AliquotSeq] =
  ## Return the category of the aliquot sequence of a number "n" and the sequence itself.

  var count = 0         # Number of elements currently generated.
  var prev = n          # Previous element in the sequence.
  result.cat = Unknown
  for k in aliquotSeq(n):
    inc count
    if k == 0:
      result.cat = Terminating
    elif k == n:
      result.cat = case count
                   of 1: Perfect
                   of 2: Amicable
                   else: Sociable
    elif k > Limit or count > 16:
      result.cat = NonTerminating
    elif k == prev:
      result.cat = Aspiring
    elif k in result.values:
      result.cat = Cyclic
    prev = k
    result.values.add(k)
    if result.cat != Unknown:
      break

#---------------------------------------------------------------------------------------------------

let t0 = getTime()

for n in 1..10:
  let (cat, aseq) = classification(n)
  echo fmt"{n:14}: {cat:<20} {aseq}"

echo ""
for n in [11, 12, 28, 496, 220, 1184, 12496, 1264460,
          790, 909, 562, 1064, 1488, 15355717786080.int]:
  let (cat, aseq) = classification(n)
  echo fmt"{n:14}:  {cat:<20} {aseq}"

echo ""
echo fmt"Processed in {(getTime() - t0).inMilliseconds} ms."


Empty := Object clone

e := Empty clone
e foo := 1


   C=:<'exampleclass'         NB. this will be our class name
   V__C=: 0                   NB. ensure the class exists
   OBJ1=:conew 'exampleclass' NB. create an instance of our class
   OBJ2=:conew 'exampleclass' NB. create another instance
   V__OBJ1,V__OBJ2            NB. both of our instances exist
0
   W__OBJ1                    NB. instance does not have a W
|value error
   W__OBJ1=: 0                NB. here, we add a W to this instance
   W__OBJ1                    NB. this instance now has a W
0
   W__OBJ2                    NB. our other instance does not
|value error


e = {}       // generic object
e.foo = 1
e["bar"] = 2    // name specified at runtime


// version 1.1.2

class SomeClass {
    val runtimeVariables = mutableMapOf<String, Any>()
}

fun main(args: Array<String>) {
    val sc = SomeClass()
    println("Create two variables at runtime: ")
    for (i in 1..2) {
        println("  Variable #$i:")
        print("       Enter name  : ")
        val name = readLine()!!
        print("       Enter value : ")
        val value = readLine()!!
        sc.runtimeVariables.put(name, value)
        println()
    }
    while (true) {
        print("Which variable do you want to inspect ? ")
        val name = readLine()!!
        val value = sc.runtimeVariables[name]
        if (value == null) {
            println("There is no variable of that name, try again")
        } else {
            println("Its value is '${sc.runtimeVariables[name]}'")
            return
        }
    }
}


import java.util.Map;

void setup() {
  String[] words = loadStrings("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt");
  topAnagrams(words);
}

void topAnagrams (String[] words){
  HashMap<String, StringList> anagrams = new HashMap<String, StringList>();
  int maxcount = 0;
  for (String word : words) {
    char[] chars = word.toCharArray();
    chars = sort(chars);
    String key = new String(chars);
    if (!anagrams.containsKey(key)) {
      anagrams.put(key, new StringList());
    }
    anagrams.get(key).append(word);
    maxcount = max(maxcount, anagrams.get(key).size());
  }
  for (StringList ana : anagrams.values()) {
    if (ana.size() >= maxcount) {
      println(ana);
    }
  }
}


:- use_module(library( http/http_open )).

anagrams:-
        % we read the URL of the words
	http_open('http://wiki.puzzlers.org/pub/wordlists/unixdict.txt',	In, []),
	read_file(In, [], Out),
	close(In),

        % we get a list of pairs key-value where key = a-word value = <list-of-its-codes>
        % this list must be sorted
	msort(Out, MOut),

        % in order to gather values with the same keys
	group_pairs_by_key(MOut, GPL),

        % we sorted this list in decreasing order of the length of values
	predsort(my_compare, GPL, GPLSort),

	% we extract the first 6 items
        GPLSort = [_H1-T1, _H2-T2, _H3-T3, _H4-T4, _H5-T5, _H6-T6 | _],

        % Tnn are lists of codes (97 for 'a'), we create the strings
	maplist(maplist(atom_codes), L, [T1, T2, T3, T4, T5, T6] ),

	maplist(writeln, L).

read_file(In, L, L1) :-
	read_line_to_codes(In, W),
	(   W == end_of_file ->
               % the file is read
	       L1 = L
	       ;
               % we sort the list of codes of the line
	       msort(W, W1),

               % to create the key in alphabetic order
	       atom_codes(A, W1),

               % and we have the pair Key-Value in the result list
	       read_file(In, [A-W | L], L1)).

% predicate for sorting list of pairs Key-Values
% if the lentgh of values is the same
% we sort the keys in alhabetic order
my_compare(R, K1-V1, K2-V2) :-
	length(V1, L1),
	length(V2, L2),
	(   L1 < L2 -> R = >; L1 > L2 -> R = <; compare(R, K1, K2)).


Object subclass:#Amb
        instanceVariableNames:''
        classVariableNames:''
        poolDictionaries:''
        category:'Rosetta'
!
Smalltalk::Notification subclass:#FoundSolution
        instanceVariableNames:''
        classVariableNames:''
        poolDictionaries:''
        privateIn:Amb
!

!Amb::FoundSolution methods!

defaultAction
    ^ parameter
! !

!Amb class methods!

try:values in:aBlock
    values do:[:each |
        |rslt|
        (rslt := aBlock value:each) notNil ifTrue:[
            "hint: Notifications simply return nil, if there is no handler"
            (FoundSolution raiseRequestWith:rslt) notNil ifTrue:[ ^ rslt ].
        ].
    ].
    ^ nil
! !


set amb {
    {the    that     a}
    {frog   elephant thing}
    {walked treaded  grows}
    {slowly quickly}
}

proc joins {a b} {
    expr {[string index $a end] eq [string index $b 0]}
}

foreach i [lindex $amb 0] {
    foreach j [lindex $amb 1] {
        if ![joins $i $j] continue
        foreach k [lindex $amb 2] {
            if ![joins $j $k] continue
            foreach l [lindex $amb 3] {
                if [joins $k $l] {
                    puts [list $i $j $k $l]
                }
            }
        }
    }
}


import: mapping
import: quicksort
import: math

Object method: sum ( coll -- m )
   #+ self reduce dup ifNull: [ drop 0 ] ;

Integer method: properDivs
| i l |
   Array new dup 1 over add ->l
   2 self nsqrt tuck for: i [ self i mod ifFalse: [ i l add  self i / l add ] ]
   sq self == ifTrue: [ l pop drop ]
   dup sort
;

: aliquot( n -- [] )	\ Returns aliquot sequence of n
| end l |
   2 47 pow ->end
   Array new dup n over add ->l
   while ( l size 16 <  l last 0 <> and  l last end <= and ) [ l last properDivs sum  l add ]
;

: aliquotClass( n -- [] s )   \ Returns aliquot sequence and classification
| l i j |
   n aliquot dup ->l
   l last 0   == ifTrue: [ "terminate" return ]
   l second n == ifTrue: [ "perfect" return ]
   3 l at   n == ifTrue: [ "amicable" return ]
   l indexOfFrom(n, 2) ifNotNull: [ "sociable" return ]

   l size loop: i [
      l indexOfFrom(l at(i), i 1+ ) -> j
      j i 1+ == ifTrue: [ "aspiring" return ]
      j ifNotNull: [ "cyclic" return ]
      ]
   "non-terminating"
;


aliquot(x) =
{
  my (L = List(x), M = Map(Mat([x,1])), k, m = "non-term.", n = x);

  for (i = 2, 16, n = vecsum(divisors(n)) - n;
    if (n > 2^47, break,
        n == 0, m = "terminates"; break,
        mapisdefined(M, n, &k),
        m = if (k == 1,
              if (i == 2, "perfect",
                  i == 3, "amicable",
                  i > 3, concat("sociable-",i-1)),
                k < i-1, concat("cyclic-",i-k),
              "aspiring"); break,
        mapput(M, n, i); listput(L, n));
  );
  printf("%16d: %10s, %s\n", x, m, Vec(L));
}


myObject := Object clone.

;; Name known at compile-time.
myObject foo := "bar".

;; Name known at runtime.
myObject slot 'foo = "bar".


obj = script("MyClass").new()

put obj.foo
-- "FOO"

-- add new property 'bar'
obj.setProp(#bar, "BAR")
put obj.bar
-- "BAR"


% we start by defining an empty object
:- object(foo).

    % ensure that complementing categories are allowed
	:- set_logtalk_flag(complements, allow).

:- end_object.

% define a complementing category, adding a new predicate
:- category(bar,
    complements(foo)).

	:- public(bar/1).
	bar(1).
	bar(2).
	bar(3).

:- end_category.


HAI 1.3

I HAS A object ITZ A BUKKIT
I HAS A name, I HAS A value

IM IN YR interface
    VISIBLE "R U WANTIN 2 (A)DD A VAR OR (P)RINT 1? "!
    I HAS A option, GIMMEH option

    option, WTF?
    OMG "A"
        VISIBLE "NAME: "!, GIMMEH name
        VISIBLE "VALUE: "!, GIMMEH value
        object HAS A SRS name ITZ value, GTFO
    OMG "P"
        VISIBLE "NAME: "!, GIMMEH name
        VISIBLE object'Z SRS name
    OIC
IM OUTTA YR interface

KTHXBYE


Module checkit {
      class alfa {
            x=5
      }
      \\ a class is a global function which return a group
      Dim a(5)=alfa()
      Print a(3).x=5
      For a(3) {
            group anyname { y=10}
            \\ merge anyname to this (a(3))
            this=anyname
      }
      Print a(3).y=10
      Print Valid(a(2).y)=false
      \\ make a copy of a(3) to m
      m=a(3)
      m.y*=2
      Print m.y=20, a(3).y=10
      \\ make a pointer to a(3) in n
      n->a(3)
      Print n=>y=10
      n=>y+=20
      Print a(3).y=30
     \\ now n points to a(2)
     n->a(2)
     Print Valid(n=>y)=false  ' y not exist in a(2)
     Print n is a(2)  ' true
     \\ we don't have types for groups
     Print valid(@n as m)=false  ' n haven't all members of m
     Print valid(@m as n)=true  ' m have all members of n
}
checkit


InitNetwork()  ;
OpenConsole()

Procedure.s sortWord(word$)
  len.i = Len(word$)
  Dim CharArray.s (len)

  For n = 1 To len                                 ; Transfering each single character
     CharArray(n) = Mid(word$, n, 1)      ; of the word into an array.
  Next

  SortArray(CharArray(),#PB_Sort_NoCase ) ; Sorting the array.

  word$ =""
  For n = 1 To len                       ; Writing back each single
     word$ + CharArray(n)             ; character of the array.
  Next

  ProcedureReturn word$
EndProcedure

;for a faster and more advanced alternative replace the previous procedure with this code
; Procedure.s sortWord(word$) ;returns a string with the letters of the word sorted
;   Protected wordLength = Len(word$)
;   Protected Dim letters.c(wordLength)
;
;   PokeS(@letters(), word$) ;overwrite the array with the strings contents
;   SortArray(letters(), #PB_Sort_Ascending, 0, wordLength - 1)
;   ProcedureReturn PeekS(@letters(), wordLength) ;return the arrays contents
; EndProcedure

tmpdir$   = GetTemporaryDirectory()
filename$ = tmpdir$ + "unixdict.txt"
Structure ana
   isana.l
   anas.s
EndStructure

NewMap anaMap.ana()

If ReceiveHTTPFile("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt", filename$)
  If ReadFile(1, filename$)
    Repeat
      word$ = (ReadString(1))             ; Reading a word from a file.
      key$  = (sortWord(word$))             ; Sorting the word and storing in key$.

      If FindMapElement(anaMap(), key$)   ; Looking up if a word already had the same key$.

                                          ; if yes
         anaMap()\anas  = anaMap()\anas+ ", " + word$   ; adding the word
         anaMap()\isana + 1
      Else
                                          ; if no
         anaMap(key$)\anas = word$        ; applying  a new record
         anaMap()\isana = 1
       EndIf

      If anaMap()\isana > maxAnagrams ;make note of maximum anagram count
        maxAnagrams = anaMap()\isana
      EndIf

    Until Eof(1)
    CloseFile(1)
    DeleteFile(filename$)

    ;----- output -----
    ForEach anaMap()
      If anaMap()\isana = maxAnagrams      ; only emit elements that have the most hits
        PrintN(anaMap()\anas)
      EndIf
    Next

    PrintN("Press any key"): Repeat: Until Inkey() <> ""
  EndIf
EndIf


$$ MODE TUSCRIPT
set1="the'that'a"
set2="frog'elephant'thing"
set3="walked'treaded'grows"
set4="slowly'quickly"
LOOP w1=set1
 lastw1=EXTRACT (w1,-1,0)
 LOOP w2=set2
 IF (w2.sw.$lastw1) THEN
  lastw2=EXTRACT (w2,-1,0)
  LOOP w3=set3
  IF (w3.sw.$lastw2) THEN
   lastw3=EXTRACT (w3,-1,0)
   LOOP w4=set4
   IF (w4.sw.$lastw3) sentence=JOIN (w1," ",w2,w3,w4)
   ENDLOOP
  ENDIF
  ENDLOOP
 ENDIF
 ENDLOOP
ENDLOOP
PRINT sentence


(defmacro amb-scope (. forms)
  ^(block amb-scope ,*forms))