Sorting algorithms/Bead sort

From Rosetta Code
< Sorting algorithms(Redirected from Bead Sort)
Jump to: navigation, search
Task
Sorting algorithms/Bead sort
You are encouraged to solve this task according to the task description, using any language you may know.

Sorting Algorithm
This is a sorting algorithm. It may be applied to a set of data in order to sort it.

For other sorting algorithms, see Category:Sorting Algorithms, or:
O(n logn) Sorts
Heapsort | Mergesort | Quicksort
O(n log2n) Sorts
Shell Sort
O(n2) Sorts
Bubble sort | Cocktail sort | Comb sort | Gnome sort | Insertion sort | Selection sort | Strand sort
Other Sorts
Bead sort | Bogosort | Counting sort | Pancake sort | Permutation sort | Radix sort | Sleep sort | Stooge sort

In this task, the goal is to sort an array of positive integers using the Bead Sort Algorithm.

Algorithm has O(S), where S is the sum of the integers in the input set: Each bead is moved individually. This is the case when bead sort is implemented without a mechanism to assist in finding empty spaces below the beads, such as in software implementations.

Contents

[edit] AutoHotkey

BeadSort(data){
Pole:=[] , TempObj:=[], Result:=[]
for, i, v in data {
Row := i
loop, % v
MaxPole := MaxPole>A_Index?MaxPole:A_Index , Pole[A_Index, row] := 1
}
 
for i , obj in Pole {
TempVar:=0 , c := A_Index
for n, v in obj
TempVar += v
loop, % TempVar
TempObj[c, A_Index] := 1
}
 
loop, % Row {
TempVar:=0 , c := A_Index
Loop, % MaxPole
TempVar += TempObj[A_Index,c]
Result[c] := TempVar
}
return Result
}
Examples:
for i, val in BeadSort([54,12,87,56,36])
res := val (res?",":"") res
MsgBox % res
Outputs:
12,36,54,56,87

[edit] C

A rather straightforward implementation; since we do not use dynamic matrix, we have to know the maximum value in the array in advance. Requires (max * length) bytes for beads; if memory is of concern, bytes can be replaced by bits.

#include <stdio.h>
#include <stdlib.h>
 
void bead_sort(int *a, int len)
{
int i, j, max, sum;
unsigned char *beads;
# define BEAD(i, j) beads[i * max + j]
 
for (i = 1, max = a[0]; i < len; i++)
if (a[i] > max) max = a[i];
 
beads = calloc(1, max * len);
 
/* mark the beads */
for (i = 0; i < len; i++)
for (j = 0; j < a[i]; j++)
BEAD(i, j) = 1;
 
for (j = 0; j < max; j++) {
/* count how many beads are on each post */
for (sum = i = 0; i < len; i++) {
sum += BEAD(i, j);
BEAD(i, j) = 0;
}
/* mark bottom sum beads */
for (i = len - sum; i < len; i++) BEAD(i, j) = 1;
}
 
for (i = 0; i < len; i++) {
for (j = 0; j < max && BEAD(i, j); j++);
a[i] = j;
}
free(beads);
}
 
int main()
{
int i, x[] = {5, 3, 1, 7, 4, 1, 1, 20};
int len = sizeof(x)/sizeof(x[0]);
 
bead_sort(x, len);
for (i = 0; i < len; i++)
printf("%d\n", x[i]);
 
return 0;
}

[edit] C++

//this algorithm only works with positive, whole numbers.
//O(2n) time complexity where n is the summation of the whole list to be sorted.
//O(3n) space complexity.
 
#include <iostream>
#include <vector>
 
using std::cout;
using std::vector;
 
void distribute(int dist, vector<int> &List) {
//*beads* go down into different buckets using gravity (addition).
if (dist > List.size() )
List.resize(dist); //resize if too big for current vector
 
for (int i=0; i < dist; i++)
List[i]++;
}
 
vector<int> beadSort(int *myints, int n) {
vector<int> list, list2, fifth (myints, myints + n);
 
cout << "#1 Beads falling down: ";
for (int i=0; i < fifth.size(); i++)
distribute (fifth[i], list);
cout << '\n';
 
cout << "\nBeads on their sides: ";
for (int i=0; i < list.size(); i++)
cout << " " << list[i];
cout << '\n';
 
//second part
 
cout << "#2 Beads right side up: ";
for (int i=0; i < list.size(); i++)
distribute (list[i], list2);
cout << '\n';
 
return list2;
}
 
int main() {
int myints[] = {734,3,1,24,324,324,32,432,42,3,4,1,1};
vector<int> sorted = beadSort(myints, sizeof(myints)/sizeof(int));
cout << "Sorted list/array: ";
for(unsigned int i=0; i<sorted.size(); i++)
cout << sorted[i] << ' ';
}

[edit] Clojure

Translation of: Haskell
(defn transpose [xs]
(loop [ret [], remain xs]
(if (empty? remain)
ret
(recur (conj ret (map first remain))
(filter not-empty (map rest remain))))))
 
