10 DEFINT A-Z
20 N=3
30 S=N: T=0
40 X=S: S=0
50 FOR I=1 TO X-1
60 A=X: B=I
70 IF B>0 THEN C=A: A=B: B=C MOD B: GOTO 70
80 IF A=1 THEN S=S+1
90 NEXT
100 T=T+S
110 IF S>1 GOTO 40
120 IF T=N THEN PRINT N,: Z=Z+1
130 N=N+2
140 IF Z<20 GOTO 30


found = 0
curr = 3

while found < 20
    sum = Totient(curr)
    toti = sum
    while toti <> 1
        toti = Totient(toti)
        sum += toti
    end while
    if sum = curr then
        print sum
        found += 1
    end if
    curr += 1
end while
end

function GCD(n, d)
    if n = 0 then return d
    if d = 0 then return n
    if n > d then return GCD(d, (n mod d))
    return GCD(n, (d mod n))
end function

function Totient(n)
    phi = 0
    for m = 1 to n
        if GCD(m, n) = 1 then phi += 1
    next m
    return phi
end function


get "libhdr"

let gcd(a,b) = b=0 -> a, gcd(b, a rem b)

let totient(n) = valof
$(  let r = 0
    for i=1 to n-1
        if gcd(n,i) = 1 then r := r + 1
    resultis r
$)

let perfect(n) = valof
$(  let sum = 0 and x = n
    $(  x := totient(x)
        sum := sum + x
    $) repeatuntil x = 1
    resultis sum = n
$)

let start() be
$(  let seen = 0 and n = 3
    while seen < 20
    $(  if perfect(n)
        $(  writef("%N ", n)
            seen := seen + 1
        $)
        n := n + 2
    $)
    wrch('*N')
$)


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

long totient(long n){
	long tot = n,i;

	for(i=2;i*i<=n;i+=2){
		if(n%i==0){
			while(n%i==0)
				n/=i;
			tot-=tot/i;
		}

		if(i==2)
			i=1;
	}

	if(n>1)
		tot-=tot/n;

	return tot;
}

long* perfectTotients(long n){
	long *ptList = (long*)malloc(n*sizeof(long)), m,count=0,sum,tot;

	for(m=1;count<n;m++){
		 tot = m;
		 sum = 0;
        while(tot != 1){
            tot = totient(tot);
            sum += tot;
        }
        if(sum == m)
			ptList[count++] = m;
        }

		return ptList;
}

long main(long argC, char* argV[])
{
	long *ptList,i,n;

	if(argC!=2)
		printf("Usage : %s <number of perfect Totient numbers required>",argV[0]);
	else{
		n = atoi(argV[1]);

		ptList = perfectTotients(n);

		printf("The first %d perfect Totient numbers are : \n[",n);

		for(i=0;i<n;i++)
			printf(" %d,",ptList[i]);
		printf("\b]");
	}

	return 0;
}


#include <cassert>
#include <iostream>
#include <vector>

class totient_calculator {
public:
    explicit totient_calculator(int max) : totient_(max + 1) {
        for (int i = 1; i <= max; ++i)
            totient_[i] = i;
        for (int i = 2; i <= max; ++i) {
            if (totient_[i] < i)
                continue;
            for (int j = i; j <= max; j += i)
                totient_[j] -= totient_[j] / i;
        }
    }
    int totient(int n) const {
        assert (n >= 1 && n < totient_.size());
        return totient_[n];
    }
    bool is_prime(int n) const {
        return totient(n) == n - 1;
    }
private:
    std::vector<int> totient_;
};

bool perfect_totient_number(const totient_calculator& tc, int n) {
    int sum = 0;
    for (int m = n; m > 1; ) {
        int t = tc.totient(m);
        sum += t;
        m = t;
    }
    return sum == n;
}

int main() {
    totient_calculator tc(10000);
    int count = 0, n = 1;
    std::cout << "First 20 perfect totient numbers:\n";
    for (; count < 20; ++n) {
        if (perfect_totient_number(tc, n))  {
            if (count > 0)
                std::cout << ' ';
            ++count;
            std::cout << n;
        }
    }
    std::cout << '\n';
    return 0;
}


gcd = proc (a, b: int) returns (int)
    while b ~= 0 do
        a, b := b, a//b
    end
    return(a)
end gcd

totient = proc (n: int) returns (int)
    tot: int := 0
    for i: int in int$from_to(1,n-1) do
        if gcd(n,i)=1 then tot := tot + 1 end
    end
    return(tot)
end totient

perfect = proc (n: int) returns (bool)
    sum: int := 0
    x: int := n
    while true do
        x := totient(x)
        sum := sum + x
        if x=1 then break end
    end
    return(sum = n)
end perfect

start_up = proc ()
    po: stream := stream$primary_output()
    seen: int := 0
    n: int := 3
    while seen < 20 do
        if perfect(n) then
            stream$puts(po, int$unparse(n) || " ")
            seen := seen + 1
        end
        n := n + 2
    end
end start_up


include "cowgol.coh";

sub gcd(a: uint16, b: uint16): (r: uint16) is
    while b != 0 loop
        r := a;
        a := b;
        b := r % b;
    end loop;
    r := a;
end sub;

sub totient(n: uint16): (tot: uint16) is
    var i: uint16 := 1;
    tot := 0;
    while i < n loop
        if gcd(n,i) == 1 then
            tot := tot + 1;
        end if;
        i := i + 1;
    end loop;
end sub;

sub totientSum(n: uint16): (sum: uint16) is
    var x := n;
    sum := 0;
    while x > 1 loop
        x := totient(x);
        sum := sum + x;
    end loop;
end sub;

var seen: uint8 := 0;
var n: uint16 := 3;
while seen < 20 loop
    if totientSum(n) == n then
        print_i16(n);
        print_char(' ');
        seen := seen + 1;
    end if;
    n := n + 2;
end loop;
print_nl();


program Perfect_totient_numbers;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

function totient(n: Integer): Integer;
begin
  var tot := n;
  var i := 2;
  while i * i <= n do
  begin
    if (n mod i) = 0 then
    begin
      while (n mod i) = 0 do
        n := n div i;
      dec(tot, tot div i);
    end;
    if i = 2 then
      i := 1;
    inc(i, 2);
  end;
  if n > 1 then
    dec(tot, tot div n);
  Result := tot;
end;

begin
  var perfect: TArray<Integer>;
  var n := 1;
  while length(perfect) < 20 do
  begin
    var tot := n;
    var sum := 0;
    while tot <> 1 do
    begin
      tot := totient(tot);
      inc(sum, tot);
    end;
    if sum = n then
    begin
      SetLength(perfect, Length(perfect) + 1);
      perfect[High(perfect)] := n;
    end;
    inc(n, 2);
  end;
  writeln('The first 20 perfect totient numbers are:');
  write('[');
  for var e in perfect do
    write(e, ' ');
  writeln(']');
  readln;
end.


proc nonrec gcd(word a, b) word:
    word c;
    while b ~= 0 do
        c := a;
        a := b;
        b := c % b
    od;
    a
corp

proc nonrec totient(word n) word:
    word r, i;
    r := 0;
    for i from 1 upto n-1 do
        if gcd(n,i) = 1 then r := r+1 fi
    od;
    r
corp

proc nonrec perfect(word n) bool:
    word sum, x;
    sum := 0;
    x := n;
    while
        x := totient(x);
        sum := sum + x;
        x ~= 1
    do od;
    sum = n
corp

proc nonrec main() void:
    word seen, n;
    seen := 0;
    n := 3;
    while seen < 20 do
        if perfect(n) then
            write(n, " ");
            seen := seen + 1
        fi;
        n := n + 2
    od
corp


USING: formatting kernel lists lists.lazy math
math.primes.factors ;

: perfect? ( n -- ? )
    [ 0 ] dip dup [ dup 2 < ] [ totient tuck [ + ] 2dip ] until
    drop = ;

20 1 lfrom [ perfect? ] lfilter ltake list>array
"%[%d, %]\n" printf


#include"totient.bas"

dim as uinteger found = 0, curr = 3, sum, toti

while found < 20
    sum = totient(curr)
    toti = sum
    do
        toti = totient(toti)
        sum += toti
    loop while toti <> 1
    if sum = curr then
        print sum
        found += 1
    end if
    curr += 1
wend


package main

import "fmt"

func gcd(n, k int) int {
    if n < k || k < 1 {
        panic("Need n >= k and k >= 1")
    }

    s := 1
    for n&1 == 0 && k&1 == 0 {
        n >>= 1
        k >>= 1
        s <<= 1
    }

    t := n
    if n&1 != 0 {
        t = -k
    }
    for t != 0 {
        for t&1 == 0 {
            t >>= 1
        }
        if t > 0 {
            n = t
        } else {
            k = -t
        }
        t = n - k
    }
    return n * s
}

func totient(n int) int {
    tot := 0
    for k := 1; k <= n; k++ {
        if gcd(n, k) == 1 {
            tot++
        }
    }
    return tot
}

func main() {
    var perfect []int
    for n := 1; len(perfect) < 20; n += 2 {
        tot := n
        sum := 0
        for tot != 1 {
            tot = totient(tot)
            sum += tot
        }
        if sum == n {
            perfect = append(perfect, n)
        }
    }
    fmt.Println("The first 20 perfect totient numbers are:")
    fmt.Println(perfect)
}


perfectTotients :: [Int]
perfectTotients =
  filter ((==) <*> (succ . sum . tail . takeWhile (1 /=) . iterate φ)) [2 ..]

φ :: Int -> Int
φ = memoize (\n -> length (filter ((1 ==) . gcd n) [1 .. n]))

memoize :: (Int -> a) -> (Int -> a)
memoize f = (!!) (f <$> [0 ..])

main :: IO ()
main = print $ take 20 perfectTotients


