        >>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
*> This is GNUCOBOL 2.0
identification division.
program-id. heapsort.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01  filler.
    03  a pic 99.
    03  a-start pic 99.
    03  a-end pic 99.
    03  a-parent pic 99.
    03  a-child pic 99.
    03  a-sibling pic 99.
    03  a-lim pic 99 value 10.
    03  array-swap pic 99.
    03  array occurs 10 pic 99.
procedure division.
start-heapsort.

    *> fill the array
    compute a = random(seconds-past-midnight)
    perform varying a from 1 by 1 until a > a-lim
        compute array(a) = random() * 100
    end-perform

    perform display-array
    display  space 'initial array'

    *>heapify the array
    move a-lim to a-end
    compute a-start = (a-lim + 1) / 2
    perform sift-down varying a-start from a-start by -1 until a-start = 0

    perform display-array
    display space 'heapified'

    *> sort the array
    move 1 to a-start
    move a-lim to a-end
    perform until a-end = a-start
        move array(a-end) to array-swap
        move array(a-start) to array(a-end)
        move array-swap to array(a-start)
        subtract 1 from a-end
        perform sift-down
    end-perform

    perform display-array
    display space 'sorted'

    stop run
    .
sift-down.
    move a-start to a-parent
    perform until a-parent * 2 > a-end
        compute a-child = a-parent * 2
        compute a-sibling = a-child + 1
        if a-sibling <= a-end and array(a-child) < array(a-sibling)
            *> take the greater of the two
            move a-sibling to a-child
        end-if
        if a-child <= a-end and array(a-parent) < array(a-child)
           *> the child is greater than the parent
           move array(a-child) to array-swap
           move array(a-parent) to array(a-child)
           move array-swap to array(a-parent)
        end-if
        *> continue down the tree
        move a-child to a-parent
    end-perform
    .
display-array.
    perform varying a from 1 by 1 until a > a-lim
        display space array(a) with no advancing
    end-perform
    .
end program heapsort.


(import (rnrs base (6))
        (srfi :27 random-bits))

(define (shuffle lst)
  (define (swap! vec i j)
    (let ((tmp (vector-ref vec i)))
      (vector-set! vec i (vector-ref vec j))
      (vector-set! vec j tmp)))
  (define vec (list->vector lst))
  (let loop ((i (sub1 (vector-length vec))))
    (unless (zero? i)
      (swap! vec i (random-integer (add1 i)))
      (loop (sub1 i))))
  (vector->list vec))

