#include <algorithm>
#include <random>
#include <vector>
#include <iostream>
#include <numeric>
#include <iomanip>
using VecIt = std::vector<int>::const_iterator ;

//creates vector of length n, based on probability p for 1
std::vector<int> createVector( int n, double p ) {
   std::vector<int> result( n ) ;
   std::random_device rd ;
   std::mt19937 gen( rd( ) ) ;
   std::uniform_real_distribution<> dis( 0 , 1 ) ;
   for ( int i = 0 ; i < n ; i++ ) {
      double number = dis( gen ) ;
      if ( number <= p )
	 result[ i ] = 1 ;
      else
	 result[ i ] = 0 ;
   }
   return result ;
}

//find number of 1 runs in the vector
int find_Runs( const std::vector<int> & numberVector ) {
   int runs = 0 ;
   VecIt found = numberVector.begin( ) ;
   while ( ( found = std::find( found , numberVector.end( ) , 1 ) )
	 != numberVector.end( ) ) {
      runs++ ;
      while ( found != numberVector.end( ) && ( *found == 1 ) )
	 std::advance( found , 1 ) ;
      if ( found == numberVector.end( ) )
	 break ;
   }
   return runs ;
}

int main( ) {
   std::cout << "t = 100\n" ;
   std::vector<double> p_values { 0.1 , 0.3 , 0.5 , 0.7 , 0.9 } ;
   for ( double p : p_values ) {
      std::cout << "p = " << p << " , K(p) = " << p * ( 1 - p ) << std::endl ;
      for ( int n = 10 ; n < 100000 ; n *= 10 ) {
	 std::vector<double> runsFound ;
	 for ( int i = 0 ; i < 100 ; i++ ) {
	    std::vector<int> ones_and_zeroes = createVector( n , p ) ;
	    runsFound.push_back( find_Runs( ones_and_zeroes ) / static_cast<double>( n ) ) ;
	 }
	 double average = std::accumulate( runsFound.begin( ) , runsFound.end( ) , 0.0 ) / runsFound.size( ) ;
	 std::cout << "  R(" << std::setw( 6 ) << std::right << n << ", p) = " << average << std::endl ;
      }
   }
   return 0 ;
}


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

enum n = 100, p = 0.5, t = 500;

double meanRunDensity(in size_t n, in double prob) {
    return n.iota.map!(_ => uniform01 < prob)
           .array.uniq.sum / double(n);
}

void main() {
    foreach (immutable p; iota(0.1, 1.0, 0.2)) {
        immutable limit = p * (1 - p);
        writeln;
        foreach (immutable n2; iota(10, 16, 2)) {
            immutable n = 2 ^^ n2;
            immutable sim = t.iota.map!(_ => meanRunDensity(n, p))
                            .sum / t;
            writefln("t=%3d, p=%4.2f, n=%5d, p(1-p)=%5.5f, " ~
                     "sim=%5.5f, delta=%3.1f%%", t, p, n, limit, sim,
                     limit ? abs(sim - limit) / limit * 100 : sim*100);
        }
    }
}