Until =: conjunction def 'u^:(0 -: v)^:_'
Filter =: (#~`)(`:6)
totient =: 5&p:
totient_chain =: [: }. (, [email protected]{:)Until(1={:)
ptnQ =: (= ([: +/ totient_chain))&>


import java.util.ArrayList;
import java.util.List;

public class PerfectTotientNumbers {

    public static void main(String[] args) {
        computePhi();
        int n = 20;
        System.out.printf("The first %d perfect totient numbers:%n%s%n", n, perfectTotient(n));
    }

    private static final List<Integer> perfectTotient(int n) {
        int test = 2;
        List<Integer> results = new ArrayList<Integer>();
        for ( int i = 0 ; i < n ; test++ ) {
            int phiLoop = test;
            int sum = 0;
            do {
                phiLoop = phi[phiLoop];
                sum += phiLoop;
            } while ( phiLoop > 1);
            if ( sum == test ) {
                i++;
                results.add(test);
            }
        }
        return results;
    }

    private static final int max = 100000;
    private static final int[] phi = new int[max+1];

    private static final void computePhi() {
        for ( int i = 1 ; i <= max ; i++ ) {
            phi[i] = i;
        }
        for ( int i = 2 ; i <= max ; i++ ) {
            if (phi[i] < i) continue;
            for ( int j = i ; j <= max ; j += i ) {
                phi[j] -= phi[j] / i;
            }
        }
    }

}


(() => {
    'use strict';

    // main :: IO ()
    const main = () =>
        showLog(
            take(20, perfectTotients())
        );

    // perfectTotients :: Generator [Int]
    function* perfectTotients() {
        const
            phi = memoized(
                n => length(
                    filter(
                        k => 1 === gcd(n, k),
                        enumFromTo(1, n)
                    )
                )
            ),
            imperfect = n => n !== sum(
                tail(iterateUntil(
                    x => 1 === x,
                    phi,
                    n
                ))
            );
        let ys = dropWhileGen(imperfect, enumFrom(1))
        while (true) {
            yield ys.next().value - 1;
            ys = dropWhileGen(imperfect, ys)
        }
    }

    // GENERIC FUNCTIONS ----------------------------

    // abs :: Num -> Num
    const abs = Math.abs;

    // dropWhileGen :: (a -> Bool) -> Gen [a] -> [a]
    const dropWhileGen = (p, xs) => {
        let
            nxt = xs.next(),
            v = nxt.value;
        while (!nxt.done && p(v)) {
            nxt = xs.next();
            v = nxt.value;
        }
        return xs;
    };

    // enumFrom :: Int -> [Int]
    function* enumFrom(x) {
        let v = x;
        while (true) {
            yield v;
            v = 1 + v;
        }
    }

    // enumFromTo :: Int -> Int -> [Int]
    const enumFromTo = (m, n) =>
        m <= n ? iterateUntil(
            x => n <= x,
            x => 1 + x,
            m
        ) : [];

    // filter :: (a -> Bool) -> [a] -> [a]
    const filter = (f, xs) => xs.filter(f);

    // gcd :: Int -> Int -> Int
    const gcd = (x, y) => {
        const
            _gcd = (a, b) => (0 === b ? a : _gcd(b, a % b)),
            abs = Math.abs;
        return _gcd(abs(x), abs(y));
    };

    // iterateUntil :: (a -> Bool) -> (a -> a) -> a -> [a]
    const iterateUntil = (p, f, x) => {
        const vs = [x];
        let h = x;
        while (!p(h))(h = f(h), vs.push(h));
        return vs;
    };

    // Returns Infinity over objects without finite length.
    // This enables zip and zipWith to choose the shorter
    // argument when one is non-finite, like cycle, repeat etc

    // length :: [a] -> Int
    const length = xs =>
        (Array.isArray(xs) || 'string' === typeof xs) ? (
            xs.length
        ) : Infinity;

    // memoized :: (a -> b) -> (a -> b)
    const memoized = f => {
        const dctMemo = {};
        return x => {
            const v = dctMemo[x];
            return undefined !== v ? v : (dctMemo[x] = f(x));
        };
    };

    // showLog :: a -> IO ()
    const showLog = (...args) =>
        console.log(
            args
            .map(JSON.stringify)
            .join(' -> ')
        );

    // sum :: [Num] -> Num
    const sum = xs => xs.reduce((a, x) => a + x, 0);

    // tail :: [a] -> [a]
    const tail = xs => 0 < xs.length ? xs.slice(1) : [];

    // take :: Int -> [a] -> [a]
    // take :: Int -> String -> String
    const take = (n, xs) =>
        'GeneratorFunction' !== xs.constructor.constructor.name ? (
            xs.slice(0, n)
        ) : [].concat.apply([], Array.from({
            length: n
        }, () => {
            const x = xs.next();
            return x.done ? [] : [x.value];
        }));

    // MAIN ---
    main();
})();


Lookup:      ;INPUT: X = atomic number of the element of interest.
LDA PeriodicTable_Column,x
STA $20                    ;store column number in memory (I chose $20 arbitrarily, you can store it anywhere)
LDA PeriodicTable_Row,x
STA $21                    ;store row number in memory
RTS

PeriodicTable_Column:
db $ff,$01,$18,$01,$02,$13,$14,$15,$16,$17,$18,...         ;I don't need to write them all out, the concept is self-explanatory enough.
PeriodicTable_Row:
db $ff,$01,$01,$02,$02,$02,$02,$02,$02,$02,$02,...


# jq optimizes the recursive call of _gcd in the following:
def gcd(a;b):
  def _gcd:
    if .[1] != 0 then [.[1], .[0] % .[1]] | _gcd else .[0] end;
  [a,b] | _gcd ;

def count(s): reduce s as $x (0; .+1);

# A perfect totient number is an integer that is equal to the sum of its iterated totients.
# aka Euler's phi function
def totient:
  . as $n
  | count( range(0; .) | select( gcd($n; .) == 1) );

# input: the cache
# output: the updated cache
def cachephi($n):
  ($n|tostring) as $s
  | if (has($s)|not) then .[$s] = ($n|totient) else . end ;

# Emit the stream of perfect totients
def perfect_totients:
  . as $n
  | foreach range(1; infinite) as $i ({cache: {}};
        .tot = $i
        | .tsum = 0
        | until( .tot == 1;
	     .tot as $tot
             | .cache |= cachephi($tot)
             | .tot = .cache[$tot|tostring]
             | .tsum += .tot);
        if .tsum == $i then $i else empty end );

"The first 20 perfect totient numbers:",
limit(20; perfect_totients)


using Primes

eulerphi(n) = (r = one(n); for (p,k) in factor(abs(n)) r *= p^(k-1)*(p-1) end; r)

const phicache = Dict{Int, Int}()

cachedphi(n) = (if !haskey(phicache, n) phicache[n] = eulerphi(n) end; phicache[n])

function perfecttotientseries(n)
    perfect = Vector{Int}()
    i = 1
    while length(perfect) < n
        tot = i
        tsum = 0
        while tot != 1
            tot = cachedphi(tot)
            tsum += tot
        end
        if tsum == i
            push!(perfect, i)
        end
        i += 1
    end
    perfect
end

println("The first 20 perfect totient numbers are: $(perfecttotientseries(20))")
println("The first 40 perfect totient numbers are: $(perfecttotientseries(40))")


// Version 1.3.21

fun totient(n: Int): Int {
    var tot = n
    var nn = n
    var i = 2
    while (i * i <= nn) {
        if (nn % i == 0) {
            while (nn % i == 0) nn /= i
            tot -= tot / i
        }
        if (i == 2) i = 1
        i += 2
    }
    if (nn > 1) tot -= tot / nn
    return tot
}

fun main() {
    val perfect = mutableListOf<Int>()
    var n = 1
    while (perfect.size < 20) {
        var tot = n
        var sum = 0
        while (tot != 1) {
            tot = totient(tot)
            sum += tot
        }
        if (sum == n) perfect.add(n)
        n += 2
    }
    println("The first 20 perfect totient numbers are:")
    println(perfect)
}


            NORMAL MODE IS INTEGER

            INTERNAL FUNCTION(Y,Z)
            ENTRY TO GCD.
            A = Y
            B = Z
LOOP        WHENEVER A.E.B, FUNCTION RETURN A
            WHENEVER A.G.B, A = A-B
            WHENEVER A.L.B, B = B-A
            TRANSFER TO LOOP
            END OF FUNCTION

            INTERNAL FUNCTION(C)
            ENTRY TO TOTENT.
            E = 0
            THROUGH LOOP, FOR D=1, 1, D.GE.C
LOOP        WHENEVER GCD.(C,D).E.1, E = E+1
            FUNCTION RETURN E
            END OF FUNCTION

            INTERNAL FUNCTION(G)
            ENTRY TO PERFCT.
            H = G
            I = 0
LOOP        H = TOTENT.(H)
            I = I+H
            WHENEVER H.G.1, TRANSFER TO LOOP
            FUNCTION RETURN I.E.G
            END OF FUNCTION

            SEEN = 0
            THROUGH LOOP, FOR N=3, 2, SEEN.GE.20
            WHENEVER PERFCT.(N)
                SEEN = SEEN+1
                PRINT FORMAT FMT,N
            END OF CONDITIONAL
LOOP        CONTINUE

            VECTOR VALUES FMT = $I9*$
            END OF PROGRAM


Lookup:
;input: D0.W = the atomic number of interest.
LEA PeriodicTable,A0
ADD.W D0,D0        ;we're indexing a table of words, so double the index.
MOVE.W (A0,D0),D0  ;D0.W contains row number in the high byte and column number in the low byte.
RTS

PeriodicTable:
DC.W $FFFF ;padding since arrays start at zero in assembly.
DC.W $0101 ;HYDROGEN
DC.W $0118 ;HELIUM
DC.W $0201 ;LITHIUM
DC.W $0202 ;BERYLLIUM
DC.W $0213 ;BORON
DC.W $0214 ;CARBON
DC.W $0215 ;NITROGEN
DC.W $0216 ;OXYGEN
DC.W $0217 ;FLUORINE
DC.W $0218 ;NEON
;etc.


BEGIN # display the period and group number of an element, #
      # given its atomic number                            #
    INT max atomic number = 118; # highest known element   #
    # the positions are stored as:                         #
    #     ( group number * group multiplier ) + period     #
    INT group multiplier  = 100;
    [ 1 : max atomic number ]INT position;
    # construct the positions of the elements in the table #
    BEGIN
        STRING periodic table = "-                ="
                              + "--          -----="
                              + "--          -----="
                              + "-----------------="
                              + "-----------------="
                              + "--8--------------="
                              + "--9--------------="
                              ;
        INT period  := 1;
        INT group   := 1;
        INT element := 1;
        FOR t FROM LWB periodic table TO UPB periodic table DO
            CHAR p = periodic table[ t ];
            IF p = "8" OR p = "9" THEN
                # lantanoids or actinoids                   #
                INT series period = IF p = "8" THEN 8 ELSE 9 FI;
                INT series group := 4;
                FOR e TO 15 DO
                    position[ element ] := ( group multiplier * series group ) + series period;
                    element            +:= 1;
                    series group       +:= 1
                OD
            ELIF p /= " " THEN
                # there is a single element here            #
                position[ element ] := ( group multiplier * group ) + period;
                element            +:= 1;
                IF p = "=" THEN
                    # final element of the period           #
                    period +:= 1;
                    group   := 0
                FI
            FI;
            group +:= 1
        OD
    END;
    # display the period and group numbers of test elements #
    []INT test = ( 1, 2, 29, 42, 57, 58, 59, 71, 72, 89, 90, 103, 113 );
    FOR t FROM LWB test TO UPB test DO
        INT e = test[ t ];
        IF e < LWB position OR e > UPB position THEN
            print( ( "Invalid element: ", whole( e, 0 ), newline ) )
        ELSE
            INT period = position[ e ] MOD  group multiplier;
            INT group  = position[ e ] OVER group multiplier;
            print( ( "Element ", whole( e,      -3 )
                   , " -> ", whole( period,  0 ), ", ", whole( group,  -2 )
                   , newline
                   )
                 )
        FI
    OD
END


iterated_totient := proc(n::posint, total)
 if NumberTheory:-Totient(n) = 1 then
   return total + 1;
 else
   return iterated_totient(NumberTheory:-Totient(n), total + NumberTheory:-Totient(n));
 end if;
end proc:

isPerfect := n -> evalb(iterated_totient(n, 0) = n):

count := 0:
num_list := []:
for i while count < 20 do
 if isPerfectTotient(i) then
  num_list := [op(num_list), i];
  count := count + 1;
 end if;
end do;
num_list;


ClearAll[PerfectTotientNumberQ]
PerfectTotientNumberQ[n_Integer] := Total[Rest[Most[FixedPointList[EulerPhi, n]]]] == n
res = {};
i = 0;
While[Length[res] < 20,
 i++;
 If[PerfectTotientNumberQ[i], AppendTo[res, i]]
 ]
res


MODULE PerfectTotient;
FROM InOut IMPORT WriteCard, WriteLn;

CONST Amount = 20;
VAR n, seen: CARDINAL;

PROCEDURE GCD(a, b: CARDINAL): CARDINAL;
VAR c: CARDINAL;
BEGIN
    WHILE b # 0 DO
        c := a MOD b;
        a := b;
        b := c;
    END;
    RETURN a;
END GCD;

PROCEDURE Totient(n: CARDINAL): CARDINAL;
VAR i, tot: CARDINAL;
BEGIN
    tot := 0;
    FOR i := 1 TO n/2 DO
        IF GCD(n,i) = 1 THEN
            tot := tot + 1;
        END;
    END;
    RETURN tot;
END Totient;

PROCEDURE Perfect(n: CARDINAL): BOOLEAN;
VAR sum, x: CARDINAL;
BEGIN
    sum := 0;
    x := n;
    REPEAT
        x := Totient(x);
        sum := sum + x;
    UNTIL x = 1;
    RETURN sum = n;
END Perfect;

BEGIN
    seen := 0;
    n := 3;
    WHILE seen < Amount DO
        IF Perfect(n) THEN
            WriteCard(n,5);
            seen := seen + 1;
            IF seen MOD 14 = 0 THEN
                WriteLn();
            END;
        END;
        n := n + 2;
    END;
    WriteLn();
END PerfectTotient.


import strformat

func totient(n: int): int =
  var tot = n
  var nn = n
  var i = 2
  while i * i <= nn:
    if nn mod i == 0:
      while nn mod i == 0:
        nn = nn div i
      dec tot, tot div i
    if i == 2:
      i = 1
    inc i, 2
  if nn > 1:
    dec tot, tot div nn
  tot

var n = 1
var num = 0
echo "The first 20 perfect totient numbers are:"
while num < 20:
  var tot = n
  var sum = 0
  while tot != 1:
    tot = totient(tot)
    inc sum, tot
  if sum == n:
    write(stdout, fmt"{n} ")
    inc num
  inc n, 2
write(stdout, "\n")


SUB MostarPos (N)
    DIM a(7)
    RESTORE a:
    FOR x = 0 TO 7: READ a(x): NEXT x
    DIM b(7)
    RESTORE b:
    FOR x = 0 TO 7: READ b(x): NEXT x

    I = 7
    WHILE a(I) > N
    I = I - 1
    WEND
    M = N + b(I)
    R = (M \ 18) + 1
    C = (M MOD 18) + 1
    PRINT USING "Atomic number ### -> #_, ##"; N; R; C
END SUB

DIM Element(0 TO 12)
RESTORE elements
elements:
DATA 1, 2, 29, 42, 57, 58, 59, 71, 72, 89, 90, 103, 113
FOR x = 0 TO 12: READ Element(x): NEXT x

FOR I = 0 TO UBOUND(Element)
    MostarPos (Element(I))
NEXT I

a:
DATA  1,  2,  5, 13, 57, 72, 89, 104
b:
DATA -1, 15, 25, 35, 72, 21, 58,   7


program Perftotient;
{$IFdef FPC}
  {$MODE DELPHI} {$CodeAlign proc=32,loop=1}
{$IFEND}
uses
  sysutils;
const
  cLimit = 57395631;//177147;//4190263;//57395631;//1162261467;//
//global
var
  TotientList : array of LongWord;
  Sieve : Array of byte;
  SolList : array of LongWord;
  T1,T0 : INt64;

procedure SieveInit(svLimit:NativeUint);
var
  pSieve:pByte;
  i,j,pr :NativeUint;
Begin
  svlimit := (svLimit+1) DIV 2;
  setlength(sieve,svlimit+1);
  pSieve := @Sieve[0];
  For i := 1 to svlimit do
  Begin
    IF pSieve[i]= 0 then
    Begin
      pr := 2*i+1;
      j := (sqr(pr)-1) DIV 2;
      IF  j> svlimit then
        BREAK;
      repeat
        pSieve[j]:= 1;
        inc(j,pr);
      until j> svlimit;
    end;
  end;
  pr := 0;
  j := 0;
  For i := 1 to svlimit do
  Begin
    IF pSieve[i]= 0 then
    Begin
      pSieve[j] := i-pr;
      inc(j);
      pr := i;
    end;
  end;
  setlength(sieve,j);
end;

procedure TotientInit(len: NativeUint);
var
  pTotLst : pLongWord;
  pSieve  : pByte;
  test : double;
  i: NativeInt;
  p,j,k,svLimit : NativeUint;
Begin
  SieveInit(len);
  T0:= GetTickCount64;
  setlength(TotientList,len+12);
  pTotLst := @TotientList[0];

//Fill totient with simple start values for odd and even numbers
//and multiples of 3
  j := 1;
  k := 1;// k == j DIV 2
  p := 1;// p == j div 3;
  repeat
    pTotLst[j] := j;//1
    pTotLst[j+1] := k;//2 j DIV 2; //2
    inc(k);
    inc(j,2);
    pTotLst[j] := j-p;//3
    inc(p);
    pTotLst[j+1] := k;//4  j div 2
    inc(k);
    inc(j,2);
    pTotLst[j] := j;//5
    pTotLst[j+1] := p;//6   j DIV 3 <=  (div 2) * 2 DIV/3
    inc(j,2);
    inc(p);
    inc(k);
  until j>len+6;

//correct values of totient by prime factors
  svLimit := High(sieve);
  p := 3;// starting after 3
  pSieve := @Sieve[svLimit+1];
  i := -svlimit;
  repeat
    p := p+2*pSieve[i];
    j := p;
//  Test := (1-1/p);
    while j <= cLimit do
    Begin
//    pTotLst[j] := trunc(pTotLst[j]*Test);
      k:= pTotLst[j];
      pTotLst[j]:= k-(k DIV p);
      inc(j,p);
    end;
    inc(i);
  until i=0;

  T1:= GetTickCount64;
  writeln('totient calculated in ',T1-T0,' ms');
  setlength(sieve,0);
end;

function GetPerfectTotient(len: NativeUint):NativeUint;
var
  pTotLst : pLongWord;
  i,sum: NativeUint;
Begin
  T0:= GetTickCount64;
  pTotLst := @TotientList[0];
  setlength(SolList,100);
  result := 0;
  For i := 3 to Len do
  Begin
    sum := pTotLst[i];
    pTotLst[i] := sum+pTotLst[sum];
  end;
  //Check for solution ( IF ) in seperate loop ,reduces time consuption ~ 12% for this function
  For i := 3 to Len do
    IF pTotLst[i] =i then
    Begin
      SolList[result] := i;
      inc(result);
    end;

  T1:= GetTickCount64;
  setlength(SolList,result);
  writeln('calculated totientsum in ',T1-T0,' ms');
  writeln('found ',result,' perfect totient numbers');
end;

var
  j,k : NativeUint;

Begin
  TotientInit(climit);
  GetPerfectTotient(climit);
  k := 0;
  For j := 0 to High(Sollist) do
  Begin
    inc(k);
    if k > 4 then
    Begin
      writeln(Sollist[j]);
      k := 0;
    end
    else
      write(Sollist[j],',');
  end;
end.


Sub MostarPos(N As Integer)
    Dim As Integer M, I, R, C
    Dim As Integer A(0 To 7) = { 1,  2,  5, 13, 57, 72, 89, 104} 'magic numbers
    Dim As Integer B(0 To 7) = {-1, 15, 25, 35, 72, 21, 58,   7}
    I = 7
    While A(I) > N
        I -= 1
    Wend
    M = N + B(I)
    R = (M \ 18) +1
    C = (M Mod 18) +1
    Print Using "Atomic number ### -> #_, ##"; N; R; C
End Sub

Dim As Integer Element(0 To 12) = {1, 2, 29, 42, 57, 58, 59, 71, 72, 89, 90, 103, 113}
For I As Integer = 0 To Ubound(Element)
    MostarPos(Element(I))
Next I


include "NSLog.incl"

local fn PeriodicTable( n as NSInteger ) as CFDictionaryRef
NSInteger  i, row = 0, start = 0, finish, limits(6,6)
CFDictionaryRef dict = NULL

if n < 1 or n > 118 then NSLog( @"Atomic number is out of range." ) : exit fn
if n == 1 then dict = @{@"row":@1, @"col":@1}  : exit fn
if n == 2 then dict = @{@"row":@1, @"col":@18} : exit fn
if n >= 57 and n <= 71  then dict = @{@"row":@8, @"col":fn NumberWithInteger( n - 53 )} : exit fn
if n >= 89 and n <= 103 then dict = @{@"row":@9, @"col":fn NumberWithInteger( n - 85 )} : exit fn

limits(0,0) = 3  : limits(0,1) = 10
limits(1,0) = 11 : limits(1,1) = 18
limits(2,0) = 19 : limits(2,1) = 36
limits(3,0) = 37 : limits(3,1) = 54
limits(4,0) = 55 : limits(4,1) = 86
limits(5,0) = 87 : limits(5,1) = 118

for i = 0 to 5
if ( n >= limits(i,0) and n <= limits(i,1) )
row    = i + 2
start  = limits(i,0)
finish = limits(i,1)
break
end if
next

if ( n < start + 2 or row == 4 or row == 5 )
dict = @{@"row":fn NumberWithInteger(row), @"col":fn NumberWithInteger( n - start + 1 )} : exit fn
end if
dict = @{@"row":fn NumberWithInteger(row), @"col":fn NumberWithInteger( n - finish + 18 )}
end fn = dict

local fn BuildTable
NSInteger  i, count
CFArrayRef numbers = @[@1, @2, @29, @42, @57, @58, @59, @71, @72, @89, @90, @103, @113]

count = fn ArrayCount( numbers )

for i = 0 to count -1
CFDictionaryRef coordinates = fn PeriodicTable( fn NumberIntegerValue( numbers[i] ) )
NSLog( @"Atomic number %3d -> (%d, %d)", fn NumberIntegerValue( numbers[i] ), fn NumberIntegerValue( coordinates[@"row"] ), fn NumberIntegerValue( coordinates[@"col"] ) )
next
end fn

fn BuildTable

HandleEvents


package main

import (
    "fmt"
    "log"
)

var limits = [][2]int{
    {3, 10}, {11, 18}, {19, 36}, {37, 54}, {55, 86}, {87, 118},
}

func periodicTable(n int) (int, int) {
    if n < 1 || n > 118 {
        log.Fatal("Atomic number is out of range.")
    }
    if n == 1 {
        return 1, 1
    }
    if n == 2 {
        return 1, 18
    }
    if n >= 57 && n <= 71 {
        return 8, n - 53
    }
    if n >= 89 && n <= 103 {
        return 9, n - 85
    }
    var row, start, end int
    for i := 0; i < len(limits); i++ {
        limit := limits[i]
        if n >= limit[0] && n <= limit[1] {
            row, start, end = i+2, limit[0], limit[1]
            break
        }
    }
    if n < start+2 || row == 4 || row == 5 {
        return row, n - start + 1
    }
    return row, n - end + 18
}

func main() {
    for _, n := range []int{1, 2, 29, 42, 57, 58, 59, 71, 72, 89, 90, 103, 113} {
        row, col := periodicTable(n)
        fmt.Printf("Atomic number %3d -> %d, %-2d\n", n, row, col)
    }
}


use ntheory qw(euler_phi);

sub phi_iter {
    my($p) = @_;
    euler_phi($p) + ($p == 2 ? 0 : phi_iter(euler_phi($p)));
}

my @perfect;
for (my $p = 2; @perfect < 20 ; ++$p) {
    push @perfect, $p if $p == phi_iter($p);
}

printf "The first twenty perfect totient numbers:\n%s\n", join ' ', @perfect;


with javascript_semantics
function totient(integer n)
    integer tot = n, i = 2
    while i*i<=n do
        if mod(n,i)=0 then
            while true do
                n /= i
                if mod(n,i)!=0 then exit end if
            end while
            tot -= tot/i
        end if
        i += iff(i=2?1:2)
    end while
    if n>1 then
        tot -= tot/n
    end if
    return tot
end function

sequence perfect = {}
integer n = 1
while length(perfect)<20 do
    integer tot = n,
            tsum = 0
    while tot!=1 do
        tot = totient(tot)
        tsum += tot
    end while
    if tsum=n then
        perfect &= n
    end if
    n += 2
end while
printf(1,"The first 20 perfect totient numbers are:\n")
?perfect


PT=: (' ',.~[;._2) {{)n
   1   2   3   4  5  6  7  8  9  10 11 12 13 14 15 16 17 18
 1 H                                                     He
 2 Li  Be                                 B  C  N  O  F  Ne
 3 Na  Mg                                 Al Si P  S  Cl Ar
 4 K   Ca  Sc  Ti V  Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr
 5 Rb  Sr  Y   Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I  Xe
 6 Cs  Ba  *   Hf Ta W  Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn
 7 Fr  Ra  -   Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og
 8 Lantanoidi* La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu
 9  Aktinoidi- Ak Th Pa U  Np Pu Am Cm Bk Cf Es Fm Md No Lr
}}

ptrc=: {{
  tokens=. (#~ (3>#)@> * */@(tolower~:toupper)@>) ~.,;:,PT
  ndx=. (>' ',L:0' ',L:0~tokens) {[email protected]@E."1 ,PT
  Lantanoidi=. ndx{+/\'*'=,PT
  Aktinoidi=. ndx{+/\'-'=,PT
  j=. 13|3*Lantanoidi+3*Aktinoidi
  k=. {:$PT
  0,}."1/:~j,.(<.ndx%k),.1+(/:[email protected]~. i. ])k|ndx
}}

rowcol=: ptrc''


const limits = [3:10, 11:18, 19:36, 37:54, 55:86, 87:118]

function periodic_table(n)
    (n < 1 || n > 118) && error("Atomic number is out of range.")
    n == 1 && return [1, 1]
    n == 2 && return [1, 18]
    57 <= n <= 71 && return [8, n - 53]
    89 <= n <= 103 && return [9, n - 85]
    row, limitstart, limitstop = 0, 0, 0
    for i in eachindex(limits)
        if limits[i].start <= n <= limits[i].stop
            row, limitstart, limitstop = i + 1, limits[i].start, limits[i].stop
            break
        end
    end
    return (n < limitstart + 2 || row == 4 || row == 5) ?
        [row, n - limitstart + 1] : [row, n - limitstop + 18]
end

for n in [1, 2, 29, 42, 57, 58, 59, 71, 72, 89, 90, 103, 113]
    rc = periodic_table(n)
    println("Atomic number ", lpad(n, 3), " -> ($(rc[1]), $(rc[2]))")
end


(gc 16)
(de gcd (A B)
   (until (=0 B)
      (let M (% A B)
         (setq A B B M) ) )
   (abs A) )
(de totient (N)
   (let C 0
      (for I N
         (and (=1 (gcd N I)) (inc 'C)) )
      C ) )
(de totients (NIL)
   (let (C 0  N 1)
      (while (> 20 C)
         (let (Cur N  S 0)
            (while (> Cur 1)
               (inc 'S (setq Cur (totient Cur))) )
            (when (= S N)
               (inc 'C)
               (prin N " ")
               (flush) )
            (inc 'N 2) ) )
      (prinl) ) )
(totients)


C :z=0
  :n=3
*num
C :s=0
  :x=n
*perfect
C :t=0
  :i=1
*totient
C :a=x
  :b=i
*gcd
C :c=a-b*(a/b)
  :a=b
  :b=c
J (b>0):*gcd
C (a=1):t=t+1
C :i=i+1
J (i<=x-1):*totient
C :x=t
  :s=s+x
J (x<>1):*perfect
T (s=n):#n
C (s=n):z=z+1
C :n=n+2
J (z<20):*num
E :


perfectTotient: procedure options(main);
    gcd: procedure(aa, bb) returns(fixed);
        declare (aa, bb, a, b, c) fixed;
        a = aa;
        b = bb;
        do while(b ^= 0);
            c = a;
            a = b;
            b = mod(c, b);
        end;
        return(a);
    end gcd;

    totient: procedure(n) returns(fixed);
        declare (i, n, s) fixed;
        s = 0;
        do i=1 to n-1;
            if gcd(n,i) = 1 then s = s+1;
        end;
        return(s);
    end totient;

    perfect: procedure(n) returns(bit);
        declare (n, x, sum) fixed;
        sum = 0;
        x = n;
        do while(x > 1);
            x = totient(x);
            sum = sum + x;
        end;
        return(sum = n);
    end perfect;

    declare (n, seen) fixed;
    seen = 0;
    do n=3 repeat(n+2) while(seen<20);
        if perfect(n) then do;
            put edit(n) (F(5));
            seen = seen+1;
            if mod(seen,10) = 0 then put skip;
        end;
    end;
end perfectTotient;


with javascript_semantics
constant match_wp = false

function prc(integer n)
    constant t = {0,2,10,18,36,54,86,118,119}
    integer row = abs(binary_search(n,t,true))-1,
            col = n-t[row]
    if col>1+(row>1) then
        col = 18-(t[row+1]-n)
        if match_wp then
            if col<=2 then return {row+2,col+14} end if
        else -- matches above ascii:
            if col<=2+(row>5) then return {row+2,col+15} end if
        end if
    end if
    return {row,col}
end function

sequence pt = repeat(repeat("   ",19),10)
pt[1][2..$] = apply(true,sprintf,{{"%3d"},tagset(18)})  -- column headings
for i=1 to 9 do pt[i+1][1] = sprintf("%3d",i) end for -- row numbers
for i=1 to 118 do
    integer {r,c} = prc(i)
    pt[r+1][c+1] = sprintf("%3d",i)
end for
if not match_wp then -- (ascii only:)
    pt[7][4] = " L*"
    pt[8][4] = " A*"
    pt[9][2..4] = {"Lanthanide:"}
    pt[10][2..4] = {"  Actinide:"}
end if
printf(1,"%s\n",{join(apply(true,join,{pt,{"|"}}),"\n")})


def perta(atomic) -> (int, int):

    NOBLES = 2, 10, 18, 36, 54, 86, 118
    INTERTWINED = 0, 0, 0, 0, 0, 57, 89
    INTERTWINING_SIZE = 14
    LINE_WIDTH = 18

    prev_noble = 0
    for row, noble in enumerate(NOBLES):
        if atomic <= noble:  # we are at the good row. We now need to determine the column
            nb_elem = noble - prev_noble  # number of elements on that row
            rank =  atomic - prev_noble  # rank of the input element among elements
            if INTERTWINED[row] and INTERTWINED[row] <= atomic <= INTERTWINED[row] + INTERTWINING_SIZE:  # lantanides or actinides
                row += 2
                col = rank + 1
            else:  # not a lantanide nor actinide
                # handle empty spaces between 1-2, 4-5 and 12-13.
                nb_empty = LINE_WIDTH - nb_elem  # spaces count as columns
                inside_left_element_rank = 2 if noble > 2 else 1
                col = rank + (nb_empty if rank > inside_left_element_rank else 0)
            break
        prev_noble = noble
    return row+1, col

# small test suite

TESTS = {
    1: (1, 1),
    2: (1, 18),
    29: (4,11),
    42: (5, 6),
    58: (8, 5),
    59: (8, 6),
    57: (8, 4),
    71: (8, 18),
    72: (6, 4),
    89: (9, 4),
    90: (9, 5),
    103: (9, 18),
}

for input, out in TESTS.items():
    found = perta(input)
    print('TEST:{:3d} -> '.format(input) + str(found) + (f' ; ERROR: expected {out}' if found != out else ''))


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

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

GCD: PROCEDURE (A, B) ADDRESS;
    DECLARE (A, B, C) ADDRESS;
    DO WHILE B <> 0;
        C = A;
        A = B;
        B = C MOD B;
    END;
    RETURN A;
END GCD;

TOTIENT: PROCEDURE (N) ADDRESS;
    DECLARE (I, N, S) ADDRESS;
    S = 0;
    DO I=1 TO N-1;
        IF GCD(N,I) = 1 THEN S = S+1;
    END;
    RETURN S;
END TOTIENT;

PERFECT: PROCEDURE (N) BYTE;
    DECLARE (N, X, SUM) ADDRESS;
    X = N;
    SUM = 0;
    DO WHILE X > 1;
        X = TOTIENT(X);
        SUM = SUM + X;
    END;
    RETURN SUM = N;
END PERFECT;

DECLARE N ADDRESS, SEEN BYTE;
SEEN = 0;
N = 3;
DO WHILE SEEN < 20;
    IF PERFECT(N) THEN DO;
        CALL PRINT$NUMBER(N);
        SEEN = SEEN+1;
    END;
    N = N+2;
END;
CALL EXIT;
EOF


from math import gcd
from functools import lru_cache
from itertools import islice, count

@lru_cache(maxsize=None)
def  φ(n):
    return sum(1 for k in range(1, n + 1) if gcd(n, k) == 1)

def perfect_totient():
    for n0 in count(1):
        parts, n = 0, n0
        while n != 1:
            n = φ(n)
            parts += n
        if parts == n0:
            yield n0

if __name__ == '__main__':
    print(list(islice(perfect_totient(), 20)))


  [ 0 over
    [ dup 1 != while
      totient
      dup dip +
      again ]
    drop = ]                is perfecttotient ( n --> b )

  [ [] 1
    [ dup perfecttotient if
        [ dup dip join ]
      2 +
    over size 20 =
    until ] drop ]          is task            (   -->  )


#lang racket
(require math/number-theory)

(define (tot n)
  (match n
    [1 0]
    [n (define t (totient n))
       (+ t (tot t))]))

(define (perfect? n)
  (= n (tot n)))

(define-values (ns i)
  (for/fold ([ns '()] [i 0])
            ([n (in-naturals 1)]
             #:break (= i 20)
             #:when (perfect? n))
    (values (cons n ns) (+ i 1))))

(reverse ns)


use Prime::Factor;

my \𝜑 = lazy 0, |(1..*).hyper.map: -> \t { t * [*] t.&prime-factors.squish.map: 1 - 1/* }
my \𝜑𝜑 = Nil, |(3, *+2 … *).grep: -> \p { p == sum 𝜑[p], { 𝜑[$_] } … 1 };

put "The first twenty Perfect totient numbers:\n",  𝜑𝜑[1..20];


import "./fmt" for Fmt

var limits = [3..10, 11..18, 19..36, 37..54, 55..86, 87..118]

var periodicTable = Fn.new { |n|
    if (n < 1 || n > 118) Fiber.abort("Atomic number is out of range.")
    if (n == 1) return [1, 1]
    if (n == 2) return [1, 18]
    if (n >= 57 && n <= 71)  return [8, n - 53]
    if (n >= 89 && n <= 103) return [9, n - 85]
    var row
    var start
    var end
    for (i in 0...limits.count) {
        var limit = limits[i]
        if (n >= limit.from && n <= limit.to) {
            row = i + 2
            start = limit.from
            end = limit.to
            break
        }
    }
    if (n < start + 2 || row == 4 || row == 5) return [row, n - start + 1]
    return [row, n - end + 18]
}

for (n in [1, 2, 29, 42, 57, 58, 59, 71, 72, 89, 90, 103, 113]) {
    var rc = periodicTable.call(n)
    Fmt.print("Atomic number $3d -> $d, $-2d", n, rc[0], rc[1])
}


/*REXX program  calculates and displays  the first   N   perfect totient  numbers.      */
parse arg N .                                    /*obtain optional argument from the CL.*/
if N==''  |  N==","  then N= 20                  /*Not specified?  Then use the default.*/
@.= .                                            /*memoization array of totient numbers.*/
p= 0                                             /*the count of perfect    "       "    */
$=                                               /*list of the     "       "       "    */
    do j=3  by 2  until p==N;   s= phi(j)        /*obtain totient number for a number.  */
    a= s                                         /* [↓]  search for a perfect totient #.*/
                                do until a==1;           a= phi(a);            s= s + a
                                end   /*until*/
    if s\==j  then iterate                       /*Is  J  not a perfect totient number? */
    p= p + 1                                     /*bump count of perfect totient numbers*/
    $= $ j                                       /*add to perfect totient numbers list. */
    end   /*j*/

say 'The first '  N  " perfect totient numbers:" /*display the header to the terminal.  */
say strip($)                                     /*   "     "  list.   "  "     "       */
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
gcd: parse arg x,y;   do  until y==0;  parse value  x//y  y   with   y  x;  end;  return x
/*──────────────────────────────────────────────────────────────────────────────────────*/
phi: procedure expose @.; parse arg z;   if @.z\==.  then return @.z /*was found before?*/
     #= z==1;         do m=1  for z-1;   if gcd(m, z)==1  then #= # + 1;    end  /*m*/
     @.z= #;   return #                                              /*use memoization. */


perfect = []
n = 1
while len(perfect)<20
      totnt = n
      tsum = 0
      while totnt!=1
            totnt = totient(totnt)
            tsum = tsum + totnt
      end
      if tsum=n
         add(perfect,n)
      ok
      n = n + 2
end
see "The first 20 perfect totient numbers are:" + nl
showarray(perfect)

func totient n
     totnt = n
     i = 2
     while i*i <= n
           if n%i=0
              while true
                    n = n/i
                    if n%i!=0
                       exit
                    ok
              end
              totnt = totnt - totnt/i
           ok
           if i=2
              i = i + 1
           else
              i = i + 2
           ok
     end
    if n>1
       totnt = totnt - totnt/n
    ok
    return totnt

func showArray array
     txt = ""
     see "["
     for n = 1 to len(array)
         txt = txt + array[n] + ","
     next
     txt = left(txt,len(txt)-1)
     txt = txt + "]"
     see txt


require "prime"

class Integer

  def φ
    prime_division.inject(1) {|res, (pr, exp)| res *= (pr-1) * pr**(exp-1) }
  end

  def perfect_totient?
    f, sum = self, 0
    until f == 1 do
      f = f.φ
      sum += f
    end
    self == sum
  end

end

puts (1..).lazy.select(&:perfect_totient?).first(20).join(", ")


//List of perfect totients
def isPerfectTotient(num: Int): Boolean = LazyList.iterate(totient(num))(totient).takeWhile(_ != 1).foldLeft(0L)(_+_) + 1 == num
def perfectTotients: LazyList[Int] = LazyList.from(3).filter(isPerfectTotient)

//Totient Function
@tailrec def scrub(f: Long, num: Long): Long = if(num%f == 0) scrub(f, num/f) else num
def totient(num: Long): Long = LazyList.iterate((num, 2: Long, num)){case (ac, i, n) => if(n%i == 0) (ac*(i - 1)/i, i + 1, scrub(i, n)) else (ac, i + 1, n)}.dropWhile(_._3 != 1).head._1


func perfect_totient({.<=1}, sum=0) { sum }
func perfect_totient(     n, sum=0) { __FUNC__(var(t = n.euler_phi), sum + t) }

say (1..Inf -> lazy.grep {|n| perfect_totient(n) == n }.first(20))


public func totient(n: Int) -> Int {
  var n = n
  var i = 2
  var tot = n

  while i * i <= n {
    if n % i == 0 {
      while n % i == 0 {
        n /= i
      }

      tot -= tot / i
    }

    if i == 2 {
      i = 1
    }

    i += 2
  }

  if n > 1 {
    tot -= tot / n
  }

  return tot
}

public struct PerfectTotients: Sequence, IteratorProtocol {
  private var m = 1

  public init() { }

  public mutating func next() -> Int? {
    while true {
      defer {
        m += 1
      }

      var tot = m
      var sum = 0

      while tot != 1 {
        tot = totient(n: tot)
        sum += tot
      }

      if sum == m {
        return m
      }
    }
  }
}

print("The first 20 perfect totient numbers are:")
print(Array(PerfectTotients().prefix(20)))


var totient = Fn.new { |n|
    var tot = n
    var i = 2
    while (i*i <= n) {
        if (n%i == 0) {
            while(n%i == 0) n = (n/i).floor
            tot = tot - (tot/i).floor
        }
        if (i == 2) i = 1
        i = i + 2
    }
    if (n > 1) tot = tot - (tot/n).floor
    return tot
}

var perfect = []
var n = 1
while (perfect.count < 20) {
    var tot = n
    var sum = 0
    while (tot != 1) {
        tot = totient.call(tot)
        sum = sum + tot
    }
    if (sum == n) perfect.add(n)
    n = n + 2
}
System.print("The first 20 perfect totient numbers are:")
System.print(perfect)


var totients=List.createLong(10_000,0);	// cache
fcn totient(n){ if(phi:=totients[n]) return(phi);
   totients[n]=[1..n].reduce('wrap(p,k){ p + (n.gcd(k)==1) })
}
fcn perfectTotientW{	// -->iterator
   (1).walker(*).tweak(fcn(z){
      parts,n := 0,z;
      while(n!=1){ parts+=( n=totient(n) ) }
      if(parts==z) z else Void.Skip;
   })
}


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

int p[512];

double fade(double t) { return t * t * t * (t * (t * 6 - 15) + 10); }
double lerp(double t, double a, double b) { return a + t * (b - a); }
double grad(int hash, double x, double y, double z) {
      int h = hash & 15;
      double u = h<8 ? x : y,
             v = h<4 ? y : h==12||h==14 ? x : z;
      return ((h&1) == 0 ? u : -u) + ((h&2) == 0 ? v : -v);
   }

double noise(double x, double y, double z) {
      int X = (int)floor(x) & 255,
          Y = (int)floor(y) & 255,
          Z = (int)floor(z) & 255;
      x -= floor(x);
      y -= floor(y);
      z -= floor(z);
      double u = fade(x),
             v = fade(y),
             w = fade(z);
      int A = p[X  ]+Y, AA = p[A]+Z, AB = p[A+1]+Z,
          B = p[X+1]+Y, BA = p[B]+Z, BB = p[B+1]+Z;

      return lerp(w, lerp(v, lerp(u, grad(p[AA  ], x  , y  , z   ),
                                     grad(p[BA  ], x-1, y  , z   )),
                             lerp(u, grad(p[AB  ], x  , y-1, z   ),
                                     grad(p[BB  ], x-1, y-1, z   ))),
                     lerp(v, lerp(u, grad(p[AA+1], x  , y  , z-1 ),
                                     grad(p[BA+1], x-1, y  , z-1 )),
                             lerp(u, grad(p[AB+1], x  , y-1, z-1 ),
                                     grad(p[BB+1], x-1, y-1, z-1 ))));
   }

void loadPermutation(char* fileName){
	FILE* fp = fopen(fileName,"r");
	int permutation[256],i;

	for(i=0;i<256;i++)
		fscanf(fp,"%d",&permutation[i]);

	fclose(fp);

	for (int i=0; i < 256 ; i++) p[256+i] = p[i] = permutation[i];
}

int main(int argC,char* argV[])
{
	if(argC!=5)
		printf("Usage : %s <permutation data file> <x,y,z co-ordinates separated by space>");
	else{
		loadPermutation(argV[1]);
		printf("Perlin Noise for (%s,%s,%s) is %.17lf",argV[2],argV[3],argV[4],noise(strtod(argV[2],NULL),strtod(argV[3],NULL),strtod(argV[4],NULL)));
	}

	return 0;
}


import std.stdio, std.math;

struct PerlinNoise {
    private static double fade(in double t) pure nothrow @safe @nogc {
        return t ^^ 3 * (t * (t * 6 - 15) + 10);
    }

    private static double lerp(in double t, in double a, in double b)
    pure nothrow @safe @nogc {
        return a + t * (b - a);
    }

    private static double grad(in ubyte hash,
                               in double x, in double y, in double z)
    pure nothrow @safe @nogc {
        // Convert lo 4 bits of hash code into 12 gradient directions.
        immutable h = hash & 0xF;
        immutable double u = (h < 8) ? x : y,
                         v = (h < 4) ? y : (h == 12 || h == 14 ? x : z);
        return ((h & 1) == 0 ? u : -u) + ((h & 2) == 0 ? v : -v);
    }

    static immutable ubyte[512] p;

    static this() pure nothrow @safe @nogc {
        static immutable permutation = cast(ubyte[256])x"97 A0 89 5B 5A
            0F 83 0D C9 5F 60 35 C2 E9 07 E1 8C 24 67 1E 45 8E 08 63 25
            F0 15 0A 17 BE 06 94 F7 78 EA 4B 00 1A C5 3E 5E FC DB CB 75
            23 0B 20 39 B1 21 58 ED 95 38 57 AE 14 7D 88 AB A8 44 AF 4A
            A5 47 86 8B 30 1B A6 4D 92 9E E7 53 6F E5 7A 3C D3 85 E6 DC
            69 5C 29 37 2E F5 28 F4 66 8F 36 41 19 3F A1 01 D8 50 49 D1
            4C 84 BB D0 59 12 A9 C8 C4 87 82 74 BC 9F 56 A4 64 6D C6 AD
            BA 03 40 34 D9 E2 FA 7C 7B 05 CA 26 93 76 7E FF 52 55 D4 CF
            CE 3B E3 2F 10 3A 11 B6 BD 1C 2A DF B7 AA D5 77 F8 98 02 2C
            9A A3 46 DD 99 65 9B A7 2B AC 09 81 16 27 FD 13 62 6C 6E 4F
            71 E0 E8 B2 B9 70 68 DA F6 61 E4 FB 22 F2 C1 EE D2 90 0C BF
            B3 A2 F1 51 33 91 EB F9 0E EF 6B 31 C0 D6 1F B5 C7 6A 9D B8
            54 CC B0 73 79 32 2D 7F 04 96 FE 8A EC CD 5D DE 72 43 1D 18
            48 F3 8D 80 C3 4E 42 D7 3D 9C B4";

        // Two copies of permutation.
        p[0 .. permutation.length] = permutation[];
        p[permutation.length .. $] = permutation[];
    }

    /// x0, y0 and z0 can be any real numbers, but the result is
    /// zero if they are all integers.
    /// The result is probably in [-1.0, 1.0].
    static double opCall(in double x0, in double y0, in double z0)
    pure nothrow @safe @nogc {
        // Find unit cube that contains point.
        immutable ubyte X = cast(int)x0.floor & 0xFF,
                        Y = cast(int)y0.floor & 0xFF,
                        Z = cast(int)z0.floor & 0xFF;

        // Find relative x,y,z of point in cube.
        immutable x = x0 - x0.floor,
                  y = y0 - y0.floor,
                  z = z0 - z0.floor;

        // Compute fade curves for each of x,y,z.
        immutable u = fade(x),
                  v = fade(y),
                  w = fade(z);

        // Hash coordinates of the 8 cube corners.
        immutable A  = p[X  ]   + Y,
                  AA = p[A]     + Z,
                  AB = p[A + 1] + Z,
                  B  = p[X + 1] + Y,
                  BA = p[B]     + Z,
                  BB = p[B + 1] + Z;

        // And add blended results from  8 corners of cube.
        return lerp(w, lerp(v, lerp(u, grad(p[AA  ], x  , y  , z  ),
                                       grad(p[BA  ], x-1, y  , z  )),
                               lerp(u, grad(p[AB  ], x  , y-1, z  ),
                                       grad(p[BB  ], x-1, y-1, z  ))),
                       lerp(v, lerp(u, grad(p[AA+1], x  , y  , z-1),
                                       grad(p[BA+1], x-1, y  , z-1)),
                               lerp(u, grad(p[AB+1], x  , y-1, z-1),
                                       grad(p[BB+1], x-1, y-1, z-1))));
    }
}

void main() {
    writefln("%1.17f", PerlinNoise(3.14, 42, 7));

    /*
    // Generate a demo image using the Gray Scale task module.
    import grayscale_image;
    enum N = 200;
    auto im = new Image!Gray(N, N);
    foreach (immutable y; 0 .. N)
        foreach (immutable x; 0 .. N) {
            immutable p = PerlinNoise(x / 30.0, y / 30.0, 0.1);
            im[x, y] = Gray(cast(ubyte)((p + 1) / 2 * 256));
        }
    im.savePGM("perlin_noise.pgm");
    */
}


x floor >integer 255 bitand :> X
y floor >integer 255 bitand :> Y
z floor >integer 255 bitand :> Z


float rand(vec2 c){
	return fract(sin(dot(c.xy ,vec2(12.9898,78.233))) * 43758.5453);
}

float noise(vec2 p, float freq ){
	float unit = screenWidth/freq;
	vec2 ij = floor(p/unit);
	vec2 xy = mod(p,unit)/unit;
	//xy = 3.*xy*xy-2.*xy*xy*xy;
	xy = .5*(1.-cos(PI*xy));
	float a = rand((ij+vec2(0.,0.)));
	float b = rand((ij+vec2(1.,0.)));
	float c = rand((ij+vec2(0.,1.)));
	float d = rand((ij+vec2(1.,1.)));
	float x1 = mix(a, b, xy.x);
	float x2 = mix(c, d, xy.x);
	return mix(x1, x2, xy.y);
}

float pNoise(vec2 p, int res){
	float persistance = .5;
	float n = 0.;
	float normK = 0.;
	float f = 4.;
	float amp = 1.;
	int iCount = 0;
	for (int i = 0; i<50; i++){
		n+=amp*noise(p, f);
		f*=2.;
		normK+=amp;
		amp*=persistance;
		if (iCount == res) break;
		iCount++;
	}
	float nf = n/normK;
	return nf*nf*nf*nf;
}


package main

import (
    "fmt"
    "math"
)

func main() {
    fmt.Println(noise(3.14, 42, 7))
}

func noise(x, y, z float64) float64 {
    X := int(math.Floor(x)) & 255
    Y := int(math.Floor(y)) & 255
    Z := int(math.Floor(z)) & 255
    x -= math.Floor(x)
    y -= math.Floor(y)
    z -= math.Floor(z)
    u := fade(x)
    v := fade(y)
    w := fade(z)
    A := p[X] + Y
    AA := p[A] + Z
    AB := p[A+1] + Z
    B := p[X+1] + Y
    BA := p[B] + Z
    BB := p[B+1] + Z
    return lerp(w, lerp(v, lerp(u, grad(p[AA], x, y, z),
        grad(p[BA], x-1, y, z)),
        lerp(u, grad(p[AB], x, y-1, z),
            grad(p[BB], x-1, y-1, z))),
        lerp(v, lerp(u, grad(p[AA+1], x, y, z-1),
            grad(p[BA+1], x-1, y, z-1)),
            lerp(u, grad(p[AB+1], x, y-1, z-1),
                grad(p[BB+1], x-1, y-1, z-1))))
}
func fade(t float64) float64       { return t * t * t * (t*(t*6-15) + 10) }
func lerp(t, a, b float64) float64 { return a + t*(b-a) }
func grad(hash int, x, y, z float64) float64 {
    // Go doesn't have a ternary.  Ternaries can be translated directly
    // with if statements, but chains of if statements are often better
    // expressed with switch statements.
    switch hash & 15 {
    case 0, 12:
        return x + y
    case 1, 14:
        return y - x
    case 2:
        return x - y
    case 3:
        return -x - y
    case 4:
        return x + z
    case 5:
        return z - x
    case 6:
        return x - z
    case 7:
        return -x - z
    case 8:
        return y + z
    case 9, 13:
        return z - y
    case 10:
        return y - z
    }
    // case 11, 16:
    return -y - z
}

var permutation = []int{
    151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225,
    140, 36, 103, 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148,
    247, 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, 11, 32,
    57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, 68, 175,
    74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, 231, 83, 111, 229, 122,
    60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54,
    65, 25, 63, 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169,
    200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, 198, 173, 186, 3, 64,
    52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212,
    207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, 183, 170, 213,
    119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9,
    129, 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104,
    218, 246, 97, 228, 251, 34, 242, 193, 238, 210, 144, 12, 191, 179, 162, 241,
    81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157,
    184, 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93,
    222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, 61, 156, 180,
}
var p = append(permutation, permutation...)


// JAVA REFERENCE IMPLEMENTATION OF IMPROVED NOISE - COPYRIGHT 2002 KEN PERLIN.

public final class ImprovedNoise {
   static public double noise(double x, double y, double z) {
      int X = (int)Math.floor(x) & 255,                  // FIND UNIT CUBE THAT
          Y = (int)Math.floor(y) & 255,                  // CONTAINS POINT.
          Z = (int)Math.floor(z) & 255;
      x -= Math.floor(x);                                // FIND RELATIVE X,Y,Z
      y -= Math.floor(y);                                // OF POINT IN CUBE.
      z -= Math.floor(z);
      double u = fade(x),                                // COMPUTE FADE CURVES
             v = fade(y),                                // FOR EACH OF X,Y,Z.
             w = fade(z);
      int A = p[X  ]+Y, AA = p[A]+Z, AB = p[A+1]+Z,      // HASH COORDINATES OF
          B = p[X+1]+Y, BA = p[B]+Z, BB = p[B+1]+Z;      // THE 8 CUBE CORNERS,

      return lerp(w, lerp(v, lerp(u, grad(p[AA  ], x  , y  , z   ),  // AND ADD
                                     grad(p[BA  ], x-1, y  , z   )), // BLENDED
                             lerp(u, grad(p[AB  ], x  , y-1, z   ),  // RESULTS
                                     grad(p[BB  ], x-1, y-1, z   ))),// FROM  8
                     lerp(v, lerp(u, grad(p[AA+1], x  , y  , z-1 ),  // CORNERS
                                     grad(p[BA+1], x-1, y  , z-1 )), // OF CUBE
                             lerp(u, grad(p[AB+1], x  , y-1, z-1 ),
                                     grad(p[BB+1], x-1, y-1, z-1 ))));
   }
   static double fade(double t) { return t * t * t * (t * (t * 6 - 15) + 10); }
   static double lerp(double t, double a, double b) { return a + t * (b - a); }
   static double grad(int hash, double x, double y, double z) {
      int h = hash & 15;                      // CONVERT LO 4 BITS OF HASH CODE
      double u = h<8 ? x : y,                 // INTO 12 GRADIENT DIRECTIONS.
             v = h<4 ? y : h==12||h==14 ? x : z;
      return ((h&1) == 0 ? u : -u) + ((h&2) == 0 ? v : -v);
   }
   static final int p[] = new int[512], permutation[] = { 151,160,137,91,90,15,
   131,13,201,95,96,53,194,233,7,225,140,36,103,30,69,142,8,99,37,240,21,10,23,
   190, 6,148,247,120,234,75,0,26,197,62,94,252,219,203,117,35,11,32,57,177,33,
   88,237,149,56,87,174,20,125,136,171,168, 68,175,74,165,71,134,139,48,27,166,
   77,146,158,231,83,111,229,122,60,211,133,230,220,105,92,41,55,46,245,40,244,
   102,143,54, 65,25,63,161, 1,216,80,73,209,76,132,187,208, 89,18,169,200,196,
   135,130,116,188,159,86,164,100,109,198,173,186, 3,64,52,217,226,250,124,123,
   5,202,38,147,118,126,255,82,85,212,207,206,59,227,47,16,58,17,182,189,28,42,
   223,183,170,213,119,248,152, 2,44,154,163, 70,221,153,101,155,167, 43,172,9,
   129,22,39,253, 19,98,108,110,79,113,224,232,178,185, 112,104,218,246,97,228,
   251,34,242,193,238,210,144,12,191,179,162,241, 81,51,145,235,249,14,239,107,
   49,192,214, 31,181,199,106,157,184, 84,204,176,115,121,50,45,127, 4,150,254,
   138,236,205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,61,156,180
   };
   static { for (int i=0; i < 256 ; i++) p[256+i] = p[i] = permutation[i]; }
}


with javascript_semantics
constant ph = x"97 A0 89 5B 5A 0F 83 0D C9 5F 60 35 C2 E9 07 E1"&
              x"8C 24 67 1E 45 8E 08 63 25 F0 15 0A 17 BE 06 94"&
              x"F7 78 EA 4B 00 1A C5 3E 5E FC DB CB 75 23 0B 20"&
              x"39 B1 21 58 ED 95 38 57 AE 14 7D 88 AB A8 44 AF"&
              x"4A A5 47 86 8B 30 1B A6 4D 92 9E E7 53 6F E5 7A"&
              x"3C D3 85 E6 DC 69 5C 29 37 2E F5 28 F4 66 8F 36"&
              x"41 19 3F A1 01 D8 50 49 D1 4C 84 BB D0 59 12 A9"&
              x"C8 C4 87 82 74 BC 9F 56 A4 64 6D C6 AD BA 03 40"&
              x"34 D9 E2 FA 7C 7B 05 CA 26 93 76 7E FF 52 55 D4"&
              x"CF CE 3B E3 2F 10 3A 11 B6 BD 1C 2A DF B7 AA D5"&
              x"77 F8 98 02 2C 9A A3 46 DD 99 65 9B A7 2B AC 09"&
              x"81 16 27 FD 13 62 6C 6E 4F 71 E0 E8 B2 B9 70 68"&
              x"DA F6 61 E4 FB 22 F2 C1 EE D2 90 0C BF B3 A2 F1"&
              x"51 33 91 EB F9 0E EF 6B 31 C0 D6 1F B5 C7 6A 9D"&
              x"B8 54 CC B0 73 79 32 2D 7F 04 96 FE 8A EC CD 5D"&
              x"DE 72 43 1D 18 48 F3 8D 80 C3 4E 42 D7 3D 9C B4",
        p = ph&ph

function fade(atom t) return t * t * t * (t * (t * 6 - 15) + 10) end function
function lerp(atom t, a, b) return a + t * (b - a) end function
function grad(int hash, atom x, y, z)
    int h = and_bits(hash,15)
    atom u = iff(h<8 ? x : y),
         v = iff(h<4 ? y : iff(h==12 or h==14 ? x : z))
    return iff(and_bits(h,1) == 0 ? u : -u) +
           iff(and_bits(h,2) == 0 ? v : -v)
end function

function noise(atom x, y, z)
    integer X = and_bits(x,255),
            Y = and_bits(y,255),
            Z = and_bits(z,255)
    x -= floor(x)
    y -= floor(y)
    z -= floor(z)
    atom u = fade(x),
         v = fade(y),
         w = fade(z)
    integer A = p[X+1]+Y, AA = p[A+1]+Z, AB = p[A+2]+Z,
            B = p[X+2]+Y, BA = p[B+1]+Z, BB = p[B+2]+Z

    return lerp(w,lerp(v,lerp(u,grad(p[AA+1], x  , y  , z   ),
                                grad(p[BA+1], x-1, y  , z   )),
                         lerp(u,grad(p[AB+1], x  , y-1, z   ),
                                grad(p[BB+1], x-1, y-1, z   ))),
                  lerp(v,lerp(u,grad(p[AA+2], x  , y  , z-1 ),
                                grad(p[BA+2], x-1, y  , z-1 )),
                         lerp(u,grad(p[AB+2], x  , y-1, z-1 ),
                                grad(p[BB+2], x-1, y-1, z-1 ))))
end function

printf(1,"Perlin Noise for (3.14,42,7) is %.17f\n",{noise(3.14,42,7)})


/*REXX program  implements a   Perlin noise algorithm   of a  point  in  3D─space.      */
_= 97a0895b5a0f830dc95f6035c2e907e18c24671e458e086325f0150a17be0694f778ea4b001ac53e5efcdbcb75230b2039b12158ed953857ae147d88aba844af,
 ||4aa547868b301ba64d929ee7536fe57a3cd385e6dc695c29372ef528f4668f3641193fa101d85049d14c84bbd05912a9c8c4878274bc9f56a4646dc6adba0340,
 ||34d9e2fa7c7b05ca2693767eff5255d4cfce3be32f103a11b6bd1c2adfb7aad577f898022c9aa346dd99659ba72bac09811627fd13626c6e4f71e0e8b2b97068,
 ||daf661e4fb22f2c1eed2900cbfb3a2f1513391ebf90eef6b31c0d61fb5c76a9db854ccb07379322d7f0496fe8aeccd5dde72431d1848f38d80c34e42d73d9cb4
     do j=0  for length(_)%2;   @.j= x2d( substr(_,  2 * j  + 1,  2) )
     end   /*j*/                                 /* [↑]  assign an indexed array.       */
parse arg x y z d .                              /*obtain optional arguments from the CL*/
if x=='' | x==","  then x=   3.14                /*Not specified?  Then use the default.*/
if y=='' | y==","  then y=  42                   /* "      "         "   "   "     "    */
if z=='' | z==","  then z=   7                   /* "      "         "   "   "     "    */
if d=='' | d==","  then d= 100                   /* "      "         "   "   "     "    */
numeric digits d                                 /*use  D  decimal digits for precision.*/
say 'Perlin noise for the 3D point  ['space(x y z, 3)"]  ───► "       PerlinNoise(x, y, z)
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
fade:  procedure; parse arg t;                    return  t**3 * (t * (t * 6 - 15)  +  10)
floor: procedure; parse arg x;       _= x % 1;    return  _  -   (x < 0)   *   (x \= _)
lerp:  procedure; parse arg t,a,b;                return  a  +    t * (b - a)
pick:  _= abs( arg(1) ) // 256;                   return  @._
/*──────────────────────────────────────────────────────────────────────────────────────*/
grad:  procedure; parse arg hash,x,y,z;  _= abs(hash) // 16   /*force positive remainder*/
         select
         when _== 0 | _==12  then return  x+y;       when _== 1 | _==14  then return  y-x
         when _== 2          then return  x-y;       when _== 3          then return -x-y
         when _== 4          then return  x+z;       when _== 5          then return  z-x
         when _== 6          then return  x-z;       when _== 7          then return -x-z
         when _== 8          then return  y+z;       when _== 9 | _==13  then return  z-y
         when _==10          then return  y-z
         otherwise                return -y-z             /*for cases   11  or  15. */
         end   /*select*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
PerlinNoise: procedure expose @.;     parse arg x,y,z
             x$= floor(x) // 256;     x = x - floor(x);    xm= x-1;     u= fade(x)
             y$= floor(y) // 256;     y = y - floor(y);    ym= y-1;     v= fade(y)
             z$= floor(z) // 256;     z = z - floor(z);    zm= z-1;     w= fade(z)
             a = pick(x$   ) + y$;    aa= pick(a) + z$;                ab= pick(a +1) + z$
             b = pick(x$ +1) + y$;    ba= pick(b) + z$;                bb= pick(b +1) + z$
             return lerp(w, lerp(v, lerp(u,  grad(  pick(aa  ),   x ,    y ,   z   ),    ,
                                             grad(  pick(ba  ),   xm,    y ,   z   )),   ,
                                    lerp(u,  grad(  pick(ab  ),   x ,    ym,   z   ),    ,
                                             grad(  pick(bb  ),   xm,    ym,   z   ))),  ,
                            lerp(v, lerp(u,  grad(  pick(aa+1),   x ,    y ,   zm  ),    ,
                                             grad(  pick(ba+1),   xm,    y ,   zm  )),   ,
                                    lerp(u,  grad(  pick(ab+1),   x ,    ym,   zm  ),    ,
                                             grad(  pick(bb+1),   xm,    ym,   zm  )))) /1


namespace eval perlin {
    proc noise {x y z} {
	# Find unit cube that contains point.
	set X [expr {int(floor($x)) & 255}]
	set Y [expr {int(floor($y)) & 255}]
	set Z [expr {int(floor($z)) & 255}]

	# Find relative x,y,z of point in cube.
	set x [expr {$x - floor($x)}]
	set y [expr {$y - floor($y)}]
	set z [expr {$z - floor($z)}]

	# Compute fade curves for each of x,y,z.
	set u [expr {fade($x)}]
	set v [expr {fade($y)}]
	set w [expr {fade($z)}]

	# Hash coordinates of the 8 cube corners...
	variable p
	set A  [expr {p($X)   + $Y}]
	set AA [expr {p($A)   + $Z}]
	set AB [expr {p($A+1) + $Z}]
	set B  [expr {p($X+1) + $Y}]
	set BA [expr {p($B)   + $Z}]
	set BB [expr {p($B+1) + $Z}]

	# And add blended results from 8 corners of cube
	return [expr {
	    lerp($w, lerp($v, lerp($u, grad(p($AA),   $x,   $y,   $z ),
				       grad(p($BA),   $x-1, $y,   $z )),
			      lerp($u, grad(p($AB),   $x,   $y-1, $z ),
				       grad(p($BB),   $x-1, $y-1, $z ))),
		     lerp($v, lerp($u, grad(p($AA+1), $x,   $y,   $z-1 ),
				       grad(p($BA+1), $x-1, $y,   $z-1 )),
			      lerp($u, grad(p($AB+1), $x,   $y-1, $z-1 ),
				       grad(p($BB+1), $x-1, $y-1, $z-1 ))))
	}]
    }

    namespace eval tcl::mathfunc {
	proc p    {idx}   {lindex $::perlin::permutation $idx}
	proc fade {t}     {expr { $t**3 * ($t * ($t * 6 - 15) + 10) }}
	proc lerp {t a b} {expr { $a + $t * ($b - $a) }}
	proc grad {hash x y z} {
	    # Convert low 4 bits of hash code into 12 gradient directions
	    set h [expr { $hash & 15 }]
	    set u [expr { $h<8 ? $x : $y }]
	    set v [expr { $h<4 ? $y : ($h==12 || $h==14) ? $x : $z }]
	    expr { (($h&1)==0 ? $u : -$u) + (($h&2)==0 ? $v : -$v) }
	}
    }

    apply {{} {
	binary scan [binary format H* [join {
	    97A0895B5A0F830DC95F6035C2E907E18C24671E458E086325F0150A17BE0694F7
	    78EA4B001AC53E5EFCDBCB75230B2039B12158ED953857AE147D88ABA844AF4AA5
            47868B301BA64D929EE7536FE57A3CD385E6DC695C29372EF528F4668F3641193F
	    A101D85049D14C84BBD05912A9C8C4878274BC9F56A4646DC6ADBA034034D9E2FA
            7C7B05CA2693767EFF5255D4CFCE3BE32F103A11B6BD1C2ADFB7AAD577F898022C
	    9AA346DD99659BA72BAC09811627FD13626C6E4F71E0E8B2B97068DAF661E4FB22
            F2C1EED2900CBFB3A2F1513391EBF90EEF6B31C0D61FB5C76A9DB854CCB0737932
	    2D7F0496FE8AECCD5DDE72431D1848F38D80C34E42D73D9CB4
	} ""]] cu* p
	variable ::perlin::permutation [concat $p $p]
    }}
}

puts [perlin::noise 3.14 42 7]


UInt32 seed = 0
F nonrandom()
   :seed = 1664525 * :seed + 1013904223
   R (:seed >> 16) / Float(FF'FF)

V nn = 15
V tt = 5
V pp = 0.5
V NotClustered = 1
V Cell2Char = ‘ #abcdefghijklmnopqrstuvwxyz’
V NRange = [4, 64, 256, 1024, 4096]

F newGrid(n, p)
   R (0 .< n).map(i -> (0 .< @n).map(i -> Int(nonrandom() < @@p)))

F walkMaze(&grid, m, n, idx) -> N
   grid[n][m] = idx
   I n < grid.len - 1 & grid[n + 1][m] == NotClustered
      walkMaze(&grid, m, n + 1, idx)
   I m < grid[0].len - 1 & grid[n][m + 1] == NotClustered
      walkMaze(&grid, m + 1, n, idx)
   I m > 0 & grid[n][m - 1] == NotClustered
      walkMaze(&grid, m - 1, n, idx)
   I n > 0 & grid[n - 1][m] == NotClustered
      walkMaze(&grid, m, n - 1, idx)

F clusterCount(&grid)
   V walkIndex = 1
   L(n) 0 .< grid.len
      L(m) 0 .< grid[0].len
         I grid[n][m] == NotClustered
            walkIndex++
            walkMaze(&grid, m, n, walkIndex)
   R walkIndex - 1

F clusterDensity(n, p)
   V grid = newGrid(n, p)
   R clusterCount(&grid) / Float(n * n)

F print_grid(grid)
   L(row) grid
      print(L.index % 10, end' ‘) ’)
      L(cell) row
         print(‘ ’Cell2Char[cell], end' ‘’)
      print()

V grid = newGrid(nn, 0.5)
print(‘Found ’clusterCount(&grid)‘ clusters in this ’nn‘ by ’nn" grid\n")
print_grid(grid)
print()

L(n) NRange
   V sum = 0.0
   L 0 .< tt
      sum += clusterDensity(n, pp)
   V sim = sum / tt
   print(‘t = #.  p = #.2  n = #4  sim = #.5’.format(tt, pp, n, sim))


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

int *map, w, ww;

void make_map(double p)
{
	int i, thresh = RAND_MAX * p;
	i = ww = w * w;

	map = realloc(map, i * sizeof(int));
	while (i--) map[i] = -(rand() < thresh);
}

char alpha[] = "+.ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		"abcdefghijklmnopqrstuvwxyz";
#define ALEN ((int)(sizeof(alpha) - 3))

void show_cluster(void)
{
	int i, j, *s = map;

	for (i = 0; i < w; i++) {
		for (j = 0; j < w; j++, s++)
			printf(" %c", *s < ALEN ? alpha[1 + *s] : '?');
		putchar('\n');
	}
}

void recur(int x, int v) {
	if (x >= 0 && x < ww && map[x] == -1) {
		map[x] = v;
		recur(x - w, v);
		recur(x - 1, v);
		recur(x + 1, v);
		recur(x + w, v);
	}
}

int count_clusters(void)
{
	int i, cls;

	for (cls = i = 0; i < ww; i++) {
		if (-1 != map[i]) continue;
		recur(i, ++cls);
	}

	return cls;
}

double tests(int n, double p)
{
	int i;
	double k;

	for (k = i = 0; i < n; i++) {
		make_map(p);
		k += (double)count_clusters() / ww;
	}
	return k / n;
}

int main(void)
{
	w = 15;
	make_map(.5);
	printf("width=15, p=0.5, %d clusters:\n", count_clusters());
	show_cluster();

	printf("\np=0.5, iter=5:\n");
	for (w = 1<<2; w <= 1<<14; w<<=2)
		printf("%5d %9.6f\n", w, tests(5, .5));

	free(map);
	return 0;
}


import std.stdio, std.algorithm, std.random, std.math, std.array,
       std.range, std.ascii;

alias Cell = ubyte;
alias Grid = Cell[][];
enum Cell notClustered = 1; // Filled cell, but not in a cluster.

Grid initialize(Grid grid, in double prob, ref Xorshift rng) nothrow {
    foreach (row; grid)
        foreach (ref cell; row)
            cell = Cell(rng.uniform01 < prob);
    return grid;
}

void show(in Grid grid) {
    immutable static cell2char = " #" ~ letters;
    writeln('+', "-".replicate(grid.length), '+');
    foreach (row; grid) {
        write('|');
        row.map!(c => c < cell2char.length ? cell2char[c] : '@').write;
        writeln('|');
    }
    writeln('+', "-".replicate(grid.length), '+');
}

size_t countClusters(bool justCount=false)(Grid grid)
pure nothrow @safe @nogc {
    immutable side = grid.length;
    static if (justCount)
        enum Cell clusterID = 2;
    else
        Cell clusterID = 1;

    void walk(in size_t r, in size_t c) nothrow @safe @nogc {
        grid[r][c] = clusterID; // Fill grid.

        if (r < side - 1 && grid[r + 1][c] == notClustered) // Down.
            walk(r + 1, c);
        if (c < side - 1 && grid[r][c + 1] == notClustered) // Right.
            walk(r, c + 1);
        if (c > 0 && grid[r][c - 1] == notClustered) // Left.
            walk(r, c - 1);
        if (r > 0 && grid[r - 1][c] == notClustered) // Up.
            walk(r - 1, c);
    }

    size_t nClusters = 0;

    foreach (immutable r; 0 .. side)
        foreach (immutable c; 0 .. side)
            if (grid[r][c] == notClustered) {
                static if (!justCount)
                    clusterID++;
                nClusters++;
                walk(r, c);
            }
    return nClusters;
}

double clusterDensity(Grid grid, in double prob, ref Xorshift rng) {
    return grid.initialize(prob, rng).countClusters!true /
           double(grid.length ^^ 2);
}

void showDemo(in size_t side, in double prob, ref Xorshift rng) {
    auto grid = new Grid(side, side);
    grid.initialize(prob, rng);
    writefln("Found %d clusters in this %d by %d grid:\n",
             grid.countClusters, side, side);
    grid.show;
}

void main() {
    immutable prob = 0.5;
    immutable nIters = 5;
    auto rng = Xorshift(unpredictableSeed);

    showDemo(15, prob, rng);
    writeln;
    foreach (immutable i; iota(4, 14, 2)) {
        immutable side = 2 ^^ i;
        auto grid = new Grid(side, side);
        immutable density = nIters
                            .iota
                            .map!(_ => grid.clusterDensity(prob, rng))
                            .sum / nIters;
        writefln("n_iters=%3d, p=%4.2f, n=%5d, sim=%7.8f",
                 nIters, prob, side, density);
    }
}


(define-constant BLACK  (rgb 0 0 0.6))
(define-constant WHITE -1)
;; sets pixels to clusterize to WHITE
;; returns bit-map vector
(define (init-C n p )
    (plot-size n n)
    (define C (pixels->int32-vector )) ;; get canvas bit-map
    (pixels-map (lambda (x y) (if (< (random) p) WHITE BLACK )) C)
    C )

;; random color for new cluster
(define (new-color)
    (hsv->rgb (random) 0.9 0.9))

;; make-region predicate
(define (in-cluster C x y)
    (= (pixel-ref C x y) WHITE))

;; paint all adjacents to (x0,y0) with new color
(define (make-cluster C x0 y0)
                (pixel-set! C x0 y0 (new-color))
                (make-region in-cluster C x0 y0))

;; task
(define (make-clusters (n 400) (p 0.5))
    (define Cn 0)
    (define C null)
        (for ((t 5)) ;; 5 iterations
        (plot-clear)
        (set!  C (init-C n p))
        (for* ((x0 n) (y0 n))
            #:when  (= (pixel-ref C x0 y0) WHITE)
            (set! Cn (1+ Cn))
         (make-cluster C x0 y0)))

    (writeln 'n n  'Cn Cn  'density  (// Cn (* n n) 5) )
    (vector->pixels C)) ;; to screen


USING: combinators formatting generalizations kernel math
math.matrices random sequences ;
IN: rosetta-code.mean-cluster-density

CONSTANT: p 0.5
CONSTANT: iterations 5

: rand-bit-matrix ( n probability -- matrix )
    dupd [ random-unit > 1 0 ? ] curry make-matrix ;

: flood-fill ( x y matrix -- )
    3dup ?nth ?nth 1 = [
        [ [ -1 ] 3dip nth set-nth ] [
            {
                [ [ 1 + ] 2dip ]
                [ [ 1 - ] 2dip ]
                [ [ 1 + ] dip ]
                [ [ 1 - ] dip ]
            } [ flood-fill ] map-compose 3cleave
        ] 3bi
    ] [ 3drop ] if ;

: count-clusters ( matrix -- Cn )
    0 swap dup dim matrix-coordinates flip concat [
        first2 rot 3dup ?nth ?nth 1 = [ flood-fill 1 + ]
        [ 3drop ] if
    ] with each ;

: mean-cluster-density ( matrix -- mcd )
    [ count-clusters ] [ dim first sq / ] bi ;

: simulate ( n -- avg-mcd )
    iterations swap [ p rand-bit-matrix mean-cluster-density ]
    curry replicate sum iterations / ;

: main ( -- )
    { 4 64 256 1024 4096 } [
        [ iterations p ] dip dup simulate
        "iterations = %d p = %.1f n = %4d sim = %.5f\n" printf
    ] each ;

MAIN: main


package main

import (
    "fmt"
    "math/rand"
    "time"
)

var (
    n_range = []int{4, 64, 256, 1024, 4096}
    M       = 15
    N       = 15
)

const (
    p             = .5
    t             = 5
    NOT_CLUSTERED = 1
    cell2char     = " #abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
)

func newgrid(n int, p float64) [][]int {
    g := make([][]int, n)
    for y := range g {
        gy := make([]int, n)
        for x := range gy {
            if rand.Float64() < p {
                gy[x] = 1
            }
        }
        g[y] = gy
    }
    return g
}

func pgrid(cell [][]int) {
    for n := 0; n < N; n++ {
        fmt.Print(n%10, ") ")
        for m := 0; m < M; m++ {
            fmt.Printf(" %c", cell2char[cell[n][m]])
        }
        fmt.Println()
    }
}

func cluster_density(n int, p float64) float64 {
    cc := clustercount(newgrid(n, p))
    return float64(cc) / float64(n) / float64(n)
}

func clustercount(cell [][]int) int {
    walk_index := 1
    for n := 0; n < N; n++ {
        for m := 0; m < M; m++ {
            if cell[n][m] == NOT_CLUSTERED {
                walk_index++
                walk_maze(m, n, cell, walk_index)
            }
        }
    }
    return walk_index - 1
}

func walk_maze(m, n int, cell [][]int, indx int) {
    cell[n][m] = indx
    if n < N-1 && cell[n+1][m] == NOT_CLUSTERED {
        walk_maze(m, n+1, cell, indx)
    }
    if m < M-1 && cell[n][m+1] == NOT_CLUSTERED {
        walk_maze(m+1, n, cell, indx)
    }
    if m > 0 && cell[n][m-1] == NOT_CLUSTERED {
        walk_maze(m-1, n, cell, indx)
    }
    if n > 0 && cell[n-1][m] == NOT_CLUSTERED {
        walk_maze(m, n-1, cell, indx)
    }
}

func main() {
    rand.Seed(time.Now().Unix())
    cell := newgrid(N, .5)
    fmt.Printf("Found %d clusters in this %d by %d grid\n\n",
        clustercount(cell), N, N)
    pgrid(cell)
    fmt.Println()

    for _, n := range n_range {
        M = n
        N = n
        sum := 0.
        for i := 0; i < t; i++ {
            sum += cluster_density(n, p)
        }
        sim := sum / float64(t)
        fmt.Printf("t=%3d p=%4.2f n=%5d sim=%7.5f\n", t, p, n, sim)
    }
}


{-# language FlexibleContexts #-}
import Data.List
import Data.Maybe
import System.Random
import Control.Monad.State
import Text.Printf
import Data.Set (Set)
import qualified Data.Set  as S

type Matrix = [[Bool]]
type Cell = (Int, Int)
type Cluster = Set (Int, Int)

clusters :: Matrix -> [Cluster]
clusters m = unfoldr findCuster cells
  where
    cells = S.fromList [ (i,j) | (r, i) <- zip m [0..]
                               , (x, j) <- zip r [0..], x]

    findCuster s = do
      (p, ps) <- S.minView s
      return $ runState (expand p) ps

    expand p = do
      ns <- state $ extract (neigbours p)
      xs <- mapM expand $ S.elems ns
      return $ S.insert p $ mconcat xs

    extract s1 s2 = (s2 `S.intersection` s1, s2 S.\\ s1)
    neigbours (i,j) = S.fromList [(i-1,j),(i+1,j),(i,j-1),(i,j+1)]
    n = length m

showClusters :: Matrix -> String
showClusters m = unlines [ unwords [ mark (i,j)
                                   | j <- [0..n-1] ]
                         | i <- [0..n-1] ]
  where
    cls = clusters m
    n = length m
    mark c = maybe "." snd $ find (S.member c . fst) $ zip cls syms
    syms = sequence [['a'..'z'] ++ ['A'..'Z']]
------------------------------------------------------------

randomMatrices :: Int -> StdGen -> [Matrix]
randomMatrices n = clipBy n . clipBy n . randoms
  where
    clipBy n = unfoldr (Just . splitAt n)

randomMatrix n = head . randomMatrices n

tests :: Int -> StdGen -> [Int]
tests n = map (length . clusters) . randomMatrices n

task :: Int -> StdGen -> (Int, Double)
task n g = (n, result)
  where
    result = mean $ take 10 $ map density $ tests n g
    density c = fromIntegral c / fromIntegral n**2
    mean lst = sum lst / genericLength lst

main = newStdGen >>= mapM_ (uncurry (printf "%d\t%.5f\n")) . res
  where
    res = mapM task [10,50,100,500]


using Printf, Distributions

newgrid(p::Float64, r::Int, c::Int=r) = rand(Bernoulli(p), r, c)

function walkmaze!(grid::Matrix{Int}, r::Int, c::Int, indx::Int)
    NOT_CLUSTERED = 1 # const
    N, M = size(grid)
    dirs = [[1, 0], [-1, 0], [0, 1], [0, -1]]
    # fill cell
    grid[r, c] = indx
    # check for each direction
    for d in dirs
        rr, cc = (r, c) .+ d
        if checkbounds(Bool, grid, rr, cc) && grid[rr, cc] == NOT_CLUSTERED
            walkmaze!(grid, rr, cc, indx)
        end
    end
end

function clustercount!(grid::Matrix{Int})
    NOT_CLUSTERED = 1 # const
    walkind = 1
    for r in 1:size(grid, 1), c in 1:size(grid, 2)
        if grid[r, c] == NOT_CLUSTERED
            walkind += 1
            walkmaze!(grid, r, c, walkind)
        end
    end
    return walkind - 1
end
clusterdensity(p::Float64, n::Int) = clustercount!(newgrid(p, n)) / n ^ 2

function printgrid(G::Matrix{Int})
    LETTERS = vcat(' ', '#', 'A':'Z', 'a':'z')
    for r in 1:size(G, 1)
        println(r % 10, ") ", join(LETTERS[G[r, :] .+ 1], ' '))
    end
end

G = newgrid(0.5, 15)
@printf("Found %i clusters in this %i×%i grid\n\n", clustercount!(G), size(G, 1), size(G, 2))
printgrid(G)
println()

const nrange = 2 .^ (4:2:12)
const p = 0.5
const nrep = 5
for n in nrange
    sim = mean(clusterdensity(p, n) for _ in 1:nrep)
    @printf("nrep = %2i p = %.2f dim = %-13s sim = %.5f\n", nrep, p, "$n × $n", sim)
end


// version 1.2.10

import java.util.Random

val rand = Random()
const val RAND_MAX = 32767

lateinit var map: IntArray
var w = 0
var ww = 0

const val ALPHA = "+.ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
const val ALEN = ALPHA.length - 3

fun makeMap(p: Double) {
    val thresh = (p * RAND_MAX).toInt()
    ww = w * w
    var i = ww
    map = IntArray(i)
    while (i-- != 0) {
        val r = rand.nextInt(RAND_MAX + 1)
        if (r < thresh) map[i] = -1
    }
}

fun showCluster() {
    var k = 0
    for (i in 0 until w) {
        for (j in 0 until w) {
            val s = map[k++]
            val c = if (s < ALEN) ALPHA[1 + s] else '?'
            print(" $c")
        }
        println()
    }
}

fun recur(x: Int, v: Int) {
    if ((x in 0 until ww) && map[x] == -1) {
        map[x] = v
        recur(x - w, v)
        recur(x - 1, v)
        recur(x + 1, v)
        recur(x + w, v)
    }
}

fun countClusters(): Int {
    var cls = 0
    for (i in 0 until ww) {
        if (map[i] != -1) continue
        recur(i, ++cls)
    }
    return cls
}

fun tests(n: Int, p: Double): Double {
    var k = 0.0
    for (i in 0 until n) {
        makeMap(p)
        k += countClusters().toDouble() / ww
    }
    return k / n
}

fun main(args: Array<String>) {
    w = 15
    makeMap(0.5)
    val cls = countClusters()
    println("width = 15, p = 0.5, $cls clusters:")
    showCluster()

    println("\np = 0.5, iter = 5:")
    w = 1 shl 2
    while (w <= 1 shl 13) {
        val t = tests(5, 0.5)
        println("%5d %9.6f".format(w, t))
        w = w shl 1
    }
}


(*Calculate C_n / n^2 for n=1000, 2000, ..., 10 000*)
In[1]:= Table[N[[email protected][
     RandomVariate[BernoulliDistribution[.5], {n, n}],
     CornerNeighbors -> False]/n^2], {n, 10^3, 10^4, 10^3}]

(*Find the average*)
In[2]:= % // MeanAround

(*Show a 15x15 matrix with each cluster given an incrementally higher number, Colorize instead of MatrixForm creates an image*)
In[3]:= MorphologicalComponents[RandomChoice[{0, 1}, {15, 15}], CornerNeighbors -> False] // MatrixForm


import random, sequtils, strformat

const
  N = 15
  T = 5
  P = 0.5
  NotClustered = 1
  Cell2Char = " #abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
  NRange = [4, 64, 256, 1024, 4096]

type Grid = seq[seq[int]]

proc newGrid(n: Positive; p: float): Grid =
  result = newSeqWith(n, newSeq[int](n))
  for row in result.mitems:
    for cell in row.mitems:
      if rand(1.0) < p: cell = 1

func walkMaze(grid: var Grid; m, n, idx: int) =
  grid[n][m] = idx
  if n < grid.high and grid[n + 1][m] == NotClustered:
    grid.walkMaze(m, n + 1, idx)
  if m < grid[0].high and grid[n][m + 1] == NotClustered:
    grid.walkMaze(m + 1, n, idx)
  if m > 0 and grid[n][m - 1] == NotClustered:
    grid.walkMaze(m - 1, n, idx)
  if n > 0 and grid[n - 1][m] == NotClustered:
    grid.walkMaze(m, n - 1, idx)

func clusterCount(grid: var Grid): int =
  var walkIndex = 1
  for n in 0..grid.high:
    for m in 0..grid[0].high:
      if grid[n][m] == NotClustered:
        inc walkIndex
        grid.walkMaze(m, n, walkIndex)
  result = walkIndex - 1

proc clusterDensity(n: int; p: float): float =
  var grid = newGrid(n, p)
  result = grid.clusterCount() / (n * n)

proc print(grid: Grid) =
  for n, row in grid:
    stdout.write n mod 10, ") "
    for cell in row:
      stdout.write ' ', Cell2Char[cell]
    stdout.write '\n'

when isMainModule:

  randomize()

  var grid = newGrid(N, 0.5)
  echo &"Found {grid.clusterCount()} clusters in this {N} by {N} grid\n"
  grid.print()
  echo ""

  for n in NRange:
    var sum = 0.0
    for _ in 1..T:
      sum += clusterDensity(n, P)
    let sim = sum / T
    echo &"t = {T}  p = {P:4.2f}  n = {n:4}  sim = {sim:7.5f}"


$fill = 'x';
$D{$_} = $i++ for qw<DeadEnd Up Right Down Left>;

sub deq { defined $_[0] && $_[0] eq $_[1] }

sub perctest {
    my($grid) = @_;
    generate($grid);
    my $block = 1;
    for my $y (0..$grid-1) {
        for my $x (0..$grid-1) {
            fill($x, $y, $block++) if $perc[$y][$x] eq $fill
        }
    }
    ($block - 1) / $grid**2;
}

sub generate {
    my($grid) = @_;
    for my $y (0..$grid-1) {
        for my $x (0..$grid-1) {
            $perc[$y][$x] = rand() < .5 ? '.' : $fill;
        }
    }
}

sub fill {
    my($x, $y, $block) = @_;
    $perc[$y][$x] = $block;
    my @stack;
    while (1) {
        if (my $dir = direction( $x, $y )) {
            push @stack, [$x, $y];
            ($x,$y) = move($dir, $x, $y, $block)
        } else {
            return unless @stack;
            ($x,$y) = @{pop @stack};
        }
    }
}

sub direction {
    my($x, $y) = @_;
    return $D{Down}  if deq($perc[$y+1][$x  ], $fill);
    return $D{Left}  if deq($perc[$y  ][$x-1], $fill);
    return $D{Right} if deq($perc[$y  ][$x+1], $fill);
    return $D{Up}    if deq($perc[$y-1][$x  ], $fill);
    return $D{DeadEnd};
}

sub move {
    my($dir,$x,$y,$block) = @_;
    $perc[--$y][   $x] = $block if $dir == $D{Up};
    $perc[++$y][   $x] = $block if $dir == $D{Down};
    $perc[  $y][ --$x] = $block if $dir == $D{Left};
    $perc[  $y][ ++$x] = $block if $dir == $D{Right};
    ($x, $y)
}

my $K = perctest(15);
for my $row (@perc) {
    printf "%3s", $_ for @$row;
    print "\n";
}
printf  "𝘱 = 0.5, 𝘕 = 15, 𝘒 = %.4f\n\n", $K;

$trials = 5;
for $N (10, 30, 100, 300, 1000) {
    my $total = 0;
    $total += perctest($N) for 1..$trials;
    printf "𝘱 = 0.5, trials = $trials, 𝘕 = %4d, 𝘒 = %.4f\n", $N, $total / $trials;
}


with javascript_semantics
sequence grid
integer w, ww

procedure make_grid(atom p)
    ww = w*w
    grid = repeat(0,ww)
    for i=1 to ww do
        grid[i] = -(rnd()<p)
    end for
end procedure

constant alpha = "+.ABCDEFGHIJKLMNOPQRSTUVWXYZ"&
                   "abcdefghijklmnopqrstuvwxyz"

procedure show_cluster()
    for i=1 to ww do
        integer gi = grid[i]+2
        grid[i] = iff(gi<=length(alpha)?alpha[gi]:'?')
    end for
    puts(1,join_by(grid,w,w,""))
end procedure

procedure recur(integer x, v)
    if x>=1 and x<=ww and grid[x]==-1 then
        grid[x] = v
        recur(x-w, v)
        recur(x-1, v)
        recur(x+1, v)
        recur(x+w, v)
    end if
end procedure

function count_clusters()
    integer cls = 0
    for i=1 to ww do
        if grid[i]=-1 then
            cls += 1
            recur(i, cls)
        end if
    end for
    return cls
end function

function tests(int n, atom p)
    atom k = 0
    for i=1 to n do
        make_grid(p)
        k += count_clusters()/ww
    end for
    return k / n
end function

procedure main()
    w = 15
    make_grid(0.5)
    printf(1,"width=15, p=0.5, %d clusters:\n", count_clusters())
    show_cluster()

    printf(1,"\np=0.5, iter=5:\n")
    w = 4
    while w<=4096 do
        printf(1,"%5d %9.6f\n", {w, tests(5,0.5)})
        w *= 4
    end while
end procedure
main()


from __future__ import division
from random import random
import string
from math import fsum

n_range, p, t = (2**n2 for n2 in range(4, 14, 2)), 0.5, 5
N = M = 15

NOT_CLUSTERED = 1   # filled but not clustered cell
cell2char = ' #' + string.ascii_letters

def newgrid(n, p):
    return [[int(random() < p) for x in range(n)] for y in range(n)]

def pgrid(cell):
    for n in range(N):
        print( '%i)  ' % (n % 10)
               + ' '.join(cell2char[cell[n][m]] for m in range(M)))

def cluster_density(n, p):
    cc = clustercount(newgrid(n, p))
    return cc / n / n

def clustercount(cell):
    walk_index = 1
    for n in range(N):
        for m in range(M):
            if cell[n][m] == NOT_CLUSTERED:
                walk_index += 1
                walk_maze(m, n, cell, walk_index)
    return walk_index - 1

def walk_maze(m, n, cell, indx):
    # fill cell
    cell[n][m] = indx
    # down
    if n < N - 1 and cell[n+1][m] == NOT_CLUSTERED:
        walk_maze(m, n+1, cell, indx)
    # right
    if m < M - 1 and cell[n][m + 1] == NOT_CLUSTERED:
        walk_maze(m+1, n, cell, indx)
    # left
    if m and cell[n][m - 1] == NOT_CLUSTERED:
        walk_maze(m-1, n, cell, indx)
    # up
    if n and cell[n-1][m] == NOT_CLUSTERED:
        walk_maze(m, n-1, cell, indx)

if __name__ == '__main__':
    cell = newgrid(n=N, p=0.5)
    print('Found %i clusters in this %i by %i grid\n'
          % (clustercount(cell), N, N))
    pgrid(cell)
    print('')

    for n in n_range:
        N = M = n
        sim = fsum(cluster_density(n, p) for i in range(t)) / t
        print('t=%3i p=%4.2f n=%5i sim=%7.5f'
              % (t, p, n, sim))


#lang racket
(require srfi/14) ; character sets

; much faster than safe fixnum functions
(require
  racket/require ; for fancy require clause below
  (filtered-in
          (lambda (name) (regexp-replace #rx"unsafe-" name ""))
          racket/unsafe/ops)
  ; these aren't in racket/unsafe/ops
  (only-in racket/fixnum for/fxvector in-fxvector fxvector-copy))

; ...(but less safe). if in doubt use this rather than the one above
; (require racket/fixnum)

(define t (make-parameter 5))

(define (build-random-grid p M N)
  (define p-num (numerator p))
  (define p-den (denominator p))
  (for/fxvector #:length (fx* M N) ((_ (in-range (* M N))))
                (if (< (random p-den) p-num) 1 0)))

(define letters
  (sort (char-set->list (char-set-intersection
                         char-set:letter
                         ; char-set:ascii
                         )) char<?))
(define n-letters (length letters))
(define cell->char
  (match-lambda
    (0 #\space) (1 #\.)
    (c (list-ref letters (modulo (- c 2) n-letters)))))

(define (draw-percol-grid M N . gs)
  (for ((r N))
    (for ((g gs))
      (define row-str
        (list->string
         (for/list ((idx (in-range (* r M) (* (+ r 1) M))))
           (cell->char (fxvector-ref g idx)))))
      (printf "|~a| " row-str))
    (newline)))

(define (count-clusters! M N g)
  (define (gather-cluster! k c)
    (when (fx= 1 (fxvector-ref g k))
      (define k-r (fxquotient k M))
      (define k-c (fxremainder k M))
      (fxvector-set! g k c)
      (define-syntax-rule (gather-surrounds range? k+)
        (let ((idx k+))
          (when (and range? (fx= 1 (fxvector-ref g idx)))
            (gather-cluster! idx c))))
      (gather-surrounds (fx> k-r 0) (fx- k M))
      (gather-surrounds (fx> k-c 0) (fx- k 1))
      (gather-surrounds (fx< k-c (fx- M 1)) (fx+ k 1))
      (gather-surrounds (fx< k-r (fx- N 1)) (fx+ k M))))

  (define-values (rv _c)
    (for/fold ((rv 0) (c 2))
      ((pos (in-range (fx* M N)))
       #:when (fx= 1 (fxvector-ref g pos)))
      (gather-cluster! pos c)
      (values (fx+ rv 1) (fx+ c 1))))
  rv)

(define (display-sample-clustering p)
  (printf "Percolation cluster sample: p=~a~%" p)
  (define g (build-random-grid p 15 15))
  (define g+ (fxvector-copy g))
  (define g-count (count-clusters! 15 15 g+))
  (draw-percol-grid 15 15 g g+)
  (printf "~a clusters~%" g-count))

(define (experiment p n t)
  (printf "Experiment: ~a ~a ~a\t" p n t) (flush-output)
  (define sum-Cn
    (for/sum ((run (in-range t)))
      (printf "[~a" run) (flush-output)
      (define g (build-random-grid p n n))
      (printf "*") (flush-output)
      (define Cn (count-clusters! n n g))
      (printf "]") (flush-output)
      Cn))
  (printf "\tmean K(p) = ~a~%" (real->decimal-string (/ sum-Cn t (sqr n)) 6)))

(module+ main
  (t 10)
  (for ((n (in-list '(4000 1000 750 500 400 300 200 100 15))))
    (experiment 1/2 n (t)))
  (display-sample-clustering 1/2))

(module+ test
  (define grd (build-random-grid 1/2 1000 1000))
  (/ (for/sum ((g (in-fxvector grd)) #:when (zero? g)) 1) (fxvector-length grd))
  (display-sample-clustering 1/2))


my @perc;
my $fill = 'x';

enum Direction <DeadEnd Up Right Down Left>;

my $𝘒 = perctest(15);
.fmt("%-2s").say for @perc;
say "𝘱 = 0.5, 𝘕 = 15, 𝘒 = $𝘒\n";

my $trials = 5;
for 10, 30, 100, 300, 1000 -> $𝘕 {
    my $𝘒 = ( [+] perctest($𝘕) xx $trials ) / $trials;
    say "𝘱 = 0.5, trials = $trials, 𝘕 = $𝘕, 𝘒 = $𝘒";
}

sub infix:<deq> ( $a, $b ) { $a.defined && ($a eq $b) }

sub perctest ( $grid ) {
    generate $grid;
    my $block = 1;
    for ^$grid X ^$grid -> ($y, $x) {
        fill( [$x, $y], $block++ ) if @perc[$y; $x] eq $fill
    }
    ($block - 1) / $grid²;
}

sub generate ( $grid ) {
    @perc = ();
    @perc.push: [ ( rand < .5 ?? '.' !! $fill ) xx $grid ] for ^$grid;
}

sub fill ( @cur, $block ) {
    @perc[@cur[1]; @cur[0]] = $block;
    my @stack;
    my $current = @cur;

    loop {
        if my $dir = direction( $current ) {
            @stack.push: $current;
            $current = move $dir, $current, $block
        }
        else {
            return unless @stack;
            $current = @stack.pop
        }
    }

    sub direction( [$x, $y] ) {
        ( Down  if @perc[$y + 1][$x] deq $fill ) ||
        ( Left  if @perc[$y][$x - 1] deq $fill ) ||
        ( Right if @perc[$y][$x + 1] deq $fill ) ||
        ( Up    if @perc[$y - 1][$x] deq $fill ) ||
        DeadEnd
    }

    sub move ( $dir, @cur, $block ) {
        my ( $x, $y ) = @cur;
        given $dir {
            when Up    { @perc[--$y; $x] = $block }
            when Down  { @perc[++$y; $x] = $block }
            when Left  { @perc[$y; --$x] = $block }
            when Right { @perc[$y; ++$x] = $block }
        }
        [$x, $y]
    }
}


package require Tcl 8.6

proc determineClusters {w h p} {
    # Construct the grid
    set grid [lrepeat $h [lrepeat $w 0]]
    for {set i 0} {$i < $h} {incr i} {
	for {set j 0} {$j < $w} {incr j} {
	    lset grid $i $j [expr {rand() < $p ? -1 : 0}]
	}
    }
    # Find (and count) the clusters
    set cl 0
    for {set i 0} {$i < $h} {incr i} {
	for {set j 0} {$j < $w} {incr j} {
	    if {[lindex $grid $i $j] == -1} {
		incr cl
		for {set q [list $i $j];set k 0} {$k<[llength $q]} {incr k} {
		    set y [lindex $q $k]
		    set x [lindex $q [incr k]]
		    if {[lindex $grid $y $x] != -1} continue
		    lset grid $y $x $cl
		    foreach dx {1 0 -1 0} dy {0 1 0 -1} {
			set nx [expr {$x+$dx}]
			set ny [expr {$y+$dy}]
			if {
			    $nx >= 0 && $ny >= 0 && $nx < $w && $ny < $h &&
			    [lindex $grid $ny $nx] == -1
			} then {
			    lappend q $ny $nx
			}
		    }
		}
	    }
	}
    }
    return [list $cl $grid]
}

# Print a sample 15x15 grid
lassign [determineClusters 15 15 0.5] n g
puts "15x15 grid, p=0.5, with $n clusters"
puts "+[string repeat - 15]+"
foreach r $g {puts |[join [lmap x $r {format %c [expr {$x==0?32:64+$x}]}] ""]|}
puts "+[string repeat - 15]+"

# Determine the densities as the grid size increases
puts "p=0.5, iter=5"
foreach n {5 30 180 1080 6480} {
    set tot 0
    for {set i 0} {$i < 5} {incr i} {
	lassign [determineClusters $n $n 0.5] nC
	incr tot $nC
    }
    puts "n=$n, K(p)=[expr {$tot/5.0/$n**2}]"
}


import "random" for Random
import "/fmt" for Fmt

var rand = Random.new()
var RAND_MAX = 32767

var list = []
var w = 0
var ww = 0

var ALPHA = "+.ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
var ALEN  = ALPHA.count - 3

var makeList = Fn.new { |p|
    var thresh = (p * RAND_MAX).truncate
    ww = w * w
    var i = ww
    list = List.filled(i, 0)
    while (i != 0) {
        i = i - 1
        var r = rand.int(RAND_MAX+1)
        if (r < thresh) list[i] = -1
    }
}

var showCluster = Fn.new {
    var k = 0
    for (i in 0...w) {
        for (j in 0...w) {
            var s = list[k]
            k = k + 1
            var c = (s < ALEN) ? ALPHA[1 + s] : "?"
            System.write(" %(c)")
        }
        System.print()
    }
}

var recur // recursive
recur = Fn.new { |x, v|
    if (x >= 0 && x < ww && list[x] == -1) {
        list[x] = v
        recur.call(x - w, v)
        recur.call(x - 1, v)
        recur.call(x + 1, v)
        recur.call(x + w, v)
    }
}

var countClusters = Fn.new {
    var cls = 0
    for (i in 0...ww) {
        if (list[i] == -1) {
            cls = cls + 1
            recur.call(i, cls)
        }
    }
    return cls
}

var tests = Fn.new { |n, p|
    var k = 0
    for (i in 0...n) {
        makeList.call(p)
        k = k + countClusters.call() / ww
    }
    return k / n
}

w = 15
makeList.call(0.5)
var cls = countClusters.call()
System.print("width = 15, p = 0.5, %(cls) clusters:")
showCluster.call()

System.print("\np = 0.5, iter = 5:")
w = 1 << 2
while (w <= (1 << 13)) {
    var t = tests.call(5, 0.5)
    Fmt.print("$5d $9.6f", w, t)
    w = w << 1
}


const X=-1;	// the sentinal that marks an untouched cell
var C,N,NN,P;
fcn createC(n,p){
   N,P=n,p; NN=N*N;
   C=NN.pump(List.createLong(NN),0);  // vector of ints
   foreach n in (NN){ C[n]=X*(Float.random(1)<=P) } // X is the sentinal
}
fcn showCluster{
   alpha:="-ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz";
   foreach n in ([0..NN,N]){ C[n,N].pump(String,alpha.get).println() }
}
fcn countClusters{
   clusters:=0;
   foreach n in (NN){
      if(X!=C[n]) continue;
      fcn(n,v){
	 if((0<=n<NN) and C[n]==X){
	    C[n]=v;
	    self.fcn(n-N,v); self.fcn(n-1,v); self.fcn(n+1,v); self.fcn(n+N,v);
	 }
      }(n,clusters+=1);
   }
   clusters
}
fcn tests(N,n,p){
   k:=0.0;
   foreach z in (n){ createC(N,p); k+=countClusters().toFloat()/NN; }
   k/n
}


UInt32 seed = 0
F nonrandom()
   :seed = 1664525 * :seed + 1013904223
   R Int(:seed >> 16) / Float(FF'FF)

V (p, t) = (0.5, 500)

F newv(n, p)
   R (0 .< n).map(i -> Int(nonrandom() < @p))

F runs(v)
   R sum(zip(v, v[1..] [+] [0]).map((a, b) -> (a [&] (-)b)))

F mean_run_density(n, p)
   R runs(newv(n, p)) / Float(n)

L(p10) (1.<10).step(2)
   p = p10 / 10
   V limit = p * (1 - p)
   print(‘’)
   L(n2) (10.<16).step(2)
      V n = 2 ^ n2
      V sim = sum((0 .< t).map(i -> mean_run_density(@n, :p))) / t
      print(‘t=#3 p=#.2 n=#5 p(1-p)=#.3 sim=#.3 delta=#.1%’.format(
             t,   p,    n,       limit, sim, I limit {abs(sim - limit) / limit * 100} E sim * 100))


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

// just generate 0s and 1s without storing them
double run_test(double p, int len, int runs)
{
	int r, x, y, i, cnt = 0, thresh = p * RAND_MAX;

	for (r = 0; r < runs; r++)
		for (x = 0, i = len; i--; x = y)
			cnt += x < (y = rand() < thresh);

	return (double)cnt / runs / len;
}

int main(void)
{
	double p, p1p, K;
	int ip, n;

	puts(	"running 1000 tests each:\n"
		" p\t   n\tK\tp(1-p)\t     diff\n"
		"-----------------------------------------------");
	for (ip = 1; ip < 10; ip += 2) {
		p = ip / 10., p1p = p * (1 - p);

		for (n = 100; n <= 100000; n *= 10) {
			K = run_test(p, n, 1000);
			printf("%.1f\t%6d\t%.4f\t%.4f\t%+.4f (%+.2f%%)\n",
				p, n, K, p1p, K - p1p, (K - p1p) / p1p * 100);
		}
		putchar('\n');
	}

	return 0;
}