#lang QB64
'***************************************************
'* BeadSort is VERY fast for small CGSortLibArray(max)-CGSortLibArray(min). Typical performance is
'* O(NlogN) or better. However as the key values (array values and ranges) go up, the performance
'* drops steeply excellent for small-ranged arrays. Integer only at this point.  Throughput is
'* roughly 900k/GHzS for double-precision, with binary range (0,1). Related to CountingSort()
'***************************************************
SUB BeadSort (CGSortLibArray() AS DOUBLE, start AS LONG, finish AS LONG, order&)
    DIM MAX AS DOUBLE: MAX = CGSortLibArray(start)
    DIM BeadSort_Sum AS DOUBLE
    DIM BeadSort_I AS LONG
    DIM BeadSort_J AS LONG
    FOR BeadSort_I = start + 1 TO (finish - start)
        IF (CGSortLibArray(BeadSort_I) > MAX) THEN MAX = CGSortLibArray(BeadSort_I)
    NEXT
    REDIM beads((finish - start), MAX)
    FOR BeadSort_I = 0 TO (finish - start) - 1
        FOR BeadSort_J = 0 TO CGSortLibArray(BeadSort_I) - 1
            beads(BeadSort_I, BeadSort_J) = 1
        NEXT
    NEXT
    IF order& = 1 THEN
        FOR BeadSort_J = 0 TO MAX
            BeadSort_Sum = 0
            FOR BeadSort_I = 0 TO (finish - start)
                BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J)
                beads(BeadSort_I, BeadSort_J) = 0
            NEXT
            FOR BeadSort_I = (finish - start) - BeadSort_Sum TO (finish - start)
                beads(BeadSort_I, BeadSort_J) = 1
            NEXT
        NEXT
        FOR BeadSort_I = 0 TO (finish - start)
            BeadSort_J = 0
            WHILE BeadSort_J < MAX AND beads(BeadSort_I, BeadSort_J)
                BeadSort_J = BeadSort_J + 1
            WEND
            CGSortLibArray(BeadSort_I) = BeadSort_J
        NEXT
    ELSE
        FOR BeadSort_J = MAX TO 0 STEP -1
            BeadSort_Sum = 0
            FOR I = 0 TO (finish - start)
                BeadSort_Sum = BeadSort_Sum + beads(I, BeadSort_J)
                beads(I, BeadSort_J) = 0
            NEXT
            FOR I = (finish - start) TO (finish - start) - BeadSort_Sum STEP -1
                beads(I, BeadSort_J) = 1
            NEXT
        NEXT
        FOR BeadSort_I = 0 TO (finish - start)
            BeadSort_J = 0
            WHILE BeadSort_J < MAX AND beads(BeadSort_I, BeadSort_J)
                BeadSort_J = BeadSort_J + 1
            WEND
            CGSortLibArray(finish - BeadSort_I) = BeadSort_J
        NEXT
    END IF
END SUB


#lang racket
(require rackunit)

(define (columns lst)
  (match (filter (λ (l) (not (empty? l))) lst)
    ['() '()]
    [l (cons (map car l) (columns (map cdr l)))]))

(define (bead-sort lst)
  (map length (columns (columns (map (λ (n) (make-list n 1)) lst)))))

