all tasks

Task/Sorting-algorithms-Bead-sort/0DESCRIPTION

@@ -0,0 +1,4 @@
+{{Sorting Algorithm}}
+In this task, the goal is to sort an array of positive integers using the [[wp:Bead_sort|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.

Task/Sorting-algorithms-Bead-sort/1META.yaml

@@ -0,0 +1,2 @@
+---
+note: Sorting Algorithms

Task/Sorting-algorithms-Bead-sort/C++/sorting-algorithms-bead-sort.cpp

@@ -0,0 +1,49 @@
+//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] << ' ';
+}

Task/Sorting-algorithms-Bead-sort/C/sorting-algorithms-bead-sort.c

@@ -0,0 +1,47 @@
+#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;
+}

Task/Sorting-algorithms-Bead-sort/Clojure/sorting-algorithms-bead-sort.clj

@@ -0,0 +1,14 @@
+(defn transpose [xs]
+  (loop [transposed [], remaining xs]
+    (if (empty? remaining)
+      transposed
+      (recur
+        (conj transposed (map #(first %) remaining))
+        (filter #(not-empty %) (map #(rest %) remaining)))) ))
+
+(defn bead-sort [xs]
+  (map #(reduce + %)
+    (transpose
+      (transpose (map #(replicate % 1) xs)))))
+
+(println (bead-sort [5 2 4 1 3 3 9]))

Task/Sorting-algorithms-Bead-sort/D/sorting-algorithms-bead-sort.d

@@ -0,0 +1,20 @@
+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;
+}

Task/Sorting-algorithms-Bead-sort/Delphi/sorting-algorithms-bead-sort.delphi

@@ -0,0 +1,66 @@
+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.

Task/Sorting-algorithms-Bead-sort/Factor/sorting-algorithms-bead-sort-1.factor

@@ -0,0 +1,9 @@
+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 ;

Task/Sorting-algorithms-Bead-sort/Factor/sorting-algorithms-bead-sort-2.factor

@@ -0,0 +1,2 @@
+( scratchpad ) { 5 2 4 1 3 3 9 } beadsort .
+{ 9 5 4 3 3 2 1 }

Task/Sorting-algorithms-Bead-sort/Fortran/sorting-algorithms-bead-sort.f

@@ -0,0 +1,41 @@
+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

Task/Sorting-algorithms-Bead-sort/Go/sorting-algorithms-bead-sort.go

@@ -0,0 +1,74 @@
+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
+    }
+}

Task/Sorting-algorithms-Bead-sort/Groovy/sorting-algorithms-bead-sort-1.groovy

@@ -0,0 +1,12 @@
+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()
+    }
+}

Task/Sorting-algorithms-Bead-sort/Groovy/sorting-algorithms-bead-sort-2.groovy

@@ -0,0 +1,19 @@
+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() }
+}

Task/Sorting-algorithms-Bead-sort/Groovy/sorting-algorithms-bead-sort-3.groovy

@@ -0,0 +1,2 @@
+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])

Task/Sorting-algorithms-Bead-sort/Haskell/sorting-algorithms-bead-sort-1.hs

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

Task/Sorting-algorithms-Bead-sort/Haskell/sorting-algorithms-bead-sort-2.hs

@@ -0,0 +1,2 @@
+*Main> beadSort [2,4,1,3,3]
+[4,3,3,2,1]

Task/Sorting-algorithms-Bead-sort/Icon/sorting-algorithms-bead-sort.icon

@@ -0,0 +1,25 @@
+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

Task/Sorting-algorithms-Bead-sort/J/sorting-algorithms-bead-sort-1.j

@@ -0,0 +1 @@
+bead=: [: +/ #"0&1

Task/Sorting-algorithms-Bead-sort/J/sorting-algorithms-bead-sort-2.j

@@ -0,0 +1,4 @@
+   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

Task/Sorting-algorithms-Bead-sort/J/sorting-algorithms-bead-sort-3.j

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

Task/Sorting-algorithms-Bead-sort/J/sorting-algorithms-bead-sort-4.j

@@ -0,0 +1,2 @@
+   bball 2 0 _1 3 1 _2 _3 0
+3 2 1 0 0 _1 _2 _3

Task/Sorting-algorithms-Bead-sort/Mathematica/sorting-algorithms-bead-sort.math

@@ -0,0 +1,12 @@
+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];
+]

Task/Sorting-algorithms-Bead-sort/NetRexx/sorting-algorithms-bead-sort.netrexx

@@ -0,0 +1,48 @@
+/* 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, ',')']'

Task/Sorting-algorithms-Bead-sort/OCaml/sorting-algorithms-bead-sort.ocaml

@@ -0,0 +1,9 @@
+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)))

Task/Sorting-algorithms-Bead-sort/Octave/sorting-algorithms-bead-sort.octave

@@ -0,0 +1,21 @@
+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])

Task/Sorting-algorithms-Bead-sort/OpenEdge-Progress/sorting-algorithms-bead-sort.openedge

@@ -0,0 +1,51 @@
+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.

Task/Sorting-algorithms-Bead-sort/PARI-GP/sorting-algorithms-bead-sort.pari

@@ -0,0 +1,24 @@
+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
+};

Task/Sorting-algorithms-Bead-sort/PHP/sorting-algorithms-bead-sort.php

@@ -0,0 +1,21 @@
+<?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)));
+?>

Task/Sorting-algorithms-Bead-sort/PL-I/sorting-algorithms-bead-sort.pli

@@ -0,0 +1,73 @@
+/* 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;

Task/Sorting-algorithms-Bead-sort/Perl-6/sorting-algorithms-bead-sort-1.pl6

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

Task/Sorting-algorithms-Bead-sort/Perl-6/sorting-algorithms-bead-sort-2.pl6

@@ -0,0 +1,9 @@
+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;

Task/Sorting-algorithms-Bead-sort/Perl/sorting-algorithms-bead-sort.pl

@@ -0,0 +1,16 @@
+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;

Task/Sorting-algorithms-Bead-sort/PicoLisp/sorting-algorithms-bead-sort.l

@@ -0,0 +1,9 @@
+(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 @) ) ) ) )

Task/Sorting-algorithms-Bead-sort/PowerShell/sorting-algorithms-bead-sort.psh

@@ -0,0 +1,40 @@
+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 ) } )

Task/Sorting-algorithms-Bead-sort/PureBasic/sorting-algorithms-bead-sort.purebasic

@@ -0,0 +1,72 @@
+#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

Task/Sorting-algorithms-Bead-sort/Python/sorting-algorithms-bead-sort.py

@@ -0,0 +1,16 @@
+try:
+  from itertools import zip_longest
+except:
+  try:
+    from itertools import izip_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:
+beadsort([5,3,1,7,4,1,1])

Task/Sorting-algorithms-Bead-sort/REXX/sorting-algorithms-bead-sort.rexx

@@ -0,0 +1,62 @@
+/*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

Task/Sorting-algorithms-Bead-sort/Racket/sorting-algorithms-bead-sort.rkt

@@ -0,0 +1,15 @@
+#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))

Task/Sorting-algorithms-Bead-sort/Ruby/sorting-algorithms-bead-sort.rb

@@ -0,0 +1,19 @@
+class Array
+	def beadsort
+		self.map {|e| [1] * e}.columns.columns.map {|e| e.length}
+	end
+
+	def columns
+		y = self.length
+		x = self.map {|l| l.length}.max
+
+		Array.new(x) do |row|
+			Array.new(y) { |column|
+				self[column][row]
+			}.compact # Remove nulls.
+		end
+	end
+end
+
+# Demonstration code:
+[5,3,1,7,4,1,1].beadsort

Task/Sorting-algorithms-Bead-sort/Standard-ML/sorting-algorithms-bead-sort.ml

@@ -0,0 +1,9 @@
+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)))

Task/Sorting-algorithms-Bead-sort/Tcl/sorting-algorithms-bead-sort.tcl

@@ -0,0 +1,23 @@
+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}]

Task/Sorting-algorithms-Bead-sort/XPL0/sorting-algorithms-bead-sort.xpl0

@@ -0,0 +1,27 @@
+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, ^ )];
+]