;; count 1-runs - The vector is not stored
(define (runs p n)
(define ct 0)
(define run-1 #t)
    (for ([i n])
        (if (< (random) p)
        (set! run-1 #t) ;; 0 case
        (begin ;; 1 case
            (when run-1 (set! ct (1+ ct)))
            (set! run-1 #f))))
    (// ct n))

;; mean of t counts
(define (truns p (n 1000 )  (t 1000))
    (// (for/sum ([i t]) (runs p n)) t))

(define (task)
    (for ([p (in-range 0.1 1.0 0.2)])
    (writeln)
    (writeln '🔸 'p p 'Kp (* p (- 1 p)))
        (for ([n '(10 100 1000)])
        (printf "\t-- n %5d   →  %d" n (truns p n)))))


USING: formatting fry io kernel math math.ranges math.statistics
random sequences ;
IN: rosetta-code.mean-run-density

: rising? ( ? ? -- ? ) [ f = ] [ t = ] bi* and ;

: count-run ( n ? ? -- m ? )
    2dup rising? [ [ 1 + ] 2dip ] when nip ;

: runs ( n p -- n )
    [ 0 f ] 2dip '[ random-unit _ < count-run ] times drop ;

: rn ( n p -- x ) over [ runs ] dip /f ;

: sim ( n p -- avg )
    [ 1000 ] 2dip [ rn ] 2curry replicate mean ;

: theory ( p -- x ) 1 over - * ;

: result ( n p -- )
    [ swap ] [ sim ] [ nip theory ] 2tri 2dup - abs
    "%.1f  %-5d  %.4f  %.4f  %.4f\n" printf ;

: test ( p -- )
    { 100 1,000 10,000 } [ swap result ] with each nl ;

: header ( -- )
    "1000 tests each:\np    n      K       p(1-p)  diff" print ;

: main ( -- ) header .1 .9 .2 <range> [ test ] each ;

MAIN: main


! loosely translated from python.  We do not need to generate and store the entire vector at once.
! compilation: gfortran -Wall -std=f2008 -o thisfile thisfile.f08

program percolation_mean_run_density
  implicit none
  integer :: i, p10, n2, n, t
  real :: p, limit, sim, delta
  data n,p,t/100,0.5,500/
  write(6,'(a3,a5,4a7)')'t','p','n','p(1-p)','sim','delta%'
  do p10=1,10,2
     p = p10/10.0
     limit = p*(1-p)
     write(6,'()')
     do n2=10,15,2
        n = 2**n2
        sim = 0
        do i=1,t
           sim = sim + mean_run_density(n,p)
        end do
        sim = sim/t
        if (limit /= 0) then
           delta = abs(sim-limit)/limit
        else
           delta = sim
        end if
        delta = delta * 100
        write(6,'(i3,f5.2,i7,2f7.3,f5.1)')t,p,n,limit,sim,delta
     end do
  end do

contains

  integer function runs(n, p)
    integer, intent(in) :: n
    real, intent(in) :: p
    real :: harvest
    logical :: q
    integer :: count, i
    count = 0
    q = .false.
    do i=1,n
       call random_number(harvest)
       if (harvest < p) then
          q = .true.
       else
          if (q) count = count+1
          q = .false.
       end if
    end do
    runs = count
  end function runs

  real function mean_run_density(n, p)
    integer, intent(in) :: n
    real, intent(in) :: p
    mean_run_density = real(runs(n,p))/real(n)
  end function mean_run_density

end program percolation_mean_run_density


Function run_test(p As Double, longitud As Integer, runs As Integer) As Double
    Dim As Integer r, l, cont = 0
    Dim As Integer v, pv

    For r = 1 To runs
        pv = 0
        For l = 1 To longitud
            v = Rnd < p
            cont += Iif(pv < v, 1, 0)
            pv = v
        Next l
    Next r
    Return (cont/runs/longitud)
End Function

Print "Running 1000 tests each:"
Print " p        n  K       p(1-p)       delta"
Print String(46,"-")

Dim As Double K, p, p1p
Dim As Integer n, ip

For ip = 1 To 10 Step 2
    p = ip / 10
    p1p = p * (1-p)
    n = 100
    While n <= 100000
        K = run_test(p, n, 1000)
        Print Using !"#.#  ######  #.####  #.####  +##.#### (##.## \b%)"; _
        p; n; K; p1p; K-p1p; (K-p1p)/p1p*100
        n *= 10
    Wend
    Print
Next ip
Sleep


package main

import (
    "fmt"
    "math/rand"
)

var (
    pList = []float64{.1, .3, .5, .7, .9}
    nList = []int{1e2, 1e3, 1e4, 1e5}
    t     = 100
)

func main() {
    for _, p := range pList {
        theory := p * (1 - p)
        fmt.Printf("\np: %.4f  theory: %.4f  t: %d\n", p, theory, t)
        fmt.Println("        n          sim     sim-theory")
        for _, n := range nList {
            sum := 0
            for i := 0; i < t; i++ {
                run := false
                for j := 0; j < n; j++ {
                    one := rand.Float64() < p
                    if one && !run {
                        sum++
                    }
                    run = one
                }
            }
            K := float64(sum) / float64(t) / float64(n)
            fmt.Printf("%9d %15.4f %9.6f\n", n, K, K-theory)
        }
    }
}


import Control.Monad.Random
import Control.Applicative
import Text.Printf
import Control.Monad
import Data.Bits

data OneRun = OutRun | InRun deriving (Eq, Show)

randomList :: Int -> Double -> Rand StdGen [Int]
randomList n p = take n . map f <$> getRandomRs (0,1)
  where f n = if (n > p) then 0 else 1

countRuns xs = fromIntegral . sum $
               zipWith (\x y -> x .&. xor y 1) xs (tail xs ++ [0])

calcK :: Int -> Double -> Rand StdGen Double
calcK n p = (/ fromIntegral n) . countRuns <$> randomList n p

printKs :: StdGen -> Double -> IO ()
printKs g p = do
  printf "p= %.1f, K(p)= %.3f\n" p (p * (1 - p))
  forM_ [1..5] $ \n -> do
    let est = evalRand (calcK (10^n) p) g
    printf "n=%7d, estimated K(p)= %5.3f\n" (10^n::Int) est

main = do
  x <- newStdGen
  forM_ [0.1,0.3,0.5,0.7,0.9] $ printKs x


NB. translation of python

NB.  'N P T' =: 100 0.5 500            NB. hypothetical example values, to aid comprehension...

newv =: (> [email protected](#&0))~                   NB. generate a random binary vector.  Use:  N newv P
runs =: {: + [: +/ 1 0&E.              NB. add the tail to the sum of 1 0 occurrences  Use: runs V
mean_run_density =: [ %~ [: runs newv  NB. perform experiment.  Use: N mean_run_density P

main =: 3 : 0                          NB.Usage: main T
 T =. y
 smoutput'  T  P    N    P(1-P) SIM   DELTA%'
 for_P. 10 %~ >: +: i. 5 do.
   LIMIT =. (* -.) P
   smoutput ''
   for_N. 2 ^ 10 + +: i. 3 do.
     SIM =. T %~ +/ (N mean_run_density P"_)^:(<T) 0
     smoutput 4 5j2 6 6j3 6j3 4j1 ": T, P, N, LIMIT, SIM, SIM (100 * [`(|@:(- % ]))@.(0 ~: ])) LIMIT
   end.
 end.
 EMPTY
)


using Printf, Distributions, IterTools

newv(n::Int, p::Float64) = rand(Bernoulli(p), n)
runs(v::Vector{Int}) = sum((a & ~b) for (a, b) in zip(v, IterTools.chain(v[2:end], v[1])))

mrd(n::Int, p::Float64) = runs(newv(n, p)) / n

nrep = 500

for p in 0.1:0.2:1
    lim = p * (1 - p)

    println()
    for ex in 10:2:14
        n = 2 ^ ex
        sim = mean(mrd.(n, p) for _ in 1:nrep)
        @printf("nrep = %3i\tp = %4.2f\tn = %5i\np · (1 - p) = %5.3f\tsim = %5.3f\tΔ = %3.1f%%\n",
                nrep, p, n, lim, sim, lim > 0 ? abs(sim - lim) / lim * 100 : sim * 100)
    end
end


// version 1.2.10

import java.util.Random

val rand = Random()
const val RAND_MAX = 32767

// just generate 0s and 1s without storing them
fun runTest(p: Double, len: Int, runs: Int): Double {
    var cnt = 0
    val thresh = (p * RAND_MAX).toInt()
    for (r in 0 until runs) {
        var x = 0
        var i = len
        while (i-- > 0) {
            val y = if (rand.nextInt(RAND_MAX + 1) < thresh) 1 else 0
            if (x < y) cnt++
            x = y
        }
    }
    return cnt.toDouble() / runs / len
}

fun main(args: Array<String>) {
    println("running 1000 tests each:")
    println(" p\t   n\tK\tp(1-p)\t     diff")
    println("------------------------------------------------")
    val fmt = "%.1f\t%6d\t%.4f\t%.4f\t%+.4f (%+.2f%%)"
    for (ip in 1..9 step 2) {
        val p = ip / 10.0
        val p1p = p * (1.0 - p)
        var n = 100
        while (n <= 100_000) {
            val k = runTest(p, n, 1000)
            println(fmt.format(p, n, k, p1p, k - p1p, (k - p1p) / p1p * 100))
            n *= 10
        }
        println()
    }
}


meanRunDensity[p_, len_, trials_] :=
 Mean[Length[Cases[[email protected]#, {1, ___}]] & /@
    Unitize[Chop[RandomReal[1, {trials, len}], 1 - p]]]/len

[email protected][
  Grid[Join[{{p, n, K, diff}},
    Table[{q, n, x = meanRunDensity[q, n, 100] // N,
      q (1 - q) - x}, {n, {100, 1000, 10000, 100000}}], {}],
   Alignment -> Left], {q, {.1, .3, .5, .7, .9}}]


import random, strformat

const T = 100

var
  pList = [0.1, 0.3, 0.5, 0.7, 0.9]
  nList = [100, 1_000, 10_000, 100_000]

for p in pList:

  let theory = p * (1 - p)
  echo &"\np: {p:.4f}  theory: {theory:.4f}  t: {T}"
  echo "        n          sim     sim-theory"

  for n in nList:
    var sum = 0
    for _ in 1..T:
      var run = false
      for _ in 1..n:
        let one = rand(1.0) < p
        if one and not run: inc sum
        run = one

    let k = sum / (T * n)
    echo &"{n:9} {k:15.4f} {k - theory:10.6f}"


{$MODE objFPC}//for using result,parameter runs becomes for variable..
uses
  sysutils;//Format
const
  MaxN = 100*1000;

function run_test(p:double;len,runs: NativeInt):double;
var
   x, y, i,cnt : NativeInt;
Begin
  result := 1/ (runs * len);
  cnt := 0;
  for  runs := runs-1 downto 0 do
  Begin
    x := 0;
    y := 0;
    for i := len-1 downto 0 do
    begin
      x := y;
      y := Ord(Random() < p);
      cnt := cnt+ord(x < y);
    end;
  end;
  result := result *cnt;
end;

//main
var
  p, p1p, K : double;
  ip, n : nativeInt;
Begin
  randomize;
  writeln( 'running 1000 tests each:'#13#10,
    ' p      n      K     p(1-p)   diff'#13#10,
    '-----------------------------------------------');
  ip:= 1;
  while ip < 10 do
  Begin
     p := ip / 10;
     p1p := p * (1 - p);
     n := 100;
     While n <= MaxN do
     Begin
       K := run_test(p, n, 1000);
       writeln(Format('%4.1f %6d  %6.4f  %6.4f %7.4f (%5.2f %%)',
         [p, n, K, p1p, K - p1p, (K - p1p) / p1p * 100]));
       n := n*10;
     end;
     writeln;
     ip := ip+2;
   end;
end.


with javascript_semantics
function run_test(atom p, integer len, runs)
    integer count = 0
    for r=1 to runs do
        bool v, pv = false
        for l=1 to len do
            v = rnd()<p
            count += pv<v
            pv = v
        end for
    end for
    return count/runs/len
end function

procedure main()
    printf(1,"Running 1000 tests each:\n")
    printf(1," p        n  K       p(1-p)       delta\n")
    printf(1,"--------------------------------------------\n")
    for ip=1 to 10 by 2 do
        atom p = ip/10,
             p1p = p*(1-p)
        integer n = 100
        while n<=100000 do
            atom K = run_test(p, n, 1000)
            printf(1,"%.1f  %6d  %6.4f  %6.4f  %+7.4f (%+5.2f%%)\n",
                   {p, n, K, p1p, K-p1p, (K-p1p)/p1p*100})
            n *= 10
        end while
        printf(1,"\n")
    end for
end procedure
main()


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

n, p, t = 100, 0.5, 500

def newv(n, p):
    return [int(random() < p) for i in range(n)]

def runs(v):
    return sum((a & ~b) for a, b in zip(v, v[1:] + [0]))

def mean_run_density(n, p):
    return runs(newv(n, p)) / n

for p10 in range(1, 10, 2):
    p = p10 / 10
    limit = p * (1 - p)
    print('')
    for n2 in range(10, 16, 2):
        n = 2**n2
        sim = fsum(mean_run_density(n, p) for i in range(t)) / t
        print('t=%3i p=%4.2f n=%5i p(1-p)=%5.3f sim=%5.3f delta=%3.1f%%'
              % (t, p, n, limit, sim, abs(sim - limit) / limit * 100 if limit else sim * 100))


#lang racket
(require racket/fixnum)
(define t (make-parameter 100))

(define (Rn v)
  (define (inner-Rn rv idx b-1)
    (define b (fxvector-ref v idx))
    (define rv+ (if (and (= b 1) (= b-1 0)) (add1 rv) rv))
    (if (zero? idx) rv+ (inner-Rn rv+ (sub1 idx) b)))
  (inner-Rn 0 (sub1 (fxvector-length v)) 0))

(define ((make-random-bit-vector p) n)
  (for/fxvector
   #:length n ((i n))
   (if (<= (random) p) 1 0)))

(define (Rn/n l->p n) (/ (Rn (l->p n)) n))

(for ((p (in-list '(1/10 3/10 1/2 7/10 9/10))))
  (define l->p (make-random-bit-vector p))
  (define Kp (* p (- 1 p)))
  (printf "p = ~a\tK(p) =\t~a\t~a~%" p Kp (real->decimal-string Kp 4))
  (for ((n (in-list '(10 100 1000 10000))))
    (define sum-Rn/n (for/sum ((i (in-range (t)))) (Rn/n l->p n)))
    (define sum-Rn/n/t (/ sum-Rn/n (t)))
    (printf "mean(R_~a/~a) =\t~a\t~a~%"
            n n sum-Rn/n/t (real->decimal-string sum-Rn/n/t 4)))
  (newline))

(module+ test
  (require rackunit)
  (check-eq? (Rn (fxvector 1 1 0 0 0 1 0 1 1 1)) 3))


/* REXX */
Numeric Digits 20
Call random(,12345) /* make the run reproducable */
pList = '.1 .3 .5 .7 .9'
nList = '1e2 1e3 1e4 1e5'
t     = 100
Do While plist<>''
  Parse Var plist p plist
  theory=p*(1-p)
  Say ' '
  Say 'p:' format(p,2,4)'  theory:'format(theory,2,4)'  t:'format(t,4)
  Say '         n          sim     sim-theory'
  nl=nlist
  Do While nl<>''
    Parse Var nl n nl
    sum=0
    Do i=1 To t
      run=0
      Do j=1 To n
        one=random(1000)<p*1000
        If one & (run=0) Then
          sum=sum+1
        run=one
        End
      End
    sim=sum/(n*100)
    Say format(n,10)'        ' format(sim,2,4)' 'format(sim-theory,2,6)
    End
  End


proc randomString {length probability} {
    for {set s ""} {[string length $s] < $length} {} {
	append s [expr {rand() < $probability}]
    }
    return $s
}

# By default, [regexp -all] gives the number of times that the RE matches
proc runs {str} {
    regexp -all {1+} $str
}

# Compute the mean run density
proc mrd {t p n} {
    for {set i 0;set total 0.0} {$i < $t} {incr i} {
	set run [randomString $n $p]
	set total [expr {$total + double([runs $run])/$n}]
    }
    return [expr {$total / $t}]
}

# Parameter sweep with nested [foreach]
set runs 500
foreach p {0.10 0.30 0.50 0.70 0.90} {
    foreach n {1024 4096 16384} {
	set theory [expr {$p * (1 - $p)}]
	set sim [mrd $runs $p $n]
	set diffpc [expr {abs($theory-$sim)*100/$theory}]
	puts [format "t=%d, p=%.2f, n=%5d, p(1-p)=%.3f, sim=%.3f, delta=%.2f%%" \
		      $runs $p $n $theory $sim $diffpc]
    }
    puts ""
}


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

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

// just generate 0s and 1s without storing them
var runTest = Fn.new { |p, len, runs|
    var cnt = 0
    var thresh = (p * RAND_MAX).truncate
    for (r in 0...runs) {
        var x = 0
        var i = len
        while (i > 0) {
            i = i - 1
            var y = (rand.int(RAND_MAX + 1) < thresh) ? 1 : 0
            if (x < y) cnt = cnt + 1
            x = y
        }
    }
    return cnt / runs / len
}

System.print("Running 1000 tests each:")
System.print(" p\t   n\tK\tp(1-p)\t     diff")
System.print("------------------------------------------------")
var fmt = "$.1f\t$6d\t$.4f\t$.4f\t$+.4f ($+.2f\%)"
for (ip in [1, 3, 5, 7, 9]) {
    var p = ip / 10
    var p1p = p * (1 - p)
    var n = 100
    while (n <= 1e5) {
        var k = runTest.call(p, n, 1000)
        Fmt.lprint(fmt, [p, n, k, p1p, k - p1p, (k - p1p) /p1p * 100])
        n = n * 10
    }
    System.print()
}


fcn run_test(p,len,runs){
   cnt:=0; do(runs){
      pv:=0; do(len){
         v:=0 + ((0.0).random(1.0)<p);  // 0 or 1, value of V[n]
         cnt += (pv<v);  // if v is 1 & prev v was zero, inc cnt
         pv = v;
      }
   }
   return(cnt.toFloat() / runs / len);
}


F flatten(lst)
   [Int] r
   L(sublst) lst
      L(i) sublst
         r [+]= i
   R r

F magic_shuffle(deck)
   V half = deck.len I/ 2
   R flatten(zip(deck[0 .< half], deck[half ..]))

F after_how_many_is_equal(start, end)
   V deck = magic_shuffle(start)
   V counter = 1
   L deck != end
      deck = magic_shuffle(deck)
      counter++
   R counter

print(‘Length of the deck of cards | Perfect shuffles needed to obtain the same deck back’)
L(length) (8, 24, 52, 100, 1020, 1024, 10000)
   V deck = Array(0 .< length)
   V shuffles_needed = after_how_many_is_equal(deck, deck)
   print(‘#<5 | #.’.format(length, shuffles_needed))


DEFINE MAXDECK="5000"

PROC Order(INT ARRAY deck INT count)
  INT i

  FOR i=0 TO count-1
  DO
    deck(i)=i
  OD
RETURN

BYTE FUNC IsOrdered(INT ARRAY deck INT count)
  INT i

  FOR i=0 TO count-1
  DO
    IF deck(i)#i THEN
      RETURN (0)
    FI
  OD
RETURN (1)

PROC Shuffle(INT ARRAY src,dst INT count)
  INT i,i1,i2

  i=0 i1=0 i2=count RSH 1
  WHILE i<count
  DO
    dst(i)=src(i1) i==+1 i1==+1
    dst(i)=src(i2) i==+1 i2==+1
  OD
RETURN

PROC Test(INT ARRAY deck,deck2 INT count)
  INT ARRAY tmp
  INT n

  Order(deck,count)
  n=0
  DO
    Shuffle(deck,deck2,count)
    tmp=deck deck=deck2 deck2=tmp
    n==+1
    Poke(77,0) ;turn off the attract mode
    PrintF("%I cards -> %I iterations%E",count,n)
    Put(28) ;move cursor up
  UNTIL IsOrdered(deck,count)
  OD
  PutE()
RETURN

PROC Main()
  INT ARRAY deck(MAXDECK),deck2(MAXDECK)
  INT ARRAY counts=[8 24 52 100 1020 1024 MAXDECK]
  INT i

  FOR i=0 TO 6
  DO
    Test(deck,deck2,counts(i))
  OD
RETURN


with ada.text_io;use ada.text_io;

procedure perfect_shuffle is
  function count_shuffle (half_size : Positive) return Positive is
    subtype index is Natural range 0..2 * half_size - 1;
    subtype index_that_move is index range index'first+1..index'last-1;
    type deck is array (index) of index;
    initial, d, next : deck;
    count : Natural := 1;
  begin
    for i in index loop initial (i) := i; end loop;
    d := initial;
    loop
      for i in index_that_move loop
        next (i) := (if d (i) mod 2 = 0 then d(i)/2 else d(i)/2 + half_size);
      end loop;
      exit when next (index_that_move)= initial(index_that_move);
      d := next;
      count := count + 1;
    end loop;
    return count;
  end count_shuffle;
  test : array (Positive range <>) of Positive := (8, 24, 52, 100, 1020, 1024, 10_000);
begin
  for size of test loop
    put_line ("For" & size'img & " cards, there are "& count_shuffle (size / 2)'img & " shuffles needed.");
  end loop;
end perfect_shuffle;


# returns an array of the specified length, initialised to an ascending sequence of integers #
OP   DECK = ( INT length )[]INT:
     BEGIN
         [ 1 : length ]INT result;
         FOR i TO UPB result DO result[ i ] := i OD;
        result
     END # DECK # ;

# in-place shuffles the deck as per the task requirements #
# LWB deck is assumed to be 1 #
PROC shuffle = ( REF[]INT deck )VOID:
     BEGIN
         [ 1 : UPB deck ]INT result;
         INT left pos  := 1;
         INT right pos := ( UPB deck OVER 2 ) + 1;
         FOR i FROM 2 BY 2 TO UPB result DO
             result[ left pos  ] := deck[ i - 1 ];
             result[ right pos ] := deck[ i     ];
             left pos  +:= 1;
             right pos +:= 1
         OD;
         FOR i TO UPB deck DO deck[ i ] := result[ i ] OD
     END # SHUFFLE # ;

# compares two integer arrays for equality #
OP   = = ( []INT a, b )BOOL:
     IF LWB a /= LWB b OR UPB a /= UPB b
     THEN # the arrays have different bounds #
         FALSE
     ELSE
         BOOL result := TRUE;
         FOR i FROM LWB a TO UPB a WHILE result := a[ i ] = b[ i ] DO SKIP OD;
         result
     FI # = # ;

# compares two integer arrays for inequality #
OP   /= = ( []INT a, b )BOOL: NOT ( a = b );

# returns the number of shuffles required to return a deck of the specified length #
# back to its original state #
PROC count shuffles = ( INT length )INT:
     BEGIN
         []            INT original deck  = DECK length;
         [ 1 : length ]INT shuffled deck := original deck;
         INT   count         := 1;
         WHILE shuffle( shuffled deck );
               shuffled deck /= original deck
         DO
             count +:= 1
         OD;
         count
     END # count shuffles # ;

# test the shuffling #
[]INT lengths = ( 8, 24, 52, 100, 1020, 1024, 10 000 );
FOR l FROM LWB lengths TO UPB lengths DO
    print( ( whole( lengths[ l ], -8 ) + ": " + whole( count shuffles( lengths[ l ] ), -6 ), newline ) )
OD


faro ← ∊∘⍉(2,2÷⍨≢)⍴⊢
count ← {⍺←⍵ ⋄ ⍺≡r←⍺⍺ ⍵:1 ⋄ 1+⍺∇r}
(⊢,[1.5] (faro count ⍳)¨) 8 24 52 100 1020 1024 10000


perfectShuffle: function [deckSize][
    deck: 1..deckSize
    original: new deck
    halfDeck: deckSize/2

    i: 1
    while [true][
        deck: flatten couple first.n: halfDeck deck last.n: halfDeck deck
        if deck = original -> return i
        i: i+1
    ]
]

loop [8 24 52 100 1020 1024 10000] 's ->
    print [
        pad.right join @["Perfect shuffles required for deck size " to :string s ":"] 48
        perfectShuffle s
    ]


Shuffle(cards){
	n := cards.MaxIndex()/2,	res := []
	loop % n
		res.push(cards[A_Index]), res.push(cards[round(A_Index + n)])
	return res
}


/* ===> INCLUDES <============================================================*/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>

/* ===> CONSTANTS <===========================================================*/
#define N_DECKS 7
const int kDecks[N_DECKS] = { 8, 24, 52, 100, 1020, 1024, 10000 };

/* ===> FUNCTION PROTOTYPES <=================================================*/
int CreateDeck( int **deck, int nCards );
void InitDeck( int *deck, int nCards );
int DuplicateDeck( int **dest, const int *orig, int nCards );
int InitedDeck( int *deck, int nCards );
int ShuffleDeck( int *deck, int nCards );
void FreeDeck( int **deck );

/* ===> FUNCTION DEFINITIONS <================================================*/

int main() {
    int i, nCards, nShuffles;
    int *deck = NULL;

    for( i=0; i<N_DECKS; ++i ) {
        nCards = kDecks[i];

        if( !CreateDeck(&deck,nCards) ) {
            fprintf( stderr, "Error: malloc() failed!\n" );
            return 1;
        }

        InitDeck( deck, nCards );
        nShuffles = 0;

        do {
            ShuffleDeck( deck, nCards );
            ++nShuffles;
        } while( !InitedDeck(deck,nCards) );

        printf( "Cards count: %d, shuffles required: %d.\n", nCards, nShuffles );

        FreeDeck( &deck );
    }

    return 0;
}

int CreateDeck( int **deck, int nCards ) {
    int *tmp = NULL;

    if( deck != NULL )
        tmp = malloc( nCards*sizeof(*tmp) );

    return tmp!=NULL ? (*deck=tmp)!=NULL : 0; /* (?success) (:failure) */
}

void InitDeck( int *deck, int nCards ) {
    if( deck != NULL ) {
        int i;

        for( i=0; i<nCards; ++i )
            deck[i] = i;
    }
}

int DuplicateDeck( int **dest, const int *orig, int nCards ) {
    if( orig != NULL && CreateDeck(dest,nCards) ) {
        memcpy( *dest, orig, nCards*sizeof(*orig) );
        return 1; /* success */
    }
    else {
        return 0; /* failure */
    }
}

int InitedDeck( int *deck, int nCards ) {
    int i;

    for( i=0; i<nCards; ++i )
        if( deck[i] != i )
            return 0; /* not inited */

    return 1; /* inited */
}

int ShuffleDeck( int *deck, int nCards ) {
    int *copy = NULL;

    if( DuplicateDeck(&copy,deck,nCards) ) {
        int i, j;

        for( i=j=0; i<nCards/2; ++i, j+=2 ) {
            deck[j] = copy[i];
            deck[j+1] = copy[i+nCards/2];
        }

        FreeDeck( &copy );
        return 1; /* success */
    }
    else {
        return 0; /* failure */
    }
}

void FreeDeck( int **deck ) {
    if( *deck != NULL ) {
        free( *deck );
        *deck = NULL;
    }
}


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

public static class PerfectShuffle
{
    static void Main()
    {
        foreach (int input in new [] {8, 24, 52, 100, 1020, 1024, 10000}) {
            int[] numbers = Enumerable.Range(1, input).ToArray();
            Console.WriteLine($"{input} cards: {ShuffleThrough(numbers).Count()}");
        }

        IEnumerable<T[]> ShuffleThrough<T>(T[] original) {
            T[] copy = (T[])original.Clone();
            do {
                yield return copy = Shuffle(copy);
            } while (!Enumerable.SequenceEqual(original, copy));
        }
    }

    public static T[] Shuffle<T>(T[] array) {
        if (array.Length % 2 != 0) throw new ArgumentException("Length must be even.");
        int half = array.Length / 2;
        T[] result = new T[array.Length];
        for (int t = 0, l = 0, r = half; l < half; t+=2, l++, r++) {
            result[t] = array[l];
            result[t+1] = array[r];
        }
        return result;
    }

}


#include <iostream>
#include <algorithm>
#include <vector>

int pShuffle( int t ) {
    std::vector<int> v, o, r;

    for( int x = 0; x < t; x++ ) {
        o.push_back( x + 1 );
    }

    r = o;
    int t2 = t / 2 - 1, c = 1;

    while( true ) {
        v = r;
        r.clear();

        for( int x = t2; x > -1; x-- ) {
            r.push_back( v[x + t2 + 1] );
            r.push_back( v[x] );
        }

        std::reverse( r.begin(), r.end() );

        if( std::equal( o.begin(), o.end(), r.begin() ) ) return c;
        c++;
    }
}

int main() {
    int s[] = { 8, 24, 52, 100, 1020, 1024, 10000 };
    for( int x = 0; x < 7; x++ ) {
        std::cout << "Cards count: " << s[x] << ", shuffles required: ";
        std::cout << pShuffle( s[x] ) << ".\n";
    }
    return 0;
}


(defn perfect-shuffle [deck]
  (let [half (split-at (/ (count deck) 2) deck)]
    (interleave (first half) (last half))))

(defn solve [deck-size]
  (let [original (range deck-size)
        trials (drop 1 (iterate perfect-shuffle original))
        predicate #(= original %)]
    (println (format "%5s: %s" deck-size
      (inc (some identity (map-indexed (fn [i x] (when (predicate x) i)) trials)))))))

(map solve [8 24 52 100 1020 1024 10000])


(defun perfect-shuffle (deck)
  (let* ((half (floor (length deck) 2))
         (left (subseq deck 0 half))
         (right (nthcdr half deck)))
    (mapcan #'list left right)))

(defun solve (deck-size)
  (loop with original = (loop for n from 1 to deck-size collect n)
        for trials from 1
        for deck = original then shuffled
        for shuffled = (perfect-shuffle deck)
        until (equal shuffled original)
        finally (format t "~5D: ~4D~%" deck-size trials)))

(solve 8)
(solve 24)
(solve 52)
(solve 100)
(solve 1020)
(solve 1024)
(solve 10000)


import std.stdio;

void main() {
    auto sizes = [8, 24, 52, 100, 1020, 1024, 10_000];
    foreach(s; sizes) {
        writefln("%5s : %5s", s, perfectShuffle(s));
    }
}

int perfectShuffle(int size) {
    import std.exception : enforce;
    enforce(size%2==0);

    import std.algorithm : copy, equal;
    import std.range;
    int[] orig = iota(0, size).array;

    int[] process;
    process.length = size;
    copy(orig, process);

    for(int count=1; true; count++) {
        process = roundRobin(process[0..$/2], process[$/2..$]).array;

        if (equal(orig, process)) {
            return count;
        }
    }

    assert(false, "How did this get here?");
}


program Perfect_shuffle;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

type
  TDeck = record
    Cards: TArray<Integer>;
    Len: Integer;
    constructor Create(deckSize: Integer); overload;
    constructor Create(deck: TDeck); overload;
    procedure shuffleDeck();
    class operator Equal(a, b: TDeck): boolean;
    function ShufflesRequired: Integer;
    procedure Assign(a: TDeck);
  end;

{ TDeck }

procedure TDeck.Assign(a: TDeck);
begin
  Len := a.Len;
  Cards := copy(a.Cards, 0, len);
end;

constructor TDeck.Create(deckSize: Integer);
begin
  if deckSize < 1 then
    raise Exception.Create('Error: Deck size must have above zero');

  if Odd(deckSize) then
    raise Exception.Create('Error: Deck size must be even');

  SetLength(Cards, deckSize);
  Len := deckSize;

  for var i := 0 to High(Cards) do
    Cards[i] := i;
end;

constructor TDeck.Create(deck: TDeck);
begin
  Assign(deck);
end;

class operator TDeck.Equal(a, b: TDeck): boolean;
begin
  if a.len <> b.len then
    raise Exception.Create('Error: Decks aren''t equally sized');

  if a.Len = 0 then
    exit(True);

  for var i := 0 to a.Len - 1 do
    if a.Cards[i] <> b.Cards[i] then
      exit(False);

  Result := True;
end;

procedure TDeck.shuffleDeck;
var
  tmp: TArray<Integer>;
begin
  SetLength(tmp, len);
  for var i := 0 to len div 2 - 1 do
  begin
    tmp[i * 2] := Cards[i];
    tmp[i * 2 + 1] := Cards[len div 2 + i];
  end;
  Cards := copy(tmp, 0, len);
end;

function TDeck.ShufflesRequired: Integer;
var
  ref: TDeck;
begin
  Result := 1;
  ref := TDeck.Create(self);
  shuffleDeck;
  while not (self = ref) do
  begin
    shuffleDeck;
    inc(Result);
  end;
end;

const
  cases: TArray<Integer> = [8, 24, 52, 100, 1020, 1024, 10000];

begin
  for var size in cases do
  begin
    var deck := TDeck.Create(size);
    writeln(format('Cards count: %d, shuffles required: %d', [size, deck.ShufflesRequired]));
  end;
  readln;
end.


func shuffle(arr) {
    if arr.Length() % 2 != 0 {
        throw @InvalidValue(arr.Length())
    }
    var half = arr.Length() / 2
    var result = Array.Empty(arr.Length())
    var (t, l, r) = (0, 0, half)

    while l < half {
        result[t] = arr[l]
        result[t+1] = arr[r]
        l += 1
        r += 1
        t += 2
    }
    result
}

func arrayEqual(xs, ys) {
    if xs.Length() != ys.Length() {
        return false
    }
    for i in xs.Indices() {
        if xs[i] != ys[i] {
            return false
        }
    }
    return true
}

func shuffleThrough(original) {
    var copy = original.Clone()

    while true {
        copy = shuffle(copy)
        yield copy
        if arrayEqual(original, copy) {
            break
        }
    }
}

for input in yields { 8, 24, 52, 100, 1020, 1024, 10000} {
    var numbers = [1..input]
    print("\(input) cards: \(shuffleThrough(numbers).Length())")
}


;; shuffler : a permutation vector which interleaves both halves of deck
(define (make-shuffler n)
	(let ((s (make-vector n)))
		(for ((i (in-range 0 n 2))) (vector-set! s i (/ i 2)))
		(for ((i (in-range 0 n 2))) (vector-set! s (1+ i) (+ (/ n 2) (vector-ref s i))))
	 s))

;; output : (n . # of shuffles needed to go back)
(define (magic-shuffle n)
		(when (odd? n) (error "magic-shuffle:odd input" n))
		(let [(deck (list->vector (iota n))) ;; (0 1 ... n-1)
			(dock (list->vector (iota n))) ;; keep trace or init deck
			(shuffler (make-shuffler n))]

		(cons n (1+
		(for/sum ((i Infinity)) ; (in-naturals missing  in EchoLisp v2.9)
			(vector-permute! deck shuffler) ;; permutes in place
		    #:break (eqv? deck dock) ;; compare to first
			1)))))


defmodule Perfect do
  def shuffle(n) do
    start = Enum.to_list(1..n)
    m = div(n, 2)
    shuffle(start, magic_shuffle(start, m), m, 1)
  end

  defp shuffle(start, start, _, step), do: step
  defp shuffle(start, deck, m, step) do
    shuffle(start, magic_shuffle(deck, m), m, step+1)
  end

  defp magic_shuffle(deck, len) do
    {left, right} = Enum.split(deck, len)
    Enum.zip(left, right)
    |> Enum.map(&Tuple.to_list/1)
    |> List.flatten
  end
end

Enum.each([8, 24, 52, 100, 1020, 1024, 10000], fn n ->
  step = Perfect.shuffle(n)
  IO.puts "#{n} : #{step}"
end)


let perfectShuffle xs =
  let h = (List.length xs) / 2
  xs
  |> List.mapi (fun i x->(if i<h then i * 2 else ((i-h) * 2) + 1), x)
  |> List.sortBy fst
  |> List.map snd

let orderCount n =
  let xs = [1..n]
  let rec spin count ys =
    if xs=ys then count
    else ys |> perfectShuffle |> spin (count + 1)
  xs |> perfectShuffle |> spin 1

[ 8; 24; 52; 100; 1020; 1024; 10000 ] |> List.iter (fun n->n |> orderCount |> printfn "%d %d" n)


USING: arrays formatting kernel math prettyprint sequences
sequences.merged ;
IN: rosetta-code.perfect-shuffle

CONSTANT: test-cases { 8 24 52 100 1020 1024 10000 }

: shuffle ( seq -- seq' ) halves 2merge ;

: shuffle-count ( n -- m )
    <iota> >array 0 swap dup [ 2dup = ] [ shuffle [ 1 + ] 2dip ]
    do until 2drop ;

"Deck size" "Number of shuffles required" "%-11s %-11s\n" printf
test-cases [ dup shuffle-count "%-11d %-11d\n" printf ] each


MODULE PERFECT_SHUFFLE
     IMPLICIT NONE

     CONTAINS

     ! Shuffle the deck/array of integers
     FUNCTION SHUFFLE(NUM_ARR)
          INTEGER, DIMENSION(:), INTENT(IN) :: NUM_ARR
          INTEGER, DIMENSION(SIZE(NUM_ARR)) :: SHUFFLE
          INTEGER :: I, IDX

          IF (MOD(SIZE(NUM_ARR), 2) .NE. 0) THEN
              WRITE(*,*) "ERROR: SIZE OF DECK MUST BE EVEN NUMBER"
              CALL EXIT(1)
          END IF

          IDX = 1

          DO I=1, SIZE(NUM_ARR)/2
              SHUFFLE(IDX) = NUM_ARR(I)
              SHUFFLE(IDX+1) = NUM_ARR(SIZE(NUM_ARR)/2+I)
              IDX = IDX + 2
          END DO

    END FUNCTION SHUFFLE

    ! Compare two arrays element by element
    FUNCTION COMPARE_ARRAYS(ARRAY_1, ARRAY_2)
        INTEGER, DIMENSION(:) :: ARRAY_1, ARRAY_2
        LOGICAL :: COMPARE_ARRAYS
        INTEGER :: I

        DO I=1,SIZE(ARRAY_1)
            IF (ARRAY_1(I) .NE. ARRAY_2(I)) THEN
                COMPARE_ARRAYS = .FALSE.
                RETURN
            END IF
        END DO

        COMPARE_ARRAYS = .TRUE.
    END FUNCTION COMPARE_ARRAYS

    ! Generate a deck/array of consecutive integers
    FUNCTION GEN_DECK(DECK_SIZE)
        INTEGER, INTENT(IN) :: DECK_SIZE
        INTEGER, DIMENSION(DECK_SIZE) :: GEN_DECK
        INTEGER :: I

        GEN_DECK = (/(I, I=1,DECK_SIZE)/)
    END FUNCTION GEN_DECK
END MODULE PERFECT_SHUFFLE

! Program to demonstrate the perfect shuffle algorithm
! for various deck sizes
PROGRAM DEMO_PERFECT_SHUFFLE
    USE PERFECT_SHUFFLE
    IMPLICIT NONE

    INTEGER, PARAMETER, DIMENSION(7) :: DECK_SIZES = (/8, 24, 52, 100, 1020, 1024, 10000/)
    INTEGER, DIMENSION(:), ALLOCATABLE :: DECK, SHUFFLED
    INTEGER :: I, COUNTER

    WRITE(*,'(A, A, A)') "input (deck size)", " | ", "output (number of shuffles required)"
    WRITE(*,*) REPEAT("-", 55)

    DO I=1, SIZE(DECK_SIZES)
        IF (I .GT. 1) THEN
            DEALLOCATE(DECK)
            DEALLOCATE(SHUFFLED)
        END IF
        ALLOCATE(DECK(DECK_SIZES(I)))
        ALLOCATE(SHUFFLED(DECK_SIZES(I)))
        DECK = GEN_DECK(DECK_SIZES(I))
        SHUFFLED = SHUFFLE(DECK)
        COUNTER = 1
        DO WHILE (.NOT. COMPARE_ARRAYS(DECK, SHUFFLED))
            SHUFFLED = SHUFFLE(SHUFFLED)
            COUNTER = COUNTER + 1
        END DO

        WRITE(*,'(I17, A, I35)') DECK_SIZES(I), " | ", COUNTER
   END DO
END PROGRAM DEMO_PERFECT_SHUFFLE


function is_in_order( d() as uinteger ) as boolean
    'tests if a deck is in order
    for i as uinteger = lbound(d) to ubound(d)-1
        if d(i) > d(i+1) then return false
    next i
    return true
end function

sub init_deck( d() as uinteger )
    for i as uinteger = 1 to ubound(d)
        d(i) = i
    next i
    return
end sub

sub shuffle( d() as uinteger )
    'does a faro shuffle of the deck
    dim as integer n = ubound(d), i
    dim as integer b( 1 to n )
    for i = 1 to n/2
        b(2*i-1) = d(i)
        b(2*i)   = d(n/2+i)
    next i
    for i = 1 to n
        d(i) = b(i)
    next i
    return
end sub

function shufs_needed( size as integer ) as uinteger
    dim as uinteger d(1 to size), s = 0
    init_deck(d())
    do
        shuffle(d())
        s+=1
        if is_in_order(d()) then exit do
    loop
    return s
end function

dim as uinteger tests(1 to 7) = {8, 24, 52, 100, 1020, 1024, 10000}, i
for i = 1 to 7
    print tests(i);" cards require "; shufs_needed(tests(i)); " shuffles."
next i


package main

import "fmt"

type Deck struct {
	Cards []int
	length int
}

func NewDeck(deckSize int) (res *Deck){
	if deckSize % 2 != 0{
		panic("Deck size must be even")
	}
	res = new(Deck)
	res.Cards = make([]int, deckSize)
	res.length = deckSize
	for i,_ := range  res.Cards{
		res.Cards[i] = i
	}
	return
}
func (d *Deck)shuffleDeck(){
	tmp := make([]int,d.length)
	for i := 0;i <d.length/2;i++  {
		tmp[i*2] = d.Cards[i]
		tmp[i*2+1] = d.Cards[d.length / 2 + i]
	}
	d.Cards = tmp
}
func (d *Deck) isEqualTo(c Deck) (res bool) {
	if d.length != c.length {
		panic("Decks aren't equally sized")
	}
	res = true
	for i, v := range d.Cards{
		if v != c.Cards[i] {
			res = false
		}
	}
	return
}

func main(){
	for _,v := range []int{8,24,52,100,1020,1024,10000} {
		fmt.Printf("Cards count: %d, shuffles required: %d\n",v,ShufflesRequired(v))
	}
}

func ShufflesRequired(deckSize int)(res int){
	deck := NewDeck(deckSize)
	Ref := *deck
	deck.shuffleDeck()
	res++
	for ;!deck.isEqualTo(Ref);deck.shuffleDeck(){
		res++
	}
	return
}


shuffle :: [a] -> [a]
shuffle lst = let (a,b) = splitAt (length lst `div` 2) lst
              in foldMap (\(x,y) -> [x,y]) $ zip a b

findCycle :: Eq a => (a -> a) -> a -> [a]
findCycle f x = takeWhile (/= x) $ iterate f (f x)

main = mapM_ report [ 8, 24, 52, 100, 1020, 1024, 10000 ]
  where
    report n = putStrLn ("deck of " ++ show n ++ " cards: "
                         ++ show (countSuffles n) ++ " shuffles!")
    countSuffles n = 1 + length (findCycle shuffle [1..n])


import java.util.Arrays;
import java.util.stream.IntStream;

public class PerfectShuffle {

    public static void main(String[] args) {
        int[] sizes = {8, 24, 52, 100, 1020, 1024, 10_000};
        for (int size : sizes)
            System.out.printf("%5d : %5d%n", size, perfectShuffle(size));
    }

    static int perfectShuffle(int size) {
        if (size % 2 != 0)
            throw new IllegalArgumentException("size must be even");

        int half = size / 2;
        int[] a = IntStream.range(0, size).toArray();
        int[] original = a.clone();
        int[] aa = new int[size];

        for (int count = 1; true; count++) {
            System.arraycopy(a, 0, aa, 0, size);

            for (int i = 0; i < half; i++) {
                a[2 * i] = aa[i];
                a[2 * i + 1] = aa[i + half];
            }

            if (Arrays.equals(a, original))
                return count;
        }
    }
}


(() => {
    'use strict';

    // shuffleCycleLength :: Int -> Int
    const shuffleCycleLength = deckSize =>
        firstCycle(shuffle, range(1, deckSize))
        .all.length;

    // shuffle :: [a] -> [a]
    const shuffle = xs =>
        concat(zip.apply(null, splitAt(div(length(xs), 2), xs)));

    // firstycle :: Eq a => (a -> a) -> a -> [a]
    const firstCycle = (f, x) =>
        until(
            m => EqArray(x, m.current),
            m => {
                const fx = f(m.current);
                return {
                    current: fx,
                    all: m.all.concat([fx])
                };
            }, {
                current: f(x),
                all: [x]
            }
        );

    // Two arrays equal ?
    // EqArray :: [a] -> [b] -> Bool
    const EqArray = (xs, ys) => {
        const [nx, ny] = [xs.length, ys.length];
        return nx === ny ? (
            nx > 0 ? (
                xs[0] === ys[0] && EqArray(xs.slice(1), ys.slice(1))
            ) : true
        ) : false;
    };

    // GENERIC FUNCTIONS

    // zip :: [a] -> [b] -> [(a,b)]
    const zip = (xs, ys) =>
        xs.slice(0, Math.min(xs.length, ys.length))
        .map((x, i) => [x, ys[i]]);

    // concat :: [[a]] -> [a]
    const concat = xs => [].concat.apply([], xs);

    // splitAt :: Int -> [a] -> ([a],[a])
    const splitAt = (n, xs) => [xs.slice(0, n), xs.slice(n)];

    // div :: Num -> Num -> Int
    const div = (x, y) => Math.floor(x / y);

    // until :: (a -> Bool) -> (a -> a) -> a -> a
    const until = (p, f, x) => {
        const go = x => p(x) ? x : go(f(x));
        return go(x);
    }

    // range :: Int -> Int -> [Int]
    const range = (m, n) =>
        Array.from({
            length: Math.floor(n - m) + 1
        }, (_, i) => m + i);

    // length :: [a] -> Int
    // length :: Text -> Int
    const length = xs => xs.length;

    // maximumBy :: (a -> a -> Ordering) -> [a] -> a
    const maximumBy = (f, xs) =>
        xs.reduce((a, x) => a === undefined ? x : (
            f(x, a) > 0 ? x : a
        ), undefined);

    // transpose :: [[a]] -> [[a]]
    const transpose = xs =>
        xs[0].map((_, iCol) => xs.map((row) => row[iCol]));

    // show :: a -> String
    const show = x => JSON.stringify(x, null, 2);

    // replicateS :: Int -> String -> String
    const replicateS = (n, s) => {
        let v = s,
            o = '';
        if (n < 1) return o;
        while (n > 1) {
            if (n & 1) o = o.concat(v);
            n >>= 1;
            v = v.concat(v);
        }
        return o.concat(v);
    };

    // justifyRight :: Int -> Char -> Text -> Text
    const justifyRight = (n, cFiller, strText) =>
        n > strText.length ? (
            (replicateS(n, cFiller) + strText)
            .slice(-n)
        ) : strText;

    // TEST
    return transpose(transpose([
                ['Deck', 'Shuffles']
            ].concat(
                [8, 24, 52, 100, 1020, 1024, 10000]
                .map(n => [n.toString(), shuffleCycleLength(n)
                    .toString()
                ])))
            .map(col => { // Right-justified number columns
                const width = length(
                    maximumBy((a, b) => length(a) - length(b), col)
                ) + 2;

                return col.map(x => justifyRight(width, ' ', x));
            }))
        .map(row => row.join(''))
        .join('\n');
})();


def perfect_shuffle:
  . as $a
  | if (length % 2) == 1 then "cannot perform perfect shuffle on odd-length array" | error
    else (length / 2) as $mid
    | reduce range(0; $mid) as $i (null;
       .[2*$i] = $a[$i]
       | .[2*$i + 1] =  $a[$mid+$i] )
    end;

# How many iterations of f are required to get back to . ?
def recurrence(f):
  def r:
    # input: [$init, $current, $count]
    (.[1]|f) as $next
    | if .[0] == $next then .[-1] + 1
      else [.[0], $next, .[-1]+1] | r
      end;
   [., ., 0] | r;

def count_perfect_shuffles:
  [range(0;.)] | recurrence(perfect_shuffle);

(8, 24, 52, 100, 1020, 1024, 10000, 100000)
| [., count_perfect_shuffles]


using Printf

function perfect_shuffle(a::Array)::Array
    if isodd(length(a)) error("cannot perform perfect shuffle on odd-length array") end

    rst = zeros(a)
    mid = div(length(a), 2)
    for i in 1:mid
        rst[2i-1], rst[2i] = a[i], a[mid+i]
    end
    return rst
end

function count_perfect_shuffles(decksize::Int)::Int
    a = collect(1:decksize)
    b, c = perfect_shuffle(a), 1
    while a != b
        b = perfect_shuffle(b)
        c += 1
    end
    return c
end

println("    Deck  n.Shuffles")
for i in (8, 24, 52, 100, 1020, 1024, 10000, 100000)
    count = count_perfect_shuffles(i)
    @printf("%7i%7i\n", i, count)
end


// version 1.1.2

fun areSame(a: IntArray, b: IntArray): Boolean {
    for (i in 0 until a.size) if (a[i] != b[i]) return false
    return true
}

fun perfectShuffle(a: IntArray): IntArray {
    var b = IntArray(a.size)
    val hSize = a.size / 2
    for (i in 0 until hSize) b[i * 2] = a[i]
    var j = 1
    for (i in hSize until a.size) {
        b[j] = a[i]
        j += 2
    }
    return b
}

fun countShuffles(a: IntArray): Int {
    require(a.size >= 2 && a.size % 2 == 0)
    var b = a
    var count = 0
    while (true) {
        val c = perfectShuffle(b)
        count++
        if (areSame(a, c)) return count
        b = c
    }
}

fun main(args: Array<String>) {
    println("Deck size  Num shuffles")
    println("---------  ------------")
    val sizes = intArrayOf(8, 24, 52, 100, 1020, 1024, 10000)
    for (size in sizes) {
        val a = IntArray(size) { it }
        val count = countShuffles(a)
        println("${"%-9d".format(size)}     $count")
    }
}


-- Perform weave shuffle
function shuffle (cards)
    local pile1, pile2 = {}, {}
    for card = 1, #cards / 2 do table.insert(pile1, cards[card]) end
    for card = (#cards / 2) + 1, #cards do table.insert(pile2, cards[card]) end
    cards = {}
    for card = 1, #pile1 do
        table.insert(cards, pile1[card])
        table.insert(cards, pile2[card])
    end
    return cards
end

-- Return boolean indicating whether or not the cards are in order
function inOrder (cards)
    for k, v in pairs(cards) do
        if k ~= v then return false end
    end
    return true
end

-- Count the number of shuffles needed before the cards are in order again
function countShuffles (deckSize)
    local deck, count = {}, 0
    for i = 1, deckSize do deck[i] = i end
    repeat
        deck = shuffle(deck)
        count = count + 1
    until inOrder(deck)
    return count
end

-- Main procedure
local testCases = {8, 24, 52, 100, 1020, 1024, 10000}
print("Input", "Output")
for _, case in pairs(testCases) do print(case, countShuffles(case)) end


shuffle[deck_] := Apply[Riffle, TakeDrop[deck, Length[deck]/2]];
shuffleCount[n_] := Block[{count=0}, NestWhile[shuffle, shuffle[Range[n]], (count++; OrderedQ[#] )&];count];
Map[shuffleCount, {8, 24, 52, 100, 1020, 1024, 10000}]


function [New]=PerfectShuffle(Nitems, Nturns)
    if mod(Nitems,2)==0 %only if even number
        X=1:Nitems; %define deck
        for c=1:Nturns %defines one shuffle
            X=reshape(X,Nitems/2,2)'; %split the deck in two and stack halves
            X=X(:)'; %mix the halves
        end
        New=X; %result of multiple shufflings
    end


MODULE PerfectShuffle;
FROM FormatString IMPORT FormatString;
FROM Storage IMPORT ALLOCATE,DEALLOCATE;
FROM SYSTEM IMPORT ADDRESS,TSIZE;
FROM Terminal IMPORT WriteString,WriteLn,ReadChar;

PROCEDURE WriteCard(c : CARDINAL);
VAR buf : ARRAY[0..15] OF CHAR;
BEGIN
    FormatString("%c", buf, c);
    WriteString(buf)
END WriteCard;

PROCEDURE Init(VAR arr : ARRAY OF INTEGER);
VAR i : CARDINAL;
BEGIN
    FOR i:=0 TO HIGH(arr) DO
        arr[i] := i + 1
    END
END Init;

PROCEDURE PerfectShuffle(VAR arr : ARRAY OF INTEGER);
    PROCEDURE Inner(ti : CARDINAL);
    VAR
        tv : INTEGER;
        tp,tn,n : CARDINAL;
    BEGIN
        n := HIGH(arr);
        tn := ti;
        tv := arr[ti];
        REPEAT
            tp := tn;
            IF tp MOD 2 = 0 THEN
                tn := tp / 2
            ELSE
                tn := (n+1)/2+tp/2
            END;
            arr[tp] := arr[tn];
        UNTIL tn = ti;
        arr[tp] := tv
    END Inner;
VAR
    done : BOOLEAN;
    i,c : CARDINAL;
BEGIN
    c := 0;
    Init(arr);

    REPEAT
        i := 1;
        WHILE i <= (HIGH(arr)/2) DO
            Inner(i);
            INC(i,2)
        END;
        INC(c);

        done := TRUE;
        FOR i:=0 TO HIGH(arr) DO
            IF arr[i] # INT(i+1) THEN
                done := FALSE;
                BREAK
            END
        END
    UNTIL done;

    WriteCard(HIGH(arr)+1);
    WriteString(": ");
    WriteCard(c);
    WriteLn
END PerfectShuffle;

(* Main *)
VAR
        v8 : ARRAY[1..8] OF INTEGER;
       v24 : ARRAY[1..24] OF INTEGER;
       v52 : ARRAY[1..52] OF INTEGER;
      v100 : ARRAY[1..100] OF INTEGER;
     v1020 : ARRAY[1..1020] OF INTEGER;
     v1024 : ARRAY[1..1024] OF INTEGER;
    v10000 : ARRAY[1..10000] OF INTEGER;
BEGIN
    PerfectShuffle(v8);
    PerfectShuffle(v24);
    PerfectShuffle(v52);
    PerfectShuffle(v100);
    PerfectShuffle(v1020);
    PerfectShuffle(v1024);
    PerfectShuffle(v10000);

    ReadChar
END PerfectShuffle.


import sequtils, strutils

proc newValList(size: Positive): seq[int] =
  if (size and 1) != 0:
    raise newException(ValueError, "size must be even.")
  result = toSeq(1..size)

func shuffled(list: seq[int]): seq[int] =
  result.setLen(list.len)
  let half = list.len div 2
  for i in 0..<half:
    result[2 * i] = list[i]
    result[2 * i + 1] = list[half + i]

for size in [8, 24, 52, 100, 1020, 1024, 10000]:
  let initList = newValList(size)
  var valList = initList
  var count = 0
  while true:
    inc count
    valList = shuffled(valList)
    if valList == initList:
      break
  echo ($size).align(5), ": ", ($count).align(4)


: shuffle(l)     l size 2 / dup l left swap l right zip expand ;
: nbShuffles(l)  1 l while( shuffle dup l <> ) [ 1 under+ ] drop ;


use List::Util qw(all);

sub perfect_shuffle {
   my $mid = @_ / 2;
   map { @_[$_, $_ + $mid] } 0..($mid - 1);
}

for my $size (8, 24, 52, 100, 1020, 1024, 10000) {

    my @shuffled = my @deck = 1 .. $size;
    my $n = 0;
    do { $n++; @shuffled = perfect_shuffle(@shuffled) }
        until all { $shuffled[$_] == $deck[$_] } 0..$#shuffled;

    printf "%5d cards: %4d\n", $size, $n;
}


with javascript_semantics
function perfect_shuffle(sequence deck)
    integer l = length(deck), mp = l/2, k = 1
    sequence res = repeat(0,l)
    for i=1 to mp do
        res[k] = deck[i]        k += 1
        res[k] = deck[i+mp]     k += 1
    end for
    return res
end function

constant testsizes = {8, 24, 52, 100, 1020, 1024, 10000}
for i=1 to length(testsizes) do
    sequence deck = tagset(testsizes[i])
    sequence work = perfect_shuffle(deck)
    integer count = 1
    while work!=deck do
        work = perfect_shuffle(work)
        count += 1
    end while
    printf(1,"%5d cards: %4d\n", {testsizes[i],count})
end for


go =>
   member(N,[8,24,52,100,1020,1024,10_000]),
   println(n=N),
   InOut = out, % in/out shuffling
   println(inOut=InOut),
   Print = cond(N < 100, true,false),
   if Print then
     println(1..N),
   end,
   Count = show_all_shuffles(N,InOut,Print),
   println(count=Count),
   nl,
   fail,
   nl.

%
% Show all the shuffles
%
show_all_shuffles(N,InOut) = show_all_shuffles(N,InOut,false).
show_all_shuffles(N,InOut,Print) = Count =>
   Order = 1..N,
   Perfect1 = perfect_shuffle(1..N,InOut),
   Perfect = copy_term(Perfect1),
   if Print == true then
     println(Perfect)
   end,
   Count = 1,
   while (Perfect != Order)
     Perfect := [Perfect1[Perfect[I]] : I in 1..N],
     if Print == true then
       println(Perfect)
     end,
     Count := Count + 1
   end.

%
% Perfect shuffle a list
%
% InOut = in|out
%  in: first card in Top half is the first card in the new deck
%  out: first card in Bottom half is the first card in the new deck
%
perfect_shuffle(List,InOut) = Perfect =>
   [Top,Bottom] = split_deck(List,InOut),
   if InOut = out then
     Perfect = zip2(Top,Bottom)
   else
     Perfect = zip2(Bottom,Top)
   end.

%
% split the deck in two "halves"
%
% For odd out shuffles, we have to adjust the
% range of the top and bottom.
%
split_deck(L,InOut) = [Top,Bottom] =>
  N = L.len,
  if InOut = out, N mod 2 = 1 then
    Top = 1..(N div 2)+1,
    Bottom = (N div 2)+2..N
  else
    Top = 1..(N div 2),
    Bottom = (N div 2)+1..N
  end.

%
% If L1 and L2 has uneven lengths, we add the odd element last
% in the resulting list.
%
zip2(L1,L2) = R =>
  L1Len = L1.len,
  L2Len = L2.len,
  R1 = [],
  foreach(I in 1..min(L1Len,L2Len))
    R1 := R1 ++ [L1[I],L2[I]]
  end,
  if L1Len < L2Len then
    R1 := R1 ++ [L2[L2Len]]
  elseif L1Len > L2Len then
    R1 := R1 ++ [L1[L1Len]]
  end,
  R = R1.


(de perfectShuffle (Lst)
   (mapcan '((B A) (list A B))
      (cdr (nth Lst (/ (length Lst) 2)))
      Lst ) )

(for N (8 24 52 100 1020 1024 10000)
   (let (Lst (range 1 N)  L Lst  Cnt 1)
      (until (= Lst (setq L (perfectShuffle L)))
         (inc 'Cnt) )
      (tab (5 6) N Cnt) ) )


import doctest
import random

def flatten(lst):
    """
    >>> flatten([[3,2],[1,2]])
    [3, 2, 1, 2]
    """
    return [i for sublst in lst for i in sublst]

def magic_shuffle(deck):
    """
    >>> magic_shuffle([1,2,3,4])
    [1, 3, 2, 4]
    """
    half = len(deck) // 2
    return flatten(zip(deck[:half], deck[half:]))

def after_how_many_is_equal(shuffle_type,start,end):
    """
    >>> after_how_many_is_equal(magic_shuffle,[1,2,3,4],[1,2,3,4])
    2
    """

    start = shuffle_type(start)
    counter = 1
    while start != end:
        start = shuffle_type(start)
        counter += 1
    return counter

def main():
    doctest.testmod()

    print("Length of the deck of cards | Perfect shuffles needed to obtain the same deck back")
    for length in (8, 24, 52, 100, 1020, 1024, 10000):
        deck = list(range(length))
        shuffles_needed = after_how_many_is_equal(magic_shuffle,deck,deck)
        print("{} | {}".format(length,shuffles_needed))

if __name__ == "__main__":
    main()


  [ [] swap
    times [ i^ join ] ]       is deck     ( n --> [ )

  [ dup size 2 / split swap
    witheach
      [ swap i^ 2 * stuff ] ] is weave    ( [ --> [ )

  [ 0 swap
    deck dup
    [ rot 1+ unrot
      weave 2dup = until ]
    2drop ]                   is shuffles ( n --> n )

' [ 8 24 52 100 1020 1024 10000 ]

witheach
  [ say "A deck of "
    dup echo say " cards needs "
    shuffles echo say " shuffles."
    cr ]


wave.shuffle <- function(n) {
  deck <- 1:n ## create the original deck
  new.deck <- c(matrix(data = deck, ncol = 2, byrow = TRUE)) ## shuffle the deck once
  counter <- 1 ## track the number of loops
  ## defining a loop that shuffles the new deck until identical with the original one
  ## and in the same time increses the counter with 1 per loop
  while (!identical(deck, new.deck)) { ## logical condition
    new.deck <- c(matrix(data = new.deck, ncol = 2, byrow = TRUE)) ## shuffle
    counter <- counter + 1 ## add 1 to the number of loops
  }
  return(counter) ## final result - total number of loops until the condition is met
}
test.values <- c(8, 24, 52, 100, 1020, 1024, 10000) ## the set of the test values
test <- sapply(test.values, wave.shuffle) ## apply the wave.shuffle function on each element
names(test) <- test.values ## name the result
test ## print the result out


#lang racket/base
(require racket/list)

(define (perfect-shuffle l)
  (define-values (as bs) (split-at l (/ (length l) 2)))
  (foldr (λ (a b d) (list* a b d)) null as bs))

(define (perfect-shuffles-needed n)
  (define-values (_ rv)
    (for/fold ((d (perfect-shuffle (range n))) (i 1))
              ((_ (in-naturals))
               #:break (apply < d))
      (values (perfect-shuffle d) (add1 i))))
  rv)

(module+ test
  (require rackunit)
  (check-equal? (perfect-shuffle '(1 2 3 4)) '(1 3 2 4))

  (define (test-perfect-shuffles-needed n e)
    (define psn (perfect-shuffles-needed n))
    (printf "Deck size:\t~a\tShuffles needed:\t~a\t(~a)~%" n psn e)
    (check-equal? psn e))

  (for-each test-perfect-shuffles-needed
            '(8 24 52 100 1020 1024 10000)
            '(3 11  8  30 1018   10   300)))


sub perfect-shuffle (@deck) {
    my $mid = @deck / 2;
    flat @deck[0 ..^ $mid] Z @deck[$mid .. *];
}

for 8, 24, 52, 100, 1020, 1024, 10000 -> $size {
    my @deck = ^$size;
    my $n;
    repeat until [<] @deck {
        $n++;
        @deck = perfect-shuffle @deck;
    }

    printf "%5d cards: %4d\n", $size, $n;
}


/*REXX program performs a  "perfect shuffle"  for a number of  even numbered  decks.    */
parse arg X                                      /*optional list of test cases from C.L.*/
if X=''  then X=8 24 52 100 1020 1024 10000      /*Not specified?  Then use the default.*/
w=length(word(X, words(X)))                      /*used for right─aligning the numbers. */

    do j=1  for words(X);  y=word(X,j)           /*use numbers in the test suite (list).*/

      do k=1  for y;       @.k=k;      end /*k*/ /*generate a deck to be used (shuffled)*/
      do t=1  until eq();  call magic; end /*t*/ /*shuffle until  before  equals  after.*/

    say 'deck size:'    right(y,w)","       right(t,w)      'perfect shuffles.'
    end   /*j*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
eq:    do ?=1  for y;   if @.?\==?  then return 0;   end;           return 1
/*──────────────────────────────────────────────────────────────────────────────────────*/
magic: z=0                                       /*set the  Z  pointer  (used as index).*/
       h=y%2                                     /*get the half─way (midpoint) pointer. */
                do s=1  for h;  z=z+1;  h=h+1    /*traipse through the card deck pips.  */
                !.[email protected].s;        z=z+1            /*assign left half; then bump pointer. */
                !.[email protected].h                          /*   "   right  "                      */
                end   /*s*/                      /*perform a perfect shuffle of the deck*/

                do r=1  for y;  @.r=!.r;  end    /*re─assign to the original card deck. */
       return


def perfect_shuffle(deck_size = 52)
  deck     = (1..deck_size).to_a
  original = deck.dup
  half     = deck_size / 2
  1.step do |i|
    deck = deck.first(half).zip(deck.last(half)).flatten
    return i if deck == original
  end
end

[8, 24, 52, 100, 1020, 1024, 10000].each {|i| puts "Perfect shuffles required for deck size #{i}: #{perfect_shuffle(i)}"}


extern crate itertools;

fn shuffle<T>(mut deck: Vec<T>) -> Vec<T> {
    let index = deck.len() / 2;
    let right_half = deck.split_off(index);
    itertools::interleave(deck, right_half).collect()
}

fn main() {
    for &size in &[8, 24, 52, 100, 1020, 1024, 10_000] {
        let original_deck: Vec<_> = (0..size).collect();
        let mut deck = original_deck.clone();
        let mut iterations = 0;
        loop {
            deck = shuffle(deck);
            iterations += 1;
            if deck == original_deck {
                break;
            }
        }
        println!("{: >5}: {: >4}", size, iterations);
    }
}


object PerfectShuffle extends App {
  private def sizes = Seq(8, 24, 52, 100, 1020, 1024, 10000)

  private def perfectShuffle(size: Int): Int = {
    require(size % 2 == 0, "Card deck must be even")

    val (half, a) = (size / 2, Array.range(0, size))
    val original = a.clone
    var count = 1
    while (true) {
      val aa = a.clone
      for (i <- 0 until half) {
        a(2 * i) = aa(i)
        a(2 * i + 1) = aa(i + half)
      }
      if (a.deep == original.deep) return count
      count += 1
    }
    0
  }

  for (size <- sizes) println(f"$size%5d : ${perfectShuffle(size)}%5d")

}


function New=PerfectShuffle(Nitems,Nturns)
    if modulo(Nitems,2)==0 then
        X=1:Nitems;
        for c=1:Nturns
            X=matrix(X,Nitems/2,2)';
            X=X(:);
        end
        New=X';
    end
endfunction

Result=[];
Q=[8, 24, 52, 100, 1020, 1024, 10000];
for n=Q
    Same=0;
    T=0;
    Compare=[];
    while ~Same
        T=T+1;
        R=PerfectShuffle(n,T);
        Compare = find(R-(1:n));
        if Compare == [] then
            Same = 1;
        end
    end
    Result=[Result;T];
end
disp([Q', Result])


func perfect_shuffle(deck) {
     deck/2 -> zip.flat
}

[8, 24, 52, 100, 1020, 1024, 10000].each { |size|
    var deck = @(1..size)
    var shuffled = deck

    var n = (1..Inf -> lazy.first {
        (shuffled = perfect_shuffle(shuffled)) == deck
    })

    printf("%5d cards: %4d\n", size, n)
}


func perfectShuffle<T>(_ arr: [T]) -> [T]? {
  guard arr.count & 1 == 0 else {
    return nil
  }

  let half = arr.count / 2
  var res = [T]()

  for i in 0..<half {
    res.append(arr[i])
    res.append(arr[i + half])
  }

  return res
}

let decks = [
  Array(1...8),
  Array(1...24),
  Array(1...52),
  Array(1...100),
  Array(1...1020),
  Array(1...1024),
  Array(1...10000)
]

for deck in decks {
  var shuffled = deck
  var shuffles = 0

  repeat {
    shuffled = perfectShuffle(shuffled)!
    shuffles += 1
  } while shuffled != deck

  print("Deck of \(shuffled.count) took \(shuffles) shuffles to get back to original order")
}


namespace eval shuffle {

    proc perfect {deck} {
        if {[llength $deck]%2} {
            return -code error "Deck must be of even length!"
        }
        set split [expr {[llength $deck]/2}]
        set top [lrange $deck 0 $split-1]
        set btm [lrange $deck $split end]
        foreach a $top b $btm {
            lappend res $a $b
        }
        return $res
    }

    proc cycle_length {transform deck} {
        set d $deck
        while 1 {
            set d [$transform $d]
            incr i
            if {$d eq $deck} {return $i}
        }
        return $i
    }

    proc range {a {b ""}} {
        if {$b eq ""} {
            set b $a; set a 0
        }
        set res {}
        while {$a < $b} {
            lappend res $a
            incr a
        }
        return $res
    }

}

set ::argv {}
package require tcltest
tcltest::test "Test perfect shuffle cycles" {} -body {
    lmap size {8 24 52 100 1020 1024 10000} {
        shuffle::cycle_length perfect [range $size]
    }
} -result {3 11 8 30 1018 10 300}


Option Explicit

Sub Main()
Dim T, Arr, X As Long, C As Long
   Arr = Array(8, 24, 52, 100, 1020, 1024, 10000)
   For X = LBound(Arr) To UBound(Arr)
      C = 0
      Call PerfectShuffle(T, CLng(Arr(X)), C)
      Debug.Print Right(String(19, " ") & "For " & Arr(X) & " cards => ", 19) & C & " shuffles needed."
      Erase T
   Next
End Sub

Private Sub PerfectShuffle(tb, NbCards As Long, Count As Long)
Dim arr1, arr2, StrInit As String, StrTest As String

   tb = CreateArray(1, NbCards)
   StrInit = Join(tb, " ")
   Do
      Count = Count + 1
      Call DivideArr(tb, arr1, arr2)
      tb = RemakeArray(arr1, arr2)
      StrTest = Join(tb, " ")
   Loop While StrTest <> StrInit
End Sub

Private Function CreateArray(First As Long, Length As Long) As String()
Dim i As Long, T() As String, C As Long
   If IsEven(Length) Then
      ReDim T(Length - 1)
      For i = First To First + Length - 1
         T(C) = i
         C = C + 1
      Next i
      CreateArray = T
   End If
End Function

Private Sub DivideArr(A, B, C)
Dim i As Long
   B = A
   ReDim Preserve B(UBound(A) \ 2)
   ReDim C(UBound(B))
   For i = LBound(C) To UBound(C)
      C(i) = A(i + UBound(B) + 1)
   Next
End Sub

Private Function RemakeArray(A1, A2) As String()
Dim i As Long, T() As String, C As Long
   ReDim T((UBound(A2) * 2) + 1)
   For i = LBound(T) To UBound(T) - 1 Step 2
      T(i) = A1(C)
      T(i + 1) = A2(C)
      C = C + 1
   Next
   RemakeArray = T
End Function

Private Function IsEven(Number As Long) As Boolean
    IsEven = (Number Mod 2 = 0)
End Function


import "/fmt" for Fmt

var areSame = Fn.new { |a, b|
    for (i in 0...a.count) if (a[i] != b[i]) return false
    return true
}

var perfectShuffle = Fn.new { |a|
    var n = a.count
    var b = List.filled(n, 0)
    var hSize = (n/2).floor
    for (i in 0...hSize) b[i * 2] = a[i]
    var j = 1
    for (i in hSize...n) {
        b[j] = a[i]
        j = j + 2
    }
    return b
}

var countShuffles = Fn.new { |a|
    var n = a.count
    if (n < 2 || n % 2 == 1) Fiber.abort("Array must be even-sized and non-empty.")
    var b = a
    var count = 0
    while (true) {
        var c = perfectShuffle.call(b)
        count = count + 1
        if (areSame.call(a, c)) return count
        b = c
    }
}

System.print("Deck size  Num shuffles")
System.print("---------  ------------")
var sizes = [8, 24, 52, 100, 1020, 1024, 10000]
for (size in sizes) {
    var a = List.filled(size, 0)
    for (i in 1...size) a[i] = i
    var count = countShuffles.call(a)
    Fmt.print("$-9d     $d", size, count)
}


int     Deck(10000), Deck0(10000);
int     Cases, Count, Test, Size, I;

proc    Shuffle;                \Do perfect shuffle of Deck0 into Deck
int     DeckLeft, DeckRight;
int     I;
[DeckLeft:= Deck0;
DeckRight:= Deck0 + Size*4/2;   \4 bytes per integer
for I:= 0 to Size-1 do
        Deck(I):= if I&1 then DeckRight(I/2)
                         else DeckLeft(I/2);
];

[Cases:= [8, 24, 52, 100, 1020, 1024, 10000];
for Test:= 0 to 7-1 do
        [Size:= Cases(Test);
        for I:= 0 to Size-1 do Deck(I):= I;
        Count:= 0;
        repeat  for I:= 0 to Size-1 do Deck0(I):= Deck(I);
                Shuffle;
                Count:= Count+1;
                for I:= 0 to Size-1 do
                        if Deck(I) # I then I:= Size;
        until   I = Size;       \equal starting configuration
        IntOut(0, Size);  ChOut(0, 9\tab\);  IntOut(0, Count);  CrLf(0);
        ];
]


fcn perfectShuffle(numCards){
   deck,shuffle,n,N:=numCards.pump(List),deck,0,numCards/2;
   do{ shuffle=shuffle[0,N].zip(shuffle[N,*]).flatten(); n+=1 }
   while(deck!=shuffle);
   n
}
foreach n in (T(8,24,52,100,1020,1024,10000)){
   println("%5d : %d".fmt(n,perfectShuffle(n)));
}


F perf(n)
   V sum = 0
   L(i) 1 .< n
      I n % i == 0
         sum += i
   R sum == n

L(i) 1..10000
   I perf(i)
      print(i, end' ‘ ’)


*        Perfect numbers           15/05/2016
PERFECTN CSECT
         USING  PERFECTN,R13       prolog
SAVEAREA B      STM-SAVEAREA(R15)  "
         DC     17F'0'             "
STM      STM    R14,R12,12(R13)    "
         ST     R13,4(R15)         "
         ST     R15,8(R13)         "
         LR     R13,R15            "
         LA     R6,2               i=2
LOOPI    C      R6,NN              do i=2 to nn
         BH     ELOOPI
         LR     R1,R6              i
         BAL    R14,PERFECT
         LTR    R0,R0              if perfect(i)
         BZ     NOTPERF
         XDECO  R6,PG              edit i
         XPRNT  PG,L'PG            print i
NOTPERF  LA     R6,1(R6)           i=i+1
         B      LOOPI
ELOOPI   L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    "
         XR     R15,R15            "
         BR     R14                exit
PERFECT  SR     R9,R9              function perfect(n); sum=0
         LA     R7,1               j
         LR     R8,R1              n
         SRA    R8,1               n/2
LOOPJ    CR     R7,R8              do j=1 to n/2
         BH     ELOOPJ
         LR     R4,R1              n
         SRDA   R4,32
         DR     R4,R7              n/j
         LTR    R4,R4              if mod(n,j)=0
         BNZ    NOTMOD
         AR     R9,R7              sum=sum+j
NOTMOD   LA     R7,1(R7)           j=j+1
         B      LOOPJ
ELOOPJ   SR     R0,R0              r0=false
         CR     R9,R1              if sum=n
         BNE    NOTEQ
         BCTR   R0,0               r0=true
NOTEQ    BR     R14                return(r0); end perfect
NN       DC     F'10000'
PG       DC     CL12' '            buffer
         YREGS
         END    PERFECTN


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program perfectNumber64.s   */
/* use Euclide Formula : if M=(2puis p)-1 is prime M * (M+1)/2 is perfect see Wikipedia  */
/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeConstantesARM64.inc"

.equ MAXI,      63

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:        .asciz "Perfect  : @ \n"
szMessOverflow:     .asciz "Overflow in function isPrime.\n"
szCarriageReturn:   .asciz "\n"

/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:                  .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                               // entry of program
    mov x4,2                        // start 2
    mov x3,1                        // counter 2 power
1:                                  // begin loop
    lsl x4,x4,1                     // 2 power
    sub x0,x4,1                     // - 1
    bl isPrime                      // is prime ?
    cbz x0,2f                       // no
    sub x0,x4,1                     // yes
    mul x1,x0,x4                    // multiply m by m-1
    lsr x0,x1,1                     // divide by 2
    bl displayPerfect               // and display
2:
    add x3,x3,1                     // next power of 2
    cmp x3,MAXI
    blt 1b

100:                                // standard end of the program
    mov x0,0                        // return code
    mov x8,EXIT                     // request to exit program
    svc 0                           // perform the system call
qAdrszCarriageReturn:    .quad szCarriageReturn
qAdrsMessResult:         .quad sMessResult

/******************************************************************/
/*      Display perfect number                                */
/******************************************************************/
/* x0 contains the number */
displayPerfect:
    stp x1,lr,[sp,-16]!             // save  registers
    ldr x1,qAdrsZoneConv
    bl conversion10                 // call décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv            // insert conversion in message
    bl strInsertAtCharInc
    bl affichageMess                // display message
100:
    ldp x1,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30
qAdrsZoneConv:                   .quad sZoneConv

/***************************************************/
/*   is a number prime ?         */
/***************************************************/
/* x0 contains the number */
/* x0 return 1 if prime  else 0  */
//2147483647  OK
//4294967297  NOK
//131071       OK
//1000003    OK
//10001363   OK
isPrime:
    stp x1,lr,[sp,-16]!        // save  registres
    stp x2,x3,[sp,-16]!        // save  registres
    mov x2,x0
    sub x1,x0,#1
    cmp x2,0
    beq 99f                    // return zero
    cmp x2,2                   // for 1 and 2 return 1
    ble 2f
    mov x0,#2
    bl moduloPuR64
    bcs 100f                   // error overflow
    cmp x0,#1
    bne 99f                    // no prime
    cmp x2,3
    beq 2f
    mov x0,#3
    bl moduloPuR64
    blt 100f                   // error overflow
    cmp x0,#1
    bne 99f

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

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

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

    cmp x2,13
    beq 2f
    mov x0,#13
    bl moduloPuR64
    bcs 100f                   // error overflow
    cmp x0,#1
    bne 99f                    // Pas premier
2:
    cmn x0,0                   // carry à zero no error
    mov x0,1                   // prime
    b 100f
99:
    cmn x0,0                   // carry à zero no error
    mov x0,#0                  // prime
100:
    ldp x2,x3,[sp],16          // restaur des  2 registres
    ldp x1,lr,[sp],16          // restaur des  2 registres
    ret

/**************************************************************/
/********************************************************/
/*   Compute modulo de b power e modulo m  */
/*    Exemple 4 puissance 13 modulo 497 = 445         */
/********************************************************/
/* x0  number  */
/* x1 exposant */
/* x2 modulo   */
moduloPuR64:
    stp x1,lr,[sp,-16]!        // save  registres
    stp x3,x4,[sp,-16]!        // save  registres
    stp x5,x6,[sp,-16]!        // save  registres
    stp x7,x8,[sp,-16]!        // save  registres
    stp x9,x10,[sp,-16]!       // save  registres
    cbz x0,100f
    cbz x1,100f
    mov x8,x0
    mov x7,x1
    mov x6,1                   // result
    udiv x4,x8,x2
    msub x9,x4,x2,x8           // remainder
1:
    tst x7,1                   // if bit = 1
    beq 2f
    mul x4,x9,x6
    umulh x5,x9,x6
    mov x6,x4
    mov x0,x6
    mov x1,x5
    bl divisionReg128U         // division 128 bits
    cbnz x1,99f                // overflow
    mov x6,x3                  // remainder
2:
    mul x8,x9,x9
    umulh x5,x9,x9
    mov x0,x8
    mov x1,x5
    bl divisionReg128U
    cbnz x1,99f                // overflow
    mov x9,x3
    lsr x7,x7,1
    cbnz x7,1b
    mov x0,x6                  // result
    cmn x0,0                   // carry à zero no error
    b 100f
99:
    ldr x0,qAdrszMessOverflow
    bl  affichageMess          // display error message
    cmp x0,0                   // carry set error
    mov x0,-1                  // code erreur

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

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


PROC Main()
  DEFINE MAXNUM="10000"
  CARD ARRAY pds(MAXNUM+1)
  CARD i,j

  FOR i=2 TO MAXNUM
  DO
    pds(i)=1
  OD
  FOR i=2 TO MAXNUM
  DO
    FOR j=i+i TO MAXNUM STEP i
    DO
      pds(j)==+i
    OD
  OD

  FOR i=2 TO MAXNUM
  DO
    IF pds(i)=i THEN
      PrintCE(i)
    FI
  OD
RETURN


function Is_Perfect(N : Positive) return Boolean is
   Sum : Natural := 0;
begin
   for I in 1..N - 1 loop
      if N mod I = 0 then
         Sum := Sum + I;
      end if;
   end loop;
   return Sum = N;
end Is_Perfect;


begin

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

comment - return true if n is perfect, otherwise false;
boolean procedure isperfect(n);
  value n; integer n;
begin
  integer sum, f1, f2;
  sum := 1;
  f1 := 1;
  for f1 := f1 + 1 while (f1 * f1) <= n do
    begin
      if mod(n, f1) = 0 then
        begin
           sum := sum + f1;
           f2 := n / f1;
           if f2 > f1 then sum := sum + f2;
        end;
    end;
  isperfect := (sum = n);
end;

comment - exercise the procedure;
integer i, found;
outstring(1,"Searching up to 10000 for perfect numbers\n");
found := 0;
for i := 2 step 1 until 10000 do
  if isperfect(i) then
    begin
      outinteger(1,i);
      found := found + 1;
    end;
outstring(1,"\n");
outinteger(1,found);
outstring(1,"perfect numbers were found");

end


PROC is perfect = (INT candidate)BOOL: (
  INT sum :=1;
  FOR f1 FROM 2 TO ENTIER ( sqrt(candidate)*(1+2*small real) ) WHILE
    IF candidate MOD f1 = 0 THEN
      sum +:= f1;
      INT f2 = candidate OVER f1;
      IF f2 > f1 THEN
        sum +:= f2
      FI
    FI;
# WHILE # sum <= candidate DO
    SKIP
  OD;
  sum=candidate
);

test:(
  FOR i FROM 2 TO 33550336 DO
    IF is perfect(i) THEN print((i, new line)) FI
  OD
)


begin
    % returns true if n is perfect, false otherwise                %
    % n must be > 0                                                %
    logical procedure isPerfect ( integer value candidate ) ;
        begin
            integer sum;
            sum    := 1;
            for f1 := 2 until round( sqrt( candidate ) ) do begin
                if candidate rem f1 = 0 then begin
                    integer f2;
                    sum := sum + f1;
                    f2  := candidate div f1;
                    % avoid e.g. counting 2 twice as a factor of 4 %
                    if f2 > f1 then sum := sum + f2
                end if_candidate_rem_f1_eq_0 ;
            end for_f1 ;
            sum = candidate
        end isPerfect ;

    % test isPerfect                                               %
    for n := 2 until 10000 do if isPerfect( n ) then write( n );
end.


-- PERFECT NUMBERS -----------------------------------------------------------

-- perfect :: integer -> bool
on perfect(n)

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

    -- quotient :: number -> number
    script quotient
        on |λ|(x)
            n / x
        end |λ|
    end script

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

    -- Integer factors of n below the square root
    set lows to filter(isFactor, enumFromTo(1, (n ^ (1 / 2)) as integer))

    -- low and high factors (quotients of low factors) tested for perfection
    (n > 1) and (foldl(sum, 0, (lows & map(quotient, lows))) / 2 = n)
end perfect

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

    filter(perfect, enumFromTo(1, 10000))

    --> {6, 28, 496, 8128}

end run

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

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

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

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

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

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


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

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

.equ MAXI,      1<<31

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResultPerf:    .asciz "Perfect  : @ \n"
szCarriageReturn:   .asciz "\n"

/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:                  .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                             @ entry of program
    mov r2,#2                     @ begin first number
1:                                @ begin loop
    mov r5,#1                     @ sum
    mov r4,#2                     @ first divisor 1
2:
    udiv r0,r2,r4                 @ compute divisor 2
    mls r3,r0,r4,r2               @ remainder
    cmp r3,#0
    bne 3f                        @ remainder = 0 ?
    add r5,r5,r0                  @ add divisor 2
    add r5,r5,r4                  @ add divisor 1
3:
    add r4,r4,#1                  @ increment divisor
    cmp r4,r0                     @ divisor 1  < divisor 2
    blt 2b                        @ yes -> loop
    cmp r2,r5                     @ compare number and divisors sum
    bne 4f                        @ not equal
    mov r0,r2                     @ equal -> display
    ldr r1,iAdrsZoneConv
    bl conversion10               @ call décimal conversion
    ldr r0,iAdrsMessResultPerf
    ldr r1,iAdrsZoneConv          @ insert conversion in message
    bl strInsertAtCharInc
    bl affichageMess              @ display message
4:
    add r2,#2                     @ no perfect number odd < 10 puis 1500
    cmp r2,#MAXI                  @ end ?
    blo 1b                        @ no -> loop

100:                              @ standard end of the program
    mov r0, #0                    @ return code
    mov r7, #EXIT                 @ request to exit program
    svc #0                        @ perform the system call
iAdrszCarriageReturn:    .int szCarriageReturn
iAdrsMessResultPerf:     .int sMessResultPerf
iAdrsZoneConv:           .int sZoneConv

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


divisors: $[n][ select 1..(n/2)+1 'i -> 0 = n % i ]
perfect?: $[n][ n = sum divisors n ]

loop 2..1000 'i [
	if perfect? i -> print i
]


Loop, 30 {
  If isMersennePrime(A_Index + 1)
    res .= "Perfect number: " perfectNum(A_Index + 1) "`n"
}

MsgBox % res

perfectNum(N) {
  Return 2**(N - 1) * (2**N - 1)
}

isMersennePrime(N) {
  If (isPrime(N)) && (isPrime(2**N - 1))
    Return true
}

isPrime(N) {
  Loop, % Floor(Sqrt(N))
    If (A_Index > 1 && !Mod(N, A_Index))
      Return false
  Return true
}


perfect?(n:Integer):Boolean == reduce(+,divisors n) = 2*n


FUNCTION perf(n)
	sum = 0
	FOR i = 1 TO n - 1
		IF n MOD i = 0 THEN
			sum = sum + i
		END IF
	NEXT i
	IF sum = n THEN
		perf = 1
	ELSE
		perf = 0
	END IF
END FUNCTION


      FOR n% = 2 TO 10000 STEP 2
        IF FNperfect(n%) PRINT n%
      NEXT
      END

      DEF FNperfect(N%)
      LOCAL I%, S%
      S% = 1
      FOR I% = 2 TO SQR(N%)-1
        IF N% MOD I% = 0 S% += I% + N% DIV I%
      NEXT
      IF I% = SQR(N%) S% += I%
      = (N% = S%)


#include "stdio.h"
#include "math.h"

int perfect(int n) {
    int max = (int)sqrt((double)n) + 1;
    int tot = 1;
    int i;

    for (i = 2; i < max; i++)
        if ( (n % i) == 0 ) {
            tot += i;
            int q = n / i;
            if (q > i)
                tot += q;
        }

    return tot == n;
}

int main() {
    int n;
    for (n = 2; n < 33550337; n++)
        if (perfect(n))
            printf("%d\n", n);

    return 0;
}


static void Main(string[] args)
{
	Console.WriteLine("Perfect numbers from 1 to 33550337:");

	for (int x = 0; x < 33550337; x++)
	{
		if (IsPerfect(x))
			Console.WriteLine(x + " is perfect.");
	}

	Console.ReadLine();
}

static bool IsPerfect(int num)
{
	int sum = 0;
	for (int i = 1; i < num; i++)
	{
		if (num % i == 0)
			sum += i;
	}

	return sum == num ;
}


#include <iostream>
using namespace std ;

int divisor_sum( int number ) {
   int sum = 0 ;
   for ( int i = 1 ; i < number ; i++ )
      if ( number % i == 0 )
         sum += i ;
   return sum;
}

int main( ) {
   cout << "Perfect numbers from 1 to 33550337:\n" ;
   for ( int num = 1 ; num < 33550337 ; num++ ) {
      if (divisor_sum(num) == num)
         cout << num << '\n' ;
   }
   return 0 ;
}


(defn proper-divisors [n]
  (if (< n 4)
    [1]
    (->> (range 2 (inc (quot n 2)))
         (filter #(zero? (rem n %)))
         (cons 1))))

(defn perfect? [n]
  (= (reduce + (proper-divisors n)) n))


      $set REPOSITORY "UPDATE ON"

       IDENTIFICATION DIVISION.
       PROGRAM-ID. perfect-main.

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       REPOSITORY.
           FUNCTION perfect
           .
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  i                      PIC 9(8).

       PROCEDURE DIVISION.
           PERFORM VARYING i FROM 2 BY 1 UNTIL 33550337 = i
               IF FUNCTION perfect(i) = 0
                   DISPLAY i
               END-IF
           END-PERFORM

           GOBACK
           .
       END PROGRAM perfect-main.


is_perfect_number = (n) ->
  do_factors_add_up_to n, 2*n

do_factors_add_up_to = (n, desired_sum) ->
  # We mildly optimize here, by taking advantage of
  # the fact that the sum_of_factors( (p^m) * x)
  # is (1 + ... + p^m-1 + p^m) * sum_factors(x) when
  # x is not itself a multiple of p.

  p = smallest_prime_factor(n)
  if p == n
    return desired_sum == p + 1

  # ok, now sum up all powers of p that
  # divide n
  sum_powers = 1
  curr_power = 1
  while n % p == 0
    curr_power *= p
    sum_powers += curr_power
    n /= p

  # if desired_sum does not divide sum_powers, we
  # can short circuit quickly
  return false unless desired_sum % sum_powers == 0

  # otherwise, recurse
  do_factors_add_up_to n, desired_sum / sum_powers

smallest_prime_factor = (n) ->
  for i in [2..n]
    return n if i*i > n
    return i if n % i == 0

# tests
do ->
  # This is pretty fast...
  for n in [2..100000]
    console.log n if is_perfect_number n

  # For big numbers, let's just sanity check the known ones.
  known_perfects = [
    33550336
    8589869056
    137438691328
  ]
  for n in known_perfects
    throw Error("fail") unless is_perfect_number(n)
    throw Error("fail") if is_perfect_number(n+1)


(defun perfectp (n)
  (= n (loop for i from 1 below n when (= 0 (mod n i)) sum i)))


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

bool isPerfectNumber1(in uint n) pure nothrow
in {
    assert(n > 0);
} body {
    return n == iota(1, n - 1).filter!(i => n % i == 0).sum;
}

void main() {
    iota(1, 10_000).filter!isPerfectNumber1.writeln;
}


/*
 * Function to test if a number is a perfect number
 * A number is a perfect number if it is equal to the sum of all its divisors
 * Input: Positive integer n
 * Output: true if n is a perfect number, false otherwise
 */
bool isPerfect(int n){
    //Generate a list of integers in the range 1 to n-1 : [1, 2, ..., n-1]
    List<int> range = new List<int>.generate(n-1, (int i) => i+1);

    //Create a list that filters the divisors of n from range
    List<int> divisors = new List.from(range.where((i) => n%i == 0));

    //Sum the all the divisors
    int sumOfDivisors = 0;
    for (int i = 0; i < divisors.length; i++){
        sumOfDivisors = sumOfDivisors + divisors[i];
    }

    // A number is a perfect number if it is equal to the sum of its divisors
    // We return the test if n is equal to sumOfDivisors
    return n == sumOfDivisors;
}


func isPerfect(num) {
    var sum = 0
    for i in 1..<num {
        if !i {
            break
        }
        if num % i == 0 {
            sum += i
        }
    }
    return sum == num
}

let max = 33550337
print("Perfect numbers from 0 to \(max):")

for x in 0..max {
    if isPerfect(x) {
        print("\(x) is perfect")
    }
}


pragma.enable("accumulator")
def isPerfectNumber(x :int) {
  var sum := 0
  for d ? (x % d <=> 0) in 1..!x {
    sum += d
    if (sum > x) { return false }
  }
  return sum <=> x
}


class
	APPLICATION

create
	make

feature

	make
		do
			io.put_string ("  6 is perfect...%T")
			io.put_boolean (is_perfect_number (6))
			io.new_line
			io.put_string (" 77 is perfect...%T")
			io.put_boolean (is_perfect_number (77))
			io.new_line
			io.put_string ("128 is perfect...%T")
			io.put_boolean (is_perfect_number (128))
			io.new_line
			io.put_string ("496 is perfect...%T")
			io.put_boolean (is_perfect_number (496))
		end

	is_perfect_number (n: INTEGER): BOOLEAN
			-- Is 'n' a perfect number?
		require
			n_positive: n > 0
		local
			sum: INTEGER
		do
			across
				1 |..| (n - 1) as c
			loop
				if n \\ c.item = 0 then
					sum := sum + c.item
				end
			end
			Result := sum = n
		end

end


import system'routines;
import system'math;
import extensions;

extension extension
{
    isPerfect()
        = new Range(1, self - 1).selectBy:(n => (self.mod:n == 0).iif(n,0) ).summarize(new Integer()) == self;
}

public program()
{
    for(int n := 1, n < 10000, n += 1)
    {
        if(n.isPerfect())
            { console.printLine(n," is perfect") }
    };

    console.readChar()
}


defmodule RC do
  def is_perfect(1), do: false
  def is_perfect(n) when n > 1 do
    Enum.sum(factor(n, 2, [1])) == n
  end

  defp factor(n, i, factors) when n <  i*i   , do: factors
  defp factor(n, i, factors) when n == i*i   , do: [i | factors]
  defp factor(n, i, factors) when rem(n,i)==0, do: factor(n, i+1, [i, div(n,i) | factors])
  defp factor(n, i, factors)                 , do: factor(n, i+1, factors)
end

IO.inspect (for i <- 1..10000, RC.is_perfect(i), do: i)


is_perfect(X) ->
    X == lists:sum([N || N <- lists:seq(1,X-1), X rem N == 0]).


PROGRAM PERFECT

PROCEDURE PERFECT(N%->OK%)
      LOCAL I%,S%
      S%=1
      FOR I%=2 TO SQR(N%)-1 DO
        IF N% MOD I%=0 THEN S%+=I%+N% DIV I%
      END FOR
      IF I%=SQR(N%) THEN S%+=I%
      OK%=(N%=S%)
END PROCEDURE

BEGIN
    PRINT(CHR$(12);) ! CLS
    FOR N%=2 TO 10000 STEP 2 DO
       PERFECT(N%->OK%)
       IF OK% THEN PRINT(N%)
    END FOR
END PROGRAM


let perf n = n = List.fold (+) 0 (List.filter (fun i -> n % i = 0) [1..(n-1)])

for i in 1..10000 do if (perf i) then printfn "%i is perfect" i


USING: kernel math math.primes.factors sequences ;
IN: rosettacode.perfect-numbers

: perfect? ( n -- ? )  [ divisors sum ] [ 2 * ] bi = ;


[0\1[\[email protected][email protected]][\[email protected][email protected][email protected][email protected]\/*=[@\[email protected][email protected]@]?1+]#%=]p:
45p;!." "28p;!.   { 0 -1 }


: perfect? ( n -- ? )
  1
  over 2/ 1+ 2 ?do
    over i mod 0= if i + then
  loop
  = ;


FUNCTION isPerfect(n)
  LOGICAL :: isPerfect
  INTEGER, INTENT(IN) :: n
  INTEGER :: i, factorsum

  isPerfect = .FALSE.
  factorsum = 1
  DO i = 2, INT(SQRT(REAL(n)))
     IF(MOD(n, i) == 0) factorsum = factorsum + i + (n / i)
  END DO
  IF (factorsum == n) isPerfect = .TRUE.
END FUNCTION isPerfect


' FB 1.05.0 Win64

Function isPerfect(n As Integer) As Boolean
   If n < 2 Then Return False
   If n Mod 2 = 1 Then Return False '' we can assume odd numbers are not perfect
   Dim As Integer sum = 1, q
   For i As Integer = 2 To Sqr(n)
     If n Mod i = 0 Then
       sum += i
       q = n \ i
       If q > i Then sum += q
     End If
   Next
   Return n = sum
End Function

Print "The first 5 perfect numbers are : "
For i As Integer = 2 To 33550336
  If isPerfect(i) Then Print i; " ";
Next

Print
Print "Press any key to quit"
Sleep


isPerfect = {|n| sum[allFactors[n, true, false]] == n}
println[select[1 to 1000, isPerfect]]


def perfect( n ) = sum( d | d <- 1..n if d|n ) == 2n

println( (1..500).filter(perfect) )


package main

import "fmt"

func computePerfect(n int64) bool {
    var sum int64
    for i := int64(1); i < n; i++ {
        if n%i == 0 {
            sum += i
        }
    }
    return sum == n
}

// following function satisfies the task, returning true for all
// perfect numbers representable in the argument type
func isPerfect(n int64) bool {
    switch n {
    case 6, 28, 496, 8128, 33550336, 8589869056,
        137438691328, 2305843008139952128:
        return true
    }
    return false
}

// validation
func main() {
    for n := int64(1); ; n++ {
        if isPerfect(n) != computePerfect(n) {
            panic("bug")
        }
        if n%1e3 == 0 {
            fmt.Println("tested", n)
        }
    }
}


def isPerfect = { n ->
    n > 4 && (n == (2..Math.sqrt(n)).findAll { n % it == 0 }.inject(1) { factorSum, i -> factorSum += i + n/i })
}


   DO i = 1, 1E4
      IF( perfect(i) ) WRITE() i
   ENDDO
END ! end of "main"

FUNCTION perfect(n)
   sum = 1
   DO i = 2, n^0.5
      sum = sum + (MOD(n, i) == 0) * (i + INT(n/i))
   ENDDO
   perfect = sum == n
END


procedure main(arglist)
limit := \arglist[1] | 100000
write("Perfect numbers from 1 to ",limit,":")
every write(isperfect(1 to limit))
write("Done.")
end

procedure isperfect(n)         #: returns n if n is perfect
local sum,i

every (sum := 0) +:= (n ~= divisors(n))
if sum = n then return n
end

link factors


public static boolean perf(int n){
	int sum= 0;
	for(int i= 1;i < n;i++){
		if(n % i == 0){
			sum+= i;
		}
	}
	return sum == n;
}


startup()
dibSection := getPixels("lenna100.jpg")
dibSection2 := getPixels("lenna50.jpg") ; ("File-Lenna100.jpg")
pixels := dibSection.pBits
pixels2 := dibSection2.pBits
z := 0
loop % dibSection.width * dibSection.height * 4
{
x := numget(pixels - 1, A_Index, "uchar")
y := numget(pixels2 - 1, A_Index, "uchar")
z += abs(y - x)
}
msgbox % z / (dibSection.width * dibSection.height * 3 * 255 / 100 ) ; 1.626
return

CreateDIBSection2(hDC, nW, nH, bpp = 32, ByRef pBits = "")
{
dib := object()
	NumPut(VarSetCapacity(bi, 40, 0), bi)
	NumPut(nW, bi, 4)
	NumPut(nH, bi, 8)
	NumPut(bpp, NumPut(1, bi, 12, "UShort"), 0, "Ushort")
	NumPut(0,  bi,16)
hbm := DllCall("gdi32\CreateDIBSection", "Uint", hDC, "Uint", &bi, "Uint", 0, "UintP", pBits, "Uint", 0, "Uint", 0)

dib.hbm := hbm
dib.pBits := pBits
dib.width := nW
dib.height := nH
dib.bpp := bpp
dib.header := header
	Return	dib
}

startup()
{
global disposables
disposables := object()
disposables.pBitmaps := object()
disposables.hBitmaps := object()

If !(disposables.pToken := Gdip_Startup())
{
	MsgBox, 48, gdiplus error!, Gdiplus failed to start. Please ensure you have gdiplus on your system
	ExitApp
}
  OnExit, gdipExit
}

gdipExit:
loop % disposables.hBitmaps._maxindex()
DllCall("DeleteObject", "Uint", disposables.hBitmaps[A_Index])
Gdip_Shutdown(disposables.pToken)
ExitApp

getPixels(imageFile)
{
global disposables ; hBitmap will be disposed later
pBitmapFile1 := Gdip_CreateBitmapFromFile(imageFile)
hbmi := Gdip_CreateHBITMAPFromBitmap(pBitmapFile1)
width := Gdip_GetImageWidth(pBitmapFile1)
height := Gdip_GetImageHeight(pBitmapFile1)

	mDCo := DllCall("CreateCompatibleDC", "Uint", 0)
	mDCi := DllCall("CreateCompatibleDC", "Uint", 0)
	dibSection := CreateDIBSection2(mDCo, width, height)
	hBMo := dibSection.hbm

	oBM := DllCall("SelectObject", "Uint", mDCo, "Uint", hBMo)
	iBM := DllCall("SelectObject", "Uint", mDCi, "Uint", hbmi)

	DllCall("BitBlt", "Uint", mDCo, "int", 0, "int", 0, "int", width, "int", height, "Uint", mDCi, "int", 0, "int", 0, "Uint", 0x40000000 | 0x00CC0020)

	DllCall("SelectObject", "Uint", mDCo, "Uint", oBM)
DllCall("DeleteDC", "Uint", 0, "Uint", mDCi)
DllCall("DeleteDC", "Uint", 0, "Uint", mDCo)
Gdip_DisposeImage(pBitmapFile1)
DllCall("DeleteObject", "Uint", hBMi)
disposables.hBitmaps._insert(hBMo)
return dibSection
}
#Include Gdip.ahk  ; Thanks to tic (Tariq Porter) for his GDI+ Library


function is_perfect(n)
{
 var sum = 1, i, sqrt=Math.floor(Math.sqrt(n));
 for (i = sqrt-1; i>1; i--)
 {
  if (n % i == 0) {
   sum += i + n/i;
  }
 }
 if(n % sqrt == 0)
  sum += sqrt + (sqrt*sqrt == n ? 0 : n/sqrt);
 return sum === n;
}

var i;
for (i = 1; i < 10000; i++)
{
 if (is_perfect(i))
  print(i);
}


def is_perfect:
  . as $in
  | $in == reduce range(1;$in) as $i
      (0; if ($in % $i) == 0 then $i + . else . end);

# Example:
range(1;10001) | select( is_perfect )


isperfect(n::Integer) = n == sum([n % i == 0 ? i : 0 for i = 1:(n - 1)])
perfects(n::Integer) = filter(isperfect, 1:n)

@show perfects(10000)