;; unit test
(check-equal?
 (bead-sort '(5 3 1 7 4 1 1))
 '(7 5 4 3 1 1 1))


# routine cribbed from List::Utils;
sub transpose(@list is copy) {
    gather {
        while @list {
            my @heads;
            if @list[0] !~~ Positional { @heads = @list.shift; }
            else { @heads = @list.map({$_.shift unless $_ ~~ []}); }
            @list = @list.map({$_ unless $_ ~~ []});
            take [@heads];
        }
    }
}

sub beadsort(@l) {
    (transpose(transpose(map {[1 xx $_]}, @l))).map(*.elems);
}

my @list = 2,1,3,5;
say beadsort(@list).perl;


def cityList = ['UK  London', 'US  New York', 'US  Birmingham', 'UK  Birmingham',].asImmutable()
[
    'Sort by city': { city -> city[4..-1] },
    'Sort by country': { city -> city[0..3] },
].each{ String label, Closure orderBy ->
    println "\n\nBefore ${label}"
    cityList.each { println it }
    println "\nAfter ${label}"
    cityList.sort(false, orderBy).each{ println it }
}


import java.util.Arrays;
import java.util.Comparator;

public class RJSortStability {

  public static void main(String[] args) {
    String[] cityList = { "UK  London", "US  New York", "US  Birmingham", "UK  Birmingham", };

    String[] cn = cityList.clone();
    System.out.println("\nBefore sort:");
    for (String city : cn) {
      System.out.println(city);
    }

    // sort by city
    Arrays.sort(cn, new Comparator<String>() {
      public int compare(String lft, String rgt) {
        return lft.substring(4).compareTo(rgt.substring(4));
      }
    });

    System.out.println("\nAfter sort on city:");
    for (String city : cn) {
      System.out.println(city);
    }

    cn = cityList.clone();
    System.out.println("\nBefore sort:");
    for (String city : cn) {
      System.out.println(city);
    }

    // sort by country
    Arrays.sort(cn, new Comparator<String>() {
      public int compare(String lft, String rgt) {
        return lft.substring(0, 2).compareTo(rgt.substring(0, 2));
      }
    });

    System.out.println("\nAfter sort on country:");
    for (String city : cn) {
      System.out.println(city);
    }

    System.out.println();
  }
}


import java.util.Comparator;
import java.util.Arrays;

public class Test {
  public static void main(String[] args) {
    String[] strings = {"Here", "are", "some", "sample", "strings", "to", "be", "sorted"};

    Arrays.sort(strings, new Comparator<String>() {
      public int compare(String s1, String s2) {
        int c = s2.length() - s1.length();
        if (c == 0)
          c = s1.compareToIgnoreCase(s2);
        return c;
      }
    });

    for (String s: strings)
      System.out.print(s + " ");
  }
}


function lengthSorter(a, b) {
  var result = b.length - a.length;
  if (result == 0)
    result = a.localeCompare(b);
  return result;
}

var test = ["Here", "are", "some", "sample", "strings", "to", "be", "sorted"];
test.sort(lengthSorter);
alert( test.join(' ') );                      // strings sample sorted Here some are be to


use strict;
use warnings;
use feature 'say';

sub cocktail_sort {
    my @a = @_;
    while (1) {
        my $swapped_forward = 0;
        for my $i (0..$#a-1) {
            if ($a[$i] gt $a[$i+1]) {
                @a[$i, $i+1] = @a[$i+1, $i];
                $swapped_forward = 1;
            }
        }
        last if not $swapped_forward;

        my $swapped_backward = 0;
        for my $i (reverse 0..$#a-1) {
            if ($a[$i] gt $a[$i+1]) {
                @a[$i, $i+1] = @a[$i+1, $i];
                $swapped_backward = 1;
            }
        }
        last if not $swapped_backward;
    }
    @a
}

say join ' ', cocktail_sort( <t h e q u i c k b r o w n f o x j u m p s o v e r t h e l a z y d o g> );


siftDown[list_,root_,theEnd_]:=
 While[(root*2) <= theEnd,
  child = root*2;
  If[(child+1 <= theEnd)&&(list[[child]] < list[[child+1]]), child++;];
  If[list[[root]] < list[[child]],
   list[[{root,child}]] = list[[{child,root}]]; root = child;,
   Break[];
  ]
 ]
heapSort[list_] := Module[{ count, start},
 count = Length[list]; start = Floor[count/2];
 While[start >= 1,list = siftDown[list,start,count];
  start--;
 ]
 While[count > 1, list[[{count,1}]] = list[[{1,count}]];
  count--; list = siftDown[list,1,count];
 ]
]


function list = heapSort(list)

    function list = siftDown(list,root,theEnd)
        while (root * 2) <= theEnd

            child = root * 2;
            if (child + 1 <= theEnd) && (list(child) < list(child+1))
                child = child + 1;
            end

            if list(root) < list(child)
                list([root child]) = list([child root]); %Swap
                root = child;
            else
                return
            end

        end %while
    end %siftDown

    count = numel(list);

    %Because heapify is called once in pseudo-code, it is inline here
    start = floor(count/2);

    while start >= 1
        list = siftDown(list, start, count);
        start = start - 1;
    end
    %End Heapify

    while count > 1

        list([count 1]) = list([1 count]); %Swap
        count = count - 1;
        list = siftDown(list,1,count);

    end

end


/*REXX program sorts a list (four groups)  of integers  using the  bead sort  algorithm.*/
                                 /* [↓]  define  two dozen  grasshopper  numbers.       */
gHopper= 1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254 270
                                 /* [↓]  these are also called hexagonal pyramidal #s.  */
greenGrocer=  0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876 4560
                                 /* [↓]  define twenty-three Bernoulli numerator numbers*/
bernN= '1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0'
                                 /* [↓] also called the Reduced Totient function, and is*/
                                 /*also called Carmichael lambda, or the LAMBDA function*/
psi=      1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16
y= gHopper greenGrocer bernN psi                 /*combine the four lists into one list.*/
call show  'before sort',  y                     /*display the  list  before sorting.   */
say copies('░', 75)                              /*show long separator line before sort.*/
call show  ' after sort',  beadSort(y)           /*display the  list   after sorting.   */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
beadSort: procedure; parse arg low . 1 high . 1 z,$;  @.=0 /*$:  the list to be sorted. */
            do j=1  until z=='';    parse var  z   x  z    /*pick the meat off the bone.*/
            x= x / 1;               @.x= @.x + 1           /*normalize X;  bump counter.*/
            low= min(low, x);       high= max(high, x)     /*track lowest and highest #.*/
            end   /*j*/
                                                           /* [↓] now, collect the beads*/
            do m=low  to high;      if @.m>0  then $= $ copies(m' ', @.m)
            end   /*m*/
          return $
/*──────────────────────────────────────────────────────────────────────────────────────*/
show: parse arg txt,y;   z= words(y);                       w= length(z)
            do k=1  for z; say right('element',30)  right(k,w)  txt":"  right(word(y,k),9)
            end   /*k*/
      return


class Array
  def beadsort
    map {|e| [1] * e}.columns.columns.map(&:length)
  end

  def columns
    y = length
    x = map(&:length).max
    Array.new(x) do |row|
      Array.new(y) { |column| self[column][row] }.compact # Remove nils.
    end
  end
end

# Demonstration code:
p [5,3,1,7,4,1,1].beadsort


def quicksort(cmp):
  if length < 2 then .                                     # it is already sorted
  else .[0] as $pivot
    | reduce .[] as $x
      # state: [less, equal, greater]
      ( [ [], [], [] ];                                    # three empty arrays:
        if   $x == $pivot then    .[1] += [$x]             # add x to equal
        else ([$x,$pivot]|cmp) as $order
          | if   $order == 0 then .[1] += [$x]             # ditto
            elif ($order|type) == "number" then
              if $order < 0 then  .[0] += [$x]             # add x to less
              else .[2] += [$x]                            # add x to greater
              end
            else ([$pivot,$x]|cmp) as $order2
              | if $order and $order2 then   .[1] += [$x]  # add x to equal
                elif $order then   .[0] += [$x]            # add x to less
                else .[2] += [$x]                          # add x to greater
                end
            end
        end )
    | (.[0] | quicksort(cmp) ) + .[1] + (.[2] | quicksort(cmp) )
  end ;


wl = filter(!isempty, split("""You will rejoice to hear that no disaster has accompanied the
    commencement of an enterprise which you have regarded with such evil
    forebodings.""", r"\W+"))

println("Original list:\n - ", join(wl, "\n - "))
sort!(wl; by=x -> (-length(x), lowercase(x)))
println("\nSorted list:\n - ", join(wl, "\n - "))


import java.util.Arrays

fun main(args: Array<String>) {
    val strings = arrayOf("Here", "are", "some", "sample", "strings", "to", "be", "sorted")

    fun printArray(message: String, array: Array<String>) = with(array) {
        print("$message [")
        forEachIndexed { index, string ->
            print(if (index == lastIndex) string else "$string, ")
        }
        println("]")
    }

    printArray("Unsorted:", strings)

    Arrays.sort(strings) { first, second ->
        val lengthDifference = second.length - first.length
        if (lengthDifference == 0) first.lowercase().compareTo(second.lowercase(), true) else lengthDifference
    }

    printArray("Sorted:", strings)
}


test = { "Here", "we", "have", "some", "sample", "strings", "to", "be", "sorted" }

function stringSorter(a, b)
	if string.len(a) == string.len(b) then
		return string.lower(a) < string.lower(b)
	end
	return string.len(a) > string.len(b)
end
table.sort(test, stringSorter)

-- print sorted table
for k,v in pairs(test) do print(v) end


with javascript_semantics

function cocktail_sort(sequence s)
    s = deep_copy(s)
    integer swapped = 1, f = 1, t = length(s)-1, d = 1
    while swapped do
        swapped = 0
        for i=f to t by d do
            object si = s[i],
                   sn = s[i+1]
            if si>sn then
                s[i] = sn
                s[i+1] = si
                swapped = 1
            end if
        end for
        -- swap to and from, and flip direction.
        -- additionally, we can reduce one element to be
        -- examined, depending on which way we just went.
        {f,t,d} = {t-d,f,-d}
    end while
    return s
end function

constant s = sq_rand(repeat(1000,10))
printf(1,"original: %V\n",{s})
printf(1,"  sorted: %V\n",{cocktail_sort(s)})


function cocktailSort($arr){
	if (is_string($arr)) $arr = str_split(preg_replace('/\s+/','',$arr));

	do{
		$swapped = false;
		for($i=0;$i<count($arr);$i++){
			if(isset($arr[$i+1])){
				if($arr[$i] > $arr[$i+1]){
					list($arr[$i], $arr[$i+1]) = array($arr[$i+1], $arr[$i]);
					$swapped = true;
				}
			}
		}

		if ($swapped == false) break;

		$swapped = false;
		for($i=count($arr)-1;$i>=0;$i--){
			if(isset($arr[$i-1])){
				if($arr[$i] < $arr[$i-1]) {
					list($arr[$i],$arr[$i-1]) = array($arr[$i-1],$arr[$i]);
					$swapped = true;
				}
			}
		}
	}while($swapped);

	return $arr;
}
$arr = array(5, 1, 7, 3, 6, 4, 2);
$arr2 = array("John", "Kate", "Alice", "Joe", "Jane");
$strg = "big fjords vex quick waltz nymph";
$arr = cocktailSort($arr);
$arr2 = cocktailSort($arr2);
$strg = cocktailSort($strg);
echo implode(',',$arr) . '
';
echo implode(',',$arr2) . '
';
echo implode('',$strg) . '
';


fn heapify arr count =
(
	local s = count /2
	while s > 0 do
	(
		arr = siftDown arr s count
		s -= 1
	)
	return arr
)
fn siftDown arr s end =
(
	local root = s
	while root * 2 <= end do
	(
		local child = root * 2
		if child < end and arr[child] < arr[child+1] do
		(
			child += 1
		)
		if arr[root] < arr[child] then
		(
			swap arr[root] arr[child]
			root = child
		)
		else return arr
	)
	return arr
)
fn heapSort arr =
(
	local count = arr.count
	arr = heapify arr count
	local end = count
	while end >= 1 do
	(
		swap arr[1] arr[end]

		end -= 1
		arr = siftDown arr 1 end
	)

)


%%%-------------------------------------------------------------------

:- module heapsort_task.

:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module array.
:- import_module int.
:- import_module list.
:- import_module random.
:- import_module random.sfc16.

%%%-------------------------------------------------------------------
%%%
%%% heapsort/3 --
%%%
%%% A generic heapsort predicate. It takes a "Less_than" predicate to
%%% determine the order of the sort.
%%%
%%% That I call the predicate "Less_than" does not, by any means,
%%% preclude a descending order. This "Less_than" refers to the
%%% ordinals of the sequence. In other words, it means "comes before".
%%%
%%% The implementation closely follows the task pseudocode--although,
%%% of course, loops have been turned into tail recursions and arrays
%%% are treated as state variables.
%%%

:- pred heapsort(pred(T, T)::pred(in, in) is semidet,
                 array(T)::array_di, array(T)::array_uo) is det.
heapsort(Less_than, !Arr) :-
  heapsort(Less_than, size(!.Arr), !Arr).

:- pred heapsort(pred(T, T)::pred(in, in) is semidet, int::in,
                 array(T)::array_di, array(T)::array_uo) is det.
heapsort(Less_than, Count, !Arr) :-
  heapify(Less_than, Count, !Arr),
  heapsort_loop(Less_than, Count, Count - 1, !Arr).

:- pred heapsort_loop(pred(T, T)::pred(in, in) is semidet,
                      int::in, int::in,
                      array(T)::array_di, array(T)::array_uo) is det.
heapsort_loop(Less_than, Count, End, !Arr) :-
  if (End = 0) then true
  else (swap(End, 0, !Arr),
        sift_down(Less_than, 0, End - 1, !Arr),
        heapsort_loop(Less_than, Count, End - 1, !Arr)).

:- pred heapify(pred(T, T)::pred(in, in) is semidet, int::in,
                array(T)::array_di, array(T)::array_uo) is det.
heapify(Less_than, Count, !Arr) :-
  heapify(Less_than, Count, (Count - 2) // 2, !Arr).

:- pred heapify(pred(T, T)::pred(in, in) is semidet,
                int::in, int::in,
                array(T)::array_di, array(T)::array_uo) is det.
heapify(Less_than, Count, Start, !Arr) :-
  if (Start = -1) then true
  else (sift_down(Less_than, Start, Count - 1, !Arr),
        heapify(Less_than, Count, Start - 1, !Arr)).

:- pred sift_down(pred(T, T)::pred(in, in) is semidet,
                  int::in, int::in,
                  array(T)::array_di, array(T)::array_uo) is det.
sift_down(Less_than, Root, End, !Arr) :-
  if (End < (Root * 2) + 1) then true
  else (locate_child(Less_than, Root, End, !.Arr, Child),
        (if not Less_than(!.Arr^elem(Root), !.Arr^elem(Child))
         then true
         else (swap(Root, Child, !Arr),
               sift_down(Less_than, Child, End, !Arr)))).

:- pred locate_child(pred(T, T)::pred(in, in) is semidet,
                     int::in, int::in,
                     array(T)::in, int::out) is det.
locate_child(Less_than, Root, End, Arr, Child) :-
  Child0 = (Root * 2) + 1,
  (if (End =< Child0 + 1)
   then (Child = Child0)
   else if not Less_than(Arr^elem(Child0), Arr^elem(Child0 + 1))
   then (Child = Child0)
   else (Child = Child0 + 1)).

%%%-------------------------------------------------------------------

main(!IO) :-
  R = (sfc16.init),
  make_io_random(R, M, !IO),
  Generate = (pred(Index::in, Number::out, IO1::di, IO::uo) is det :-
                uniform_int_in_range(M, min(0, Index), 10, Number,
                                     IO1, IO)),
  generate_foldl(30, Generate, Arr0, !IO),
  print_line(Arr0, !IO),
  heapsort(<, Arr0, Arr1),
  print_line(Arr1, !IO),
  heapsort(>=, Arr1, Arr2),
  print_line(Arr2, !IO).

%%%-------------------------------------------------------------------
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:


$ include "seed7_05.s7i";

const proc: beadSort (inout array integer: a) is func
  local
    var integer: max is 0;
    var integer: sum is 0;
    var array bitset: beads is 0 times {};
    var integer: i is 0;
    var integer: j is 0;
  begin
    beads := length(a) times {};
    for i range 1 to length(a) do
      if a[i] > max then
        max := a[i];
      end if;
      beads[i] := {1 .. a[i]};
    end for;
    for j range 1 to max do
      sum := 0;
      for i range 1 to length(a) do
        sum +:= ord(j in beads[i]);
        excl(beads[i], j);
      end for;
      for i range length(a) - sum + 1 to length(a) do
        incl(beads[i], j);
      end for;
    end for;
    for i range 1 to length(a) do
      for j range 1 to max until j not in beads[i] do
        noop;
      end for;
      a[i] := pred(j);
    end for;
  end func;

const proc: main is func
  local
    var array integer: a is [] (5, 3, 1, 7, 4, 1, 1, 20);
    var integer: num is 0;
  begin
    beadSort(a);
    for num range a do
      write(num <& " ");
    end for;
    writeln;
  end func;


func beadsort(arr) {

    var rows = []
    var columns = []

    for datum in arr {
        for column in ^datum {
            ++(columns[column] := 0)
            ++(rows[columns[column] - 1] := 0)
        }
    }

    rows.reverse
}

say beadsort([5,3,1,7,4,1,1])


fun columns l =
  case List.filter (not o null) l of
    [] => []
  | l => map hd l :: columns (map tl l)

fun replicate (n, x) = List.tabulate (n, fn _ => x)

fun bead_sort l =
  map length (columns (columns (map (fn e => replicate (e, 1)) l)))


package require Tcl 8.5

proc beadsort numList {
    # Special case: empty list is empty when sorted.
    if {![llength $numList]} return
    # Set up the abacus...
    foreach n $numList {
	for {set i 0} {$i<$n} {incr i} {
	    dict incr vals $i
	}
    }
    # Make the beads fall...
    foreach n [dict values $vals] {
	for {set i 0} {$i<$n} {incr i} {
	    dict incr result $i
	}
    }
    # And the result is...
    dict values $result
}

# Demonstration code
puts [beadsort {5 3 1 7 4 1 1}]


import java.util.Arrays;
import java.util.Comparator;

public class RJSortStability {

  public static void main(String[] args) {
    String[] cityList = { "UK  London", "US  New York", "US  Birmingham", "UK  Birmingham", };

    String[] cn = cityList.clone();
    System.out.println("\nBefore sort:");
    for (String city : cn) {
      System.out.println(city);
    }

    // sort by city
    Arrays.sort(cn, new Comparator<String>() {
      public int compare(String lft, String rgt) {
        return lft.substring(4).compareTo(rgt.substring(4));
      }
    });

    System.out.println("\nAfter sort on city:");
    for (String city : cn) {
      System.out.println(city);
    }

    cn = cityList.clone();
    System.out.println("\nBefore sort:");
    for (String city : cn) {
      System.out.println(city);
    }

    // sort by country
    Arrays.sort(cn, new Comparator<String>() {
      public int compare(String lft, String rgt) {
        return lft.substring(0, 2).compareTo(rgt.substring(0, 2));
      }
    });

    System.out.println("\nAfter sort on country:");
    for (String city : cn) {
      System.out.println(city);
    }

    System.out.println();
  }
}


Module Checkit {
      Class Quick {
            Private:
         partition=lambda-> {
               Read &A(), p, r : i = p-1 : x=A(r)
               For j=p to r-1 {If .LE(A(j), x) Then i++:Swap A(i),A(j)
               } : Swap A(i+1), A(r) :  Push  i+2, i
         }
            Public:
         LE=Lambda->Number<=Number
         Module ForStrings {
               .partition<=lambda-> {
                     Read &a$(), p, r : i = p-1 : x$=a$(r)
                     For j=p to r-1 {If a$(j)<= x$ Then i++:Swap a$(i),a$(j)
                     } : Swap a$(i+1), a$(r) : Push i+2, i
               }
         }
         Function quicksort {
              Read ref$
              {
                      loop : If Stackitem() >= Stackitem(2) Then Drop 2 : if  empty then {Break} else continue
                      over 2,2 : call .partition(ref$) :shift 3
              }
         }
      }
      Quick=Quick()

      ToSort$="this is a set of strings to sort This Is A Set Of Strings To Sort"
      Dim a$()
      a$()=Piece$(ToSort$, " ")
      \\ we can redim to any range
      Dim a$(100 to len(a$())+99)  ' from 100 to 115 (16 items)
      Group Quick {
            Module ForStringsSpecial {
               .partition<=lambda-> {
                        Read &a$(), p, r : i = p-1 : x$=a$(r) :lx$=lcase$(x$) : k=len(x$)
                        For j=p to r-1 {
                              m=len(a$(j))
                              select case compare(m, k)
                              case 0
                              {
                                   aj$=lcase$(a$(j))
                                   if aj$>lx$ then exit
                                   if aj$=lx$ then if a$(j)<=x$ then exit
                                   i++
                                   Swap a$(i),a$(j)
                              }
                              case 1
                              {
                                    i++:Swap a$(i),a$(j)
                              }
                              End Select
                     } : Swap a$(i+1), a$(r) : Push i+2, i
               }
         }
      }
      Document doc$={Unsorted List:
      }
      k=each(a$())
      While k {
            doc$="   "+array$(k)+{
            }
      }
      Quick.ForStringsSpecial
      \\ Dimension(a$(), 0, 1) is Lbound a$() first dimension
      \\ Dimension(a$(), 0, 1) is Ubound a$() first dimension
      Call Quick.quicksort(&a$(), Dimension(a$(), 0, 1), Dimension(a$(), 1,1))
      k=each(a$())
      Doc$={
            Sorted List:
            }
      While k {
            doc$="   "+array$(k)+{
            }
      }
      Report doc$
      Clipboard doc$
}
Checkit


Compare_fn:= proc(s1, s2)
	local len1, len2;
	len1 := StringTools:-Length(s1);
	len2 := StringTools:-Length(s2);
	if (len1 > len2) then
		return true;
	elif (len1 < len2) then
		return false;
	else # ascending lexicographic order for strings of equal length / case insensitive
		StringTools:-CompareCI(s1, s2);
	end if;
end proc:

L := ["Here", "are", "some", "sample", "strings", "to", "be", "sorted", "Tooo"];
sort(L, Compare_fn);


StringOrderQ[x_String, y_String] :=
 If[StringLength[x] == StringLength[y],
       OrderedQ[{x, y}],
       StringLength[x] >StringLength[y]
   ]
words={"on","sunday","sander","sifted","and","sorted","sambaa","for","a","second"};
Sort[words,StringOrderQ]


strangeorderp(a, b) := slength(a) > slength(b) or (slength(a) = slength(b) and orderlessp(a, b))$
s: tokens("Lorem ipsum dolor sit amet consectetur adipiscing elit Sed non risus Suspendisse\
 lectus tortor dignissim sit amet adipiscing nec ultricies sed dolor")$

sort(s, strangeorderp);
["Suspendisse", "consectetur", "adipiscing", "adipiscing", "dignissim", "ultricies",
"lectus", "tortor", "Lorem", "dolor", "dolor", "ipsum", "risus", "amet", "amet",
"elit", "Sed", "nec", "non", "sed", "sit", "sit"]


fn myCmp str1 str2 =
(
    case of
    (
        (str1.count < str2.count):  1
        (str1.count > str2.count): -1
        default:(
                -- String compare is case sensitive, name compare isn't. Hence...
                str1 = str1 as name
                str2 = str2 as name
                case of
                (
                    (str1 > str2):  1
                    (str1 < str2): -1
                    default:        0
                )
                )
    )
)

strList = #("Here", "are", "some", "sample", "strings", "to", "be", "sorted")
qSort strList myCmp
print strList


(de cocktailSort (Lst)
   (use (Swapped L)
      (loop
         (off Swapped)
         (setq L Lst)
         (while (cdr L)
            (when (> (car L) (cadr L))
               (xchg L (cdr L))
               (on Swapped) )
            (pop 'L) )
         (NIL Swapped Lst)
         (off Swapped)
         (loop
            (setq L (prior L Lst))  # Not recommended (inefficient)
            (when (> (car L) (cadr L))
               (xchg L (cdr L))
               (on Swapped) )
            (T (== Lst L)) )
         (NIL Swapped Lst) ) ) )


cocktail: procedure (A);
   declare A(*) fixed;
   declare t fixed;
   declare stable bit (1);
   declare (i, n) fixed binary (31);

   n = hbound(A,1);
   do until (stable);
      stable = '1'b;
      do i = 1 to n-1, n-1 to 1 by -1;
         if A(i) > A(i+1) then
            do; stable = '0'b; /* still unsorted, so set false. */
                t = A(i); A(i) = A(i+1); A(i+1) = t;
            end;
      end;
   end;
end cocktail;


function CocktailSort ($a) {
    $l = $a.Length
	$m = 0
	if( $l -gt 1 )
	{
		$hasChanged = $true
		:outer while ($hasChanged) {
			$hasChanged = $false
			$l--
			for ($i = $m; $i -lt $l; $i++) {
				if ($a[$i] -gt $a[$i+1]) {
					$a[$i], $a[$i+1] = $a[$i+1], $a[$i]
					$hasChanged = $true
				}
			}
			if(-not $hasChanged) {
				break outer
			}
			$hasChanged = $false
			for ($i = $l; $i -gt $m; $i--) {
				if ($a[$i-1] -gt $a[$i]) {
					$a[$i-1], $a[$i] = $a[$i], $a[$i-1]
					$hasChanged = $true
				}
			}
			$m++
		}
	}
	$a
}

$l = 10; CocktailSort ( 1..$l | ForEach-Object { $Rand = New-Object Random }{ $Rand.Next( -( $l - 1 ), $l - 1 ) } )


/* NetRexx */
options replace format comments java crossref savelog symbols binary

import java.util.List

placesList = [String -
    "UK  London",     "US  New York",   "US  Boston",     "US  Washington" -
  , "UK  Washington", "US  Birmingham", "UK  Birmingham", "UK  Boston"     -
]

lists = [ -
    placesList -
  , heapSort(String[] Arrays.copyOf(placesList, placesList.length)) -
]

loop ln = 0 to lists.length - 1
  cl = lists[ln]
  loop ct = 0 to cl.length - 1
    say cl[ct]
    end ct
    say
  end ln

return

method heapSort(a = String[], count = a.length) public constant binary returns String[]

  rl = String[a.length]
  al = List heapSort(Arrays.asList(a), count)
  al.toArray(rl)

  return rl

method heapSort(a = List, count = a.size) public constant binary returns ArrayList

  a = heapify(a, count)

  iend = count - 1
  loop label iend while iend > 0
    swap = a.get(0)
    a.set(0, a.get(iend))
    a.set(iend, swap)
    a = siftDown(a, 0, iend - 1)
    iend = iend - 1
    end iend

  return ArrayList(a)

method heapify(a = List, count = int) public constant binary returns List

  start = (count - 2) % 2

  loop label strt while start >= 0
    a = siftDown(a, start, count - 1)
    start = start - 1
    end strt

  return a

method siftDown(a = List, istart = int, iend = int) public constant binary returns List

  root = istart

  loop label root while root * 2 + 1 <= iend
    child = root * 2 + 1
    if child + 1 <= iend then do
      if (Comparable a.get(child)).compareTo(Comparable a.get(child + 1)) < 0 then do
        child = child + 1
        end
      end
    if (Comparable a.get(root)).compareTo(Comparable a.get(child)) < 0 then do
      swap = a.get(root)
      a.set(root, a.get(child))
      a.set(child, swap)
      root = child
      end
    else do
      leave root
      end
    end root

  return a


Option Base 1

Private Function sq_add(arr As Variant, x As Double) As Variant
    Dim res() As Variant
    ReDim res(UBound(arr))
    For i = 1 To UBound(arr)
        res(i) = arr(i) + x
    Next i
    sq_add = res
End Function

Private Function beadsort(ByVal a As Variant) As Variant
    Dim poles() As Variant
    ReDim poles(WorksheetFunction.Max(a))
    For i = 1 To UBound(a)
        For j = 1 To a(i)
            poles(j) = poles(j) + 1
        Next j
    Next i
    For j = 1 To UBound(a)
        a(j) = 0
    Next j
    For i = 1 To UBound(poles)
        For j = 1 To poles(i)
            a(j) = a(j) + 1
        Next j
    Next i
    beadsort = a
End Function

Public Sub main()
    Debug.Print Join(beadsort([{5, 3, 1, 7, 4, 1, 1, 20}]), ", ")
End Sub


var beadSort = Fn.new { |a|
    var res = []
    var max = a.reduce { |acc, i| (i > acc) ? i : acc }
    var trans = [0] * max
    for (i in a) {
        for (n in 0...i) trans[n] = trans[n] + 1
    }
    for (i in a) {
        res.add(trans.count { |n| n > 0 })
        for (n in 0...trans.count) trans[n] = trans[n] - 1
    }
    return res[-1..0] // return in ascending order
}

var as = [ [4, 65, 2, 31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ]
for (a in as) {
    System.print("Before: %(a)")
    a = beadSort.call(a)
    System.print("After : %(a)")
    System.print()
}


ary = [["UK", "London"], ["US", "New York"], ["US", "Birmingham"], ["UK", "Birmingham"]]
print(ary);

ary.sort(function(a,b){return (a[1]<b[1] ? -1 : (a[1]>b[1] ? 1 : 0))});
print(ary);

/* a stable sort will output ["US", "Birmingham"] before ["UK", "Birmingham"] */


("Here" "are" "some" "sample" "strings" "to" "be" "sorted")
(((length) (length)) spread <) sort print


using System.Console;

module CustomSort
{
    Main() : void
    {
        def strings1 = ["these", "are", "strings", "of", "different", "length"];
        def strings2 = ["apple", "House", "chewy", "Salty", "rises", "Later"];

        WriteLine(strings1.Sort((x, y) => y.Length.CompareTo(x.Length)));
        WriteLine(strings2.Sort((x, y) => x.CompareTo(y)))
    }
}


/* NetRexx */
options replace format comments java crossref symbols nobinary

-- =============================================================================
class RSortCustomComparator public

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method main(args = String[]) public static
  sample = [String 'Here', 'are', 'some', 'sample', 'strings', 'to', 'be', 'sorted']
  say displayArray(sample)
  Arrays.sort(sample, LengthComparator())
  say displayArray(sample)
  return

method displayArray(harry = String[]) constant
  disp = ''
  loop elmt over harry
    disp = disp','elmt
    end elmt
  return '['disp.substr(2)']' -- trim leading comma

-- =============================================================================
class RSortCustomComparator.LengthComparator implements Comparator

method compare(lft = Object, rgt = Object) public binary returns int
  cRes = int
  if lft <= String, rgt <= String then do
    cRes = (String rgt).length - (String lft).length
    if cRes == 0 then cRes = (String lft).compareToIgnoreCase(String rgt)
    end
  else signal IllegalArgumentException('Arguments must be Strings')
  return cRes


ctail(_, [], Rev, Rev, sorted) :- write(Rev), nl.
ctail(fwrd, [A,B|T], In, Rev, unsorted) :- A > B, !,
	ctail(fwrd, [B,A|T], In, Rev, _).
ctail(bkwd, [A,B|T], In, Rev, unsorted) :- A < B, !,
	ctail(bkwd, [B,A|T], In, Rev, _).
ctail(D,[A|T], In, Rev, Ch) :- !, ctail(D, T, [A|In], Rev, Ch).

cocktail([], []).
cocktail(In, [Min|Out]) :-
	ctail(fwrd, In, [], [Max|Rev], SFlag),
	( SFlag=sorted->reverse([Max|Rev], [Min|Out]);
	 (ctail(bkwd, Rev, [Max], [Min|Tmp], SortFlag),
	  (SortFlag=sorted->Out=Tmp; !, cocktail(Tmp, Out)))).

test :-  In = [8,9,1,3,4,2,6,5,4],
	 writef('  input=%w\n', [In]),
	 cocktail(In, R),
	 writef('-> %w\n', [R]).


proc siftDown[T](a: var openarray[T]; start, ending: int) =
  var root = start
  while root * 2 + 1 < ending:
    var child = 2 * root + 1
    if child + 1 < ending and a[child] < a[child+1]:
      inc child
    if a[root] < a[child]:
      swap a[child], a[root]
      root = child
    else:
      return

proc heapSort[T](a: var openarray[T]) =
  let count = a.len
  for start in countdown((count - 2) div 2, 0):
    siftDown(a, start, count)
  for ending in countdown(count - 1, 1):
    swap a[ending], a[0]
    siftDown(a, 0, ending)

var a = @[4, 65, 2, -31, 0, 99, 2, 83, 782]
heapSort a
echo a


bundle Default {
  class HeapSort {
    function : Main(args : String[]) ~ Nil {
      values := [4, 3, 1, 5, 6, 2];
      HeapSort(values);
      each(i : values) {
        values[i]->PrintLine();
      };
    }

    function : HeapSort(a : Int[]) ~ Nil {
      count := a->Size();
      Heapify(a, count);

      end := count - 1;
      while(end > 0) {
        tmp := a[end];
        a[end] := a[0];
        a[0] := tmp;
        SiftDown(a, 0, end - 1);
        end -= 1;
      };
    }

    function : Heapify(a : Int[], count : Int) ~ Nil {
      start := (count - 2) / 2;
      while(start >= 0) {
        SiftDown(a, start, count - 1);
        start -= 1;
      };
    }

    function : SiftDown(a : Int[], start : Int, end : Int) ~ Nil {
      root := start;
      while((root * 2 + 1) <= end) {
        child := root * 2 + 1;
        if(child + 1 <= end & a[child] < a[child + 1]) {
          child := child + 1;
        };

        if(a[root] < a[child]) {
          tmp := a[root];
          a[root] := a[child];
          a[child] := tmp;
          root := child;
        }
        else {
          return;
        };
      };
    }
  }
}


include c:\cxpl\codes;

proc BeadSort(Array, Length);   \Sort Array into increasing order
int  Array, Length;             \Array contents range 0..31; number of items
int  Row, I, J, T, C;
[Row:= Reserve(Length*4);       \each Row has room for 32 beads
for I:= 0 to Length-1 do        \each Row gets Array(I) number of beads
    Row(I):= ~-1<<Array(I);     \(beware for 80186..Pentium <<32 doesn't shift)
for J:= 1 to Length-1 do
    for I:= Length-1 downto J do
        [T:= Row(I-1) & ~Row(I); \up to 31 beads fall in a single pass
        Row(I-1):= Row(I-1) | T; \(|=xor, !=or)
        Row(I):= Row(I) | T;
        ];
for I:= 0 to Length-1 do        \count beads in each Row
    [C:= 0;  T:= Row(I);
    while T do
        [if T&1 then C:= C+1;  T:= T>>1];
    Array(I):= C;               \count provides sorted order
    ];
];

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


fcn columns(m){ // m is list of lists of zeros/beads, # beads is n, eg (0,0,0)==3
   m
   .apply("len")   // (0,0,0)-->3
   .reduce("max")  // largest bead stack
   .walker()       // [0..max]
   .apply('wrap(i){ m.filter('wrap(s){ s.len() > i }).len().pump(List,0) });
}

fcn beadSort(data){
   data.apply("pump",List,0):columns(_):columns(_).apply("len");
}


[["UK", "London"],
 ["US", "New York"],
 ["US", "Birmingham"],
 ["UK", "Birmingham"]]
| sort_by(.[1])


julia> A = [("UK", "London"), ("US", "New York"), ("US", "Birmingham"), ("UK", "Birmingham")];
julia> sort(A, by=x -> x[2])
4-element Array{(ASCIIString,ASCIIString),1}:
 ("US","Birmingham")
 ("UK","Birmingham")
 ("UK","London")
 ("US","New York")


// version 1.1.51

fun main(args: Array<String>) {
    val cities = listOf("UK London", "US New York", "US Birmingham", "UK Birmingham")
    println("Original   : $cities")
    // sort by country
    println("By country : ${cities.sortedBy { it.take(2) } }")
    // sort by city
    println("By city    : ${cities.sortedBy { it.drop(3) } }")
}


//Single param array:
array->sort

//An array of pairs, order by the right hand element of the pair:
with i in array order by #i->second do => { … }

//The array can also be ordered by multiple values:
with i in array order by #i->second, #i->first do => { … }


randomize 0.5
N=15
dim a(N,2)

for i = 0 to N-1
    a(i,1)= int(i/5)
    a(i,2)= int(rnd(1)*5)
next

print "Unsorted by column #2"
print "by construction sorted by column #1"
for i = 0 to N-1
    print a(i,1), a(i,2)
next

sort a(), 0, N-1, 2
print

print "After sorting by column #2"
print "Notice wrong order by column #1"
for i = 0 to N-1
    print a(i,1), a(i,2),
    if i=0 then
        print
    else
        if  a(i,2) = a(i-1,2) AND  a(i,1) < a(i-1,1) then print "bad order" else print
    end if
next


import strutils, algorithm

var strings = "here are Some sample strings to be sorted".split(' ')

strings.sort(proc (x, y: string): int =
  result = cmp(y.len, x.len)
  if result == 0:
    result = cmpIgnoreCase(x, y)
)

echo strings


use Collection;

class Test {
  function : Main(args : String[]) ~ Nil {
    v := CreateHolders(["Here", "are", "some", "sample", "strings", "to", "be", "sorted"]);
    "unsorted: "->Print(); Show(v);
    v->Sort();
    "sorted: "->Print(); Show(v);
  }

  function : CreateHolders(strings : String[]) ~ CompareVector {
    vector := CompareVector->New();
    each(i : strings) {
      vector->AddBack(StringHolder->New(strings[i]));
    };

    return vector;
  }

  function : Show(v : CompareVector) ~ Nil {
    each(i : v) {
      s := v->Get(i)->As(StringHolder);
      s->ToString()->Print();
      if(i + 1 < v->Size()) {
        ','->Print();
      };
    };
    '\n'->Print();
  }
}

class StringHolder implements Compare {
  @s : String;

  New(s : String) {
    @s := s;
  }

  method : public : Compare(c : Compare) ~ Int {
    h := c->As(StringHolder);
    r := h->ToString();
    size := r->Size() - @s->Size();
    if(size = 0) {
      size := @s->ToUpper()->Compare(r->ToUpper());
    };

    return size;
  }

  method : public : HashID() ~ Int {
    return @s->HashID();
  }

  method : public : ToString() ~ String {
    return @s;
  }
}


;sorts an array of integers
Procedure cocktailSort(Array a(1))
  Protected index, hasChanged, low, high

  low = 0
  high = ArraySize(a()) - 1
  Repeat
    hasChanged = #False
    For index = low To high
      If a(index) > a(index + 1)
        Swap a(index), a(index + 1)
        hasChanged = #True
      EndIf
    Next
    high - 1

    If hasChanged = #False
      Break ;we can exit the outer loop here if no changes were made
    EndIf

    hasChanged = #False
    For index = high To low Step -1
      If a(index) > a(index + 1)
        Swap a(index), a(index + 1)
        hasChanged = #True
      EndIf
    Next
    low + 1
  Until hasChanged = #False ;if no elements have been changed, then the array is sorted
EndProcedure


def cocktailSort(A):
    up = range(len(A)-1)
    while True:
        for indices in (up, reversed(up)):
            swapped = False
            for i in indices:
                if A[i] > A[i+1]:
                    A[i], A[i+1] =  A[i+1], A[i]
                    swapped = True
            if not swapped:
                return


let heapsort a =

  let swap i j =
    let t = a.(i) in a.(i) <- a.(j); a.(j) <- t in

  let sift k l =
    let rec check x y =
      if 2*x+1 < l then
        let ch =
          if y < l-1 && a.(y) < a.(y+1) then y+1 else y in
        if a.(x) < a.(ch) then (swap x ch; check ch (2*ch+1)) in
    check k (2*k+1) in

  let len = Array.length a in

  for start = (len/2)-1 downto 0 do
    sift start len;
  done;

  for term = len-1 downto 1 do
    swap term 0;
    sift 0 term;
  done;;


Module Stable {
      Inventory queue alfa
      Stack New {
            Data "UK", "London","US", "New York","US", "Birmingham", "UK","Birmingham"
            While not empty {
                  Append alfa, Letter$:=letter$
            }
      }
      sort alfa
      k=Each(alfa)
      Document A$
      NL$={
      }
      While k {
            A$= Eval$(k, k^)+" "+eval$(k)+NL$
      }
      Clipboard A$ ' write to clipboard
      Report A$
}
Call Stable

Output:
UK London
UK Birmingham
US New York
US Birmingham


/* NetRexx */
options replace format comments java crossref savelog symbols nobinary

class RCSortStability

method main(args = String[]) public constant

  cityList = [String "UK  London", "US  New York", "US  Birmingham", "UK  Birmingham"]

  cn = String[cityList.length]

  say
  say "Before sort:"
  System.arraycopy(cityList, 0, cn, 0, cityList.length)
  loop city = 0 to cn.length - 1
    say cn[city]
    end city

  cCompNm = Comparator CityComparator()
  Arrays.sort(cn, cCompNm)

  say
  say "After sort on city:"
  loop city = 0 to cn.length - 1
    say cn[city]
    end city

  say
  say "Before sort:"
  System.arraycopy(cityList, 0, cn, 0, cityList.length)
  loop city = 0 to cn.length - 1
    say cn[city]
    end city

  cCompCtry = Comparator CountryComparator()
  Arrays.sort(cn, cCompCtry)

  say
  say "After sort on country:"
  loop city = 0 to cn.length - 1
    say cn[city]
    end city
  say

  return

class RCSortStability.CityComparator implements Comparator

method compare(lft = Object, rgt = Object) public binary returns int
  return (String lft).substring(4).compareTo((String rgt).substring(4))

class RCSortStability.CountryComparator implements Comparator

method compare(lft = Object, rgt = Object) public binary returns int
  return (String lft).substring(0, 2).compareTo((String rgt).substring(0, 2))


#import <Foundation/Foundation.h>

#define esign(X) (((X)>0)?1:(((X)<0)?-1:0))

int main()
{
  @autoreleasepool {

    NSMutableArray *arr =
    [NSMutableArray
      arrayWithArray: [@"this is a set of strings to sort"
                       componentsSeparatedByString: @" "]
     ];

    [arr sortUsingComparator: ^NSComparisonResult(id obj1, id obj2){
      NSComparisonResult l = esign((int)([obj1 length] - [obj2 length]));
      return l ? -l // reverse the ordering
               : [obj1 caseInsensitiveCompare: obj2];
     }];

    for( NSString *str in arr )
    {
      NSLog(@"%@", str);
    }

  }
  return EXIT_SUCCESS;
}


let mycmp s1 s2 =
  if String.length s1 <> String.length s2 then
    compare (String.length s2) (String.length s1)
  else
    String.compare (String.lowercase s1) (String.lowercase s2)


String method: customCmp(s)
   s size self size > ifTrue: [ true return ]
   s size self size < ifTrue: [ false return ]
   s toUpper self toUpper <= ;

["this", "is", "a", "set", "of", "strings", "to", "sort", "This", "Is", "A", "Set", "Of", "Strings", "To", "Sort"]
sortWith(#customCmp) println


cocktailSort <- function(A)
{
  repeat
  {
    swapped <- FALSE
    for(i in seq_len(length(A) - 1))
    {
      if(A[i] > A[i + 1])
      {
        A[c(i, i + 1)] <- A[c(i + 1, i)]#The cool trick mentioned above.
        swapped <- TRUE
      }
    }
    if(!swapped) break
    swapped <- FALSE
    for(i in (length(A)-1):1)
    {
      if(A[i] > A[i + 1])
      {
        A[c(i, i + 1)] <- A[c(i + 1, i)]
        swapped <- TRUE
      }
    }
    if(!swapped) break
  }
  A
}
#Examples taken from the Haxe solution.
ints <- c(1, 10, 2, 5, -1, 5, -19, 4, 23, 0)
numerics <- c(1, -3.2, 5.2, 10.8, -5.7, 7.3, 3.5, 0, -4.1, -9.5)
strings <- c("We", "hold", "these", "truths", "to", "be", "self-evident", "that", "all", "men", "are", "created", "equal")


declare
  proc {HeapSort A}
     Low = {Array.low A}
     High = {Array.high A}
     Count = High-Low+1

     %% heapify
     LastParent = Low + (Count-2) div 2
  in
     for Start in LastParent..Low;~1 do
        {Siftdown A Start High}
     end

     %% repeatedly put the maximum element to the end
     %% and re-heapify the rest
     for End in High..Low+1;~1 do
        {Swap A End Low}
        {Siftdown A Low End-1}
     end
  end

  proc {Siftdown A Start End}
     Low = {Array.low A}
     fun {FirstChildOf I} Low+(I-Low)*2+1 end

     Root = {NewCell Start}
  in
     for while:{FirstChildOf @Root} =< End
        break:Break
     do
        Child = {NewCell {FirstChildOf @Root}}
     in
        if @Child + 1 =< End andthen A[email protected]Child < A.(@Child + 1) then
           Child := @Child + 1
        end
        if A[email protected]Root < A[email protected]Child then
           {Swap A @Root @Child}
           Root := @Child
        else
           {Break}
        end
     end
  end

  proc {Swap A I J}
     A.J := (A.I := A.J)
  end

  %% create array with indices ~1..7 and fill it
  Arr = {Array.new ~1 7 0}
  {Record.forAllInd unit(~1:3 0:1 4 1 5 9 2 6 5)
   proc {$ I V}
      Arr.I := V
   end}
in
  {HeapSort Arr}
  {Show {Array.toRecord unit Arr}}


import algorithm

const Records = [(country: "UK", city: "London"),
                 (country: "US", city: "New York"),
                 (country: "US", city: "Birmingham"),
                 (country: "UK", city: "Birmingham")]

echo "Original order:"
for record in Records:
  echo record.country, " ", record.city
echo()

echo "Sorted by city name:"
for record in Records.sortedByIt(it.city):
  echo record.country, " ", record.city
echo()

echo "Sorted by country name:"
for record in Records.sortedByIt(it.country):
  echo record.country, " ", record.city


/* Rexx */
Do
  cities = .array~of('UK  London', 'US  New York', 'US  Birmingham', 'UK  Birmingham',)

  Say; Say 'Original table'
  Call display cities

  Say; Say 'Unstable sort on city'
  sorted = cities~copy
  sorted~sortWith(.ColumnComparator~new(4, 20))
  Call display sorted

  Say; Say 'Stable sort on city'
  sorted = cities~copy
  sorted~stableSortWith(.ColumnComparator~new(4, 20))
  Call display sorted

  Say; Say 'Unstable sort on country'
  sorted = cities~copy
  sorted~sortWith(.ColumnComparator~new(1, 2))
  Call display sorted

  Say; Say 'Stable sort on country'
  sorted = cities~copy
  sorted~stableSortWith(.ColumnComparator~new(1, 2))
  Call display sorted

  Return
End
Exit

display: Procedure
Do
  Use arg CT

  Say '-'~copies(80)
  Loop c_ over CT
    Say c_
    End c_

  Return
End
Exit


(import (scheme char))

(define (comp a b)
   (let ((la (string-length a))
         (lb (string-length b)))
      (or
         (> la lb)
         (and (= la lb) (string-ci<? a b)))))

(print
   (sort comp '(
      "lorem" "ipsum" "dolor" "sit" "amet" "consectetur"
      "adipiscing" "elit" "maecenas" "varius" "sapien"
      "vel" "purus" "hendrerit" "vehicula" "integer"
      "hendrerit" "viverra" "turpis" "ac" "sagittis"
      "arcu" "pharetra" "id")))


A=.array~of('The seven deadly sins','Pride','avarice','Wrath','envy','gluttony','sloth','Lust')
say 'Sorted in order of descending length, and in ascending lexicographic order'
say A~sortWith(.DescLengthAscLexical~new)~makeString

::class DescLengthAscLexical mixinclass Comparator
::method compare
use strict arg left, right
if left~length==right~length
  then return left~caselessCompareTo(right)
  else return right~length-left~length


uses generics 'containing sort macros
uses console
string sdata={"CC","Aa","aAa","bb","bbB","b","B","c","A"}
'
int count = countof sdata
'
macro filter(f,a)
=================
  'sdata[a]
  f=1 'allow all
end macro
'
macro compare(f,a,b)
====================
  int la=len sdata[a]
  int lb=len sdata[b]
  if la<lb
    f=1 'descending length
  elseif la>lb
    '
  elseif ucase(sdata[a])>ucase(sdata[b])
    f=1 'ascending but case insensitive
  endif
end macro
'
NewSortIndex(index,count,rcount,filter,compare)
NewSortedData(sorted,sdata,index,rcount)
'
print "Count: " rcount cr cr
int i
for i=1 to rcount
  print sorted[i] cr
next
pause


#lang racket
(require (only-in srfi/43 vector-swap!))

(define (cocktail-sort! xs)
  (define (ref i) (vector-ref xs i))
  (define (swap i j) (vector-swap! xs i j))
  (define len (vector-length xs))
  (define (bubble from to delta)
    (for/fold ([swaps 0]) ([i (in-range from to delta)])
      (cond [(> (ref i) (ref (+ i 1)))
             (swap i (+ i 1)) (+ swaps 1)]
            [swaps])))
  (let loop ()
    (cond [(zero? (bubble 0 (- len 2)  1)) xs]
          [(zero? (bubble (- len 2) 0  -1)) xs]
          [(loop)])))


sub cocktail_sort ( @a ) {
    my $range = 0 ..^ @a.end;
    loop {
        my $swapped_forward = 0;
        for $range.list -> $i {
            if @a[$i] > @a[$i+1] {
                @a[ $i, $i+1 ] .= reverse;
                $swapped_forward = 1;
            }
        }
        last if not $swapped_forward;

        my $swapped_backward = 0;
        for $range.reverse -> $i {
            if @a[$i] > @a[$i+1] {
                @a[ $i, $i+1 ] .= reverse;
                $swapped_backward = 1;
            }
        }
        last if not $swapped_backward;
    }
    return @a;
}

my @weights = (^50).map: { 100 + ( 1000.rand.Int / 10 ) };
say @weights.sort.Str eq @weights.&cocktail_sort.Str ?? 'ok' !! 'not ok';


program HeapSortDemo;

type
  TIntArray = array[4..15] of integer;

var
  data: TIntArray;
  i: integer;

procedure siftDown(var a: TIntArray; start, ende: integer);
  var
    root, child, swap: integer;
  begin
    root := start;
    while root * 2 - start + 1 <= ende do
    begin
      child := root * 2 - start + 1;
      if (child + 1 <= ende) and (a[child] < a[child + 1]) then
        inc(child);
      if a[root] < a[child] then
      begin
	swap     := a[root];
        a[root]  := a[child];
        a[child] := swap;
        root := child;
      end
      else
        exit;
    end;
  end;

procedure heapify(var a: TIntArray);
  var
    start, count: integer;
  begin
    count := length(a);
    start := low(a) + count div 2 - 1;
    while start >= low(a) do
    begin
      siftdown(a, start, high(a));
      dec(start);
    end;
  end;

procedure heapSort(var a: TIntArray);
  var
    ende, swap: integer;
  begin
    heapify(a);
    ende := high(a);
    while ende > low(a) do
    begin
      swap := a[low(a)];
      a[low(a)] := a[ende];
      a[ende] := swap;
      dec(ende);
      siftdown(a, low(a), ende);
    end;
  end;

begin
  Randomize;
  writeln('The data before sorting:');
  for i := low(data) to high(data) do
  begin
    data[i] := Random(high(data));
    write(data[i]:4);
  end;
  writeln;
  heapSort(data);
  writeln('The data after sorting:');
  for i := low(data) to high(data) do
  begin
    write(data[i]:4);
  end;
  writeln;
end.


DEFINE TEMP-TABLE tt
   FIELD country  AS CHAR FORMAT 'x(2)'
   FIELD city     AS CHAR FORMAT 'x(16)'
   .

DEFINE VARIABLE cc AS CHARACTER EXTENT 2.

CREATE tt. ASSIGN tt.country = 'UK' tt.city = 'London'.
CREATE tt. ASSIGN tt.country = 'US' tt.city = 'New York'.
CREATE tt. ASSIGN tt.country = 'US' tt.city = 'Birmingham'.
CREATE tt. ASSIGN tt.country = 'UK' tt.city = 'Birmingham'.

cc[1] = 'by country~n~n'.
FOR EACH tt BY tt.country BY ROWID( tt ):
   cc[1] = cc[1] + tt.country + '~t' + tt.city + '~n'.
END.

cc[2] = 'by city~n~n'.
FOR EACH tt BY tt.city BY ROWID( tt ):
   cc[2] = cc[2] + tt.country + '~t' + tt.city + '~n'.
END.

MESSAGE
   cc[1] SKIP(1) cc[2]
VIEW-AS ALERT-BOX.


declare
  fun {LexicographicLessThan Xs Ys}
     for
        X in {Map Xs Char.toLower}
        Y in {Map Ys Char.toLower}
        return:Return
        default:{Length Xs}<{Length Ys}
     do
        if X < Y then {Return true} end
     end
  end

  fun {LessThan Xs Ys}
     {Length Xs} > {Length Ys}
     orelse
     {Length Xs} == {Length Ys} andthen {LexicographicLessThan Xs Ys}
  end

  Strings = ["Here" "are" "some" "sample" "strings" "to" "be" "sorted"]
in
  {ForAll {Sort Strings LessThan} System.showInfo}


use feature 'say';

@strings = qw/Here are some sample strings to be sorted/;

# with a subroutine:
sub mycmp { length $b <=> length $a || lc $a cmp lc $b }
say join ' ', sort mycmp @strings;

# inline:
say join ' ', sort {length $b <=> length $a || lc $a cmp lc $b} @strings

# for large inputs, can be faster with a 'Schwartzian' transform:
say join ' ', map  { $_->[0] }
             sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] }
             map  { [ $_, length, lc ] }
             @strings;


V n = 13
print(sorted(Array(1..n), key' i -> String(i)))


/*REXX program sorts an array using the cocktail─sort method,  A.K.A.:  happy hour sort,*/
                                                 /*   bidirectional bubble sort,        */
                                                 /*   cocktail shaker sort, ripple sort,*/
                                                 /*   a selection sort variation,       */
                                                 /*   shuffle sort,  shuttle sort,   or */
                                                 /*   a bubble sort variation.          */
call [email protected]                                        /*generate some array elements.        */
call [email protected] 'before sort'                         /*show  unsorted  array elements.      */
     say copies('█', 101)                        /*show a separator line  (a fence).    */
call cocktailSort  #                             /*invoke the cocktail sort subroutine. */
call [email protected] ' after sort'                         /*show    sorted  array elements.      */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
cocktailSort: procedure expose @.;    parse arg N;   nn= N-1  /*N:  is number of items. */
                     do until done;   done= 1
                         do j=1   for nn;                jp= j+1
                         if @.j>@.jp  then do;  done=0;  [email protected].j;  @.[email protected].jp;  @.jp=_;  end
                         end   /*j*/
                     if done  then leave                      /*No swaps done?  Finished*/
                         do k=nn  for nn  by -1;         kp= k+1
                         if @.k>@.kp  then do;  done=0;  [email protected].k;  @.[email protected].kp;  @.kp=_;  end
                         end   /*k*/
                     end       /*until*/
              return
/*──────────────────────────────────────────────────────────────────────────────────────*/
[email protected]: @.=                                        /*assign a default value for the stem. */
      @.1 ='---the 22 card tarot deck (larger deck has 56 additional cards in 4 suits)---'
      @.2 ='==========symbol====================pip======================================'
      @.3 ='the juggler                  ◄───     I'
      @.4 ='the high priestess  [Popess] ◄───    II'
      @.5 ='the empress                  ◄───   III'
      @.6 ='the emperor                  ◄───    IV'
      @.7 ='the hierophant  [Pope]       ◄───     V'
      @.8 ='the lovers                   ◄───    VI'
      @.9 ='the chariot                  ◄───   VII'
      @.10='justice                      ◄───  VIII'
      @.11='the hermit                   ◄───    IX'
      @.12='fortune  [the wheel of]      ◄───     X'
      @.13='strength                     ◄───    XI'
      @.14='the hanging man              ◄───   XII'
      @.15='death  [often unlabeled]     ◄───  XIII'
      @.16='temperance                   ◄───   XIV'
      @.17='the devil                    ◄───    XV'
      @.18='lightning  [the tower]       ◄───   XVI'
      @.19='the stars                    ◄───  XVII'
      @.20='the moon                     ◄─── XVIII'
      @.21='the sun                      ◄───   XIX'
      @.22='judgment                     ◄───    XX'
      @.23='the world                    ◄───   XXI'
      @.24='the fool  [often unnumbered] ◄───  XXII'

            do #=1  until @.#==''; end;  #= #-1  /*find how many entries in the array.  */
      return                                     /* [↑]  adjust for DO loop advancement.*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
[email protected]: w= length(#);              do j=1  for #      /*#:  is the number of items in @. */
                                  say 'element'    right(j, w)     arg(1)":"    @.j
                                  end   /*j*/        /*     ↑                           */
       return                                        /*     └─────max width of any line.*/


aList = [ 5, 6, 1, 2, 9, 14, 2, 15, 6, 7, 8, 97]
flag = 0
cocktailSort(aList)
for i=1 to len(aList)
    see "" + aList[i] + " "
next

func cocktailSort A
       n = len(A)
       while flag =  0
             flag = 1
             for i = 1 to n-1
                 if A[i] > A[i+1]
                    temp = A[i]
                    A[i] = A[i+1]
                    A [i+1] = temp
                    flag = 0
                    ok
             next
       end


declare
  Cities = ['UK'#'London'
            'US'#'New York'
            'US'#'Birmingham'
            'UK'#'Birmingham']
in
  %% sort by city; stable because '=<' is reflexiv
  {Show {Sort Cities fun {$ A B} A.2 =< B.2 end}}

  %% sort by country; NOT stable because '<' is not reflexiv
  {Show {Sort Cities fun {$ A B} A.1 < B.1 end}}


with javascript_semantics
sequence test = {{"UK","London"},
                 {"US","New York"},
                 {"US","Birmingham"},
                 {"UK","Birmingham"}}

---------------------
-- probably stable --
---------------------
function cmp(object a, object b)
    return compare(a[2],b[2])
end function
pp(custom_sort(cmp,deep_copy(test)),{pp_Nest,1})

-----------------------
-- guaranteed stable --
-----------------------
function tag_cmp(integer i, integer j)
    integer c = compare(test[i][2],test[j][2])
    if c=0 then c = compare(i,j) end if -- (see note)
    return c
end function
sequence tags = custom_sort(tag_cmp,shuffle(tagset(4)))
pp(extract(test,tags),{pp_Nest,1})


function my_compare(sequence a, b)
    integer c = -compare(length(a),length(b))  -- descending length
    if c=0 then
        c = compare(lower(a),lower(b))         -- ascending lexical within same length
    end if
    return c
end function
?custom_sort(my_compare,{"Here", "are", "some", "sample", "strings", "to", "be", "sorted"})


PROC PrintArray(INT ARRAY a INT size)
  INT i

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

INT FUNC Compare(INT a1,a2)
  CHAR ARRAY s1(10),s2(10)
  INT res

  StrI(a1,s1) StrI(a2,s2)
  res=SCompare(s1,s2)
RETURN (res)

PROC InsertionSort(INT ARRAY a INT size)
  INT i,j,value

  FOR i=1 TO size-1
  DO
    value=a(i)
    j=i-1
    WHILE j>=0 AND Compare(a(j),value)>0
    DO
      a(j+1)=a(j)
      j==-1
    OD
    a(j+1)=value
  OD
RETURN

PROC Test(INT ARRAY a INT size)
  PrintE("Array before sort:")
  PrintArray(a,size)
  InsertionSort(a,size)
  PrintE("Array after sort:")
  PrintArray(a,size)
  PutE()
RETURN

PROC Main()
  DEFINE COUNT_A="13"
  DEFINE COUNT_B="50"
  INT ARRAY a(COUNT_A),b(COUNT_B)
  BYTE i

  FOR i=1 TO COUNT_A
  DO a(i-1)=i OD

  FOR i=1 TO COUNT_B
  DO b(i-1)=i OD

  Test(a,COUNT_A)
  Test(b,COUNT_B)
RETURN


WITH Ada.Containers.Generic_Array_Sort, Ada.Text_IO;
USE  Ada.Text_IO;
PROCEDURE Main IS
   TYPE Natural_Array IS ARRAY (Positive RANGE <>) OF Natural;
   FUNCTION Less (L, R : Natural) RETURN Boolean IS (L'Img < R'Img);
   PROCEDURE Sort_Naturals IS NEW Ada.Containers.Generic_Array_Sort
     (Positive, Natural, Natural_Array, Less);
   PROCEDURE Show (Last : Natural) IS
      A : Natural_Array (1 .. Last);
   BEGIN
      FOR I IN A'Range LOOP A (I) := I; END LOOP;
      Sort_Naturals (A);
      FOR I IN  A'Range LOOP Put (A (I)'Img); END LOOP;
      New_Line;
   END Show;
BEGIN
   Show (13);
   Show (21);
END Main;


class Array
  def cocktailsort!
    begin
      swapped = false
      0.upto(length - 2) do |i|
        if self[i] > self[i + 1]
          self[i], self[i + 1] = self[i + 1], self[i]
          swapped = true
        end
      end
      break unless swapped

      swapped = false
      (length - 2).downto(0) do |i|
        if self[i] > self[i + 1]
          self[i], self[i + 1] = self[i + 1], self[i]
          swapped = true
        end
      end
    end while swapped
    self
  end
end


for i = 1 to 100 ' fill array
  a(i) = rnd(0) * 100
next i
' ------- sort -------
beg	= 2
siz	= 100
whatWay	= 1
changed = 1
while changed
changed = 0
  FOR i = beg TO siz STEP whatWay
    IF a(i-1) > a(i) THEN
       hold	= a(i)
       a(i)	= a(i-1)
       a(i-1)	= hold
       changed	= i
    end if
  NEXT i
  siz	= beg
  beg	= changed - whatWay
  whatWay = 0 - whatWay
wend
' ------ print result --------
for i = 1 to 100
 print i;" ";a(i)
next i
end


fn cocktail_sort<T: PartialOrd>(a: &mut [T]) {
    let len = a.len();
    loop {
        let mut swapped = false;
        let mut i = 0;
        while i + 1 < len {
            if a[i] > a[i + 1] {
                a.swap(i, i + 1);
                swapped = true;
            }
            i += 1;
        }
        if swapped {
            swapped = false;
            i = len - 1;
            while i > 0 {
                if a[i - 1] > a[i] {
                    a.swap(i - 1, i);
                    swapped = true;
                }
                i -= 1;
            }
        }
        if !swapped {
            break;
        }
    }
}

fn main() {
    let mut v = vec![10, 8, 4, 3, 1, 9, 0, 2, 7, 5, 6];
    println!("before: {:?}", v);
    cocktail_sort(&mut v);
    println!("after:  {:?}", v);
}


with javascript_semantics

function siftDown(sequence arr, integer s, integer last)
integer root = s
    while root*2<=last do
        integer child = root*2
        if child<last and arr[child]<arr[child+1] then
            child += 1
        end if
        if arr[root]>=arr[child] then exit end if
        object tmp = arr[root]
        arr[root] = arr[child]
        arr[child] = tmp
        root = child
    end while
    return arr
end function

function heapify(sequence arr, integer count)
integer s = floor(count/2)
    while s>0 do
        arr = siftDown(arr,s,count)
        s -= 1
    end while
    return arr
end function

function heap_sort(sequence arr)
    integer last = length(arr)
    arr = heapify(arr,last)
    while last>1 do
        object tmp = arr[1]
        arr[1] = arr[last]
        arr[last] = tmp
        last -= 1
        arr = siftDown(arr,1,last)
    end while
    return arr
end function

?heap_sort({5,"oranges","and",3,"apples"})


# First, define a bernoulli sample, of length 26.
x <- sample(c(0, 1), 26, replace=T)

x
# [1] 1 1 1 1 0 1 1 0 1 0 1 1 1 0 1 1 0 1 0 1 0 1 1 0 1 0

# Give names to the entries. "letters" is a builtin value
names(x) <- letters

x
# a b c d e f g h i j k l m n o p q r s t u v w x y z
# 1 1 1 1 0 1 1 0 1 0 1 1 1 0 1 1 0 1 0 1 0 1 1 0 1 0

# The unstable one, see how "a" appears after "l" now
sort(x, method="quick")
# z h s u e q x n j r t v w y p o m l a i g f d c b k
# 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1

# The stable sort, letters are ordered in each section
sort(x, method="shell")
# e h j n q s u x z a b c d f g i k l m o p r t v w y
# 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1


#lang racket

(sort '(("UK" "London")
        ("US" "New York")
        ("US" "Birmingham")
        ("UK" "Birmingham"))
      string<? #:key first)
;; -> (("UK" "London") ("UK" "Birmingham")
;;     ("US" "New York") ("US" "Birmingham"))

(sort '(("UK" "London")
        ("US" "New York")
        ("US" "Birmingham")
        ("UK" "Birmingham"))
      string<? #:key second)
;; -> '(("US" "Birmingham") ("UK" "Birmingham")
;;      ("UK" "London") ("US" "New York"))


<?php
function mycmp($s1, $s2)
{
    if ($d = strlen($s2) - strlen($s1))
        return $d;
    return strcasecmp($s1, $s2);
}

$strings = array("Here", "are", "some", "sample", "strings", "to", "be", "sorted");
usort($strings, "mycmp");
?>


MRGEPKG: package exports(MERGESORT,MERGE,RMERGE);

DCL (T(4)) CHAR(20) VAR; /* scratch space of length N/2 */

MERGE: PROCEDURE (A,LA,B,LB,C,CMPFN);
   DECLARE (A(*),B(*),C(*)) CHAR(*) VAR;
   DECLARE (LA,LB) FIXED BIN(31) NONASGN;
   DECLARE (I,J,K) FIXED BIN(31);
   DECLARE CMPFN ENTRY(
          NONASGN CHAR(*) VAR,
          NONASGN CHAR(*) VAR)
          RETURNS (FIXED bin(31));

   I=1; J=1; K=1;
   DO WHILE ((I <= LA) & (J <= LB));
      IF CMPFN(A(I),B(J)) <= 0 THEN
         DO; C(K)=A(I); K=K+1; I=I+1; END;
      ELSE
         DO; C(K)=B(J); K=K+1; J=J+1; END;
   END;
   DO WHILE (I <= LA);
      C(K)=A(I); I=I+1; K=K+1;
   END;
   return;
END MERGE;

MERGESORT: PROCEDURE (A,N,CMPFN) RECURSIVE ;
     DECLARE (A(*))               CHAR(*) VAR;
     DECLARE N                    FIXED BINARY(31) NONASGN;
     DECLARE CMPFN                ENTRY(
          NONASGN CHAR(*) VAR,
          NONASGN CHAR(*) VAR)
                                  RETURNS (FIXED bin(31));
     DECLARE (M,I)                FIXED BINARY;
     DECLARE AMP1(N)              CHAR(20) VAR BASED(P);
     DECLARE P POINTER;

   IF (N=1) THEN RETURN;
   M = trunc((N+1)/2);
   IF M > 1 THEN CALL MERGESORT(A,M,CMPFN);
   P=ADDR(A(M+1));
   IF (N-M > 1) THEN CALL MERGESORT(AMP1,N-M,CMPFN);
   IF CMPFN(A(M),AMP1(1)) <= 0 THEN RETURN;
   DO I=1 to M; T(I)=A(I); END;
   CALL MERGE(T,M,AMP1,N-M,A,CMPFN);
END MERGESORT;

RMERGE: PROC OPTIONS(MAIN);
DCL I FIXED BIN(31);
DCL A(8) CHAR(20) VAR INIT("this","is","a","set","of","strings","to","sort");

MyCMP: PROCEDURE(A,B) RETURNS (FIXED BIN(31));
   DCL (A,B) CHAR(*) VAR NONASGN;
   DCL (I,J) FIXED BIN(31);

   I = length(trim(A)); J = length(trim(B));
   IF I < J THEN RETURN(+1);
   IF I > J THEN RETURN(-1);
   IF lowercase(A) < lowercase(B) THEN RETURN(-1);
   IF lowercase(A) > lowercase(B) THEN RETURN(+1);
   RETURN (0);
END MyCMP;

CALL MERGESORT(A,8,MyCMP);
DO I=1 TO 8;
   put edit (I,A(I)) (F(5),X(2),A(10)) skip;
END;

put skip;
END RMERGE;


arr: 1..13
print sort map arr => [to :string]


n2lexicog(n){
    Arr := [], list := ""
    loop % n
        list .= A_Index "`n"
    Sort, list
    for k, v in StrSplit(Trim(list, "`n"), "`n")
        Arr.Push(v)
    return Arr
}


# syntax: GAWK -f SORT_NUMBERS_LEXICOGRAPHICALLY.AWK
#
# sorting:
#   PROCINFO["sorted_in"] is used by GAWK
#   SORTTYPE is used by Thompson Automation's TAWK
#
BEGIN {
    prn(0)
    prn(1)
    prn(13)
    prn(9,10)
    prn(-11,+11)
    prn(-21)
    prn("",1)
    prn(+1,-1)
    exit(0)
}
function prn(n1,n2) {
    if (n1 <= 0 && n2 == "") {
      n2 = 1
    }
    if (n2 == "") {
      n2 = n1
      n1 = 1
    }
    printf("%d to %d: %s\n",n1,n2,snl(n1,n2))
}
function snl(start,stop,  arr,i,str) {
    if (start == "") {
      return("error: start=blank")
    }
    if (start > stop) {
      return("error: start>stop")
    }
    for (i=start; i<=stop; i++) {
      arr[i]
    }
    PROCINFO["sorted_in"] = "@ind_str_asc" ; SORTTYPE = 2
    for (i in arr) {
      str = sprintf("%s%s ",str,i)
    }
    sub(/ $/,"",str)
    return(str)
}


object CocktailSort extends App {
  def sort(arr: Array[Int]) = {
    var swapped = false
    do {
      def swap(i: Int) {
        val temp = arr(i)
        arr(i) = arr(i + 1)
        arr(i + 1) = temp
        swapped = true
      }

      swapped = false
      for (i <- 0 to (arr.length - 2)) if (arr(i) > arr(i + 1)) swap(i)

      if (swapped) {
        swapped = false
        for (j <- arr.length - 2 to 0 by -1) if (arr(j) > arr(j + 1)) swap(j)
        //if no elements have been swapped, then the list is sorted
      }
    } while (swapped)
    arr
  }

  println(sort(Array(170, 45, 75, -90, -802, 24, 2, 66)).mkString(", "))

}


function varargout=cocktailSort(list_in)
    swapped = %T;
    while swapped
        swapped = %F;
        for i = [1:length(list_in)-1]
            if list_in(i) > list_in(i+1) then
                list_in([i i+1])=list_in([i+1 i]);
                swapped = %T;
            end
        end
        if ~swapped
            break
        end
        swapped = %F;
        for i = [length(list_in)-1:-1:1]
            if list_in(i) > list_in(i+1)
                list_in([i i+1]) = list_in([i+1 i])
                swapped = %T;
            end
        end
    end
    varargout=list(list_in)
endfunction

disp(cocktailSort([6 3 7 8 5 1 2 4 9]));


main =>
  _ = random2(),
  A = [random(-10,10) : _ in 1..30],
  println(A),
  heapSort(A),
  println(A).

heapSort(A) =>
  heapify(A),
  End = A.len,
  while (End > 1)
    swap(A, End, 1),
    End := End - 1,
    siftDown(A, 1, End)
  end.

heapify(A) =>
  Count = A.len,
  Start = Count // 2,
  while (Start >= 1)
    siftDown(A, Start, Count),
    Start := Start - 1
  end.

siftDown(A, Start, End) =>
  Root = Start,
  Loop = true,
  while (Root * 2 - 1 < End, Loop == true)
    Child := Root * 2- 1,
    if Child + 1 <= End, A[Child] @< A[Child+1] then
      Child := Child + 1
    end,
    if A[Root] @< A[Child] then
      swap(A,Root, Child),
      Root := Child
    else
       Loop := false
    end
  end.

swap(L,I,J)  =>
  T = L[I],
  L[I] := L[J],
  L[J] := T.


(de heapSort (A Cnt)
   (let Cnt (length A)
      (for (Start (/ Cnt 2) (gt0 Start) (dec Start))
         (siftDown A Start (inc Cnt)) )
      (for (End Cnt (> End 1) (dec End))
         (xchg (nth A End) A)
         (siftDown A 1 End) ) )
   A )

(de siftDown (A Start End)
   (use Child
      (for (Root Start  (> End (setq Child (* 2 Root))))
         (and
            (> End (inc Child))
            (> (get A (inc Child)) (get A Child))
            (inc 'Child) )
         (NIL (> (get A Child) (get A Root)))
         (xchg (nth A Root) (nth A Child))
         (setq Root Child) ) ) )


use v6;
my @cities =
    ['UK', 'London'],
    ['US', 'New York'],
    ['US', 'Birmingham'],
    ['UK', 'Birmingham'],
    ;

.say for @cities.sort: { .[1] };


; REBOL's sort function is not stable by default. You need to use a custom comparator to make it so.

blk: [
    [UK London]
    [US New-York]
    [US Birmingham]
    [UK Birmingham]
]
sort/compare blk func [a b] [either a/2 < b/2 [-1] [either a/2 > b/2 [1] [0]]]

; Note that you can also do a stable sort without nested blocks.
blk: [
    UK London
    US New-York
    US Birmingham
    UK Birmingham
]
sort/skip/compare blk 2 func [a b] [either a < b [-1] [either a > b [1] [0]]]


/*REXX program  sorts  a (stemmed)  array  using a  (stable)   bubble─sort   algorithm. */
call [email protected]                                        /*generate the array elements (strings)*/
call show  'before sort'                         /*show the  before array  elements.    */
     say copies('▒', 50)                         /*show a separator line between shows. */
call bubbleSort   #                              /*invoke the bubble sort.              */
call show  ' after sort'                         /*show the   after array  elements.    */
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
bubbleSort: procedure expose @.; parse arg n;    m= n-1 /*N:  number of array elements. */
              do m=m  for m  by -1  until ok;    ok= 1  /*keep sorting array until done.*/
                  do j=1  for m;  k= j+1;  if @.j<[email protected].k  then iterate /*Not out─of─order?*/
                  _= @.j;  @.j= @.k;   @.k= _    ok= 0  /*swap 2 elements; flag as ¬done*/
                  end   /*j*/
              end       /*m*/;       return
/*──────────────────────────────────────────────────────────────────────────────────────*/
[email protected]: @.=;                  @.1 = 'UK  London'
                            @.2 = 'US  New York'
                            @.3 = 'US  Birmingham'
                            @.4 = 'UK  Birmingham'
              do #=1  while @.#\==''              /*determine how many entries in list. */
              end   /*#*/;    #= # - 1;   return  /*adjust for the DO loop index; return*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
show: do j=1  for #;  say '      element' right(j,length(#)) arg(1)":"  @.j;  end;  return


lvars ls = ['Here' 'are' 'some' 'sample' 'strings' 'to' 'be' 'sorted'];
define compare(s1, s2);
lvars k = length(s2) - length(s1);
if k < 0 then
    return(true);
elseif k > 0 then
    return(false);
else
    return (alphabefore(uppertolower(s1), uppertolower(s2)));
endif;
enddefine;

syssort(ls, compare) -> ls;

NOTE: The definition of compare can also be written thus:
define compare(s1, s2);
 lvars
     l1 = length(s1),
     l2 = length(s2);
 l1 > l2 or (l1 == l2 and alphabefore(uppertolower(s1), uppertolower(s2)))
enddefine;


FUNCTION Sorter(p1 AS STRING, p2 AS STRING) AS LONG
    'if p1 should be first, returns -1
    'if p2 should be first, returns 1
    '     if they're equal, returns 0
    IF LEN(p1) > LEN(p2) THEN
        FUNCTION = -1
    ELSEIF LEN(p2) > LEN(p1) THEN
        FUNCTION = 1
    ELSEIF UCASE$(p1) > UCASE$(p2) THEN
        'if we get here, they're of equal length,
        'so now we're doing a "normal" string comparison
        FUNCTION = -1
    ELSEIF UCASE$(p2) > UCASE$(p1) THEN
        FUNCTION = 1
    ELSE
        FUNCTION = 0
    END IF
END FUNCTION

FUNCTION PBMAIN()
    DIM x(7) AS STRING
    ARRAY ASSIGN x() = "Here", "are", "some", "sample", "strings", "to", "be", "sorted"

    'pb's built-in sorting; "USING" tells it to use our custom comparator
    ARRAY SORT x(), USING Sorter()
END FUNCTION


$list = "Here", "are", "some", "sample", "strings", "to", "be", "sorted"
$list | Sort-Object {-$_.Length},{$_}


rosetta_sort :-
	L = ["Here", "are", "some", "sample", "strings", "to", "be", "sorted" ],
	predsort(my_comp, L, L1),
	writeln('Input list :'),
	maplist(my_write, L), nl,nl,
	writeln('Sorted list :'),
	maplist(my_write, L1).

my_comp(Comp, W1, W2) :-
	string_length(W1,L1),
	string_length(W2, L2),
	(   L1 < L2 -> Comp = '>'
	;   L1 > L2 -> Comp = '<'
	;   compare(Comp, W1, W2)).

my_write(W) :-
	format('~s ', [W]).


CONST n = 13
FOR x = 1 TO n
    result$ = APPEND$(result$, 0, STR$(x))
NEXT
PRINT SORT$(result$)


      N%=13
      PRINT "[" LEFT$(FNLexOrder(0)) "]"
      END

      DEF FNLexOrder(nr%) : LOCAL i%, s$
      FOR i%=nr% TO nr% + 9
        IF i% > N% EXIT FOR
        IF i% > 0 s$+=STR$i% + "," + FNLexOrder(i% * 10)
      NEXT
      =s$


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

int compareStrings(const void *a, const void *b) {
    const char **aa = (const char **)a;
    const char **bb = (const char **)b;
    return strcmp(*aa, *bb);
}

void lexOrder(int n, int *ints) {
    char **strs;
    int i, first = 1, last = n, k = n, len;
    if (n < 1) {
        first = n; last = 1; k = 2 - n;
    }
    strs = malloc(k * sizeof(char *));
    for (i = first; i <= last; ++i) {
        if (i >= 1) len = (int)log10(i) + 2;
        else if (i == 0) len = 2;
        else len = (int)log10(-i) + 3;
        strs[i-first] = malloc(len);
        sprintf(strs[i-first], "%d", i);
    }
    qsort(strs, k, sizeof(char *), compareStrings);
    for (i = 0; i < k; ++i) {
        ints[i] = atoi(strs[i]);
        free(strs[i]);
    }
    free(strs);
}

int main() {
    int i, j, k, n,  *ints;
    int numbers[5] = {0, 5, 13, 21, -22};
    printf("In lexicographical order:\n\n");
    for (i = 0; i < 5; ++i) {
        k = n = numbers[i];
        if (k < 1) k = 2 - k;
        ints = malloc(k * sizeof(int));
        lexOrder(n, ints);
        printf("%3d: [", n);
        for (j = 0; j < k; ++j) {
            printf("%d ", ints[j]);
        }
        printf("\b]\n");
        free(ints);
    }
    return 0;
}


const proc: cocktailSort (inout array elemType: arr) is func
  local
    var boolean: swapped is FALSE;
    var integer: i is 0;
    var elemType: help is elemType.value;
  begin
    repeat
      swapped := FALSE;
      for i range 1 to length(arr) - 1 do
        if arr[i] > arr[i + 1] then
          help := arr[i];
          arr[i] := arr[i + 1];
          arr[i + 1] := help;
          swapped := TRUE;
        end if;
      end for;
      if swapped then
        swapped := FALSE;
        for i range length(arr) - 1 downto 1 do
          if arr[i] > arr[i + 1] then
            help := arr[i];
            arr[i] := arr[i + 1];
            arr[i + 1] := help;
            swapped := TRUE;
          end if;
        end for;
      end if;
    until not swapped;
  end func;


func cocktailsort(a) {
    var swapped = false
    func cmpsw(i) {
        if (a[i] > a[i+1]) {
            a[i, i+1] = a[i+1, i]
            swapped = true
        }
    }
    var max = a.end
    do {
        {|i| cmpsw(i) } << ^max
        swapped.not! && break
        {|i| cmpsw(max-i) } << 1..max
    } while (swapped)
    return a
}


[email protected](Sequence traits) cocktailSort
[ |swapped|
  swapped: False.
  s size <= 1 ifTrue: [^ s].
  [{0 to: s size - 2. s size - 2 downTo: 0}
    do: [|:range| range do: [|:index| (s at: index) > (s at: index + 1) ifTrue: [s swap: index with: index + 1. swapped: True]].
         swapped ifFalse: [^ s].
         swapped: False].
  ] loop
].


*process source xref attributes or(!);
 /*********************************************************************
 * Pseudocode found here:
 *   http://en.wikipedia.org/wiki/Heapsort#Pseudocode
 * Sample data from REXX
 * 27.07.2013 Walter Pachl
 *********************************************************************/
 heaps: Proc Options(main);
 Dcl a(0:25) Char(50) Var Init(
      '---letters of the modern Greek Alphabet---',
      '==========================================',
      'alpha','beta','gamma','delta','epsilon','zeta','eta','theta',
      'iota','kappa','lambda','mu','nu','xi','omicron','pi',
      'rho','sigma','tau','upsilon','phi','chi','psi','omega');
 Dcl n Bin Fixed(31) Init((hbound(a)+1));

 Call showa('before sort');
 Call heapsort((n));
 Call showa(' after sort');

 heapSort: Proc(count);
   Dcl (count,end) Bin Fixed(31);
   Call heapify((count));
   end=count-1;
   do while(end>0);
     Call swap(end,0);
     end=end-1;
     Call siftDown(0,(end));
     End;
   End;

 heapify: Proc(count);
   Dcl (count,start) Bin Fixed(31);
   start=(count-2)/2;
   Do while (start>=0);
     Call siftDown((start),count-1);
     start=start-1;
     End;
   End;

 siftDown: Proc(start,end);
   Dcl (count,start,root,end,child,sw) Bin Fixed(31);
   root=start;
   Do while(root*2+1<= end);
     child=root*2+1;
     sw=root;
     if a(sw)<a(child) Then
       sw=child;
     if child+1<=end & a(sw)<a(child+1) Then
       sw=child+1;
     if sw^=root Then Do;
       Call swap(root,sw);
       root=sw;
       End;
     else
       return;
     End;
   End;

 swap: Proc(x,y);
 Dcl (x,y) Bin Fixed(31);
 Dcl temp Char(50) Var;
   temp=a(x);
   a(x)=a(y);
   a(y)=temp;
   End;

 showa: Proc(txt);
 Dcl txt Char(*);
 Dcl j Bin Fixed(31);
 Do j=0 To hbound(a);
   Put Edit('element',j,txt,a(j))(skip,a,f(3),x(1),a,x(1),a);
   End;
 End;

 End;


aList = [["UK", "London"],
        ["US", "New York"],
        ["US", "Birmingham"],
        ["UK", "Birmingham"]]
see sort(aList,2)


ary = [["UK", "London"],
       ["US", "New York"],
       ["US", "Birmingham"],
       ["UK", "Birmingham"]]
p ary.sort {|a,b| a[1] <=> b[1]}
# MRI reverses the Birminghams:
# => [["UK", "Birmingham"], ["US", "Birmingham"], ["UK", "London"], ["US", "New York"]]


fn main() {
    let country_city = [
        ("UK", "London"),
        ("US", "New York"),
        ("US", "Birmingham"),
        ("UK", "Birmingham"),
    ];

    let mut city_sorted = country_city.clone();
    city_sorted.sort_by_key(|k| k.1);

    let mut country_sorted = country_city.clone();
    country_sorted.sort_by_key(|k| k.0);

    println!("Original:");
    for x in &country_city {
        println!("{} {}", x.0, x.1);
    }

    println!("\nWhen sorted by city:");
    for x in &city_sorted {
        println!("{} {}", x.0, x.1);
    }

    println!("\nWhen sorted by county:");
    for x in &country_sorted {
        println!("{} {}", x.0, x.1);
    }
}


scala> val list = List((1, 'c'), (1, 'b'), (2, 'a'))
list: List[(Int, Char)] = List((1,c), (1,b), (2,a))

scala> val srt1 = list.sortWith(_._2 < _._2)
srt1: List[(Int, Char)] = List((2,a), (1,b), (1,c))

scala> val srt2 = srt1.sortBy(_._1) // Ordering[Int] is implicitly defined
srt2: List[(Int, Char)] = List((1,b), (1,c), (2,a))

scala> val cities = """
     | |UK  London
     | |US  New York
     | |US  Birmingham
     | |UK  Birmingham
     | |""".stripMargin.lines.filterNot(_ isEmpty).toSeq
cities: Seq[String] = ArrayBuffer(UK  London, US  New York, US  Birmingham, UK  Birmingham)

scala> cities.sortBy(_ substring 4)
res47: Seq[String] = ArrayBuffer(US  Birmingham, UK  Birmingham, UK  London, US  New York)


strings = "here are Some sample strings to be sorted".split()

def mykey(x):
    return -len(x), x.upper()

print sorted(strings, key=mykey)


  [ $ "" swap
    witheach
      [ upper join ] ]    is upper$     (   $ --> )

  [ over size over size
    2dup = iff
      [ 2drop upper$
        swap upper$ $< ]
    else
      [ 2swap 2drop < ] ] is comparator ( $ $ -- b )

  $ ‘here are Some sample strings to be sorted’
  nest$ sortwith comparator
  witheach [ echo$ sp ]
  cr cr
  $ "sharna pax and hed on a poal when the ardship of Cambry come out of his hoal"
  nest$ sortwith comparator
  witheach [ echo$ sp ]


v = c("Here", "are", "some", "sample", "strings", "to", "be", "sorted")
print(v[order(-nchar(v), tolower(v))])


#lang racket

;; Using a combination of the two comparisons
(define (sort1 words)
  (sort words (λ(x y)
                (define xl (string-length x)) (define yl (string-length y))
                (or (> xl yl) (and (= xl yl) (string-ci<? x y))))))
(sort1 '("Some" "pile" "of" "words"))
;; -> '("words" "pile" "Some" "of")

;; Doing two sorts, relying on `sort's stability
(define (sort2 words)
  (sort (sort words string-ci<?) > #:key string-length))
(sort2 '("Some" "pile" "of" "words"))
;; -> '("words" "pile" "Some" "of")


my @strings = <Here are some sample strings to be sorted>;
put @strings.sort:{.chars, .lc};
put sort -> $x { $x.chars, $x.lc }, @strings;


using static System.Console;
using static System.Linq.Enumerable;

public class Program
{
    public static void Main() {
        foreach (int n in new [] { 0, 5, 13, 21, -22 }) WriteLine($"{n}: {string.Join(", ", LexOrder(n))}");
    }

    public static IEnumerable<int> LexOrder(int n) => (n < 1 ? Range(n, 2 - n) : Range(1, n)).OrderBy(i => i.ToString());
}


#include <algorithm>
#include <iostream>
#include <numeric>
#include <string>
#include <vector>

void lexicographical_sort(std::vector<int>& numbers) {
    std::vector<std::string> strings(numbers.size());
    std::transform(numbers.begin(), numbers.end(), strings.begin(),
                   [](int i) { return std::to_string(i); });
    std::sort(strings.begin(), strings.end());
    std::transform(strings.begin(), strings.end(), numbers.begin(),
                   [](const std::string& s) { return std::stoi(s); });
}

std::vector<int> lexicographically_sorted_vector(int n) {
    std::vector<int> numbers(n >= 1 ? n : 2 - n);
    std::iota(numbers.begin(), numbers.end(), std::min(1, n));
    lexicographical_sort(numbers);
    return numbers;
}

template <typename T>
void print_vector(std::ostream& out, const std::vector<T>& v) {
    out << '[';
    if (!v.empty()) {
        auto i = v.begin();
        out << *i++;
        for (; i != v.end(); ++i)
            out << ',' << *i;
    }
    out << "]\n";
}

int main(int argc, char** argv) {
    for (int i : { 0, 5, 13, 21, -22 }) {
        std::cout << i << ": ";
        print_vector(std::cout, lexicographically_sorted_vector(i));
    }
    return 0;
}


OrderedCollection extend [
  swap: indexA and: indexB [
    |t|
    t := self at: indexA.
    self at: indexA put: (self at: indexB).
    self at: indexB put: t
  ]
  cocktailSort [
    |swapped|
    [
      swapped := false.
      1 to: (self size - 1) do: [ :i |
        (self at: i) > (self at: (i+1)) ifTrue: [
          self swap: i and: (i+1).
	  swapped := true
        ]
      ].
      swapped ifFalse: [ ^ self ].
      swapped := false.
      (self size - 1) to: 1 by: -1 do: [ :i |
        (self at: i) > (self at: (i+1)) ifTrue: [
          self swap: i and: (i+1).
	  swapped := true
        ]
      ].
      swapped
    ] whileTrue: [ ].
    ^ self
  ]
].


extension Collection where Element: Comparable {
  public func cocktailSorted() -> [Element] {
    var swapped = false
    var ret = Array(self)

    guard count > 1 else {
      return ret
    }

    repeat {
      for i in 0...ret.count-2 where ret[i] > ret[i + 1] {
        (ret[i], ret[i + 1]) = (ret[i + 1], ret[i])
        swapped = true
      }

      guard swapped else {
        break
      }

      swapped = false

      for i in stride(from: ret.count - 2, through: 0, by: -1) where ret[i] > ret[i + 1] {
        (ret[i], ret[i + 1]) = (ret[i + 1], ret[i])
        swapped = true
      }
    } while swapped

    return ret
  }
}

let arr = (1...10).shuffled()

print("Before: \(arr)")
print("Cocktail sort: \(arr.cocktailSorted())")


package require Tcl 8.5
package require struct::list

proc cocktailsort {A} {
    set len [llength $A]
    set swapped true
    while {$swapped} {
        set swapped false
        for {set i 0} {$i < $len - 1} {incr i} {
            set j [expr {$i + 1}]
            if {[lindex $A $i] > [lindex $A $j]} {
                struct::list swap A $i $j
                set swapped true
            }
        }
        if { ! $swapped} {
            break
        }
        set swapped false
        for {set i [expr {$len - 2}]} {$i >= 0} {incr i -1} {
            set j [expr {$i + 1}]
            if {[lindex $A $i] > [lindex $A $j]} {
                struct::list swap A $i $j
                set swapped true
            }
        }
    }
    return $A
}


100H:

/* HEAP SORT AN ARRAY OF 16-BIT INTEGERS */
HEAP$SORT: PROCEDURE (AP, COUNT);
    SIFT$DOWN: PROCEDURE (AP, START, ENDV);
        DECLARE (AP, A BASED AP) ADDRESS;
        DECLARE (START, ENDV, ROOT, CHILD, TEMP) ADDRESS;
        ROOT = START;

        DO WHILE (CHILD := SHL(ROOT,1) + 1) <= ENDV;
            IF CHILD + 1 <= ENDV AND A(CHILD) < A(CHILD+1) THEN
                CHILD = CHILD + 1;
            IF A(ROOT) < A(CHILD) THEN DO;
                TEMP = A(ROOT);
                A(ROOT) = A(CHILD);
                A(CHILD) = TEMP;
                ROOT = CHILD;
            END;
            ELSE RETURN;
        END;
    END SIFT$DOWN;

    HEAPIFY: PROCEDURE (AP, COUNT);
        DECLARE (AP, COUNT, START) ADDRESS;
        START = (COUNT-2) / 2;
    LOOP:
        CALL SIFT$DOWN(AP, START, COUNT-1);
        IF START = 0 THEN RETURN;
        START = START - 1;
        GO TO LOOP;
    END HEAPIFY;

    DECLARE (AP, COUNT, ENDV, TEMP, A BASED AP) ADDRESS;

    CALL HEAPIFY(AP, COUNT);
    ENDV = COUNT - 1;
    DO WHILE ENDV > 0;
        TEMP = A(0);
        A(0) = A(ENDV);
        A(ENDV) = TEMP;
        ENDV = ENDV - 1;
        CALL SIFT$DOWN(AP, 0, ENDV);
    END;
END HEAP$SORT;

/* CP/M CALLS AND FUNCTION TO PRINT INTEGERS */
BDOS: PROCEDURE (FN, ARG);
    DECLARE FN BYTE, ARG ADDRESS;
    GO TO 5;
END BDOS;

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

/* SORT AN ARRAY */
DECLARE NUMBERS (11) ADDRESS INITIAL (4, 65, 2, 31, 0, 99, 2, 8, 3, 782, 1);
CALL HEAP$SORT(.NUMBERS, LENGTH(NUMBERS));

/* PRINT THE SORTED ARRAY */
DECLARE N BYTE;
DO N = 0 TO LAST(NUMBERS);
    CALL PRINT$NUMBER(NUMBERS(N));
END;

CALL BDOS(0,0);
EOF


function heapsort($a, $count) {
   $a = heapify $a $count
   $end = $count - 1
   while( $end -gt 0) {
      $a[$end], $a[0] = $a[0], $a[$end]
      $end--
      $a = siftDown $a 0 $end
    }
    $a
}
function heapify($a, $count) {
   $start = [Math]::Floor(($count - 2) / 2)
   while($start -ge 0) {
      $a = siftDown $a $start ($count-1)
      $start--
   }
   $a
}
function siftdown($a, $start, $end) {
   $b, $root = $true, $start
   while(( ($root * 2 + 1) -le $end) -and $b) {
      $child = $root * 2 + 1
      if( ($child + 1 -le $end) -and ($a[$child] -lt $a[$child + 1]) ) {
         $child++
      }
      if($a[$root] -lt $a[$child]) {
        $a[$root], $a[$child] = $a[$child], $a[$root]
        $root = $child
      }
      else { $b = $false}
    }
    $a
}
$array = @(60, 21, 19, 36, 63, 8, 100, 80, 3, 87, 11)
"$(heapsort $array $array.Count)"


var table = [
  <UK  London>,
  <US  New\ York>,
  <US  Birmingham>,
  <UK  Birmingham>,
];

table.sort {|a,b| a[0] <=> b[0]}.each { |col|
    say "#{col[0]} #{col[1]}"
}


import "/sort" for Cmp, Sort

var data = [ ["UK", "London"], ["US", "New York"], ["US", "Birmingham"], ["UK", "Birmingham"] ]

// for sorting by country
var cmp = Fn.new { |p1, p2| Cmp.string.call(p1[0], p2[0]) }

// for sorting by city
var cmp2 = Fn.new { |p1, p2| Cmp.string.call(p1[1], p2[1]) }

System.print("Initial data:")
System.print("  " + data.join("\n  "))

System.print("\nSorted by country:")
var data2 = data.toList
Sort.insertion(data2, cmp)
System.print("  " + data2.join("\n  "))

System.print("\nSorted by city:")
var data3 = data.toList
Sort.insertion(data3, cmp2)
System.print("  " + data3.join("\n  "))


/*REXX program sorts a (stemmed) array using the  merge-sort method. */
/*   using mycmp function for the sort order                         */
/**********************************************************************
* mergesort taken from REXX (adapted for ooRexx (and all other REXXes))
* 28.07.2013 Walter Pachl
**********************************************************************/
  Call gena                        /* generate the array elements.   */
  Call showa 'before sort'         /* show the before array elements.*/
  Call mergeSort highitem          /* invoke the merge sort for array*/
  Call showa ' after sort'         /* show the  after array elements.*/
  Exit                             /* stick a fork in it, we're done.*/
/*---------------------------------GENa subroutine-------------------*/
gena:
  a.=''                            /* assign default value for a stem*/
  a.1='---The seven deadly sins---'/* everybody:  pick your favorite.*/
  a.2='==========================='
  a.3='pride'
  a.4='avarice'
  a.5='wrath'
  a.6='envy'
  a.7='gluttony'
  a.8='sloth'
  a.9='lust'
  Do highitem=1 While a.highitem\=='' /*find number of entries       */
    End
  highitem=highitem-1              /* adjust highitem by -1.         */
  Return
/*---------------------------------MERGETOa subroutine---------------*/
mergetoa: Procedure Expose a. !.
  Parse Arg l,n
  Select
    When n==1 Then
      Nop
    When n==2 Then Do
      h=l+1
      If mycmp(a.l,a.h)=1 Then Do
        _=a.h
        a.h=a.l
        a.l=_
        End
      End
    Otherwise Do
      m=n%2
      Call mergeToa l+m,n-m
      Call mergeTo! l,m,1
      i=1
      j=l+m
      Do k=l While k<j
        If j==l+n|mycmp(!.i,a.j)<>1 Then Do
          a.k=!.i
          i=i+1
          End
        Else Do
          a.k=a.j
          j=j+1
          End
        End
      End
    End
  Return
/*---------------------------------MERGESORT subroutine--------------*/
mergesort: Procedure Expose a.
  Call mergeToa 1,arg(1)
  Return
/*---------------------------------MERGETO! subroutine---------------*/
mergeto!: Procedure Expose a. !.
  Parse Arg l,n,_
  Select
    When n==1 Then
      !._=a.l
    When n==2 Then Do
      h=l+1
      q=1+_
      If mycmp(a.l,a.h)=1 Then Do
        q=_
        _=q+1
        End
      !._=a.l
      !.q=a.h
      Return
      End
    Otherwise Do
      m=n%2
      Call mergeToa l,m
      Call mergeTo! l+m,n-m,m+_
      i=l
      j=m+_
      Do k=_ While k<j
        If j==n+_|mycmp(a.i,!.j)<>1 Then Do
          !.k=a.i
          i=i+1
          End
        Else Do
          !.k=!.j
          j=j+1
          End
        End
      End
    End
  Return
/*---------------------------------SHOWa subroutine------------------*/
showa:
  widthh=length(highitem)           /* maximum the width of any line.*/
  Do j=1 For highitem
    Say 'element' right(j,widthh) arg(1)':' a.j
    End
  Say copies('-',60)                /* show a separator line (fence).*/
  Return

mycmp: Procedure
/**********************************************************************
* shorter string considered higher
* when lengths are equal: caseless 'Z' considered higher than 'X' etc.
* Result:  1  B consider higher than A
*         -1  A consider higher than B
*          0  A==B (caseless)
**********************************************************************/
  Parse Upper Arg A,B
    A=strip(A)
    B=strip(B)
    I = length(A)
    J = length(B)
    Select
      When I << J THEN res=1
      When I >> J THEN res=-1
      When A >> B THEN res=1
      When A << B THEN res=-1
      Otherwise        res=0
      End
    RETURN res


(def n 13)
(sort-by str (range 1 (inc n)))


       identification division.
       program-id. LexicographicalNumbers.

       data division.
       working-storage section.
       78  MAX-NUMBERS            value 21.
       77  i                      pic 9(2).
       77  edited-number          pic z(2).

       01  lex-table.
           05 table-itms occurs MAX-NUMBERS.
              10 number-lex       pic x(2).

       procedure division.
       main.
      *>-> Load numbers
           perform varying i from 1 by 1 until i > MAX-NUMBERS
              move i to edited-number
              move edited-number to number-lex(i)
              call "C$JUSTIFY" using number-lex(i), "Left"
           end-perform

      *>-> Sort in lexicographic order
           sort table-itms ascending number-lex

      *>-> Show ordered numbers
           display "[" no advancing
           perform varying i from 1 by 1 until i > MAX-NUMBERS
              display function trim(number-lex(i)) no advancing
              if i < MAX-NUMBERS
                 display ", " no advancing
              end-if
           end-perform
           display "]"
           stop run
           .


(defun lexicographic-sort (n)
  (sort (alexandria:iota n :start 1) #'string<= :key #'write-to-string))
(lexicographic-sort 13)


PRINT "Cocktail sort:"
  n = FUNC (_InitArray)
  PROC _ShowArray (n)
  PROC _Cocktailsort (n)
  PROC _ShowArray (n)
PRINT

END

_Cocktailsort PARAM (1)                ' Cocktail sort
  LOCAL (2)
  [email protected] = 0

  DO WHILE [email protected] = 0
    [email protected] = 1
    FOR [email protected]=1 TO [email protected]
      IF @([email protected]) < @([email protected]) THEN PROC _Swap ([email protected], [email protected]) : [email protected] = 0
    NEXT
  UNTIL [email protected]
    [email protected] = 1
    FOR [email protected][email protected] TO 1 STEP -1
      IF @([email protected]) < @([email protected]) THEN PROC _Swap ([email protected], [email protected]) : [email protected] = 0
    NEXT
  LOOP
RETURN

_Swap PARAM(2)                         ' Swap two array elements
  PUSH @([email protected])
  @([email protected]) = @([email protected])
  @([email protected]) = POP()
RETURN

_InitArray                             ' Init example array
  PUSH 4, 65, 2, -31, 0, 99, 2, 83, 782, 1

  FOR i = 0 TO 9
    @(i) = POP()
  NEXT

RETURN (i)

_ShowArray PARAM (1)                   ' Show array subroutine
  FOR i = 0 TO [email protected]
    PRINT @(i),
  NEXT

  PRINT
RETURN


Declare heapify(Array a(1), count)
Declare siftDown(Array a(1), start, ending)

Procedure heapSort(Array a(1), count)
  Protected ending=count-1
  heapify(a(), count)
  While ending>0
    Swap a(ending),a(0)
    siftDown(a(), 0, ending-1)
    ending-1
  Wend
EndProcedure

Procedure heapify(Array a(1), count)
  Protected start=(count-2)/2
  While start>=0
    siftDown(a(),start,count-1)
    start-1
  Wend
EndProcedure

Procedure siftDown(Array a(1), start, ending)
  Protected root=start, child
  While (root*2+1)<=ending
    child=root*2+1
    If child+1<=ending And a(child)<a(child+1)
      child+1
    EndIf
    If a(root)<a(child)
      Swap a(root), a(child)
      root=child
    Else
      Break
    EndIf
  Wend
EndProcedure


load "stdlib.ring"

sList = newlist(8, 2)
aList = ["Here", "are", "some", "sample", "strings", "to", "be", "sorted"]
ind = len(aList)

for n = 1 to ind
    sList[n] [1] = aList[n]
    sList[n] [2] = len(aList[n])
next

nList = sortFirstSecond(sList, 2)
oList = newlist(8, 2)
count = 0

for n = len(nList) to 1 step -1
    count = count + 1
    oList[count] [1] = nList[n] [1]
    oList[count] [2] = nList[n] [2]
next

for n = 1 to len(oList) - 1
    temp1 = oList[n] [1]
    temp2 = oList[n+1] [1]
    if (oList[n] [2] = oList[n+1] [2]) and (strcmp(temp1, temp2) > 0)
       temp = oList[n] [1]
       oList[n] [1] = oList[n+1] [1]
       oList[n+1] [1] = temp
    ok
next

for n = 1 to len(oList)
    see oList[n] [1] + nl
next


words = %w(Here are some sample strings to be sorted)
p words.sort_by {|word| [-word.size, word.downcase]}


fn main() {
    let mut words = ["Here", "are", "some", "sample", "strings", "to", "be", "sorted"];
    words.sort_by(|l, r| Ord::cmp(&r.len(), &l.len()).then(Ord::cmp(l, r)));
    println!("{:?}", words);
}


class MAIN is

  custom_comp(a, b:STR):BOOL is
    l ::= a.length - b.length;
    if l = 0 then return a.lower < b.lower; end;
    return l > 0;
  end;

  main is
    s:ARRAY{STR} := |"this", "is", "an", "array", "of", "strings", "to", "sort"|;

    s.insertion_sort_by(bind(custom_comp(_,_)));
    loop #OUT + s.elt! + "\n"; end;
  end;
end;


List("Here", "are", "some", "sample", "strings", "to", "be", "sorted").sortWith{(a,b) =>
  val cmp=a.size-b.size
  (if (cmp==0) -a.compareTo(b) else cmp) > 0
}