(defn bead-sort [xs]
(->> xs
(map #(repeat 1 %))
transpose
transpose
(map #(reduce + %))))
 
(-> [5 2 4 1 3 3 9] bead-sort println)
 


Output:

(9 5 4 3 3 2 1)

[edit] Delphi

Translation of: C
program BeadSortTest;
 
{$APPTYPE CONSOLE}
 
uses
SysUtils;
 
procedure BeadSort(var a : array of integer);
var
i, j, max, sum : integer;
beads : array of array of integer;
begin
max := a[Low(a)];
for i := Low(a) + 1 to High(a) do
if a[i] > max then
max := a[i];
 
SetLength(beads, High(a) - Low(a) + 1, max);
 
// mark the beads
 
for i := Low(a) to High(a) do
for j := 0 to a[i] - 1 do
beads[i, j] := 1;
 
for j := 0 to max - 1 do
begin
// count how many beads are on each post
sum := 0;
for i := Low(a) to High(a) do
begin
sum := sum + beads[i, j];
beads[i, j] := 0;
end;
//mark bottom sum beads
for i := High(a) + 1 - sum to High(a) do
beads[i, j] := 1;
end;
 
for i := Low(a) to High(a) do
begin
j := 0;
while (j < max) and (beads[i, j] <> 0) do
inc(j);
a[i] := j;
end;
 
SetLength(beads, 0, 0);
end;
 
const
N = 8;
var
i : integer;
x : array[1..N] of integer = (5, 3, 1, 7, 4, 1, 1, 20);
begin
for i := 1 to N do
writeln(Format('x[%d] = %d', [i, x[i]]));
 
BeadSort(x);
 
for i := 1 to N do
writeln(Format('x[%d] = %d', [i, x[i]]));
 
readln;
end.

--DavidIzadaR 18:12, 7 August 2011 (UTC)

[edit] D

A functional-style solution.

import std.stdio, std.algorithm, std.range, std.array, std.functional;
 
alias repeat0 = curry!(repeat, 0);
 
// Currenty std.range.transposed doesn't work.
auto columns(R)(R m) /*pure nothrow*/ {
return m
.map!walkLength
.reduce!max
.iota
.map!(i => m.filter!(s => s.length > i).walkLength.repeat0);
}
 
auto beadSort(in uint[] data) /*pure nothrow*/ {
return data.map!repeat0.columns.columns.map!walkLength;
}
 
void main() {
[5, 3, 1, 7, 4, 1, 1].beadSort.writeln;
}
Output:
[7, 5, 4, 3, 1, 1, 1]

[edit] Erlang

-module(beadsort).
 
-export([sort/1]).
 
sort(L) ->
dist(dist(L)).
 
dist(L) when is_list(L) ->
lists:foldl(fun (N, Acc) -> dist(Acc, N, []) end, [], L).
 
dist([H | T], N, Acc) when N > 0 ->
dist(T, N - 1, [H + 1 | Acc]);
dist([], N, Acc) when N > 0 ->
dist([], N - 1, [1 | Acc]);
dist([H | T], 0, Acc) ->
dist(T, 0, [H | Acc]);
dist([], 0, Acc) ->
lists:reverse(Acc).

Example;

1> beadsort:sort([1,734,24,3,324,324,32,432,42,3,4,1,1]).
[734,432,324,324,42,32,24,4,3,3,1,1,1]

[edit] F#

Translation of: Haskell
open System
 
let removeEmptyLists lists = lists |> List.filter (not << List.isEmpty)
let flip f x y = f y x
 
let rec transpose = function
| [] -> []
| lists -> (List.map List.head lists) :: transpose(removeEmptyLists (List.map List.tail lists))
 
// Using the backward composition operator "<<" (equivalent to Haskells ".") ...
let beadSort = List.map List.sum << transpose << transpose << List.map (flip List.replicate 1)
 
// Using the forward composition operator ">>" ...
let beadSort2 = List.map (flip List.replicate 1) >> transpose >> transpose >> List.map List.sum

Usage: beadSort [2;4;1;3;3] or beadSort2 [2;4;1;3;3]

Output:

  val it : int list = [4; 3; 3; 2; 1]

[edit] Factor

USING: kernel math math.order math.vectors sequences ;
: fill ( seq len -- newseq ) [ dup length ] dip swap - 0 <repetition> append ;
 
: bead ( seq -- newseq )
dup 0 [ max ] reduce
[ swap 1 <repetition> swap fill ] curry map
[ ] [ v+ ] map-reduce ;
 
: beadsort ( seq -- newseq ) bead bead ;
( scratchpad ) { 5 2 4 1 3 3 9 } beadsort .
{ 9 5 4 3 3 2 1 }

[edit] Fortran

Works with: Fortran version 2003
Works with: Fortran version 95
removing the iso_fortran_env as explained in code

This implementation suffers the same problems of the C implementation: if the maximum value in the array to be sorted is very huge, likely there will be not enough free memory to complete the task. Nonetheless, if the Fortran implementation would use "silently" sparse arrays and a compact representation for "sequences" of equal values in an array, then this very same code would run fine even with large integers.

program BeadSortTest
use iso_fortran_env
! for ERROR_UNIT; to make this a F95 code,
! remove prev. line and declare ERROR_UNIT as an
! integer parameter matching the unit associated with
! standard error
 
integer, dimension(7) :: a = (/ 7, 3, 5, 1, 2, 1, 20 /)
 
call beadsort(a)
print *, a
 
contains
 
subroutine beadsort(a)
integer, dimension(:), intent(inout) :: a
 
integer, dimension(maxval(a), maxval(a)) :: t
integer, dimension(maxval(a)) :: s
integer :: i, m
 
m = maxval(a)
 
if ( any(a < 0) ) then
write(ERROR_UNIT,*) "can't sort"
return
end if
 
t = 0
forall(i=1:size(a)) t(i, 1:a(i)) = 1 ! set up abacus
forall(i=1:m) ! let beads "fall"; instead of
s(i) = sum(t(:, i)) ! moving them one by one, we just
t(:, i) = 0 ! count how many should be at bottom,
t(1:s(i), i) = 1 ! and then "reset" and set only those
end forall
 
forall(i=1:size(a)) a(i) = sum(t(i,:))
 
end subroutine beadsort
 
end program BeadSortTest

[edit] Go

Sorts non-negative integers only. The extension to negative values seemed a distraction from this fun task.

package main
 
import (
"fmt"
"sync"
)
 
var a = []int{170, 45, 75, 90, 802, 24, 2, 66}
var aMax = 1000
 
const bead = 'o'
 
func main() {
fmt.Println("before:", a)
beadSort()
fmt.Println("after: ", a)
}
 
func beadSort() {
// All space in the abacus = aMax poles x len(a) rows.
all := make([]byte, aMax*len(a))
// Slice up space by pole. (The space could be sliced by row instead,
// but slicing by pole seemed a more intuitive model of a physical abacus.)
abacus := make([][]byte, aMax)
for pole, space := 0, all; pole < aMax; pole++ {
abacus[pole] = space[:len(a)]
space = space[len(a):]
}
// Use a sync.Waitgroup as the checkpoint mechanism.
var wg sync.WaitGroup
// Place beads for each number concurrently. (Presumably beads can be
// "snapped on" to the middle of a pole without disturbing neighboring
// beads.) Also note 'row' here is a row of the abacus.
wg.Add(len(a))
for row, n := range a {
go func(row, n int) {
for pole := 0; pole < n; pole++ {
abacus[pole][row] = bead
}
wg.Done()
}(row, n)
}
wg.Wait()
// Now tip the abacus, letting beads fall on each pole concurrently.
wg.Add(aMax)
for _, pole := range abacus {
go func(pole []byte) {
// Track the top of the stack of beads that have already fallen.
top := 0
for row, space := range pole {
if space == bead {
// Move each bead individually, but move it from its
// starting row to the top of stack in a single operation.
// (More physical simulation such as discovering the top
// of stack by inspection, or modeling gravity, are
// possible, but didn't seem called for by the task.
pole[row] = 0
pole[top] = bead
top++
}
}
wg.Done()
}(pole)
}
wg.Wait()
// Read out sorted numbers by row.
for row := range a {
x := 0
for pole := 0; pole < aMax && abacus[pole][row] == bead; pole++ {
x++
}
a[len(a)-1-row] = x
}
}

[edit] Groovy

Solution:

def beadSort = { list ->
final nPoles = list.max()
list.collect {
print "."
([true] * it) + ([false] * (nPoles - it))
}.transpose().collect { pole ->
print "."
pole.findAll { ! it } + pole.findAll { it }
}.transpose().collect{ beadTally ->
beadTally.findAll{ it }.size()
}
}

Annotated Solution (same solution really):

def beadSortVerbose = { list ->
final nPoles = list.max()
// each row is a number tally-arrayed across the abacus
def beadTallies = list.collect { number ->
print "."
// true == bead, false == no bead
([true] * number) + ([false] * (nPoles - number))
}
// each row is an abacus pole
def abacusPoles = beadTallies.transpose()
def abacusPolesDrop = abacusPoles.collect { pole ->
print "."
// beads drop to the BOTTOM of the pole
pole.findAll { ! it } + pole.findAll { it }
}
// each row is a number again
def beadTalliesDrop = abacusPolesDrop.transpose()
beadTalliesDrop.collect{ beadTally -> beadTally.findAll{ it }.size() }
}

Test:

println beadSort([23,76,99,58,97,57,35,89,51,38,95,92,24,46,31,24,14,12,57,78,4]) 
println beadSort([88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1])

Output:

........................................................................................................................[4, 12, 14, 23, 24, 24, 31, 35, 38, 46, 51, 57, 57, 58, 76, 78, 89, 92, 95, 97, 99]
...............................................................................................................[0, 1, 4, 5, 7, 8, 12, 14, 18, 20, 31, 33, 44, 62, 70, 73, 75, 76, 78, 81, 82, 84, 88]

Individual dots shown here are "retallying dots". They are not equivalent to the "swap dots" shown in other Groovy sorting examples. Like the swap dots the retallying dots represent atomic operations that visually indicate the overall sorting effort. However, they are not equivalent to swaps, or even equivalent in actual effort between bead sorts.

The cost of transposition is not accounted for here because with clever indexing it can easily be optimized away. In fact, one could write a list class for Groovy that performs the transpose operation merely by setting a single boolean value that controls indexing calculations.

[edit] Haskell

import Data.List
 
beadSort :: [Int] -> [Int]
beadSort = map sum. transpose. transpose. map (flip replicate 1)

Example;

*Main> beadSort [2,4,1,3,3]
[4,3,3,2,1]

[edit] Icon and Unicon

The program below handles integers and not just whole numbers. As are so many others, the solution is limited by the lack of sparse array or list compression.

procedure main()                     #: demonstrate various ways to sort a list and string 
write("Sorting Demo using ",image(beadsort))
writes(" on list : ")
writex(UL := [3, 14, 1, 5, 9, 2, 6, 3])
displaysort(beadsort,copy(UL))
end
 
procedure beadsort(X) #: return sorted list ascending(or descending)
local base,i,j,x # handles negatives and zeros, may also reduce storage
 
poles := list(max!X-(base := min!X -1),0) # set up poles, we will track sums not individual beads
every x := !X do { # each item in the list
if integer(x) ~= x then runerr(101,x) # ... must be an integer
every poles[1 to x - base] +:= 1 # ... beads "fall" into the sum for that pole
}
 
 
every (X[j := *X to 1 by -1] := base) &
(i := 1 to *poles) do # read from the bottom of the poles
if poles[i] > 0 then { # if there's a bead on the pole ...
poles[i] -:= 1 # ... remove it
X[j] +:= 1 # ... and add it in place
}
return X
end

Note: This example relies on the supporting procedures 'writex' in Bubble Sort. Note: min and max are available in the Icon Programming Library (IPL).


Abbreviated sample output:
Sorting Demo using procedure beadsort
  on list : [ 3 14 1 5 9 2 6 3 ]
    with op = &null:         [ 1 2 3 3 5 6 9 14 ]   (0 ms)

[edit] J

Generally, this task should be accomplished in J using \:~. Here we take an approach that's more comparable with the other examples on this page.
bead=: [: +/ #"0&1

Example use:

   bead bead 2 4 1 3 3
4 3 3 2 1
bead bead 5 3 1 7 4 1 1
7 5 4 3 1 1 1

Extending to deal with sequences of arbitrary integers:

bball=: ] (] + [: bead^:2 -) <./ - 1:

Example use:

   bball 2 0 _1 3 1 _2 _3 0
3 2 1 0 0 _1 _2 _3

[edit] Java

 
 
public class BeadSort
{
public static void main(String[] args)
{
BeadSort now=new BeadSort();
int[] arr=new int[(int)(Math.random()*11)+5];
for(int i=0;i<arr.length;i++)
arr[i]=(int)(Math.random()*10);
System.out.print("Unsorted: ");
now.display1D(arr);
 
int[] sort=now.beadSort(arr);
System.out.print("Sorted: ");
now.display1D(sort);
}
int[] beadSort(int[] arr)
{
int max=0;
for(int i=0;i<arr.length;i++)
if(arr[i]>max)
max=arr[i];
 
//Set up abacus
char[][] grid=new char[arr.length][max];
int[] levelcount=new int[max];
for(int i=0;i<max;i++)
{
levelcount[i]=0;
for(int j=0;j<arr.length;j++)
grid[j][i]='_';
}
/*
display1D(arr);
display1D(levelcount);
display2D(grid);
*/

 
//Drop the beads
for(int i=0;i<arr.length;i++)
{
int num=arr[i];
for(int j=0;num>0;j++)
{
grid[levelcount[j]++][j]='*';
num--;
}
}
System.out.println();
display2D(grid);
//Count the beads
int[] sorted=new int[arr.length];
for(int i=0;i<arr.length;i++)
{
int putt=0;
for(int j=0;j<max&&grid[arr.length-1-i][j]=='*';j++)
putt++;
sorted[i]=putt;
}
 
return sorted;
}
void display1D(int[] arr)
{
for(int i=0;i<arr.length;i++)
System.out.print(arr[i]+" ");
System.out.println();
}
void display1D(char[] arr)
{
for(int i=0;i<arr.length;i++)
System.out.print(arr[i]+" ");
System.out.println();
}
void display2D(char[][] arr)
{
for(int i=0;i<arr.length;i++)
display1D(arr[i]);
System.out.println();
}
}
 

Output:

Unsorted: 9 4 7 0 4 3 0 5 3 8 7 9 8 7 0 

* * * * * * * * * 
* * * * * * * * * 
* * * * * * * * _ 
* * * * * * * * _ 
* * * * * * * _ _ 
* * * * * * * _ _ 
* * * * * * * _ _ 
* * * * * _ _ _ _ 
* * * * _ _ _ _ _ 
* * * * _ _ _ _ _ 
* * * _ _ _ _ _ _ 
* * * _ _ _ _ _ _ 
_ _ _ _ _ _ _ _ _ 
_ _ _ _ _ _ _ _ _ 
_ _ _ _ _ _ _ _ _ 

Sorted: 0 0 0 3 3 4 4 5 7 7 7 8 8 9 9 

[edit] Mathematica

beadsort[ a ] := Module[ { m, sorted, s ,t },
 
sorted = a; m = Max[a]; t=ConstantArray[0, {m,m} ];
If[ Min[a] < 0, Print["can't sort"]];
For[ i = 1, i < Length[a], i++, t[[i,1;;a[[i]]]]=1 ]
 
For[ i = 1 ,i <= m, i++, s = Total[t[[;;,i]]];
t[[ ;; , i]] = 0; t[[1 ;; s , i]] = 1; ]
 
For[ i=1,i<=Length[a],i++, sorted[[i]] = Total[t[[i,;;]]]; ]
Print[sorted];
]
beadsort[{2,1,5,3,6}]
->{6,3,2,1,0}

[edit] NetRexx

/* NetRexx */
options replace format comments java crossref symbols nobinary
 
runSample(arg)
return
 
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method bead_sort(harry = Rexx[]) public static binary returns Rexx[]
MIN_ = 'MIN'
MAX_ = 'MAX'
beads = Rexx 0
beads[MIN_] = 0
beads[MAX_] = 0
 
loop val over harry
-- collect occurences of beads in indexed string indexed on value
if val < beads[MIN_] then beads[MIN_] = val -- keep track of min value
if val > beads[MAX_] then beads[MAX_] = val -- keep track of max value
beads[val] = beads[val] + 1
end val
 
harry_sorted = Rexx[harry.length]
bi = 0
loop xx = beads[MIN_] to beads[MAX_]
-- extract beads in value order and insert in result array
if beads[xx] == 0 then iterate xx
loop for beads[xx]
harry_sorted[bi] = xx
bi = bi + 1
end
end xx
 
return harry_sorted
 
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method runSample(arg) public static
unsorted = [734, 3, 1, 24, 324, -1024, -666, -1, 0, 324, 32, 0, 432, 42, 3, 4, 1, 1]
sorted = bead_sort(unsorted)
say arrayToString(unsorted)
say arrayToString(sorted)
return
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method arrayToString(harry = Rexx[]) private static
list = Rexx ''
loop vv over harry
list = list vv
end vv
return '['list.space(1, ',')']'
 

Output:

[734,3,1,24,324,-1024,-666,-1,0,324,32,0,432,42,3,4,1,1]
[-1024,-666,-1,0,0,1,1,1,3,3,4,24,32,42,324,324,432,734]

[edit] Nimrod

proc beadSort[T](a: var openarray[T]) =
var max = low(T)
var sum = 0
 
for x in a:
if x > max: max = x
 
var beads = newSeq[int](max * a.len)
 
for i in 0 .. < a.len:
for j in 0 .. < a[i]:
beads[i * max + j] = 1
 
for j in 0 .. < max:
sum = 0
for i in 0 .. < a.len:
sum += beads[i * max + j]
beads[i * max + j] = 0
 
for i in a.len - sum .. < a.len:
beads[i * max + j] = 1
 
for i in 0 .. < a.len:
var j = 0
while j < max and beads[i * max + j] > 0: inc j
a[i] = j
 
var a = @[5, 3, 1, 7, 4, 1, 1, 20]
beadSort a
echo a

Output:

@[1, 1, 1, 3, 4, 5, 7, 20]

[edit] OCaml

Translation of: Haskell
let rec columns l =
match List.filter ((<>) []) l with
[] -> []
| l -> List.map List.hd l :: columns (List.map List.tl l)
 
let replicate n x = Array.to_list (Array.make n x)
 
let bead_sort l =
List.map List.length (columns (columns (List.map (fun e -> replicate e 1) l)))

usage

# bead_sort [5;3;1;7;4;1;1];;
- : int list = [7; 5; 4; 3; 1; 1; 1]

[edit] Octave

Translation of: Fortran
function sorted = beadsort(a)
sorted = a;
m = max(a);
if ( any(a < 0) )
error("can't sort");
endif
t = zeros(m, m);
for i = 1:numel(a)
t(i, 1:a(i)) = 1;
endfor
for i = 1:m
s = sum(t(:, i));
t(:, i) = 0;
t(1:s, i) = 1;
endfor
for i = 1:numel(a)
sorted(i) = sum(t(i, :));
endfor
endfunction
 
beadsort([5, 7, 1, 3, 1, 1, 20])

[edit] ooRexx

Translation of: REXX

Note: The only changes needed were to substitute _, ! and ? characters for the "deprecated" $, # and @ characters within variable names; as per The REXX Language, Second Edition by M. F. Cowlishaw. (See a description here).

/*REXX program sorts a list of integers using a bead sort. */
 
/*get some grassHopper numbers. */
grasshopper=,
1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254 270
 
 
 
/*GreeenGrocer numbers are also called hexagonal pyramidal */
/* numbers. */
greengrocer=,
0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876 4560
 
 
/*get some Bernoulli numerator numbers. */
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0 854513'
 
 
/*Psi is also called the Reduced Totient function, and */
/* is also called Carmichale lambda, or LAMBDA function.*/
psi=,
1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16
 
 
 
list=grasshopper greengrocer bernN psi /*combine the four lists into one*/
 
 
call showL 'before sort',list /*show list before sorting. */
!=beadSort(list) /*invoke the bead sort. */
call showL ' after sort',! /*show after array elements*/
exit
 
 
/*─────────────────────────────────beadSort@ subroutine────────────*/
beadSort: procedure expose _.
parse arg z
 !='' /*this'll be the sorted list*/
low=999999999; high=-low /*define the low and high #s*/
_.=0 /*define all beads to zero. */
 
 
do j=1 until z=='' /*pick the meat off the bone*/
parse var z x z
if \datatype(x,'Whole') then
do
say
say '*** error! ***'
say
say 'element' j "in list isn't numeric:" x
say
exit 13
end
 
x=x/1 /*normalize number, it could*/
/*be: +4 007 5. 2e3 etc.*/
_.x=_.x+1 /*indicate this bead has a #*/
low=min(low,x) /*keep track of the lowest #*/
high=max(high,x) /* " " " " highest#*/
end j
 
/*now, collect the beads and*/
do m=low to high /*let them fall (to zero). */
if _.m==0 then iterate /*No bead here? Keep looking*/
do n=1 for _.m /*let the beads fall to 0. */
 !=! m /*add it to the sorted list.*/
end n
end m
 
return !
 
 
/*─────────────────────────────────────SHOW@ subroutine────────────*/
showL:
widthH=length(words(arg(2))) /*maximum width of the index*/
 
do j=1 for words(arg(2))
say 'element' right(j,widthH) arg(1)":" right(word(arg(2),j),10)
end j
 
say copies('─',80) /*show a separator line. */
return
 

output

element   1 before sort:          1
element   2 before sort:          4
element   3 before sort:         10
element   4 before sort:         12
element   5 before sort:         22
element   6 before sort:         26
element   7 before sort:         30
element   8 before sort:         46
element   9 before sort:         54
element  10 before sort:         62
element  11 before sort:         66
element  12 before sort:         78
element  13 before sort:         94
element  14 before sort:        110
element  15 before sort:        126
element  16 before sort:        134
element  17 before sort:        138
element  18 before sort:        158
element  19 before sort:        162
element  20 before sort:        186
element  21 before sort:        190
element  22 before sort:        222
element  23 before sort:        254
element  24 before sort:        270
element  25 before sort:          0
element  26 before sort:          4
element  27 before sort:         16
element  28 before sort:         40
element  29 before sort:         80
element  30 before sort:        140
element  31 before sort:        224
element  32 before sort:        336
element  33 before sort:        480
element  34 before sort:        660
element  35 before sort:        880
element  36 before sort:       1144
element  37 before sort:       1456
element  38 before sort:       1820
element  39 before sort:       2240
element  40 before sort:       2720
element  41 before sort:       3264
element  42 before sort:       3876
element  43 before sort:       4560
element  44 before sort:          1
element  45 before sort:         -1
element  46 before sort:          1
element  47 before sort:          0
element  48 before sort:         -1
element  49 before sort:          0
element  50 before sort:          1
element  51 before sort:          0
element  52 before sort:         -1
element  53 before sort:          0
element  54 before sort:          5
element  55 before sort:          0
element  56 before sort:       -691
element  57 before sort:          0
element  58 before sort:          7
element  59 before sort:          0
element  60 before sort:      -3617
element  61 before sort:          0
element  62 before sort:      43867
element  63 before sort:          0
element  64 before sort:    -174611
element  65 before sort:          0
element  66 before sort:     854513
element  67 before sort:          1
element  68 before sort:          1
element  69 before sort:          2
element  70 before sort:          2
element  71 before sort:          4
element  72 before sort:          2
element  73 before sort:          6
element  74 before sort:          2
element  75 before sort:          6
element  76 before sort:          4
element  77 before sort:         10
element  78 before sort:          2
element  79 before sort:         12
element  80 before sort:          6
element  81 before sort:          4
element  82 before sort:          4
element  83 before sort:         16
element  84 before sort:          6
element  85 before sort:         18
element  86 before sort:          4
element  87 before sort:          6
element  88 before sort:         10
element  89 before sort:         22
element  90 before sort:          2
element  91 before sort:         20
element  92 before sort:         12
element  93 before sort:         18
element  94 before sort:          6
element  95 before sort:         28
element  96 before sort:          4
element  97 before sort:         30
element  98 before sort:          8
element  99 before sort:         10
element 100 before sort:         16
────────────────────────────────────────────────────────────────────────────────
element   1  after sort:    -174611
element   2  after sort:      -3617
element   3  after sort:       -691
element   4  after sort:         -1
element   5  after sort:         -1
element   6  after sort:         -1
element   7  after sort:          0
element   8  after sort:          0
element   9  after sort:          0
element  10  after sort:          0
element  11  after sort:          0
element  12  after sort:          0
element  13  after sort:          0
element  14  after sort:          0
element  15  after sort:          0
element  16  after sort:          0
element  17  after sort:          0
element  18  after sort:          1
element  19  after sort:          1
element  20  after sort:          1
element  21  after sort:          1
element  22  after sort:          1
element  23  after sort:          1
element  24  after sort:          2
element  25  after sort:          2
element  26  after sort:          2
element  27  after sort:          2
element  28  after sort:          2
element  29  after sort:          2
element  30  after sort:          4
element  31  after sort:          4
element  32  after sort:          4
element  33  after sort:          4
element  34  after sort:          4
element  35  after sort:          4
element  36  after sort:          4
element  37  after sort:          4
element  38  after sort:          5
element  39  after sort:          6
element  40  after sort:          6
element  41  after sort:          6
element  42  after sort:          6
element  43  after sort:          6
element  44  after sort:          6
element  45  after sort:          7
element  46  after sort:          8
element  47  after sort:         10
element  48  after sort:         10
element  49  after sort:         10
element  50  after sort:         10
element  51  after sort:         12
element  52  after sort:         12
element  53  after sort:         12
element  54  after sort:         16
element  55  after sort:         16
element  56  after sort:         16
element  57  after sort:         18
element  58  after sort:         18
element  59  after sort:         20
element  60  after sort:         22
element  61  after sort:         22
element  62  after sort:         26
element  63  after sort:         28
element  64  after sort:         30
element  65  after sort:         30
element  66  after sort:         40
element  67  after sort:         46
element  68  after sort:         54
element  69  after sort:         62
element  70  after sort:         66
element  71  after sort:         78
element  72  after sort:         80
element  73  after sort:         94
element  74  after sort:        110
element  75  after sort:        126
element  76  after sort:        134
element  77  after sort:        138
element  78  after sort:        140
element  79  after sort:        158
element  80  after sort:        162
element  81  after sort:        186
element  82  after sort:        190
element  83  after sort:        222
element  84  after sort:        224
element  85  after sort:        254
element  86  after sort:        270
element  87  after sort:        336
element  88  after sort:        480
element  89  after sort:        660
element  90  after sort:        880
element  91  after sort:       1144
element  92  after sort:       1456
element  93  after sort:       1820
element  94  after sort:       2240
element  95  after sort:       2720
element  96  after sort:       3264
element  97  after sort:       3876
element  98  after sort:       4560
element  99  after sort:      43867
element 100  after sort:     854513
────────────────────────────────────────────────────────────────────────────────

[edit] OpenEdge/Progress

Sorting algorithms are not the kind of thing you need / want to do in OpenEdge. If you want to sort simply define a temp-table with one field, populate it and get sorted results with FOR EACH temp-table DESCENDING.

FUNCTION beadSort RETURNS CHAR (
i_c AS CHAR
):
 
DEF VAR cresult AS CHAR.
DEF VAR ii AS INT.
DEF VAR inumbers AS INT.
DEF VAR irod AS INT.
DEF VAR irods AS INT.
DEF VAR crod AS CHAR.
DEF VAR cbeads AS CHAR EXTENT.
 
inumbers = NUM-ENTRIES( i_c ).
 
/* determine number of rods needed */
DO ii = 1 TO inumbers:
irods = MAXIMUM( irods, INTEGER( ENTRY( ii, i_c ) ) ).
END.
 
/* put beads on rods */
EXTENT( cbeads ) = inumbers.
DO ii = 1 TO inumbers:
cbeads[ ii ] = FILL( "X", INTEGER( ENTRY( ii, i_c ) ) ).
END.
 
/* drop beads on each rod */
DO irod = 1 TO irods:
crod = "".
DO ii = 1 TO inumbers:
crod = crod + SUBSTRING( cbeads[ ii ], irod, 1 ).
END.
crod = REPLACE( crod, " ", "" ).
DO ii = 1 TO inumbers.
SUBSTRING( cbeads[ ii ], irod, 1 ) = STRING( ii <= LENGTH( crod ), "X/ " ).
END.
END.
 
/* get beads from rods */
DO ii = 1 TO inumbers:
cresult = cresult + "," + STRING( LENGTH( REPLACE( cbeads[ ii ], " ", "" ) ) ).
END.
 
RETURN SUBSTRING( cresult, 2 ).
 
END FUNCTION. /* beadSort */
 
MESSAGE
"5,2,4,1,3,3,9 -> " beadSort( "5,2,4,1,3,3,9" ) SKIP
"5,3,1,7,4,1,1 -> " beadSort( "5,3,1,7,4,1,1" ) SKIP(1)
beadSort( "88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1" )
VIEW-AS ALERT-BOX.

Output:

---------------------------
Message
---------------------------
5,2,4,1,3,3,9  ->  9,5,4,3,3,2,1 
5,3,1,7,4,1,1  ->  7,5,4,3,1,1,1 

88,84,82,81,78,76,75,73,70,62,44,33,31,20,18,14,12,8,7,5,4,1,0
---------------------------
OK
---------------------------

[edit] PARI/GP

This implementation uses the counting sort to order the beads in a given row.

beadsort(v)={
my(sz=vecmax(v),M=matrix(#v,sz,i,j,v[i]>=j)); \\ Set up beads
for(i=1,sz,M[,i]=countingSort(M[,i],0,1)~); \\ Let them fall
vector(#v,i,value(M[i,])) \\ Convert back to numbers
};
 
countingSort(v,mn,mx)={
my(u=vector(#v),i=0);
for(n=mn,mx,
for(j=1,#v,if(v[j]==n,u[i++]=n))
);
u
};
 
value(v)={
if(#v==0 || !v[1], return(0));
if(v[#v], return(#v));
my(left=1, right=#v, mid);
while (right - left > 1,
mid=(right+left)\2;
if(v[mid], left=mid, right=mid)
);
left
};

[edit] Pascal

See Delphi

[edit] Perl

Instead of storing the bead matrix explicitly, I choose to store just the number of beads in each row and column, compacting on the fly. At all times, the sum of the row widths is equal to the sum column heights.

sub beadsort {
my @data = @_;
 
my @columns;
my @rows;
 
for my $datum (@data) {
for my $column ( 0 .. $datum-1 ) {
++ $rows[ $columns[$column]++ ];
}
}
 
return reverse @rows;
}
 
beadsort 5, 7, 1, 3, 1, 1, 20;
 

[edit] Perl 6

Translation of: Haskell
use List::Utils;
 
sub beadsort(@l) {
(transpose(transpose(map {[1 xx $_]}, @l))).map(*.elems);
}
 
my @list = 2,1,3,5;
say beadsort(@list).perl;

Output:

(5, 3, 2, 1)

Here we simulate the dropping beads by using the push method.

sub beadsort(*@list) {
my @rods;
for ^«@list -> $x { @rods[$x].push(1) }
gather for ^@rods[0] -> $y {
take [+] @rods.map: { .[$y] // last }
}
}
 
say beadsort 2,1,3,5;

The ^ is the "upto" operator that gives a range of 0 up to (but not including) its endpoint. We use it as a hyperoperator () to generate all the ranges of rod numbers we should drop a bead on, with the result that $x tells us which rod to drop each bead on. Then we use ^ again on the first rod to see how deep the beads are stacked, since they are guaranteed to be the deepest there. The [+] adds up all the beads that are found at level $y. The last short circuits the map so we don't have to look for all the missing beads at a given level, since the missing beads are all guaranteed to come after the existing beads at that level (because we always dropped left to right starting at rod 0).

[edit] PHP

Translation of: Haskell
<?php
function columns($arr) {
if (count($m) == 0)
return array();
else if (count($m) == 1)
return array_chunk($m[0], 1);
 
array_unshift($arr, NULL);
// array_map(NULL, $arr[0], $arr[1], ...)
$transpose = call_user_func_array('array_map', $arr);
return array_map('array_filter', $transpose);
}
 
function beadsort($arr) {
foreach ($arr as $e)
$poles []= array_fill(0, $e, 1);
return array_map('count', columns(columns($poles)));
}
 
print_r(beadsort(array(5,3,1,7,4,1,1)));
?>

Output:

Array
(
    [0] => 7
    [1] => 5
    [2] => 4
    [3] => 3
    [4] => 1
    [5] => 1
    [6] => 1
)

[edit] PicoLisp

The following implements a direct model of the bead sort algorithm. Each pole is a list of 'T' symbols for the beads.

(de beadSort (Lst)
(let Abacus (cons NIL)
(for N Lst # Thread beads on poles
(for (L Abacus (ge0 (dec 'N)) (cdr L))
(or (cdr L) (queue 'L (cons)))
(push (cadr L) T) ) )
(make
(while (gt0 (cnt pop (cdr Abacus))) # Drop and count beads
(link @) ) ) ) )

Output:

: (beadSort (5 3 1 7 4 1 1 20))
-> (20 7 5 4 3 1 1 1)

[edit] PL/I

 
/* Handles both negative and positive values. */
 
maxval: procedure (z) returns (fixed binary);
declare z(*) fixed binary;
declare (maxv initial (0), i) fixed binary;
do i = lbound(z,1) to hbound(z,1);
maxv = max(z(i), maxv);
end;
put skip data (maxv); put skip;
return (maxv);
end maxval;
minval: procedure (z) returns (fixed binary);
declare z(*) fixed binary;
declare (minv initial (0), i) fixed binary;
 
do i = lbound(z,1) to hbound(z,1);
if z(i) < 0 then minv = min(z(i), minv);
end;
put skip data (minv); put skip;
return (minv);
end minval;
 
/* To deal with negative values, array elements are incremented */
/* by the greatest (in magnitude) negative value, thus making */
/* them positive. The resultant values are stored in an */
/* unsigned array (PL/I provides both signed and unsigned data */
/* types). At procedure end, the array values are restored to */
/* original values. */
 
(subrg, fofl, size, stringrange, stringsize):
beadsort: procedure (z); /* 8-1-2010 */
declare (z(*)) fixed binary;
declare b(maxval(z)-minval(z)+1) bit (maxval(z)-minval(z)+1) aligned;
declare (i, j, k, m, n) fixed binary;
declare a(hbound(z,1)) fixed binary unsigned;
declare offset fixed binary initial (minval(z));
 
PUT SKIP LIST('CHECKPOINT A'); PUT SKIP;
n = hbound(z,1);
m = hbound(b,1);
 
if offset < 0 then
a = z - offset;
else
a = z;
 
b = '0'b;
 
do i = 1 to n;
substr(b(i), 1, a(i)) = copy('1'b, a(i));
end;
do j = 1 to m; put skip list (b(j)); end;
 
do j = 1 to m;
k = 0;
do i =1 to n;
if substr(b(i), j, 1) then k = k + 1;
end;
do i = 1 to n;
substr(b(i), j, 1) = (i <= k);
end;
end;
put skip;
do j = 1 to m; put skip list (b(j)); end;
 
do i = 1 to n;
k = 0;
do j = 1 to m; k = k + substr(b(i), j, 1); end;
a(i) = k;
end;
if offset < 0 then z = a + offset; else z = a;
 
end beadsort;

[edit] PowerShell

Function BeadSort ( [Int64[]] $indata )
{
if( $indata.length -gt 1 )
{
$min = $indata[ 0 ]
$max = $indata[ 0 ]
for( $i = 1; $i -lt $indata.length; $i++ )
{
if( $indata[ $i ] -lt $min )
{
$min = $indata[ $i ]
}
if( $indata[ $i ] -gt $max ) {
$max = $indata[ $i ]
}
} #Find the min & max
$poles = New-Object 'UInt64[]' ( $max - $min + 1 )
$indata | ForEach-Object {
$min..$_ | ForEach-Object {
$poles[ $_ - $min ] += 1
}
} #Add Beads to the poles, already moved to the bottom
$min..( $max - 1 ) | ForEach-Object {
$i = $_ - $min
if( $poles[ $i ] -gt $poles[ $i + 1 ] )
{ #No special case needed for min, since there will always be at least 1 = min
( $poles[ $i ] )..( $poles[ $i + 1 ] + 1 ) | ForEach-Object {
Write-Output ( $i + $min )
}
}
} #Output the results in pipeline fashion
1..( $poles[ $max - $min ] ) | ForEach-Object {
Write-Output $max #No special case needed for max, since there will always be at least 1 = max
}
} else {
Write-Output $indata
}
}
 
$l = 100; BeadSort ( 1..$l | ForEach-Object { $Rand = New-Object Random }{ $Rand.Next( -( $l - 1 ), $l - 1 ) } )

[edit] PureBasic

#MAXNUM=100
 
Dim MyData(Random(15)+5)
Global Dim Abacus(0,0)
 
Declare BeadSort(Array InData(1))
Declare PresentData(Array InData(1))
 
If OpenConsole()
Define i
;- Generate a random array
For i=0 To ArraySize(MyData())
MyData(i)=Random(#MAXNUM)
Next i
PresentData(MyData())
;
;- Sort the array
BeadSort(MyData())
PresentData(MyData())
;
Print("Press ENTER to exit"): Input()
EndIf
 
Procedure LetFallDown(x)
Protected y=ArraySize(Abacus(),2)-1
Protected ylim=y
While y>=0
If Abacus(x,y) And Not Abacus(x,y+1)
Swap Abacus(x,y), Abacus(x,y+1)
If y<ylim: y+1: Continue: EndIf
Else
y-1
EndIf
Wend
EndProcedure
 
Procedure BeadSort(Array n(1))
Protected i, j, k
NewList T()
Dim Abacus(#MAXNUM,ArraySize(N()))
;- Set up the abacus
For i=0 To ArraySize(Abacus(),2)
For j=1 To N(i)
Abacus(j,i)=#True
Next
Next
;- sort it in threads to simulate free beads falling down
For i=0 To #MAXNUM
AddElement(T()): T()=CreateThread(@LetFallDown(),i)
Next
ForEach T()
WaitThread(T())
Next
;- send it back to a normal array
For j=0 To ArraySize(Abacus(),2)
k=0
For i=0 To ArraySize(Abacus())
k+Abacus(i,j)
Next
N(j)=k
Next
EndProcedure
 
Procedure PresentData(Array InData(1))
Protected n, m, sum
PrintN(#CRLF$+"The array is;")
For n=0 To ArraySize(InData())
m=InData(n): sum+m
Print(Str(m)+" ")
Next
PrintN(#CRLF$+"And its sum= "+Str(sum))
EndProcedure
The array is;
4 38 100 25 69 69 16 8 59 71 53 33
And its sum= 545

The array is;
4 8 16 25 33 38 53 59 69 69 71 100
And its sum= 545

[edit] Python

Translation of: Haskell
try:
from itertools import zip_longest
except:
try:
from itertools import izip_longest as zip_longest
except:
zip_longest = lambda *args: map(None, *args)
 
def beadsort(l):
return map(len, columns(columns([[1] * e for e in l])))
 
def columns(l):
return [filter(None, x) for x in zip_longest(*l)]
 
# Demonstration code:
print(beadsort([5,3,1,7,4,1,1]))

Output:

[7, 5, 4, 3, 1, 1, 1]

[edit] Racket

Translation of: Haskell
 
#lang racket
(require rackunit)
 
(define (columns lst)
(match (filter (λ (l) (not (empty? l))) lst)
['() '()]
[l (cons (map car l) (columns (map cdr l)))]))
 
(define (bead-sort lst)
(map length (columns (columns (map (λ (n) (make-list n 1)) lst)))))
 
;; unit test
(check-equal?
(bead-sort '(5 3 1 7 4 1 1))
'(7 5 4 3 1 1 1))
 

[edit] REXX

The REXX language has the advantage of implenting (true) sparse arrays and with that feature,
implementing a bead sort is trivial, the major drawback is if the spread (difference between
the lowest and highest values) is quite large.
Negative and duplicate numbers (values) are no problem.

/*REXX program sorts a list of integers using a  bead  sort algorithm.  */
/*get some grassHopper numbers. */
grasshopper=,
1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254 270
 
/*GreeenGrocer numbers are also called hexagonal pyramidal */
/* numbers. */
greengrocer=,
0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876 4560
 
/*get some Bernoulli numerator numbers. */
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0 854513'
 
/*Psi is also called the Reduced Totient function, and */
/* is also called Carmichale lambda, or LAMBDA function.*/
psi=,
1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16
 
list=grasshopper greengrocer bernN psi /*combine the four lists into one*/
 
call showL 'before sort',list /*show the list before sorting. */
$=beadSort(list) /*invoke the bead sort. */
call showL ' after sort',$ /*show the after array elements.*/
exit /*stick a fork in it, we're done.*/
/*──────────────────────────────────SHOW@ subroutine────────────────────*/
beadSort: procedure expose @.; parse arg z
$= /*this'll be the sorted list. */
low=999999999; high=-low /*define the low and high numbers*/
@.=0 /*define all beads to zero. */
 
do j=1 until z=='' /*pick the meat off the bone. */
parse var z x z
if \datatype(x,'Whole') then do
say; say '*** error! ***'; say
say 'element' j "in list isn't numeric:" x
say
exit 13
end
x=x/1 /*normalize number, it could be: */
/* +4 007 5. 2e3 etc.*/
@.x=@.x+1 /*indicate this bead has a number*/
low=min(low,x) /*keep track of the lowest number*/
high=max(high,x) /* " " " " highest " */
end /*j*/
/*now, collect the beads and */
do m=low to high /*let them fall (to zero). */
if @.m==0 then iterate /*No bead here? Then keep looking*/
do n=1 for @.m /*let the beads fall to 0. */
$=$ m /*add it to the sorted list. */
end /*n*/
end /*m*/
 
return $
/*──────────────────────────────────SHOWL subroutine────────────────────*/
showL: widthH=length(words(arg(2))) /*maximum width of the index. */
 
do j=1 for words(arg(2))
say 'element' right(j,widthH) arg(1)":" right(word(arg(2),j),10)
end /*j*/
 
say copies('─',79) /*show a separator line. */
return

output

element   1 before sort:          1
element   2 before sort:          4
element   3 before sort:         10
element   4 before sort:         12
element   5 before sort:         22
element   6 before sort:         26
element   7 before sort:         30
element   8 before sort:         46
element   9 before sort:         54
element  10 before sort:         62
element  11 before sort:         66
element  12 before sort:         78
element  13 before sort:         94
element  14 before sort:        110
element  15 before sort:        126
element  16 before sort:        134
element  17 before sort:        138
element  18 before sort:        158
element  19 before sort:        162
element  20 before sort:        186
element  21 before sort:        190
element  22 before sort:        222
element  23 before sort:        254
element  24 before sort:        270
element  25 before sort:          0
element  26 before sort:          4
element  27 before sort:         16
element  28 before sort:         40
element  29 before sort:         80
element  30 before sort:        140
element  31 before sort:        224
element  32 before sort:        336
element  33 before sort:        480
element  34 before sort:        660
element  35 before sort:        880
element  36 before sort:       1144
element  37 before sort:       1456
element  38 before sort:       1820
element  39 before sort:       2240
element  40 before sort:       2720
element  41 before sort:       3264
element  42 before sort:       3876
element  43 before sort:       4560
element  44 before sort:          1
element  45 before sort:         -1
element  46 before sort:          1
element  47 before sort:          0
element  48 before sort:         -1
element  49 before sort:          0
element  50 before sort:          1
element  51 before sort:          0
element  52 before sort:         -1
element  53 before sort:          0
element  54 before sort:          5
element  55 before sort:          0
element  56 before sort:       -691
element  57 before sort:          0
element  58 before sort:          7
element  59 before sort:          0
element  60 before sort:      -3617
element  61 before sort:          0
element  62 before sort:      43867
element  63 before sort:          0
element  64 before sort:    -174611
element  65 before sort:          0
element  66 before sort:     854513
element  67 before sort:          1
element  68 before sort:          1
element  69 before sort:          2
element  70 before sort:          2
element  71 before sort:          4
element  72 before sort:          2
element  73 before sort:          6
element  74 before sort:          2
element  75 before sort:          6
element  76 before sort:          4
element  77 before sort:         10
element  78 before sort:          2
element  79 before sort:         12
element  80 before sort:          6
element  81 before sort:          4
element  82 before sort:          4
element  83 before sort:         16
element  84 before sort:          6
element  85 before sort:         18
element  86 before sort:          4
element  87 before sort:          6
element  88 before sort:         10
element  89 before sort:         22
element  90 before sort:          2
element  91 before sort:         20
element  92 before sort:         12
element  93 before sort:         18
element  94 before sort:          6
element  95 before sort:         28
element  96 before sort:          4
element  97 before sort:         30
element  98 before sort:          8
element  99 before sort:         10
element 100 before sort:         16
───────────────────────────────────────────────────────────────────────────────
element   1  after sort:    -174611
element   2  after sort:      -3617
element   3  after sort:       -691
element   4  after sort:         -1
element   5  after sort:         -1
element   6  after sort:         -1
element   7  after sort:          0
element   8  after sort:          0
element   9  after sort:          0
element  10  after sort:          0
element  11  after sort:          0
element  12  after sort:          0
element  13  after sort:          0
element  14  after sort:          0
element  15  after sort:          0
element  16  after sort:          0
element  17  after sort:          0
element  18  after sort:          1
element  19  after sort:          1
element  20  after sort:          1
element  21  after sort:          1
element  22  after sort:          1
element  23  after sort:          1
element  24  after sort:          2
element  25  after sort:          2
element  26  after sort:          2
element  27  after sort:          2
element  28  after sort:          2
element  29  after sort:          2
element  30  after sort:          4
element  31  after sort:          4
element  32  after sort:          4
element  33  after sort:          4
element  34  after sort:          4
element  35  after sort:          4
element  36  after sort:          4
element  37  after sort:          4
element  38  after sort:          5
element  39  after sort:          6
element  40  after sort:          6
element  41  after sort:          6
element  42  after sort:          6
element  43  after sort:          6
element  44  after sort:          6
element  45  after sort:          7
element  46  after sort:          8
element  47  after sort:         10
element  48  after sort:         10
element  49  after sort:         10
element  50  after sort:         10
element  51  after sort:         12
element  52  after sort:         12
element  53  after sort:         12
element  54  after sort:         16
element  55  after sort:         16
element  56  after sort:         16
element  57  after sort:         18
element  58  after sort:         18
element  59  after sort:         20
element  60  after sort:         22
element  61  after sort:         22
element  62  after sort:         26
element  63  after sort:         28
element  64  after sort:         30
element  65  after sort:         30
element  66  after sort:         40
element  67  after sort:         46
element  68  after sort:         54
element  69  after sort:         62
element  70  after sort:         66
element  71  after sort:         78
element  72  after sort:         80
element  73  after sort:         94
element  74  after sort:        110
element  75  after sort:        126
element  76  after sort:        134
element  77  after sort:        138
element  78  after sort:        140
element  79  after sort:        158
element  80  after sort:        162
element  81  after sort:        186
element  82  after sort:        190
element  83  after sort:        222
element  84  after sort:        224
element  85  after sort:        254
element  86  after sort:        270
element  87  after sort:        336
element  88  after sort:        480
element  89  after sort:        660
element  90  after sort:        880
element  91  after sort:       1144
element  92  after sort:       1456
element  93  after sort:       1820
element  94  after sort:       2240
element  95  after sort:       2720
element  96  after sort:       3264
element  97  after sort:       3876
element  98  after sort:       4560
element  99  after sort:      43867
element 100  after sort:     854513
───────────────────────────────────────────────────────────────────────────────

[edit] Ruby

Translation of: Haskell
class Array
def beadsort
map {|e| [1] * e}.columns.columns.map {|e| e.length}
end
 
def columns
y = length
x = map {|l| l.length}.max
Array.new(x) do |row|
Array.new(y) { |column| self[column][row] }.compact # Remove nils.
end
end
end
 
# Demonstration code:
p [5,3,1,7,4,1,1].beadsort
Output:
[7, 5, 4, 3, 1, 1, 1]

[edit] Seed7

$ include "seed7_05.s7i";
 
const proc: beadSort (inout array integer: a) is func
local
var integer: max is 0;
var integer: sum is 0;
var array bitset: beads is 0 times {};
var integer: i is 0;
var integer: j is 0;
begin
beads := length(a) times {};
for i range 1 to length(a) do
if a[i] > max then
max := a[i];
end if;
beads[i] := {1 .. a[i]};
end for;
for j range 1 to max do
sum := 0;
for i range 1 to length(a) do
sum +:= ord(j in beads[i]);
excl(beads[i], j);
end for;
for i range length(a) - sum + 1 to length(a) do
incl(beads[i], j);
end for;
end for;
for i range 1 to length(a) do
for j range 1 to max until j not in beads[i] do
noop;
end for;
a[i] := pred(j);
end for;
end func;
 
const proc: main is func
local
var array integer: a is [] (5, 3, 1, 7, 4, 1, 1, 20);
var integer: num is 0;
begin
beadSort(a);
for num range a do
write(num <& " ");
end for;
writeln;
end func;
Output:
1 1 1 3 4 5 7 20 

[edit] Standard ML

Translation of: Haskell
fun columns l =
case List.filter (not o null) l of
[] => []
| l => map hd l :: columns (map tl l)
 
fun replicate (n, x) = List.tabulate (n, fn _ => x)
 
fun bead_sort l =
map length (columns (columns (map (fn e => replicate (e, 1)) l)))

usage

- bead_sort [5,3,1,7,4,1,1];
val it = [7,5,4,3,1,1,1] : int list

[edit] Tcl

package require Tcl 8.5
 
proc beadsort numList {
# Special case: empty list is empty when sorted.
if {![llength $numList]} return
# Set up the abacus...
foreach n $numList {
for {set i 0} {$i<$n} {incr i} {
dict incr vals $i
}
}
# Make the beads fall...
foreach n [dict values $vals] {
for {set i 0} {$i<$n} {incr i} {
dict incr result $i
}
}
# And the result is...
dict values $result
}
 
# Demonstration code
puts [beadsort {5 3 1 7 4 1 1}]

Output:

7 5 4 3 1 1 1

[edit] XPL0

include c:\cxpl\codes;
 
proc BeadSort(Array, Length); \Sort Array into increasing order
int Array, Length; \Array contents range 0..31; number of items
int Row, I, J, T, C;
[Row:= Reserve(Length*4); \each Row has room for 32 beads
for I:= 0 to Length-1 do \each Row gets Array(I) number of beads
Row(I):= ~-1<<Array(I); \(beware for 80186..Pentium <<32 doesn't shift)
for J:= 1 to Length-1 do
for I:= Length-1 downto J do
[T:= Row(I-1) & ~Row(I); \up to 31 beads fall in a single pass
Row(I-1):= Row(I-1) | T; \(|=xor, !=or)
Row(I):= Row(I) | T;
];
for I:= 0 to Length-1 do \count beads in each Row
[C:= 0; T:= Row(I);
while T do
[if T&1 then C:= C+1; T:= T>>1];
Array(I):= C; \count provides sorted order
];
];
 
int A, I;
[A:= [3, 1, 4, 1, 25, 9, 2, 6, 5, 0];
BeadSort(A, 10);
for I:= 0 to 10-1 do [IntOut(0, A(I)); ChOut(0, ^ )];
]
Output:
0 1 1 2 3 4 5 6 9 25 
Personal tools
Namespaces

Variants
Actions
Community
Explore
Misc
Toolbox