(define (sorted? lst pred?)
  (cond
   ((null? (cdr lst)) #t)
   ((pred? (car lst) (cadr lst)) (sorted? (cdr lst) pred?))
   (else #f)))

(define (bogosort lst)
  (if (sorted? lst <)
      lst
      (bogosort (shuffle lst))))

(let ((input '(5 4 3 2 1)))
  (display "Input: ")
  (display input)
  (newline)
  (display "Output: ")
  (display (bogosort input))
  (newline))


func varSort<T: Comparable>(_ x: inout T, _ y: inout T, _ z: inout T) {
  let res = [x, y, z].sorted()

  x = res[0]
  y = res[1]
  z = res[2]
}

var x = "lions, tigers, and"
var y = "bears, oh my!"
var z = "(from the \"Wizard of OZ\")"

print("Before:")
print("x = \(x)")
print("y = \(y)")
print("z = \(z)")
print()

varSort(&x, &y, &z)

print("After:")
print("x = \(x)")
print("y = \(y)")
print("z = \(z)")


set x {lions, tigers, and}
set y {bears, oh my!}
set z {(from the "Wizard of OZ")}

lassign [lsort [list $x $y $z]] x y z

puts "x: $x"
puts "y: $y"
puts "z: $z"

set x 77444
set y -12
set z 0

lassign [lsort [list $x $y $z]] x y z

puts "x: $x"
puts "y: $y"
puts "z: $z"


Module Module1

    Sub Swap(Of T)(ByRef a As T, ByRef b As T)
        Dim c = a
        a = b
        b = c
    End Sub

    Sub Sort(Of T As IComparable(Of T))(ByRef a As T, ByRef b As T, ByRef c As T)
        If a.CompareTo(b) > 0 Then
            Swap(a, b)
        End If
        If a.CompareTo(c) > 0 Then
            Swap(a, c)
        End If
        If b.CompareTo(c) > 0 Then
            Swap(b, c)
        End If
    End Sub

    Sub Main()
        Dim x = 77444
        Dim y = -12
        Dim z = 0
        Sort(x, y, z)
        Console.WriteLine((x, y, z))

        Dim a = "lions, tigers, and"
        Dim b = "bears, oh my!"
        Dim c = "(from the 'Wizard of OZ')"
        Sort(a, b, c)
        Console.WriteLine((a, b, c))
    End Sub

End Module


#include <stdio.h>

// can be any swap function. This swap is optimized for numbers.
void swap(int *x, int *y) {
	if(x == y)
		return;
	*x ^= *y;
	*y ^= *x;
	*x ^= *y;
}
void cocktailsort(int *a, size_t n) {
	while(1) {
		// packing two similar loops into one
		char flag;
		size_t start[2] = {1, n - 1},
			   end[2] = {n, 0},
			   inc[2] = {1, -1};
		for(int it = 0; it < 2; ++it) {
			flag = 1;
			for(int i = start[it]; i != end[it]; i += inc[it])
				if(a[i - 1] > a[i]) {
					swap(a + i - 1, a + i);
					flag = 0;
				}
			if(flag)
				return;
		}
	}
}

int main(void) {
	int a[] = { 5, -1, 101, -4, 0, 1, 8, 6, 2, 3 };
	size_t n = sizeof(a)/sizeof(a[0]);

	cocktailsort(a, n);
	for (size_t i = 0; i < n; ++i)
		printf("%d ", a[i]);
	return 0;
}


# Do an in-place heap sort.
heap_sort = (arr) ->
  put_array_in_heap_order(arr)
  end = arr.length - 1
  while end > 0
    [arr[0], arr[end]] = [arr[end], arr[0]]
    sift_element_down_heap arr, 0, end
    end -= 1

put_array_in_heap_order = (arr) ->
  i = arr.length / 2 - 1
  i = Math.floor i
  while i >= 0
    sift_element_down_heap arr, i, arr.length
    i -= 1

sift_element_down_heap = (heap, i, max) ->
  while i < max
    i_big = i
    c1 = 2*i + 1
    c2 = c1 + 1
    if c1 < max and heap[c1] > heap[i_big]
      i_big = c1
    if c2 < max and heap[c2] > heap[i_big]
      i_big = c2
    return if i_big is i
    [heap[i], heap[i_big]] = [heap[i_big], heap[i]]
    i = i_big

do ->
  arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8]
  heap_sort arr
  console.log arr


Smalltalk at: #isItSorted put: [ :c |
  |isit|
  isit := false.
  (2 to: (c size)) detect: [ :i |
    ( (c at: ( i - 1 )) > (c at: i) )
  ] ifNone: [ isit := true ].
  isit
].
Smalltalk at: #bogosort put: [ :c |
  [ isItSorted value: c ] whileFalse: [
     1 to: (c size) do: [ :i |
        |r t|
        r := (Random between: 1 and: (c size)).
        t := (c at: i).
        c at: i put: (c at: r).
        c at: r put: t
     ]
  ]
].

|tobesorted|
tobesorted := { 2 . 7 . 5 . 3 . 4 . 8 . 6 . 1 }.
bogosort value: tobesorted.
tobesorted displayNl.


* Library for random()
-include 'Random.sno'

*       # String -> array
        define('s2a(str,n)i') :(s2a_end)
s2a     s2a = array(n); str = str ' '
sa1     str break(' ') . s2a<i = i + 1> span(' ') = :s(sa1)f(return)
s2a_end

*       # Array -> string
        define('a2s(a)i') :(a2s_end)
a2s     a2s = a2s a<i = i + 1> ' ' :s(a2s)f(return)
a2s_end

*       # Knuth shuffle in-place
        define('shuffle(a)alen,n,k,tmp') :(shuffle_end)
shuffle n = alen = prototype(a);
sh1     k = convert(random() * alen,'integer') + 1
        eq(a<n>,a<k>) :s(sh2)
        tmp = a<n>; a<n> = a<k>; a<k> = tmp
sh2     n = gt(n,1) n - 1 :s(sh1)
        shuffle = a :(return)
shuffle_end

*       # sorted( ) predicate -> Succeed/Fail
        define('sorted(a)alen,i') :(sorted_end)
sorted  alen = prototype(a); i = 1
std1    i = lt(i,alen) i + 1 :f(return)
        gt(a<i - 1>,a<i>) :s(freturn)f(std1)
sorted_end

*       # Bogosort
        define('bogo(a)') :(bogo_end)
bogo    output = (i = i + 1) ': ' a2s(a)
        bogo = sorted(a) a :s(return)
        shuffle(a) :(bogo)
bogo_end

*       # Test and display
        bogo(s2a('5 4 3 2 1',5))
end


import "/sort" for Sort
import "/fmt" for Fmt

var sort3 = Fn.new { |x, y, z|
    var a = [x, y, z]
    Sort.insertion(a)
    x = a[0]
    y = a[1]
    z = a[2]
    Fmt.print("  x = $s\n  y = $s\n  z = $s", x, y, z)
}

System.print("After sorting strings:")
var x = "lions, tigers, and"
var y = "bears, oh my!"
var z = "(from the \"Wizard of OZ\")"
sort3.call(x, y, z)

System.print("\nAfter sorting integers:")
x = 77444
y = -12
z = 0
sort3.call(x, y, z)

System.print("\nAfter sorting floats:")
x = 11.3
y = -9.7
z = 11.17
sort3.call(x, y, z)


x,y,z := "lions, tigers, and", "bears, oh my!", 0'|(from the "Wizard of OZ")|;
x,y,z = List(x,y,z).sort();
println(x," | ",y," | ",z);

x,y,z := 77444, -12, 0;
x,y,z = List(x,y,z).sort();
println(x," ",y," ",z);


public static void cocktailSort(int[] A)
    {
        bool swapped;
        do
        {
            swapped = false;
            for (int i = 0; i <= A.Length - 2; i++)
            {
                if (A[i] > A[i + 1])
                {
                    //test whether the two elements are in the wrong order
                    int temp = A[i];
                    A[i] = A[i + 1];
                    A[i + 1] = temp;
                    swapped = true;
                }
            }
            if (!swapped)
            {
                //we can exit the outer loop here if no swaps occurred.
                break;
            }
            swapped = false;
            for (int i = A.Length - 2; i >= 0; i--)
            {
                if (A[i] > A[i + 1])
                {
                    int temp = A[i];
                    A[i] = A[i + 1];
                    A[i + 1] = temp;
                    swapped = true;
                }
            }
            //if no elements have been swapped, then the list is sorted
        } while (swapped);
    }


#include <iostream>
#include <windows.h>

const int EL_COUNT = 77, LLEN = 11;

class cocktailSort
{
public:
    void sort( int* arr, int len )
    {
	bool notSorted = true;
	while( notSorted )
	{
	    notSorted = false;
	    for( int a = 0; a < len - 1; a++ )
	    {
		if( arr[a] > arr[a + 1] )
		{
		    sSwap( arr[a], arr[a + 1] );
		    notSorted = true;
		}
	    }

	    if( !notSorted ) break;
	    notSorted = false;

	    for( int a = len - 1; a > 0; a-- )
	    {
		if( arr[a - 1] > arr[a] )
		{
		    sSwap( arr[a], arr[a - 1] );
		    notSorted = true;
		}
	    }
	}
    }

private:
    void sSwap( int& a, int& b )
    {
	int t = a;
   	a = b; b = t;
    }
};

int main( int argc, char* argv[] )
{
    srand( GetTickCount() );
    cocktailSort cs;
    int arr[EL_COUNT];

    for( int x = 0; x < EL_COUNT; x++ )
        arr[x] = rand() % EL_COUNT + 1;

    std::cout << "Original: " << std::endl << "==========" << std::endl;
    for( int x = 0; x < EL_COUNT; x += LLEN )
    {
	for( int s = x; s < x + LLEN; s++ )
	    std::cout << arr[s] << ", ";

	std::cout << std::endl;
    }

    //DWORD now = GetTickCount();
    cs.sort( arr, EL_COUNT );
    //now = GetTickCount() - now;

    std::cout << std::endl << std::endl << "Sorted: " << std::endl << "========" << std::endl;
    for( int x = 0; x < EL_COUNT; x += LLEN )
    {
	for( int s = x; s < x + LLEN; s++ )
	    std::cout << arr[s] << ", ";

	std::cout << std::endl;
    }

    std::cout << std::endl << std::endl << std::endl << std::endl;
    //std::cout << now << std::endl << std::endl;
    return 0;
}


(defun make-heap (&optional (length 7))
  (make-array length :adjustable t :fill-pointer 0))

(defun left-index (index)
  (1- (* 2 (1+ index))))

(defun right-index (index)
  (* 2 (1+ index)))

(defun parent-index (index)
  (floor (1- index) 2))

(defun percolate-up (heap index predicate)
  (if (zerop index) heap
    (do* ((element (aref heap index))
          (index index pindex)
          (pindex (parent-index index)
                  (parent-index index)))
         ((zerop index) heap)
      (if (funcall predicate element (aref heap pindex))
        (rotatef (aref heap index) (aref heap pindex))
        (return-from percolate-up heap)))))

(defun heap-insert (heap element predicate)
  (let ((index (vector-push-extend element heap 2)))
    (percolate-up heap index predicate)))

(defun percolate-down (heap index predicate)
  (let ((length (length heap))
        (element (aref heap index)))
    (flet ((maybe-element (index)
             "return the element at index or nil, and a boolean
              indicating whether there was an element."
             (if (< index length)
               (values (aref heap index) t)
               (values nil nil))))
      (do ((index index swap-index)
           (lindex (left-index index) (left-index index))
           (rindex (right-index index) (right-index index))
           (swap-index nil) (swap-child nil))
          (nil)
        ;; Extact the left child if there is one. If there is not,
        ;; return the heap.  Set the left child as the swap-child.
        (multiple-value-bind (lchild lp) (maybe-element lindex)
          (if (not lp) (return-from percolate-down heap)
            (setf swap-child lchild
                  swap-index lindex))
          ;; Extract the right child, if any, and when better than the
          ;; current swap-child, update the swap-child.
          (multiple-value-bind (rchild rp) (maybe-element rindex)
            (when (and rp (funcall predicate rchild lchild))
              (setf swap-child rchild
                    swap-index rindex))
            ;; If the swap-child is better than element, rotate them,
            ;; and continue percolating down, else return heap.
            (if (not (funcall predicate swap-child element))
              (return-from percolate-down heap)
              (rotatef (aref heap index) (aref heap swap-index)))))))))

(defun heap-empty-p (heap)
  (eql (length heap) 0))

(defun heap-delete-min (heap predicate)
  (assert (not (heap-empty-p heap)) () "Can't pop from empty heap.")
  (prog1 (aref heap 0)
    (setf (aref heap 0) (vector-pop heap))
    (unless (heap-empty-p heap)
      (percolate-down heap 0 predicate))))

(defun heapsort (sequence predicate)
  (let ((h (make-heap (length sequence))))
    (map nil #'(lambda (e) (heap-insert h e predicate)) sequence)
    (map-into sequence #'(lambda () (heap-delete-min h predicate)))))


F bead_sort(&a)
   V maxv = max(a)
   V beads = [0] * (maxv * a.len)

   L(i) 0 .< a.len
      L(j) 0 .< a[i]
         beads[i * maxv + j] = 1

   L(j) 0 .< maxv
      V sum = 0
      L(i) 0 .< a.len
         sum += beads[i * maxv + j]
         beads[i * maxv + j] = 0

      L(i) a.len - sum .< a.len
         beads[i * maxv + j] = 1

   L(i) 0 .< a.len
      V j = 0
      L j < maxv & beads[i * maxv + j] > 0
         j++
      a[i] = j

V a = [5, 3, 1, 7, 4, 1, 1, 20]
bead_sort(&a)
print(a)


import Darwin

func shuffle<T>(inout array: [T]) {
  for i in 1..<array.count {
    let j = Int(arc4random_uniform(UInt32(i)))
    (array[i], array[j]) = (array[j], array[i])
  }
}

func issorted<T:Comparable>(ary: [T]) -> Bool {
  for i in 0..<(ary.count-1) {
    if ary[i] > ary[i+1] {
      return false
    }
  }
  return true
}

func bogosort<T:Comparable>(inout ary: [T]) {
  while !issorted(ary) {
    shuffle(&ary)
  }
}


package require Tcl 8.5

proc shuffleInPlace {listName} {
    upvar 1 $listName list
    set len [set len2 [llength $list]]
    for {set i 0} {$i < $len-1} {incr i; incr len2 -1} {
        # Pick cell to swap with
        set n [expr {int($i + $len2 * rand())}]
        # Perform swap
        set temp [lindex $list $i]
        lset list $i [lindex $list $n]
        lset list $n $temp
    }
}
proc inOrder {list} {
    set prev [lindex $list 0]
    foreach item [lrange $list 1 end] {
        if {$prev > $item} {
            return false
        }
        set prev $item
    }
    return true
}
proc bogosort {list} {
    while { ! [inOrder $list]} {
        shuffleInPlace list
    }
    return $list
}


       C-SORT SECTION.
       C-000.
           DISPLAY "SORT STARTING".

           MOVE 2       TO WC-START
           MOVE WC-SIZE TO WC-END.
           MOVE 1       TO WC-DIRECTION
                           WC-LAST-CHANGE.
           PERFORM E-SHAKER UNTIL WC-END * WC-DIRECTION <
                                  WC-START * WC-DIRECTION.

           DISPLAY "SORT FINISHED".

       C-999.
           EXIT.

       E-SHAKER SECTION.
       E-000.
           PERFORM F-PASS VARYING WB-IX-1 FROM WC-START BY WC-DIRECTION
                          UNTIL WB-IX-1 = WC-END + WC-DIRECTION.

           MOVE WC-START TO WC-END.
           SUBTRACT WC-DIRECTION FROM WC-LAST-CHANGE GIVING WC-START.
           MULTIPLY WC-DIRECTION BY -1 GIVING WC-DIRECTION.

       E-999.
           EXIT.

       F-PASS SECTION.
       F-000.
           IF WB-ENTRY(WB-IX-1 - 1) > WB-ENTRY(WB-IX-1)
              SET  WC-LAST-CHANGE        TO WB-IX-1
              MOVE WB-ENTRY(WB-IX-1 - 1) TO WC-TEMP
              MOVE WB-ENTRY(WB-IX-1)     TO WB-ENTRY(WB-IX-1 - 1)
              MOVE WC-TEMP               TO WB-ENTRY(WB-IX-1).

       F-999.
           EXIT.


(defun cocktail-sort-vector (vector predicate &aux (len (length vector)))
  (labels ((scan (start step &aux swapped)
             (loop for i = start then (+ i step) while (< 0 i len) do
               (when (funcall predicate (aref vector i)
                                        (aref vector (1- i)))
                 (rotatef (aref vector i)
                          (aref vector (1- i)))
                 (setf swapped t)))
             swapped))
    (loop while (and (scan 1         1)
                     (scan (1- len) -1))))
  vector)

(defun cocktail-sort (sequence predicate)
  (etypecase sequence
    (vector (cocktail-sort-vector sequence predicate))
    (list (map-into sequence 'identity
                    (cocktail-sort-vector (coerce sequence 'vector)
                                          predicate)))))


import std.stdio, std.container;

void heapSort(T)(T[] data) /*pure nothrow @safe @nogc*/ {
    for (auto h = data.heapify; !h.empty; h.removeFront) {}
}

void main() {
   auto items = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0];
   items.heapSort;
   items.writeln;
}


void heapSort(List a) {
  int count = a.length;

  // first place 'a' in max-heap order
  heapify(a, count);

  int end = count - 1;
  while (end > 0) {
    // swap the root (maximum value) of the heap with the
    // last element of the heap
    int tmp = a[end];
    a[end] = a[0];
    a[0] = tmp;

    // put the heap back in max-heap order
    siftDown(a, 0, end - 1);

    // decrement the size of the heap so that the previous
    // max value will stay in its proper place
    end--;
  }
}

void heapify(List a, int count) {
  // start is assigned the index in 'a' of the last parent node
  int start = ((count - 2)/2).toInt(); // binary heap

  while (start >= 0) {
    // sift down the node at index 'start' to the proper place
    // such that all nodes below the 'start' index are in heap
    // order
    siftDown(a, start, count - 1);
    start--;
  }
}

void siftDown(List a, int start, int end) {
  // end represents the limit of how far down the heap to shift
  int root = start;

  while ((root*2 + 1) <= end) { // While the root has at least one child
    int child = root*2 + 1; // root*2+1 points to the left child
    // if the child has a sibling and the child's value is less than its sibling's...
    if (child + 1 <= end && a[child] < a[child + 1]) {
      child = child+1; // .. then point to the right child instead
    }

    if (a[root] < a[child]) { // out of max-heap order
      int tmp = a[root];
      a[root] = a[child];
      a[child] = tmp;
      root = child; // repeat to continue shifting down the child now
    } else {
      return;
    }
  }

}

void main() {
  var arr=[1,5,2,7,3,9,4,6,8];
  print("Before sort");
  arr.forEach((var i)=>print("$i"));
  heapSort(arr);
  print("After sort");
  arr.forEach((var i)=>print("$i"));
}


*        Bead Sort                 11/05/2016
BEADSORT CSECT
         USING  BEADSORT,R13       base register
SAVEAR   B      STM-SAVEAR(R15)    skip savearea
         DC     17F'0'             savearea
STM      STM    R14,R12,12(R13)    prolog
         ST     R13,4(R15)         "
         ST     R15,8(R13)         "
         LR     R13,R15            "
         LA     R6,1               i=1
LOOPI1   CH     R6,=AL2(N)         do i=1 to hbound(z)
         BH     ELOOPI1            leave i
         LR     R1,R6                i
         SLA    R1,1                 <<1
         LH     R2,Z-2(R1)           z(i)
         CH     R2,LO                if z(i)<lo
         BNL    EIHO                 then
         STH    R2,LO                  lo=z(i)
EIHLO    CH     R2,HI                if z(i)>hi
         BNH    EIHHI                then
         STH    R2,HI                  hi=z(i)
EIHHI    LA     R6,1(R6)           iterate i
         B      LOOPI1             next i
ELOOPI1  LA     R9,1               1
         SH     R9,LO              -lo+1
         LA     R6,1               i=1
LOOPI2   CH     R6,=AL2(N)         do i=1 to hbound(z)
         BH     ELOOPI2            leave i
         LR     R1,R6                i
         SLA    R1,1                 <<1
         LH     R3,Z-2(R1)           z(i)
         AR     R3,R9                z(i)+o
         IC     R2,BEADS-1(R3)       beads(l)
         LA     R2,1(R2)             beads(l)+1
         STC    R2,BEADS-1(R3)       beads(l)=beads(l)+1
         LA     R6,1(R6)           iterate i
         B      LOOPI2             next i
ELOOPI2  SR     R8,R8              k=0
         LH     R6,LO              i=lo
LOOPI3   CH     R6,HI              do i=lo to hi
         BH     ELOOPI3            leave i
         LA     R7,1                 j=1
         SR     R10,R10              clear r10
         LR     R1,R6                i
         AR     R1,R9                i+o
         IC     R10,BEADS-1(R1)      beads(i+o)
LOOPJ3   CR     R7,R10               do j=1 to beads(i+o)
         BH     ELOOPJ3              leave j
         LA     R8,1(R8)               k=k+1
         LR     R1,R8                  k
         SLA    R1,1                   <<1
         STH    R6,S-2(R1)             s(k)=i
         LA     R7,1(R7)             iterate j
         B      LOOPJ3               next j
ELOOPJ3  AH     R6,=H'1'           iterate i
         B      LOOPI3             next i
ELOOPI3  LA     R7,1               j=1
LOOPJ4   CH     R7,=H'2'           do j=1 to 2
         BH     ELOOPJ4            leave j
         CH     R7,=H'1'             if j<>1
         BE     ONE                  then
         MVC    PG(7),=C'sorted:'      zap
ONE      LA     R10,PG+7             [email protected]+7
         LA     R6,1                 i=1
LOOPI4   CH     R6,=AL2(N)           do i=1 to hbound(z)
         BH     ELOOPI4              leave i
         CH     R7,=H'1'               if j=1
         BNE    TWO                    then
         LR     R1,R6                    i
         SLA    R1,1                     <<1
         LH     R11,Z-2(R1)              zs=z(i)
         B      XDECO                  else
TWO      LR     R1,R6                    i
         SLA    R1,1                     <<1
         LH     R11,S-2(R1)              zs=s(i)
XDECO    XDECO  R11,XDEC               edit zs
         MVC    0(6,R10),XDEC+6        output zs
         LA     R10,6(R10)             pgi=pgi+6
         LA     R6,1(R6)             iterate i
         B      LOOPI4               next i
ELOOPI4  XPRNT  PG,80                print buffer
         LA     R7,1(R7)             iterate j
         B      LOOPJ4             next j
ELOOPJ4  L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    "
         XR     R15,R15            "
         BR     R14                "
         LTORG                     literal table
N        EQU    (S-Z)/2            number of items
Z        DC     H'5',H'3',H'1',H'7',H'-1',H'4',H'9',H'-12'
         DC     H'2001',H'-2010',H'17',H'0'
S        DS     (N)H               s same size as z
LO       DC     H'32767'           2**31-1
HI       DC     H'-32768'          -2**31
PG       DC     CL80'   raw:'      buffer
XDEC     DS     CL12               temp
BEADS    DC     4096X'00'          beads
         YREGS
         END    BEADSORT


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program beadSort64.s */
/* En français tri par gravité ou tri par bille (ne pas confondre
   avec tri par bulle (bubble sort)) */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:   .asciz "\n"

.align 4
#TableNumber:      .quad   1,3,6,2,5,9,10,8,4,7
TableNumber:     .quad   10,9,8,7,6,5,4,3,2,1
                  .equ NBELEMENTS, (. - TableNumber) / 8
           //.equ NBELEMENTS, 4 // for others tests
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:            .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                         // entry of program

1:
    ldr x0,qAdrTableNumber    // address number table
    mov x1,#NBELEMENTS        // number of élements
    bl beadSort
    ldr x0,qAdrTableNumber    // address number table
    mov x1,#NBELEMENTS        // number of élements
    bl displayTable

    ldr x0,qAdrTableNumber    // address number table
    mov x1,#NBELEMENTS        // number of élements
    bl isSorted               // control sort
    cmp x0,#1                 // sorted ?
    beq 2f
    ldr x0,qAdrszMessSortNok  // no !! error sort
    bl affichageMess
    b 100f
2:                            // yes
    ldr x0,qAdrszMessSortOk
    bl affichageMess
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
qAdrTableNumber:          .quad TableNumber
qAdrszMessSortOk:         .quad szMessSortOk
qAdrszMessSortNok:        .quad szMessSortNok
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements  > 0  */
/* x0 return 0  if not sorted   1  if sorted */
isSorted:
    stp x2,lr,[sp,-16]!          // save  registers
    stp x3,x4,[sp,-16]!          // save  registers
    mov x2,#0
    ldr x4,[x0,x2,lsl #3]        // load A[0]
1:
    add x2,x2,#1
    cmp x2,x1                    // end ?
    bge 99f
    ldr x3,[x0,x2, lsl #3]       // load A[i]
    cmp x3,x4                    // compare A[i],A[i-1]
    blt 98f                      // smaller -> error -> return
    mov x4,x3                    // no -> A[i-1] = A[i]
    b 1b                         // and loop
98:
    mov x0,#0                    // error
    b 100f
99:
    mov x0,#1                    // ok -> return
100:
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30
/******************************************************************/
/*         bead sort                                              */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of element */
/* Caution registers x2-x12 are not saved */
beadSort:
    stp x1,lr,[sp,-16]!       // save  registers
    mov x12,x1                // save elements number
                              //search max
    ldr x10,[x0]              // load value A[0] in max
    mov x4,#1
1:                            // loop search max
    cmp x4,x12                // end ?
    bge 21f                   // yes
    ldr x2,[x0,x4,lsl #3]     // load value A[i]
    cmp x2,x10                // compare with max
    csel x10,x2,x10,gt        // if greather
    add x4,x4,#1
    b 1b                      // loop
21:
    mul x5,x10,x12            // max * elements number
    lsl x5,x5,#3              // 8 bytes for each number
    sub sp,sp,x5              // allocate on the stack
    mov fp,sp                 // frame pointer = stack address
                              // marks beads
    mov x3,x0                 // save table address
    mov x0,#0                 // start index x
2:
    mov x1,#0                 // index y
    ldr x8,[x3,x0,lsl #3]     // load A[x]
    mul x6,x0,x10             // compute bead x
3:
    add x9,x6,x1              // compute bead y
    mov x4,#1                 // value to store
    str x4,[fp,x9,lsl #3]     // store to stack area
    add x1,x1,#1
    cmp x1,x8
    blt 3b
31:                           // init to zéro the bead end
    cmp x1,x10                // max ?
    bge 32f
    add x9,x6,x1              // compute bead y
    mov x4,#0
    str x4,[fp,x9,lsl #3]
    add x1,x1,#1
    b 31b
32:
    add x0,x0,#1              // increment x
    cmp x0,x12                // end ?
    blt 2b
                              // count beads
    mov x1,#0                 // y
4:
    mov x0,#0                 // start index x
    mov x8,#0                 // sum
5:
    mul x6,x0,x10             // compute bead x
    add x9,x6,x1              // compute bead y
    ldr x4,[fp,x9,lsl #3]
    add x8,x8,x4
    mov x4,#0
    str x4,[fp,x9,lsl #3]     // raz bead
    add x0,x0,#1
    cmp x0,x12
    blt 5b
    sub x0,x12,x8             // compute end - sum
6:
    mul x6,x0,x10             // compute bead x
    add x9,x6,x1              // compute bead y
    mov x4,#1
    str x4,[fp,x9,lsl #3]     // store new bead at end
    add x0,x0,#1
    cmp x0,x12
    blt 6b

    add x1,x1,#1
    cmp x1,x10
    blt 4b

                              // final compute
    mov x0,#0                 // start index x
7:
    mov x1,#0                 // start index y
    mul x6,x0,x10             // compute bead x
8:
    add x9,x6,x1              // compute bead y
    ldr x4,[fp,x9,lsl #3]     // load bead [x,y]
    add x1,x1,#1              // add to x1 before str (index start at zéro)
    cmp x4,#1
    bne 9f
    str x1,[x3,x0, lsl #3]    // store A[x]
9:
    cmp x1,x10                // compare max
    blt 8b
    add x0,x0,#1
    cmp x0,x12                // end ?
    blt 7b

    mov x0,#0
    add sp,sp,x5              // stack alignement
100:
    ldp x1,lr,[sp],16         // restaur  2 registers
    ret                       // return to address lr x30
/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains elements number  */
displayTable:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    mov x2,x0                    // table address
    mov x4,x1                    // elements number
    mov x3,#0
1:                               // loop display table
    ldr x0,[x2,x3,lsl #3]
    ldr x1,qAdrsZoneConv
    bl conversion10              // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv         // insert conversion
    bl strInsertAtCharInc
    bl affichageMess             // display message
    add x3,x3,#1
    cmp x3,x4                    // end ?
    blt 1b                       // no -> loop
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
100:
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30
qAdrsZoneConv:           .quad sZoneConv

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


/* ARM assembly Raspberry PI  */
/*  program beadSort.s */
/* En français tri par gravité ou tri par bille (ne pas confondre
   avec tri par bulle (bubble sort) */

 /* 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"

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:   .asciz "\n"

.align 4
TableNumber:      .int   1,3,6,2,5,9,10,8,4,7
#TableNumber:     .int   10,9,8,7,6,5,4,3,2,1
                  .equ NBELEMENTS, (. - TableNumber) / 4
           @.equ NBELEMENTS, 4 @ for others tests
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:            .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                         @ entry of program

1:
    ldr r0,iAdrTableNumber    @ address number table
    mov r1,#NBELEMENTS        @ number of élements
    bl beadSort
    ldr r0,iAdrTableNumber    @ address number table
    mov r1,#NBELEMENTS        @ number of élements
    bl displayTable

    ldr r0,iAdrTableNumber    @ address number table
    mov r1,#NBELEMENTS        @ number of élements
    bl isSorted               @ control sort
    cmp r0,#1                 @ sorted ?
    beq 2f
    ldr r0,iAdrszMessSortNok  @ no !! error sort
    bl affichageMess
    b 100f
2:                            @ yes
    ldr r0,iAdrszMessSortOk
    bl affichageMess
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
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrszMessSortOk:         .int szMessSortOk
iAdrszMessSortNok:        .int szMessSortNok
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements  > 0  */
/* r0 return 0  if not sorted   1  if sorted */
isSorted:
    push {r2-r4,lr}              @ save registers
    mov r2,#0
    ldr r4,[r0,r2,lsl #2]        @ load A[0]
1:
    add r2,#1
    cmp r2,r1                    @ end ?
    movge r0,#1                  @ yes -> ok -> return
    bge 100f
    ldr r3,[r0,r2, lsl #2]       @ load A[i]
    cmp r3,r4                    @ compare A[i],A[i-1]
    movlt r0,#0                  @ smaller ?
    blt 100f                     @ yes -> error -> return
    mov r4,r3                    @ no -> A[i-1] = A[i]
    b 1b                         @ and loop
100:
    pop {r2-r4,lr}
    bx lr                        @ return
/******************************************************************/
/*         bead sort                                              */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of element */
beadSort:
    push {r1-r12,lr}          @ save registers
    mov r12,r1                @ save elements number
    @search max
    ldr r10,[r0]              @ load value A[0] in max
    mov r4,#1
1:                            @ loop search max
    cmp r4,r12                @ end ?
    bge 21f                   @ yes
    ldr r2,[r0,r4,lsl #2]     @ load value A[i]
    cmp r2,r10                @ compare with max
    movgt r10,r2              @ if greather
    add r4,r4,#1
    b 1b                      @ loop
21:
    mul r5,r10,r12            @ max * elements number
    lsl r5,r5,#2              @ 4 bytes for each number
    sub sp,sp,r5              @ allocate on the stack
    mov fp,sp                 @ frame pointer = stack address
                              @ marks beads
    mov r3,r0                 @ save table address
    mov r0,#0                 @ start index x
2:
    mov r1,#0                 @ index y
    ldr r7,[r3,r0,lsl #2]     @ load A[x]
    mul r6,r0,r10             @ compute bead x
3:
    add r9,r6,r1              @ compute bead y
    mov r4,#1                 @ value to store
    str r4,[fp,r9,lsl #2]     @ store to stack area
    add r1,r1,#1
    cmp r1,r7
    blt 3b
31:                           @ init to zéro the bead end
    cmp r1,r10                @ max ?
    bge 32f
    add r9,r6,r1              @ compute bead y
    mov r4,#0
    str r4,[fp,r9,lsl #2]
    add r1,r1,#1
    b 31b
32:
    add r0,r0,#1              @ increment x
    cmp r0,r12                @ end ?
    blt 2b
                              @ count beads
    mov r1,#0                 @ y
4:
    mov r0,#0                 @ start index x
    mov r8,#0                 @ sum
5:
    mul r6,r0,r10             @ compute bead x
    add r9,r6,r1              @ compute bead y
    ldr r4,[fp,r9,lsl #2]
    add r8,r8,r4
    mov r4,#0
    str r4,[fp,r9,lsl #2]
    add r0,r0,#1
    cmp r0,r12
    blt 5b
    sub r0,r12,r8
6:
    mul r6,r0,r10             @ compute bead x
    add r9,r6,r1              @ compute bead y
    mov r4,#1
    str r4,[fp,r9,lsl #2]
    add r0,r0,#1
    cmp r0,r12
    blt 6b

    add r1,r1,#1
    cmp r1,r10
    blt 4b

    @ suite
    mov r0,#0                 @ start index
7:
    mov r1,#0
    mul r6,r0,r10             @ compute bead x
8:
    add r9,r6,r1              @ compute bead y
    ldr r4,[fp,r9,lsl #2]
    add r1,r1,#1              @ add to r1 before str (index start at zéro)
    cmp r4,#1
    streq r1,[r3,r0, lsl #2]  @ store A[i]
    cmp r1,r10                @ compare max
    blt 8b
    add r0,r0,#1
    cmp r0,r12                @ end ?
    blt 7b

    mov r0,#0
    add sp,sp,r5              @ stack alignement
100:
    pop {r1-r12,lr}
    bx lr                     @ return
/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains elements number  */
displayTable:
    push {r0-r4,lr}              @ save registers
    mov r2,r0                    @ table address
    mov r4,r1                    @ elements number
    mov r3,#0
1:                               @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsZoneConv
    bl conversion10              @ décimal conversion
    ldr r0,iAdrsMessResult
    ldr r1,iAdrsZoneConv         @ insert conversion
    bl strInsertAtCharInc
    bl affichageMess             @ display message
    add r3,r3,#1
    cmp r3,r4                    @ end ?
    blt 1b                       @ no -> loop
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
100:
    pop {r0-r4,lr}
    bx lr
iAdrsZoneConv:           .int sZoneConv
/***************************************************/
/*      ROUTINES INCLUDE                           */
/***************************************************/
.include "../affichage.inc"


:"BOGO"
:L1→L2
:Lbl A
:dim(L2)→A
:For(B,1,dim(L2)-1)
:randInt(1,A)→C
:L2(C)→D
:L2(A)→L2(C)
:D→L2(A)
:A-1→A
:End
:For(D,1,dim(L2)-1)
:If L2(D)>L2(D+1)
:Goto A
:End
:DelVar A
:DelVar B
:DelVar C
:DelVar D
:Return


#import std
#import nat

shuffle = @iNX ~&l->r ^jrX/~&l ~&lK8PrC

bogosort = (not ordered nleq)-> shuffle

#cast %nL

example = bogosort <8,50,0,12,47,51>


Private Function Knuth(a As Variant) As Variant
    Dim t As Variant, i As Integer
    If Not IsMissing(a) Then
        For i = UBound(a) To LBound(a) + 1 Step -1
            j = Int((UBound(a) - LBound(a) + 1) * Rnd + LBound(a))
            t = a(i)
            a(i) = a(j)
            a(j) = t
        Next i
    End If
    Knuth = a
End Function

Private Function inOrder(s As Variant)
    i = 2
    Do While i <= UBound(s)
         If s(i) < s(i - 1) Then
            inOrder = False
            Exit Function
        End If
        i = i + 1
    Loop
    inOrder = True
End Function

Private Function bogosort(ByVal s As Variant) As Variant
    Do While Not inOrder(s)
        Debug.Print Join(s, ", ")
        s = Knuth(s)
    Loop
    bogosort = s
End Function

Public Sub main()
    Debug.Print Join(bogosort(Knuth([{1,2,3,4,5,6}])), ", ")
End Sub


// Written in the D programming language.
module rosettaCode.sortingAlgorithms.cocktailSort;

import std.range;

Range cocktailSort(Range)(Range data)
if (isRandomAccessRange!Range && hasLvalueElements!Range) {
    import std.algorithm : swap;
    bool swapped = void;
    void trySwap(E)(ref E lhs, ref E rhs) {
        if (lhs > rhs) {
            swap(lhs, rhs);
            swapped = true;
        }
    }

    if (data.length > 0) do {
        swapped = false;
        foreach (i; 0 .. data.length - 1)
            trySwap(data[i], data[i + 1]);
        if (!swapped)
            break;
        swapped = false;
        foreach_reverse (i; 0 .. data.length - 1)
            trySwap(data[i], data[i + 1]);
    } while(swapped);
    return data;
}

unittest {
    assert (cocktailSort([3, 1, 5, 2, 4]) == [1, 2, 3, 4, 5]);
    assert (cocktailSort([1, 2, 3, 4, 5]) == [1, 2, 3, 4, 5]);
    assert (cocktailSort([5, 4, 3, 2, 1]) == [1, 2, 3, 4, 5]);
    assert (cocktailSort((int[]).init)    == []);
    assert (cocktailSort(["John", "Kate", "Zerg", "Alice", "Joe", "Jane"]) ==
        ["Alice", "Jane", "Joe", "John", "Kate", "Zerg"]);
}


proc nonrec siftDown([*] int a; word start, end) void:
    word root, child;
    int temp;
    bool stop;

    root := start;
    stop := false;
    while not stop and root*2 + 1 <= end do
        child := root*2 + 1;
        if child+1 <= end and a[child] < a[child + 1] then
            child := child + 1
        fi;
        if a[root] < a[child] then
            temp := a[root];
            a[root] := a[child];
            a[child] := temp;
            root := child
        else
            stop := true
        fi
    od
corp

proc nonrec heapify([*] int a; word count) void:
    word start;
    bool stop;

    start := (count - 2) / 2;
    stop := false;
    while not stop do
        siftDown(a, start, count-1);
        if start=0
            then stop := true       /* avoid having to use a signed index */
            else start := start - 1
        fi
    od
corp

proc nonrec heapsort([*] int a) void:
    word end;
    int temp;

    heapify(a, dim(a,1));
    end := dim(a,1) - 1;
    while end > 0 do
        temp := a[0];
        a[0] := a[end];
        a[end] := temp;
        end := end - 1;
        siftDown(a, 0, end)
    od
corp

/* Test */
proc nonrec main() void:
    int i;
    [10] int a = (9, -5, 3, 3, 24, -16, 3, -120, 250, 17);

    write("Before sorting: ");
    for i from 0 upto 9 do write(a[i]:5) od;
    writeln();

    heapsort(a);
    write("After sorting:  ");
    for i from 0 upto 9 do write(a[i]:5) od
corp


beadSort: function [items][
    a: new items
    m: neg infinity
    s: 0

    loop a 'x [
        if x > m -> m: x
    ]

    beads: array.of: m * size a 0

    loop 0..dec size a 'i [
        loop 0..dec a\[i] 'j ->
            beads\[j + i * m]: 1
    ]

    loop 0..dec m 'j [
        s: 0
        loop 0..dec size a 'i [
            s: s + beads\[j + i*m]
            beads\[j + i*m]: 0
        ]

        loop ((size a)-s)..dec size a 'i ->
            beads\[j + i*m]: 1
    ]

    loop 0..dec size a 'i [
        j: 0
        while [and? [j < m] [beads\[j + i*m] > 0]] -> j: j + 1
        a\[i]: j
    ]

    return a
]

print beadSort [3 1 2 8 5 7 9 4 6]


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
}


sub swap( byref a, byref b )
	dim tmp
	tmp = a
	a = b
	b = tmp
end sub

'knuth shuffle (I think)
function shuffle( a )
	dim i
	dim r
	randomize timer
	for i = lbound( a ) to ubound( a )
		r = int( rnd * ( ubound( a ) + 1 )  )
		if r <> i then
			swap a(i), a(r)
		end if
	next
	shuffle = a
end function

function inOrder( a )
	dim res
	dim i
	for i = 0 to ubound( a ) - 1
		res = ( a(i) <= a(i+1) )
		if res = false then exit for
	next
	inOrder = res
end function


import rand

fn shuffle_array(mut arr []int) {
    for i := arr.len - 1; i >= 0; i-- {
        j := rand.intn(i + 1)
        arr[i], arr[j] = arr[j], arr[i]
    }
}

fn is_sorted(arr []int) bool {
    for i := 0; i < arr.len - 1; i++ {
        if arr[i] > arr[i + 1] {
            return false
        }
    }
    return true
}

fn sort_array(mut arr []int) {
    for !is_sorted(arr) {
        shuffle_array(mut arr)
        println('After Shuffle: $arr')
    }
}

fn main() {
    mut array := [6, 9, 1, 4]
    println('Input: $array')
    sort_array(mut array)
    println('Output: $array')
}


program TestShakerSort;

{$APPTYPE CONSOLE}

{.$DEFINE DYNARRAY}  // remove '.' to compile with dynamic array

type
  TItem = Integer;   // declare ordinal type for array item
{$IFDEF DYNARRAY}
  TArray = array of TItem;          // dynamic array
{$ELSE}
  TArray = array[0..15] of TItem;   // static array
{$ENDIF}

procedure ShakerSort(var A: TArray);
var
  Item: TItem;
  K, L, R, J: Integer;

begin
  L:= Low(A) + 1;
  R:= High(A);
  K:= High(A);
  repeat
    for J:= R downto L do begin
      if A[J - 1] > A[J] then begin
        Item:= A[J - 1];
        A[J - 1]:= A[J];
        A[J]:= Item;
        K:= J;
      end;
    end;
    L:= K + 1;
    for J:= L to R do begin
      if A[J - 1] > A[J] then begin
        Item:= A[J - 1];
        A[J - 1]:= A[J];
        A[J]:= Item;
        K:= J;
      end;
    end;
    R:= K - 1;
  until L > R;
end;

var
  A: TArray;
  I: Integer;

begin
{$IFDEF DYNARRAY}
  SetLength(A, 16);
{$ENDIF}
  for I:= Low(A) to High(A) do
    A[I]:= Random(100);
  for I:= Low(A) to High(A) do
    Write(A[I]:3);
  Writeln;
  ShakerSort(A);
  for I:= Low(A) to High(A) do
    Write(A[I]:3);
  Writeln;
  Readln;
end.


def heapsort := {
  def cswap(c, a, b) {
    def t := c[a]
    c[a]  := c[b]
    c[b]  := t
    # println(c)
  }

  def siftDown(array, start, finish) {
    var root := start
    while (var child := root * 2 + 1
           child <= finish) {
      if (child + 1 <= finish && array[child] < array[child + 1]) {
        child += 1
      }
      if (array[root] < array[child]) {
        cswap(array, root, child)
        root := child
      } else {
        break
      }
    }
  }

  /** Heapsort (in-place). */
  def heapsort(array) {
    # in pseudo-code, heapify only called once, so inline it here
    for start in (0..((array.size()-2)//2)).descending() {
      siftDown(array, start, array.size()-1)
    }

    for finish in (0..(array.size()-1)).descending() {
      cswap(array, 0, finish)
      siftDown(array, 0, finish - 1)
    }
  }
}


get "libhdr"

let max(A, len) = valof
$(  let x = 0
    for i=0 to len-1
        if x<A!i do x := A!i
    resultis x
$)

let beadsort(A, len) be
$(  let size = max(A, len)
    let tvec = getvec(size-1)
    for i=0 to size-1 do tvec!i := 0
    for i=0 to len-1
        for j=0 to A!i-1 do tvec!j := tvec!j + 1
    for i=len-1 to 0 by -1
    $(  let n = 0
        for j=0 to size-1
            if tvec!j > 0
            $(  tvec!j := tvec!j - 1
                n := n + 1
            $)
        A!i := n
    $)
    freevec(tvec)
$)

let write(s, A, len) be
$(  writes(s)
    for i=0 to len-1 do writed(A!i, 4)
    wrch('*N')
$)

let start() be
$(  let array = table 10,1,5,5,9,2,20,6,8,4
    let length = 10
    write("Before: ", array, length)
    beadsort(array, length)
    write("After:  ", array, length)
$)


#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;
}


import "random" for Random
import "/sort" for Sort

var bogoSort = Fn.new { |a|
    var rand = Random.new()
    while (!Sort.isSorted(a)) rand.shuffle(a)
}

var a = [31, 41, 59, 26, 53, 58, 97, 93, 23, 84]
System.print("Before: %(a)")
bogoSort.call(a)
System.print("After : %(a)")


code Ran=1, ChOut=8, IntOut=11;

proc BogoSort(A, L);    \Sort array A of length L
int  A, L;
int  I, J, T;
[loop   [I:= 0;
        loop    [if A(I) > A(I+1) then quit;
                I:= I+1;
                if I >= L-1 then return;
                ];
        I:= Ran(L);  J:= Ran(L);
        T:= A(I);  A(I):= A(J);  A(J):= T;
        ];
];

int A, I;
[A:= [3, 1, 4, 1, -5, 9, 2, 6, 5, 4];
BogoSort(A, 10);
for I:= 0 to 10-1 do [IntOut(0, A(I));  ChOut(0, ^ )];
]


/** Cocktail sort (in-place) */
def cocktailSort(array) {
    def swapIndexes := 0..(array.size() - 2)
    def directions := [swapIndexes, swapIndexes.descending()]
    while (true) {
        for direction in directions {
            var swapped := false
            for a ? (array[a] > array[def b := a + 1]) in direction {
                def t    := array[a]
                array[a] := array[b]
                array[b] := t
                swapped  := true
            }
            if (!swapped) { return }
        }
    }
}


class
	COCKTAIL_SORT [G -> COMPARABLE]

feature

	cocktail_sort (ar: ARRAY [G]): ARRAY [G]
			-- Array sorted in ascending order.
		require
			ar_not_empty: ar.count >= 1
		local
			not_swapped: BOOLEAN
			sol: ARRAY [G]
			i, j: INTEGER
			t: G
		do
			create Result.make_empty
			Result.deep_copy (ar)
			from
			until
				not_swapped = True
			loop
				not_swapped := True
				from
					i := Result.lower
				until
					i = Result.upper - 1
				loop
					if Result [i] > Result [i + 1] then
						Result := swap (Result, i)
						not_swapped := False
					end
					i := i + 1
				end
				from
					j := Result.upper - 1
				until
					j = Result.lower
				loop
					if Result [j] > Result [j + 1] then
						Result := swap (Result, j)
						not_swapped := False
					end
					j := j - 1
				end
			end
		ensure
			ar_is_sorted: is_sorted (Result)
		end

feature{NONE}

	swap (ar: ARRAY [G]; i: INTEGER): ARRAY [G]
			-- Array with elements i and i+1 swapped.
		require
			ar_not_void: ar /= Void
			i_is_in_bounds: ar.valid_index (i)
		local
			t: G
		do
			create Result.make_empty
			Result.deep_copy (ar)
			t := Result [i]
			Result [i] := Result [i + 1]
			Result [i + 1] := t
		ensure
			swapped_right: Result [i + 1] = ar [i]
			swapped_left: Result [i] = ar [i + 1]
		end

	is_sorted (ar: ARRAY [G]): BOOLEAN
			--- Is 'ar' sorted in ascending order?
		require
			ar_not_empty: ar.is_empty = False
		local
			i: INTEGER
		do
			Result := True
			from
				i := ar.lower
			until
				i = ar.upper
			loop
				if ar [i] > ar [i + 1] then
					Result := False
				end
				i := i + 1
			end
		end

end


subr make_heap
  for i = 1 to n - 1
    if data[i] > data[(i - 1) / 2]
      j = i
      while data[j] > data[(j - 1) / 2]
        swap data[j] data[(j - 1) / 2]
        j = (j - 1) / 2
      .
    .
  .
.
subr sort
  n = len data[]
  call make_heap
  for i = n - 1 downto 1
    swap data[0] data[i]
    j = 0
    ind = 1
    while ind < i
      if ind + 1 < i and data[ind + 1] > data[ind]
        ind += 1
      .
      if data[j] < data[ind]
        swap data[j] data[ind]
      .
      j = ind
      ind = 2 * j + 1
    .
  .
.
data[] = [ 29 4 72 44 55 26 27 77 92 5 ]
call sort
print data[]


(lib 'heap)

(define (heap-sort list)
    (define heap (make-heap < )) ;; make a min heap
    (list->heap list heap)
    (while (not (heap-empty? heap))
          (push 'stack (heap-pop heap)))
    (stack->list 'stack))

(define L (shuffle (iota 15)))
    → (9 4 0 12 8 3 10 7 11 2 5 6 14 13 1)
(heap-sort L)
    → (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)


//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] << ' ';
}


sub shuffle(a())
    n = arraysize(a(),1)
	m = arraysize(a(),1)*2

    for k = 1 to m
        i = int(Ran(n))
        j = int(Ran(n))
        tmp = a(i)        //swap a(i), a(j)
        a(i) = a(j)
        a(j) = tmp
    next k
end sub

sub inorder(a())
    n = arraysize(a(),1)

    for i = 0 to n-2
        if a(i) > a(i+1) then return false : fi
    next i
    return true
end sub

sub Bogosort(a())
    while not inorder(a())
        shuffle(a())
    wend
end sub

dim a(5)
a (0) = 10: a (1) = 1: a (2) = 2: a (3) = -6: a (4) = 3

Bogosort(a())

for i = 0 to arraysize(a(),1) - 1
    print a(i), "  ";
next i
end


fcn increasing(list){
   list.len()<2 or
   list.reduce(fcn(a,b){ if(b<a) return(Void.Stop,False); b }).toBool()
}

ns:=L(5,23,1,6,123,7,23);
while(not increasing(ns)){ ns=ns.shuffle() }
ns.println();


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

extension op
{
    cocktailSort()
    {
        var list := self.clone();

        bool swapped  := true;
        while(swapped)
        {
            swapped := false;

            for(int i := 0, i <= list.Length - 2, i += 1)
            {
                if (list[i]>list[i+1])
                {
                    list.exchange(i,i+1);
                    swapped := true
                }
            };
            ifnot (swapped)
            {
                ^ list
            };
            swapped := false;

            for(int i := list.Length - 2, i >= 0, i -= 1)
            {
                if (list[i]>list[i+1])
                {
                    list.exchange(i,i+1);
                    swapped := true
                }
            }
        };

        ^ list
    }
}

public program()
{
    var list := new int[]{3, 5, 1, 9, 7, 6, 8, 2, 4 };

    console.printLine("before:", list.asEnumerable());
    console.printLine("after :", list.cocktailSort().asEnumerable())
}


defmodule Sort do
  def cocktail_sort(list) when is_list(list), do: cocktail_sort(list, [], [])

  defp cocktail_sort([], minlist, maxlist), do: Enum.reverse(minlist, maxlist)
  defp cocktail_sort([x], minlist, maxlist), do: Enum.reverse(minlist, [x | maxlist])
  defp cocktail_sort(list, minlist, maxlist) do
    {max, rev} = cocktail_max(list, [])
    {min, rest} = cocktail_min(rev, [])
    cocktail_sort(rest, [min | minlist], [max | maxlist])
  end

  defp cocktail_max([max], list), do: {max, list}
  defp cocktail_max([x,y | t], list) when x<y, do: cocktail_max([y | t], [x | list])
  defp cocktail_max([x,y | t], list)         , do: cocktail_max([x | t], [y | list])

  defp cocktail_min([min], list), do: {min, list}
  defp cocktail_min([x,y | t], list) when x>y, do: cocktail_min([y | t], [x | list])
  defp cocktail_min([x,y | t], list)         , do: cocktail_min([x | t], [y | list])
end

IO.inspect Sort.cocktail_sort([5,3,9,4,1,6,8,2,7])


function cocktail_sort(sequence s)
    integer swapped, d
    object temp
    sequence fromto
    fromto = {1,length(s)-1}
    swapped = 1
    d = 1
    while swapped do
        swapped = 0
        for i = fromto[(1-d)/2+1] to fromto[(1+d)/2+1] by d do
            if compare(s[i],s[i+1])>0 then
                temp = s[i]
                s[i] = s[i+1]
                s[i+1] = temp
                swapped = 1
            end if
        end for
        d = -d
    end while
    return s
end function

constant s = rand(repeat(1000,10))
? s
? cocktail_sort(s)


class
	HEAPSORT

feature

	sort_array (ar: ARRAY [INTEGER])
			-- Sorts array 'ar' in ascending order.
		require
			not_empty: ar.count > 0
		local
			i, j, r, l, m, n: INTEGER
			sorted: BOOLEAN
		do
			n := ar.count
			j := 0
			i := 0
			m := 0
			r := n
			l := (n // 2)+1
			from
			until
				sorted
			loop
				if l > 1 then
					l := l - 1
					m := ar[l]
				else
					m := ar[r]
					ar[r] := ar[1]
					r := r - 1
					if r = 1 then
						ar[1]:=m
						sorted := True
					end
				end
				if not sorted then
					i := l
					j := l * 2
					from
					until
						j > r
					loop
						if (j < r) and (ar[j] < ar[j + 1]) then
							j := j + 1
						end
						if m < ar[j] then
							ar[i]:= ar[j]
							i := j
							j := j + i
						else
							j := r + 1
						end
					end
					ar[i]:= m
				end
			end
			ensure
				sorted: is_sorted(ar)
		end

feature{NONE}

	is_sorted (ar: ARRAY [INTEGER]): BOOLEAN
			--- Is 'ar' sorted in ascending order?
		local
			i: INTEGER
		do
			Result := True
			from
				i := ar.lower
			until
				i >= ar.upper
			loop
				if ar [i] > ar [i + 1] then
					Result := False
				end
				i := i + 1
			end
		end

end


(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 + %))))

;; This algorithm does not work if collection has zero
(-> [5 2 4 1 3 3 9] bead-sort println)


        >>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
*> This is GNUCOBOL 2.0
identification division.
program-id. beadsort.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01  filler.
    03  row occurs 9 pic x(9).
    03  r pic 99.
    03  r1 pic 99.
    03  r2 pic 99.
    03  pole pic 99.
    03  a-lim pic 99 value 9.
    03  a pic 99.
    03  array occurs 9 pic 9.
01  NL pic x value x'0A'.
procedure division.
start-beadsort.

    *> fill the array
    compute a = random(seconds-past-midnight)
    perform varying a from 1 by 1 until a > a-lim
        compute array(a) = random() * 10
    end-perform

    perform display-array
    display space 'initial array'

    *> distribute the beads
    perform varying r from 1 by 1 until r > a-lim
        move all '.' to row(r)
        perform varying pole from 1 by 1 until pole > array(r)
            move 'o' to row(r)(pole:1)
        end-perform
    end-perform
    display NL 'initial beads'
    perform display-beads

    *> drop the beads
    perform varying pole from 1 by 1 until pole > a-lim
        move a-lim to r2
        perform find-opening
        compute r1 = r2 - 1
        perform find-bead
        perform until r1 = 0 *> no bead or no opening
            *> drop the bead
            move '.' to row(r1)(pole:1)
            move 'o' to row(r2)(pole:1)
            *> continue up the pole
            compute r2 = r2 - 1
            perform find-opening
            compute r1 = r2 - 1
            perform find-bead
        end-perform
    end-perform
    display NL 'dropped beads'
    perform display-beads

    *> count the beads in each row
    perform varying r from 1 by 1 until r > a-lim
        move 0 to array(r)
        inspect row(r) tallying array(r)
            for all 'o' before initial '.'
    end-perform

    perform display-array
    display space 'sorted array'

    stop run
    .
find-opening.
    perform varying r2 from r2 by -1
    until r2 = 1 or row(r2)(pole:1) = '.'
        continue
    end-perform
    .
find-bead.
    perform varying r1 from r1 by -1
    until r1 = 0 or row(r1)(pole:1) = 'o'
        continue
    end-perform
    .
display-array.
    display space
    perform varying a from 1 by 1 until a > a-lim
        display space array(a) with no advancing
    end-perform
    .
display-beads.
    perform varying r from 1 by 1 until r > a-lim
        display row(r)
    end-perform
    .
end program beadsort.


USING: kernel locals math math.ranges sequences ;

:: cocktail-sort! ( seq -- seq' )
    f :> swapped!                                         ! bind false to mutable lexical variable 'swapped'. This must be done outside both while quotations so it is in scope of both.
    [ swapped ] [                                         ! is swapped true? Then execute body quotation. 'do' executes body quotation before predicate on first pass.
        f swapped!                                        ! set swapped to false
        seq length 2 - [| i |                             ! for each i in 0 to seq length - 2 do
            i i 1 + [ seq nth ] [email protected] >                     ! is element at index i greater than element at index i + 1?
            [ i i 1 + seq exchange t swapped! ] when      ! if so, swap them and set swapped to true
        ] each-integer
        swapped [                                         ! skip to end of loop if swapped is false
            seq length 2 - 0 [a,b] [| i |                 ! for each i in seq length - 2 to 0 do
                i i 1 + [ seq nth ] [email protected] >                 ! is element at index i greater than element at index i + 1?
                [ i i 1 + seq exchange t swapped! ] when  ! if so, swap them and set swapped to true
            ] each
        ] when
    ] do while
    seq ;                                                 ! return the sequence


defer precedes                            ( addr addr -- flag )
                                          \ e.g. ' < is precedes
: sort                                    ( a n --)
  1- cells bounds 2>r false
  begin
    0= dup
  while
    [email protected] ?do
       i cell+ @ i @ over over precedes   ( mark unsorted )
       if i cell+ ! i ! dup xor else drop drop then
    1 cells +loop
    0= dup
  while
    [email protected] swap 1 cells - ?do
       i cell+ @ i @ over over precedes   ( mark unsorted )
       if i cell+ ! i ! dup xor else drop drop then
    -1 cells +loop
  repeat then drop 2r> 2drop
;


PROGRAM COCKTAIL
  IMPLICIT NONE

  INTEGER :: intArray(10) = (/ 4, 9, 3, -2, 0, 7, -5, 1, 6, 8 /)

  WRITE(*,"(A,10I5)") "Unsorted array:", intArray
  CALL Cocktail_sort(intArray)
  WRITE(*,"(A,10I5)") "Sorted array  :", intArray

CONTAINS

  SUBROUTINE Cocktail_sort(a)
    INTEGER, INTENT(IN OUT) :: a(:)
    INTEGER :: i, bottom, top, temp
    LOGICAL :: swapped

    bottom = 1
    top = SIZE(a) - 1
    DO WHILE (bottom < top )
       swapped = .FALSE.
       DO i = bottom, top
          IF (array(i) > array(i+1)) THEN
              temp = array(i)
              array(i) = array(i+1)
              array(i+1) = temp
              swapped = .TRUE.
          END IF
       END DO
       IF (.NOT. swapped) EXIT
       DO i = top, bottom + 1, -1
          IF (array(i) < array(i-1)) THEN
              temp = array(i)
              array(i) = array(i-1)
              array(i-1) = temp
              swapped = .TRUE.
          END IF
       END DO
       IF (.NOT. swapped) EXIT
       bottom = bottom + 1
       top = top - 1
    END DO
  END SUBROUTINE Cocktail_sort

END PROGRAM COCKTAIL


defmodule Sort do
  def heapSort(list) do
    len = length(list)
    heapify(List.to_tuple(list), div(len - 2, 2))
    |> heapSort(len-1)
    |> Tuple.to_list
  end

  defp heapSort(a, finish) when finish > 0 do
    swap(a, 0, finish)
    |> siftDown(0, finish-1)
    |> heapSort(finish-1)
  end
  defp heapSort(a, _), do: a

  defp heapify(a, start) when start >= 0 do
    siftDown(a, start, tuple_size(a)-1)
    |> heapify(start-1)
  end
  defp heapify(a, _), do: a

  defp siftDown(a, root, finish) when root * 2 + 1 <= finish do
    child = root * 2 + 1
    if child + 1 <= finish and elem(a,child) < elem(a,child + 1), do: child = child + 1
    if elem(a,root) < elem(a,child),
      do:   swap(a, root, child) |> siftDown(child, finish),
      else: a
  end
  defp siftDown(a, _root, _finish), do: a

  defp swap(a, i, j) do
    {vi, vj} = {elem(a,i), elem(a,j)}
    a |> put_elem(i, vj) |> put_elem(j, vi)
  end
end

(for _ <- 1..20, do: :rand.uniform(20)) |> IO.inspect |> Sort.heapSort |> IO.inspect


let inline swap (a: _ []) i j =
  let temp = a.[i]
  a.[i] <- a.[j]
  a.[j] <- temp

let inline sift cmp (a: _ []) start count =
  let rec loop root child =
    if root * 2 + 1 < count then
      let p = child < count - 1 && cmp a.[child] a.[child + 1] < 0
      let child = if p then child + 1 else child
      if cmp a.[root] a.[child] < 0 then
        swap a root child
        loop child (child * 2 + 1)
  loop start (start * 2 + 1)

let inline heapsort cmp (a: _ []) =
  let n = a.Length
  for start = n/2 - 1 downto 0 do
    sift cmp a start n
  for term = n - 1 downto 1 do
    swap a term 0
    sift cmp a 0 term


(defun transpose (remain &optional (ret '()))
  (if (null remain)
    ret
    (transpose (remove-if #'null (mapcar #'cdr remain))
               (append ret (list (mapcar #'car remain))))))

(defun bead-sort (xs)
  (mapcar #'length (transpose (transpose (mapcar (lambda (x) (make-list x :initial-element 1)) xs)))))

(bead-sort '(5 2 4 1 3 3 9))


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*/ @safe /*@nogc*/ {
    return m
           .map!walkLength
           .reduce!max
           .iota
           .map!(i => m.filter!(s => s.length > i).walkLength.repeat0);
}

auto beadSort(in uint[] data) pure /*nothrow @nogc*/ {
    return data.map!repeat0.columns.columns.map!walkLength;
}

void main() {
    [5, 3, 1, 7, 4, 1, 1].beadSort.writeln;
}


V strings = ‘here are Some sample strings to be sorted’.split(‘ ’)

print(sorted(strings, key' x -> (-x.len, x.uppercase())))


' version 21-10-2016
' compile with: fbc -s console
' for boundry checks on array's compile with: fbc -s console -exx

Sub cocktailsort(bs() As Long)
    ' sort from lower bound to the highter bound
    ' array's can have subscript range from -2147483648 to +2147483647
    Dim As Long lb = LBound(bs)
    Dim As Long ub = UBound(bs) -1
    Dim As Long done, i

    Do
        done = 0                  ' going up
        For i = lb To ub
            If bs(i) > bs(i +1) Then
                Swap bs(i), bs(i +1)
                done = 1
            End If
        Next
        ub = ub -1
        If done = 0 Then Exit Do  ' 0 means the array is sorted
        done = 0                  ' going down
        For i = ub To lb Step -1
            If bs(i) > bs(i +1) Then
                Swap bs(i), bs(i +1)
                done = 1
            End If
        Next
        lb = lb +1
    Loop Until done = 0           ' 0 means the array is sorted

End Sub

' ------=< MAIN >=------

Dim As Long i, array(-7 To 7)

Dim As Long a = LBound(array), b = UBound(array)

Randomize Timer
For i = a To b : array(i) = i  : Next
For i = a To b ' little shuffle
    Swap array(i), array(Int(Rnd * (b - a +1)) + a)
Next

Print "unsorted ";
For i = a To b : Print Using "####"; array(i); : Next : Print
cocktailsort(array())  ' sort the array
Print "  sorted ";
For i = a To b : Print Using "####"; array(i); : Next : Print

' empty keyboard buffer
While Inkey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End


create example
  70 , 61 , 63 , 37 , 63 , 25 , 46 , 92 , 38 , 87 ,

[UNDEFINED] r'@ [IF]
: r'@ r> r> [email protected] swap >r swap >r ;
[THEN]

defer precedes                         ( n1 n2 a -- f)
defer exchange                         ( n1 n2 a --)

: siftDown                             ( a e s -- a e s)
  swap >r swap >r dup                  ( s r)
  begin                                ( s r)
    dup 2* 1+ dup r'@ <                ( s r c f)
  while                                ( s r c)
    dup 1+ dup r'@ <                   ( s r c c+1 f)
    if                                 ( s r c c+1)
      over over [email protected] precedes if swap then
    then drop                          ( s r c)
    over over [email protected] precedes              ( s r c f)
  while                                ( s r c)
    tuck [email protected] exchange                   ( s r)
  repeat then                          ( s r)
  drop drop r> swap r> swap            ( a e s)
;

: heapsort                             ( a n --)
  over >r                              ( a n)
  dup 1- 1- 2/                         ( a c s)
  begin                                ( a c s)
    dup 0< 0=                          ( a c s f)
  while                                ( a c s)
    siftDown 1-                        ( a c s)
  repeat drop                          ( a c)

  1- 0                                 ( a e 0)
  begin                                ( a e 0)
    over 0>                            ( a e 0 f)
  while                                ( a e 0)
    over over [email protected] exchange              ( a e 0)
    siftDown swap 1- swap              ( a e 0)
  repeat                               ( a e 0)
  drop drop drop r> drop
;

:noname >r cells [email protected] + @ swap cells r> + @ swap < ; is precedes
:noname >r cells [email protected] + swap cells r> + over @ over @ swap rot ! swap ! ; is exchange

: .array 10 0 do example i cells + ? loop cr ;

.array example 10 heapsort .array


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.


class
	BEAD_SORT

feature

	bead_sort (ar: ARRAY [INTEGER]): ARRAY [INTEGER]
			-- Sorted array in descending order.
		require
			only_positive_integers: across ar as a all a.item > 0 end
		local
			max, count, i, j, k: INTEGER
		do
			max := max_item (ar)
			create Result.make_filled (0, 1, ar.count)
			from
				i := 1
			until
				i > max
			loop
				count := 0
				from
					k := 1
				until
					k > ar.count
				loop
					if ar.item (k) >= i then
						count := count + 1
					end
					k := k + 1
				end
				from
					j := 1
				until
					j > count
				loop
					Result [j] := i
					j := j + 1
				end
				i := i + 1
			end
		ensure
			array_is_sorted: is_sorted (Result)
		end

feature {NONE}

	max_item (ar: ARRAY [INTEGER]): INTEGER
			-- Max item of 'ar'.
		require
			ar_not_void: ar /= Void
		do
			across
				ar as a
			loop
				if a.item > Result then
					Result := a.item
				end
			end
		ensure
			Result_is_max: across ar as a all a.item <= Result end
		end

	is_sorted (ar: ARRAY [INTEGER]): BOOLEAN
			--- Is 'ar' sorted in descending order?
		require
			ar_not_empty: ar.is_empty = False
		local
			i: INTEGER
		do
			Result := True
			from
				i := ar.lower
			until
				i = ar.upper
			loop
				if ar [i] < ar [i + 1] then
					Result := False
				end
				i := i + 1
			end
		end

end


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program customSort64.s   */

 /* use merge sort iteratif and pointer table  */
 /* but use a extra table on stack for the merge */
/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

/*******************************************/
/* Structures                               */
/********************************************/
/* city structure      */
    .struct  0
city_name:                             //
    .struct  city_name + 8             // string pointer
city_country:                          //
    .struct  city_country + 8          // string pointer
city_end:

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:           .asciz "Name : @  country : @ \n"
szMessSortName:        .asciz "Ascending sort table for name of city :\n"
szMessSortCitiesDesc:  .asciz "Descending sort table for name of city : \n"
szCarriageReturn:      .asciz "\n"

// cities name
szLondon:           .asciz "London"
szNewyork:          .asciz "New York"
szBirmin:           .asciz "Birmingham"
szParis:            .asciz "Paris"
// country name
szUK:               .asciz "UK"
szUS:               .asciz "US"
szFR:               .asciz "FR"
.align 4
TableCities:
e1:              .quad szLondon         // address name string
                 .quad szUK             // address country string
e2:              .quad szParis
                 .quad szFR
e3:              .quad szNewyork
                 .quad szUS
e4:              .quad szBirmin
                 .quad szUK
e5:              .quad szParis
                 .quad szUS
e6:              .quad szBirmin
                 .quad szUS
/* pointers table */
ptrTableCities:   .quad e1
                  .quad e2
                  .quad e3
                  .quad e4
                  .quad e5
                  .quad e6
.equ NBELEMENTS,  (. - ptrTableCities) / 8

/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:              .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                             // entry of program
    ldr x0,qAdrptrTableCities     // address pointers table
    bl displayTable

    ldr x0,qAdrszMessSortName
    bl affichageMess

    ldr x0,qAdrptrTableCities     // address pointers table
    mov x1,0                      // first element
    mov x2,NBELEMENTS             // number of élements
    adr x3,comparAreaAlphaCrois   // address custom comparator ascending
    bl mergeSortIter
    ldr x0,qAdrptrTableCities     // address table
    bl displayTable

    ldr x0,qAdrszMessSortCitiesDesc
    bl affichageMess

    ldr x0,qAdrptrTableCities     // address table
    mov x1,0                      // first element
    mov x2,NBELEMENTS             // number of élements
    adr x3,comparAreaAlphaDecrois // address custom comparator descending
    bl mergeSortIter
    ldr x0,qAdrptrTableCities     // address table
    bl displayTable

100:                              // standard end of the program
    mov x0,0                      // return code
    mov x8,EXIT                   // request to exit program
    svc 0                         // perform the system call

qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableCities:          .quad TableCities
qAdrszMessSortName:        .quad szMessSortName
qAdrszMessSortCitiesDesc:  .quad szMessSortCitiesDesc
qAdrptrTableCities:        .quad ptrTableCities

/******************************************************************/
/*      merge sort  iteratif                                      */
/* use an extra table on stack                                    */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the index of first element */
/* x2 contains the number of element */
/* x3 contains the address of custom comparator */
mergeSortIter:
    stp fp,lr,[sp,-16]!     // save  registers
    stp x1,x2,[sp,-16]!     // save  registers
    stp x4,x5,[sp,-16]!     // save  registers
    stp x6,x7,[sp,-16]!     // save  registers
    stp x8,x9,[sp,-16]!     // save  registers
    stp x10,x11,[sp,-16]!   // save  registers
    stp x12,x13,[sp,-16]!   // save  registers
    stp x14,x15,[sp,-16]!   // save  registers
    mov x15,x0              // save address
    mov x4,x1               // save N0 first element
    sub x5,x2,1             // save N° last  element
    tst x2,1                // number of  element odd ?
    add x13,x2,1            // yes then add 1
    csel x13,x13,x2,ne      // to have a multiple to 16 bytes
    lsl x13,x13,3           // for reserve the extra table to the stack
    sub sp,sp,x13
    mov fp,sp               // frame register = address extra table on stack

    mov x10,1               // subset size
1:
    mov x6,x4               // first element
2:
    lsl x8,x10,1            // compute end subset
    add x8,x8,x6
    sub x8,x8,1
    add x7,x6,x8            // compute median
    lsr x7,x7,1
    cmp x8,x5               // maxi ?
    ble 21f                 // no
    mov x8,x5               // yes -> end subset = maxi
    cmp x6,0                // subset final ?
    beq 21f                 // no
    cmp x7,x8               // compare median end subset
    blt 21f
    mov x7,x8               // maxi -> median

21:
    add x9,x7,1
    mov x0,x15
3:                          // copy first subset on extra table
    sub x1,x9,1
    ldr x2,[x0,x1,lsl 3]
    str x2,[fp,x1,lsl 3]
    sub x9,x9,1
    cmp x9,x6
    bgt 3b
    mov x9,x7
    cmp x7,x8
    beq 41f
4:                          // and copy inverse second subset on extra table
    add x1,x9,1
    add x12,x7,x8
    sub x12,x12,x9
    ldr x2,[x0,x1,lsl 3]
    str x2,[fp,x12,lsl 3]
    add x9,x9,1
    cmp x9,x8
    blt 4b
41:
    mov x11,x6  //k
    mov x1,x6  // i
    mov x2,x8  // j
5:                          // and now merge the two subset on final table
    mov x0,fp
    blr x3
    cmp x0,0
    bgt 7f
    blt 6f
    // si egalité et si i < pivot
    cmp x1,x7
    ble 6f
    b 7f
6:
    ldr x12,[fp,x1, lsl 3]
    str x12,[x15,x11, lsl 3]
    add x1,x1,1
    b 8f
7:
    ldr x12,[fp,x2, lsl 3]
    str x12,[x15,x11, lsl 3]
    sub x2,x2,1
8:
    add x11,x11,1
    cmp x11,x8
    ble 5b

9:
    mov x0,x15
    lsl x2,x10,1
    add x6,x6,x2         // compute new subset
    cmp x6,x5            // end ?
    ble 2b
    lsl x10,x10,1        // size of subset * 2
    cmp x10,x5           // end ?
    ble 1b

100:
    add sp,sp,x13           // stack alignement
    ldp x14,x15,[sp],16     // restaur  2 registers
    ldp x12,x13,[sp],16     // restaur  2 registers
    ldp x10,x11,[sp],16     // restaur  2 registers
    ldp x8,x9,[sp],16       // restaur  2 registers
    ldp x6,x7,[sp],16       // restaur  2 registers
    ldp x4,x5,[sp],16       // restaur  2 registers
    ldp x1,x2,[sp],16       // restaur  2 registers
    ldp fp,lr,[sp],16       // restaur  2 registers
    ret                     // return to address lr x30

/******************************************************************/
/*      ascending comparison sort area                                */
/******************************************************************/
/* x0 contains the address of table */
/* x1 indice area sort 1 */
/* x2 indice area sort 2 */
comparAreaAlphaCrois:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    stp x4,x5,[sp,-16]!          // save  registers
    stp x6,x7,[sp,-16]!          // save  registers
    stp x8,x9,[sp,-16]!          // save  registers

    ldr x1,[x0,x1,lsl 3]         // load pointer element 1
    ldr x6,[x1,city_name]        // load area sort element 1
    ldr x2,[x0,x2,lsl 3]         // load pointer element 2
    ldr x7,[x2,city_name]        // load area sort element 2

    mov x8,#0                    // compar alpha string
1:
    ldrb w9,[x6,x8]              // byte string 1
    ldrb w5,[x7,x8]              // byte string 2
    cmp w9,w5
    bgt 11f                      // croissant
    blt 10f

    cmp w9,#0                    //  end string 1
    beq 12f                      // end comparaison
    add x8,x8,#1                 // else add 1 in counter
    b 1b                         // and loop

10:                              // lower
    mov x0,-1
    b 100f
11:                              // highter
    mov x0,1
    b 100f
12:                              // equal
    mov x0,0
100:
    ldp x8,x9,[sp],16            // restaur  2 registers
    ldp x6,x7,[sp],16            // restaur  2 registers
    ldp x4,x5,[sp],16            // restaur  2 registers
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30
/******************************************************************/
/*      descending comparison sort area                                */
/******************************************************************/
/* x0 contains the address of table */
/* x1 indice area sort 1 */
/* x2 indice area sort 2 */
comparAreaAlphaDecrois:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    stp x4,x5,[sp,-16]!          // save  registers
    stp x6,x7,[sp,-16]!          // save  registers
    stp x8,x9,[sp,-16]!          // save  registers

    ldr x1,[x0,x1,lsl 3]         // load pointer element 1
    ldr x6,[x1,city_name]        // load area sort element 1
    ldr x2,[x0,x2,lsl 3]         // load pointer element 2
    ldr x7,[x2,city_name]        // load area sort element 2

    mov x8,#0                    // compar alpha string
1:
    ldrb w9,[x6,x8]              // byte string 1
    ldrb w5,[x7,x8]              // byte string 2
    cmp w9,w5
    blt 11f                      // descending
    bgt 10f

    cmp w9,#0                    //  end string 1
    beq 12f                      // end comparaison
    add x8,x8,#1                 // else add 1 in counter
    b 1b                         // and loop

10:                              // lower
    mov x0,-1
    b 100f
11:                              // highter
    mov x0,1
    b 100f
12:                              // equal
    mov x0,0
100:
    ldp x8,x9,[sp],16            // restaur  2 registers
    ldp x6,x7,[sp],16            // restaur  2 registers
    ldp x4,x5,[sp],16            // restaur  2 registers
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30
/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    stp x4,x5,[sp,-16]!          // save  registers
    stp x6,x7,[sp,-16]!          // save  registers
    mov x2,x0                    // table address
    mov x3,0
1:                               // loop display table
    lsl x4,x3,#3                 // offset element
    ldr x6,[x2,x4]               // load pointer
    ldr x1,[x6,city_name]
    ldr x0,qAdrsMessResult
    bl strInsertAtCharInc        // put name in message
    ldr x1,[x6,city_country]     // and put country in the message
    bl strInsertAtCharInc        // insert result at @ character
    bl affichageMess             // display message
    add x3,x3,1
    cmp x3,#NBELEMENTS
    blt 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
100:
    ldp x6,x7,[sp],16            // restaur  2 registers
    ldp x4,x5,[sp],16            // restaur  2 registers
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


DEFINE PTR="CARD"

PROC PrintArray(PTR ARRAY a INT size)
  INT i

  Put('[)
  FOR i=0 TO size-1
  DO
    IF i>0 THEN Put(' ) FI
    Print(a(i))
  OD
  Put(']) PutE()
RETURN

INT FUNC CustomComparator(CHAR ARRAY s1,s2)
  INT res

  res=s2(0) res==-s1(0)
  IF res=0 THEN
    res=SCompare(s1,s2)
  FI
RETURN (res)

INT FUNC Comparator=*(CHAR ARRAY s1,s2)
DEFINE JSR="$20"
DEFINE RTS="$60"
  [JSR $00 $00 ;JSR to address set by SetComparator
   RTS]

PROC SetComparator(PTR p)
  PTR addr

  addr=Comparator+1 ;location of address of JSR
  PokeC(addr,p)
RETURN

PROC InsertionSort(PTR ARRAY a INT size PTR compareFun)
  INT i,j
  CHAR ARRAY s

  SetComparator(compareFun)
  FOR i=1 TO size-1
  DO
    s=a(i)
    j=i-1
    WHILE j>=0 AND Comparator(s,a(j))<0
    DO
      a(j+1)=a(j)
      j==-1
    OD
    a(j+1)=s
  OD
RETURN

PROC Test(PTR ARRAY a INT size PTR compareFun)
  PrintE("Array before sort:")
  PrintArray(a,size)
  PutE()

  InsertionSort(a,size,compareFun)
  PrintE("Array after sort:")
  PrintArray(a,size)
  PutE()
RETURN

PROC Main()
  PTR ARRAY a(24)

  a(0)="lorem" a(1)="ipsum" a(2)="dolor" a(3)="sit"
  a(4)="amet" a(5)="consectetur" a(6)="adipiscing"
  a(7)="elit" a(8)="maecenas" a(9)="varius"
  a(10)="sapien" a(11)="vel" a(12)="purus"
  a(13)="hendrerit" a(14)="vehicula" a(15)="integer"
  a(16)="hendrerit" a(17)="viverra" a(18)="turpis" a(19)="ac"
  a(20)="sagittis" a(21)="arcu" a(22)="pharetra" a(23)="id"

  Test(a,24,CustomComparator)
RETURN


with Ada.Text_Io; use Ada.Text_Io;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Gnat.Heap_Sort_G;

procedure Custom_Compare is

   type StringArrayType is array (Natural range <>) of Unbounded_String;

   Strings : StringArrayType := (Null_Unbounded_String,
                                 To_Unbounded_String("this"),
                                 To_Unbounded_String("is"),
                                 To_Unbounded_String("a"),
                                 To_Unbounded_String("set"),
                                 To_Unbounded_String("of"),
                                 To_Unbounded_String("strings"),
                                 To_Unbounded_String("to"),
                                 To_Unbounded_String("sort"),
                                 To_Unbounded_String("This"),
                                 To_Unbounded_String("Is"),
                                 To_Unbounded_String("A"),
                                 To_Unbounded_String("Set"),
                                 To_Unbounded_String("Of"),
                                 To_Unbounded_String("Strings"),
                                 To_Unbounded_String("To"),
                                 To_Unbounded_String("Sort"));

   procedure Move (From, To : in Natural) is

   begin
      Strings(To) := Strings(From);
   end Move;

   function UpCase (Char : in Character) return Character is
      Temp : Character;
   begin
      if Char >= 'a' and Char <= 'z' then
         Temp := Character'Val(Character'Pos(Char)
                                 - Character'Pos('a')
                                 + Character'Pos('A'));
      else
         Temp := Char;
      end if;
      return Temp;
   end UpCase;

   function Lt (Op1, Op2 : Natural)
               return Boolean is
      Temp, Len : Natural;
   begin
      Len := Length(Strings(Op1));
      Temp := Length(Strings(Op2));
      if Len < Temp then
         return False;
      elsif Len > Temp then
         return True;
      end if;

      declare
         S1, S2 : String(1..Len);
      begin
         S1 := To_String(Strings(Op1));
         S2 := To_String(Strings(Op2));
      Put("Same size:  ");
      Put(S1);
      Put(" ");
      Put(S2);
      Put(" ");
      for I in S1'Range loop
         Put(UpCase(S1(I)));
         Put(UpCase(S2(I)));
         if UpCase(S1(I)) = UpCase(S2(I)) then
           null;
         elsif UpCase(S1(I)) < UpCase(S2(I)) then
            Put(" LT");
            New_Line;
            return True;
         else
            return False;
         end if;
      end loop;
      Put(" GTE");
      New_Line;
      return False;
      end;
   end Lt;

   procedure Put (Arr : in StringArrayType) is
   begin
      for I in 1..Arr'Length-1 loop
         Put(To_String(Arr(I)));
         New_Line;
      end loop;
   end Put;

   package Heap is new Gnat.Heap_Sort_G(Move,
                                        Lt);
   use Heap;

begin
   Put_Line("Unsorted list:");
   Put(Strings);
   New_Line;
   Sort(16);
   New_Line;
   Put_Line("Sorted list:");
   Put(Strings);
end Custom_Compare;


Public Sub Main()
Dim siCount, siRev, siProcess As Short
Dim bSorting As Boolean
Dim byToSort As Byte[] = [249, 28, 111, 36, 171, 98, 29, 448, 44, 154, 147, 102, 46, 183, 24,
                          120, 19, 123, 2, 17, 226, 11, 211, 25, 191, 205, 77]

Print "To sort: -"
ShowWorking(byToSort)
Print

Repeat
  bSorting = False
  siRev = byToSort.Max - 1
  For siCount = 0 To byToSort.Max - 1
    siProcess = siCount
    GoSub Check
    siProcess = siRev
    GoSub Check
    Dec siRev
  Next
  If bSorting Then ShowWorking(byToSort)
Until bSorting = False

Return

Check:

If byToSort[siProcess] > byToSort[siProcess + 1] Then
  Swap byToSort[siProcess], byToSort[siProcess + 1]
  bSorting = True
Endif

Return

End
'-----------------------------------------
Public Sub ShowWorking(byToSort As Byte[])
Dim siCount As Byte

For siCount = 0 To byToSort.Max
  Print Str(byToSort[siCount]);
  If siCount <> byToSort.Max Then Print ",";
Next

Print

End


program Heapsort_Demo
  implicit none

  integer, parameter :: num = 20
  real :: array(num)

  call random_seed
  call random_number(array)
  write(*,*) "Unsorted array:-"
  write(*,*) array
  write(*,*)
  call heapsort(array)
  write(*,*) "Sorted array:-"
  write(*,*) array

contains

subroutine heapsort(a)

   real, intent(in out) :: a(0:)
   integer :: start, n, bottom
   real :: temp

   n = size(a)
   do start = (n - 2) / 2, 0, -1
     call siftdown(a, start, n);
   end do

   do bottom = n - 1, 1, -1
     temp = a(0)
     a(0) = a(bottom)
     a(bottom) = temp;
     call siftdown(a, 0, bottom)
   end do

end subroutine heapsort

subroutine siftdown(a, start, bottom)

  real, intent(in out) :: a(0:)
  integer, intent(in) :: start, bottom
  integer :: child, root
  real :: temp

  root = start
  do while(root*2 + 1 < bottom)
    child = root * 2 + 1

    if (child + 1 < bottom) then
      if (a(child) < a(child+1)) child = child + 1
    end if

    if (a(root) < a(child)) then
      temp = a(child)
      a(child) = a (root)
      a(root) = temp
      root = child
    else
      return
    end if
  end do

end subroutine siftdown

end program Heapsort_Demo


defmodule Sort do
  def bead_sort(list) when is_list(list), do: dist(dist(list))

  defp dist(list), do: List.foldl(list, [], fn(n, acc) when n>0 -> dist(acc, n, []) end)

  defp dist([],    0, acc), do: Enum.reverse(acc)
  defp dist([h|t], 0, acc), do: dist(t,    0, [h  |acc])
  defp dist([],    n, acc), do: dist([], n-1, [1  |acc])
  defp dist([h|t], n, acc), do: dist(t,  n-1, [h+1|acc])
end


-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).


# define the MODE that will be sorted #
MODE SITEM = STRING;
#--- Swap function ---#
PROC swap = (REF[]SITEM array, INT first, INT second) VOID:
(
    SITEM temp := array[first];
    array[first] := array[second];
    array[second]:= temp
);
#--- Quick sort partition arg function with custom comparision function ---#
PROC quick = (REF[]SITEM array, INT first, INT last, PROC(SITEM,SITEM)INT compare) VOID:
(
    INT   smaller := first + 1,
          larger  := last;
    SITEM pivot   := array[first];
    WHILE smaller <= larger DO
        WHILE compare(array[smaller], pivot) < 0 AND smaller < last DO
            smaller +:= 1
        OD;
        WHILE compare( array[larger], pivot) > 0 AND larger > first DO
            larger  -:= 1
        OD;
        IF smaller < larger THEN
            swap(array, smaller, larger);
            smaller +:= 1;
            larger  -:= 1
        ELSE
            smaller +:= 1
        FI
    OD;
    swap(array, first, larger);
    IF first < larger-1 THEN
        quick(array, first, larger-1, compare)
    FI;
    IF last > larger +1 THEN
        quick(array, larger+1, last, compare)
    FI
);
#--- Quick sort array function with custom comparison function ---#
PROC quicksort = (REF[]SITEM array, PROC(SITEM,SITEM)INT compare) VOID:
(
  IF UPB array > LWB array THEN
    quick(array, LWB array, UPB array, compare)
  FI
);
#***************************************************************#
main:
(
    OP LENGTH  = (STRING a)INT: ( UPB a + 1 ) - LWB a;
    OP TOLOWER = (STRING a)STRING:
       BEGIN
           STRING result := a;
           FOR i FROM LWB result TO UPB result DO
               CHAR c = a[i];
               IF c >= "A" AND c <= "Z" THEN result[i] := REPR ( ( ABS c - ABS "A" ) + ABS "a" ) FI
           OD;
           result
       END # TOLOWER # ;
    # custom comparison, descending sort on length #
    # if lengths are equal, sort lexicographically #
    PROC compare = (SITEM a, b)INT:
         IF   INT a length = LENGTH a;
              INT b length = LENGTH b;
              a length < b length
         THEN
             # a is shorter than b #  1
         ELIF a length > b length
         THEN
             # a is longer than b  # -1
         ELIF STRING lower a = TOLOWER a;
              STRING lower b = TOLOWER b;
              lower a < lower b
         THEN
              # lowercase a is before lowercase b # -1
         ELIF lower a > lower b
         THEN
              # lowercase a is after lowercase b  #  1
         ELIF a > b
         THEN
             # a and b are equal ignoring case,        #
             # but a is after b considering case       #  1
         ELIF a < b
         THEN
             # a and b are equal ignoring case,        #
             # but a is before b considering case      # -1
         ELSE
             # the strings are equal                   #  0
         FI # compare # ;
    []SITEM orig = ("Here", "are", "some", "sample", "strings", "to", "be", "sorted");
    [LWB orig : UPB orig]SITEM a := orig;
    print(("Before:"));FOR i FROM LWB a TO UPB a DO print((" ",a[i])) OD; print((newline));
    quicksort(a, compare);
    print(("After :"));FOR i FROM LWB a TO UPB a DO print((" ",a[i])) OD; print((newline))
)


package main

import "fmt"

func main() {
    a := []int{170, 45, 75, -90, -802, 24, 2, 66}
    fmt.Println("before:", a)
    cocktailSort(a)
    fmt.Println("after: ", a)
}

func cocktailSort(a []int) {
    last := len(a) - 1
    for {
        swapped := false
        for i := 0; i < last; i++ {
            if a[i] > a[i+1] {
                a[i], a[i+1] = a[i+1], a[i]
                swapped = true
            }
        }
        if !swapped {
            return
        }
        swapped = false
        for i := last - 1; i >= 0; i-- {
            if a[i] > a[i+1] {
                a[i], a[i+1] = a[i+1], a[i]
                swapped = true
            }
        }
        if !swapped {
            return
        }
    }
}


def makeSwap = { a, i, j = i+1 -> print "."; a[[j,i]] = a[[i,j]] }

def checkSwap = { a, i, j = i+1 -> [(a[i] > a[j])].find{ it }.each { makeSwap(a, i, j) } }

def cocktailSort = { list ->
    if (list == null || list.size() < 2) return list
    def n = list.size()
    def swap = checkSwap.curry(list)
    while (true) {
        def swapped = (0..(n-2)).any(swap) && ((-2)..(-n)).any(swap)
        if ( ! swapped ) break
    }
    list
}