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

' sort from lower bound to the higher bound
' array's can have subscript range from -2147483648 to +2147483647

Sub siftdown(hs() As Long, start As ULong, end_ As ULong)
    Dim As ULong root = start
    Dim As Long lb = LBound(hs)

    While root * 2 + 1 <= end_
        Dim As ULong child = root * 2 + 1
        If (child + 1 <= end_) AndAlso (hs(lb + child) < hs(lb + child + 1)) Then
            child = child + 1
        End If
        If hs(lb + root) < hs(lb + child) Then
            Swap hs(lb + root), hs(lb + child)
            root = child
        Else
            Return
        End If
    Wend
End Sub

Sub heapsort(hs() As Long)
    Dim As Long lb = LBound(hs)
    Dim As ULong count = UBound(hs) - lb + 1
    Dim As Long start = (count - 2) \ 2
    Dim As ULong end_ = count - 1

    While start >= 0
        siftdown(hs(), start, end_)
        start = start - 1
    Wend

    While end_ > 0
        Swap hs(lb + end_), hs(lb)
        end_ = end_ - 1
        siftdown(hs(), 0, end_)
    Wend
End Sub

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

Dim As Long array(-7 To 7)
Dim As Long i, lb = LBound(array), ub = UBound(array)

Randomize Timer
For i = lb To ub : array(i) = i : Next
For i = lb To ub
    Swap array(i), array(Int(Rnd * (ub - lb + 1)) + lb)
Next

Print "Unsorted"
For i = lb To ub
    Print Using " ###"; array(i);
Next : Print : Print

heapsort(array())

Print "After heapsort"
For i = lb To ub
    Print Using " ###"; array(i);
Next : Print

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


open System

let removeEmptyLists lists = lists |> List.filter (not << List.isEmpty)
let flip f x y = f y x

let rec transpose = function
    | []    -> []
    | lists -> (List.map List.head lists) :: transpose(removeEmptyLists (List.map List.tail lists))

// Using the backward composition operator "<<" (equivalent to Haskells ".") ...
let beadSort = List.map List.sum << transpose << transpose << List.map (flip List.replicate 1)

// Using the forward composition operator ">>" ...
let beadSort2 = List.map (flip List.replicate 1) >> transpose >> transpose >> List.map List.sum


USING: kernel math math.order math.vectors sequences ;
: fill ( seq len -- newseq ) [ dup length ] dip swap - 0 <repetition> append ;

: bead ( seq -- newseq )
dup 0 [ max ] reduce
[ swap 1 <repetition> swap fill ] curry map
[ ] [ v+ ] map-reduce ;

: beadsort ( seq -- newseq ) bead bead ;


program BeadSortTest
  use iso_fortran_env
  ! for ERROR_UNIT; to make this a F95 code,
  ! remove prev. line and declare ERROR_UNIT as an
  ! integer parameter matching the unit associated with
  ! standard error

  integer, dimension(7) :: a = (/ 7, 3, 5, 1, 2, 1, 20 /)

  call beadsort(a)
  print *, a

contains

  subroutine beadsort(a)
    integer, dimension(:), intent(inout) :: a

    integer, dimension(maxval(a), maxval(a)) :: t
    integer, dimension(maxval(a)) :: s
    integer :: i, m

    m = maxval(a)

    if ( any(a < 0) ) then
       write(ERROR_UNIT,*) "can't sort"
       return
    end if

    t = 0
    forall(i=1:size(a)) t(i, 1:a(i)) = 1  ! set up abacus
    forall(i=1:m)             ! let beads "fall"; instead of
       s(i) = sum(t(:, i))    ! moving them one by one, we just
       t(:, i) = 0            ! count how many should be at bottom,
       t(1:s(i), i) = 1       ! and then "reset" and set only those
    end forall

    forall(i=1:size(a)) a(i) = sum(t(i,:))

  end subroutine beadsort

end program BeadSortTest


use framework "Foundation"

-- SORTING LISTS OF ATOMIC (NON-RECORD) DATA WITH A CUSTOM SORT FUNCTION

-- In sortBy, f is a function from () to a tuple of two parts:
-- 1. a function from any value to a record derived from (and containing) that value
--  The base value should be present in the record under the key 'value'
--  additional derivative keys (and optionally the 'value' key) should be included in 2:
-- 2. a list of (record key, boolean) tuples, in the order of sort comparison,
--    where the value *true* selects ascending order for the paired key
--    and the value *false* selects descending order for that key

-- sortBy :: (() -> ((a -> Record), [(String, Bool)])) -> [a] -> [a]
on sortBy(f, xs)
    set {fn, keyBools} to mReturn(f)'s |λ|()
    script unWrap
        on |λ|(x)
            value of x
        end |λ|
    end script
    map(unWrap, sortByComparing(keyBools, map(fn, xs)))
end sortBy

-- SORTING APPLESCRIPT RECORDS BY PRIMARY AND N-ARY SORT KEYS

-- sortByComparing :: [(String, Bool)] -> [Records] -> [Records]
on sortByComparing(keyDirections, xs)
    set ca to current application

    script recDict
        on |λ|(x)
            ca's NSDictionary's dictionaryWithDictionary:x
        end |λ|
    end script
    set dcts to map(recDict, xs)

    script asDescriptor
        on |λ|(kd)
            set {k, d} to kd
            ca's NSSortDescriptor's sortDescriptorWithKey:k ascending:d selector:dcts
        end |λ|
    end script

    ((ca's NSArray's arrayWithArray:dcts)'s ¬
        sortedArrayUsingDescriptors:map(asDescriptor, keyDirections)) as list
end sortByComparing

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

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

-- TEST ----------------------------------------------------------------------
on run
    set xs to ["Shanghai", "Karachi", "Beijing", "Sao Paulo", "Dhaka", "Delhi", "Lagos"]

    -- Custom comparator:

    -- Returns a lifting function and a sequence of {key, bool} pairs

    -- Strings in order of descending length,
    -- and ascending lexicographic order
    script lengthDownAZup
        on |λ|()
            script
                on |λ|(x)
                    {value:x, n:length of x}
                end |λ|
            end script
            {result, {{"n", false}, {"value", true}}}
        end |λ|
    end script

    sortBy(lengthDownAZup, xs)
end run


numbers = 5,3,7,9,1,13,999,-4
strings = Here,are,some,sample,strings,to,be,sorted
Sort, numbers, F IntegerSort D,
Sort, strings, F StringLengthSort D,
msgbox % numbers
msgbox % strings

IntegerSort(a1, a2) {
return a2 - a1
}

StringLengthSort(a1, a2){
return strlen(a1) - strlen(a2)
}


cocktailSort :: Ord a => [a] -> [a]
cocktailSort l
  | not swapped1 = l
  | not swapped2 = reverse $ l1
  | otherwise    = cocktailSort l2
  where (swapped1, l1) = swappingPass (>) (False, []) l
        (swapped2, l2) = swappingPass (<) (False, []) l1

        swappingPass :: Ord a => (a -> a -> Bool) -> (Bool, [a]) -> [a] -> (Bool, [a])
        swappingPass op (swapped, l) (x1 : x2 : xs)
          | op x1 x2  = swappingPass op (True,    x2 : l) (x1 : xs)
          | otherwise = swappingPass op (swapped, x1 : l) (x2 : xs)
        swappingPass _  (swapped, l) [x] = (swapped, x : l)
        swappingPass _  pair         []  = pair


#!/bin/ksh

# cocktail shaker sort

#	# Variables:
#
integer TRUE=1
integer FALSE=0
typeset -a arr=( 5 -1 101 -4 0 1 8 6 2 3 )

#	# Functions:
#
function _swap {
	typeset _i ; integer _i=$1
	typeset _j ; integer _j=$2
	typeset _array ; nameref _array="$3"
	typeset _swapped ; nameref _swapped=$4

	typeset _tmp ; _tmp=${_array[_i]}
	_array[_i]=${_array[_j]}
	_array[_j]=${_tmp}
	_swapped=$TRUE
}

 ######
# main #
 ######

print "( ${arr[*]} )"

integer i j
integer swapped=$TRUE
while (( swapped )); do
	swapped=$FALSE
	for (( i=0 ; i<${#arr[*]}-2 ; i++ , j=i+1 )); do
		(( arr[i] > arr[j] )) && _swap ${i} ${j} arr swapped
	done
	(( ! swapped )) && break

	swapped=$FALSE
	for (( i=${#arr[*]}-2 ; i>0 ; i-- , j=i+1 )); do
		(( arr[i] > arr[j] )) && _swap ${i} ${j} arr swapped
	done
done

print "( ${arr[*]} )"


def heapSort( a ) =
  heapify( a )
  end = a.length() - 1

  while end > 0
    a(end), a(0) = a(0), a(end)
    siftDown( a, 0, --end )

def heapify( a ) =
  for i <- (a.length() - 2)\2..0 by -1
    siftDown( a, i, a.length() - 1 )

def siftDown( a, start, end ) =
  root = start

  while root*2 + 1 <= end
    child = root*2 + 1

    if child + 1 <= end and a(child) < a(child + 1)
      child++

    if a(root) < a(child)
      a(root), a(child) = a(child), a(root)
      root = child
    else
      break

a = array( [7, 2, 6, 1, 9, 5, 0, 3, 8, 4] )
heapSort( a )
println( a )


package main

import (
  "sort"
  "container/heap"
  "fmt"
)

type HeapHelper struct {
    container sort.Interface
    length    int
}

func (self HeapHelper) Len() int { return self.length }
// We want a max-heap, hence reverse the comparison
func (self HeapHelper) Less(i, j int) bool { return self.container.Less(j, i) }
func (self HeapHelper) Swap(i, j int) { self.container.Swap(i, j) }
// this should not be called
func (self *HeapHelper) Push(x interface{}) { panic("impossible") }
func (self *HeapHelper) Pop() interface{} {
    self.length--
    return nil // return value not used
}

func heapSort(a sort.Interface) {
    helper := HeapHelper{ a, a.Len() }
    heap.Init(&helper)
    for helper.length > 0 {
        heap.Pop(&helper)
    }
}

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


#define MAXNUM 100

Sub beadSort(bs() As Long)
    Dim As Long i, j = 1, lb = Lbound(bs), ub = Ubound(bs)
    Dim As Long poles(MAXNUM)

    For i = 1 To ub
        For j = 1 To bs(i)
            poles(j) += 1
        Next j
    Next i
    For j = 1 To ub
        bs(j) = 0
    Next j
    For i = 1 To Ubound(poles)
        For j = 1 To poles(i)
            bs(j) += 1
        Next j
    Next i
End Sub

'--- Programa Principal ---
Dim As Long i
Dim As Ulong array(1 To 8) => {5, 3, 1, 7, 4, 1, 1, 20}
Dim As Long a = Lbound(array), b = Ubound(array)

Randomize Timer

Print "unsort ";
For i = a To b : Print Using "####"; array(i); : Next i

beadSort(array())

Print !"\n  sort ";
For i = a To b : Print Using "####"; array(i); : Next i

Print !"\n--- terminado, pulsa RETURN---"
Sleep


package main

import (
    "fmt"
    "sync"
)

var a = []int{170, 45, 75, 90, 802, 24, 2, 66}
var aMax = 1000

const bead = 'o'

func main() {
    fmt.Println("before:", a)
    beadSort()
    fmt.Println("after: ", a)
}

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


# syntax: GAWK -f SORT_USING_A_CUSTOM_COMPARATOR.AWK
#
# sorting:
#   PROCINFO["sorted_in"] is used by GAWK
#   SORTTYPE is used by Thompson Automation's TAWK
#
BEGIN {
    words = "This Is A Set Of Strings To Sort duplicated"
    n = split(words " " tolower(words),tmp_arr," ")
    print("unsorted:")
    for (i=1; i<=n; i++) {
      word = tmp_arr[i]
      arr[length(word)][word]++
      print(word)
    }
    print("\nsorted:")
    PROCINFO["sorted_in"] = "@ind_num_desc" ; SORTTYPE = 9
    for (i in arr) {
      PROCINFO["sorted_in"] = "caselessCompare" ; SORTTYPE = 2 # possibly 14?
      for (j in arr[i]) {
        for (k=1; k<=arr[i][j]; k++) {
          print(j)
        }
      }
    }
    exit(0)
}
function caselessCompare( i1, v1, i2, v2,        l1, l2, result )
{
    l1 = tolower( i1 );
    l2 = tolower( i2 );
return ( ( l1 < l2 ) ? -1 : ( ( l1 == l2 ) ? 0 : 1 ) );
} # caselessCompare


babel> ("Here" "are" "some" "sample" "strings" "to" "be" "sorted") strsort ! lsstr !
( "Here" "are" "be" "sample" "some" "sorted" "strings" "to" )
babel> ("Here" "are" "some" "sample" "strings" "to" "be" "sorted") lexsort ! lsstr !
( "be" "to" "are" "Here" "some" "sample" "sorted" "strings" )


class CocktailSort {
  @:generic
  public static function sort<T>(arr:Array<T>) {
    var swapped = false;
    do {
      swapped = false;
      for (i in 0...(arr.length - 1)) {
        if (Reflect.compare(arr[i], arr[i + 1]) > 0) {
          var temp = arr[i];
          arr[i] = arr[i + 1];
          arr[i + 1] = temp;
          swapped = true;
        }
      }
      if (!swapped) break;
      swapped = false;
      var i = arr.length - 2;
      while (i >= 0) {
        if (Reflect.compare(arr[i], arr[i + 1]) > 0) {
          var temp = arr[i];
          arr[i] = arr[i + 1];
          arr[i + 1] = temp;
          swapped = true;
        }
        i--;
      }
    } while (swapped);
  }
}

class Main {
  static function main() {
    var integerArray = [1, 10, 2, 5, -1, 5, -19, 4, 23, 0];
    var floatArray = [1.0, -3.2, 5.2, 10.8, -5.7, 7.3,
                      3.5, 0.0, -4.1, -9.5];
    var stringArray = ['We', 'hold', 'these', 'truths', 'to',
                       'be', 'self-evident', 'that', 'all',
                       'men', 'are', 'created', 'equal'];
    Sys.println('Unsorted Integers: ' + integerArray);
    CocktailSort.sort(integerArray);
    Sys.println('Sorted Integers:   ' + integerArray);
    Sys.println('Unsorted Floats:   ' + floatArray);
    CocktailSort.sort(floatArray);
    Sys.println('Sorted Floats:     ' + floatArray);
    Sys.println('Unsorted Strings:  ' + stringArray);
    CocktailSort.sort(stringArray);
    Sys.println('Sorted Strings:    ' + stringArray);
  }
}


procedure main()                     #: demonstrate various ways to sort a list and string
   demosort(cocktailsort,[3, 14, 1, 5, 9, 2, 6, 3],"qwerty")
end

procedure cocktailsort(X,op)          #: return sorted list
local i,swapped

   op := sortop(op,X)                 # select how and what we sort

   swapped := 1
   repeat                             # translation of pseudo code.  Contractions used to eliminate second loop.
      every (if /swapped then break break else swapped := &null & next) | ( i := 1 to *X-1) |
            (if /swapped then break break else swapped := &null & next) | ( i := *X-1 to 1 by -1) do
         if op(X[i+1],X[i]) then
            X[i+1] :=: X[swapped := i]
   return X
end


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

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

def siftDown = { a, start, end ->
    def p = start
    while (p*2 < end) {
        def c = p*2 + ((p*2 + 1 < end && a[p*2 + 2] > a[p*2 + 1]) ? 2 : 1)
        if (checkSwap(a, c, p)) { p = c }
        else                    { return }
    }
}

def heapify = {
    (((it.size()-2).intdiv(2))..0).each { start -> siftDown(it, start, it.size()-1) }
}

def heapSort = { list ->
    heapify(list)
    (0..<(list.size())).reverse().each { end ->
        makeSwap(list, 0, end)
        siftDown(list, 0, end-1)
    }
    list
}


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


import Data.List

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


procedure main()                     #: demonstrate various ways to sort a list and string
   write("Sorting Demo using ",image(beadsort))
      writes("  on list : ")
      writex(UL := [3, 14, 1, 5, 9, 2, 6, 3])
      displaysort(beadsort,copy(UL))
end

procedure beadsort(X)                           #: return sorted list ascending(or descending)
local base,i,j,x                                # handles negatives and zeros, may also reduce storage

   poles := list(max!X-(base := min!X -1),0)    # set up poles, we will track sums not individual beads
   every x := !X do {                           # each item in the list
      if integer(x) ~= x then runerr(101,x)     # ... must be an integer
      every poles[1 to x - base] +:= 1          # ... beads "fall" into the sum for that pole
      }

   every (X[j := *X to 1 by -1] := base) &
        (i := 1 to *poles) do                   # read from the bottom of the poles
     if poles[i] > 0 then {                     # if there's a bead on the pole ...
        poles[i] -:= 1                          # ... remove it
	    X[j] +:= 1                          # ... and add it in place
     }
   return X
end


blsq ) {"acb"  "Abc" "Acb" "acc" "ADD"}><
{"ADD" "Abc" "Acb" "acb" "acc"}
blsq ) {"acb"  "Abc" "Acb" "acc" "ADD"}(zz)CMsb
{"Abc" "acb" "Acb" "acc" "ADD"}


#include <stdlib.h>  /* for qsort */
#include <string.h>  /* for strlen */
#include <strings.h> /* for strcasecmp */

int mycmp(const void *s1, const void *s2)
{
    const char *l = *(const char **)s1, *r = *(const char **)s2;
    size_t ll = strlen(l), lr = strlen(r);

    if (ll > lr) return -1;
    if (ll < lr) return 1;
    return strcasecmp(l, r);
}

int main()
{
    const char *strings[] = {
      "Here", "are", "some", "sample", "strings", "to", "be", "sorted" };

    qsort(strings, sizeof(strings)/sizeof(*strings), sizeof(*strings), mycmp);
    return 0;
}


using System;
using System.Collections.Generic;

namespace RosettaCode {
    class SortCustomComparator {
        // Driver program
        public void CustomSort() {
            String[] items = { "Here", "are", "some", "sample", "strings", "to", "be", "sorted" };
            List<String> list = new List<string>(items);

            DisplayList("Unsorted", list);

            list.Sort(CustomCompare);
            DisplayList("Descending Length", list);

            list.Sort();
            DisplayList("Ascending order", list);
        }

        // Custom compare
        public int CustomCompare(String x, String y) {
            int result = -x.Length.CompareTo(y.Length);
            if (result == 0) {
                result = x.ToLower().CompareTo(y.ToLower());
            }

            return result;
        }

        // Output routine
        public void DisplayList(String header, List<String> theList) {
            Console.WriteLine(header);
            Console.WriteLine("".PadLeft(header.Length, '*'));
            foreach (String str in theList) {
                Console.WriteLine(str);
            }
            Console.WriteLine();
        }
    }
}


List do (
    cocktailSortInPlace := method(
        start := 0
        end := size - 2

        loop(
            swapped := false

            for(idx, start, end,
                if(at(idx) > at(idx + 1),
                    swapped := true
                    swapIndices(idx, idx + 1)
                )
            )

            if(swapped not, break, end := end - 1)

            for (idx, end, start, -1,
                if(at(idx) > at(idx + 1),
                    swapped := true
                    swapIndices(idx, idx + 1)
                )
            )

            if(swapped not, break, start := start + 1)
        )
    self)
)

l := list(2, 3, 4, 5, 1)
l cocktailSortInPlace println # ==> list(1, 2, 3, 4, 5)


100 PROGRAM "CocktSrt.bas"
110 RANDOMIZE
120 NUMERIC ARRAY(5 TO 24)
130 CALL INIT(ARRAY)
140 CALL WRITE(ARRAY)
150 CALL COCKTAILSORT(ARRAY)
160 CALL WRITE(ARRAY)
170 DEF INIT(REF A)
180   FOR I=LBOUND(A) TO UBOUND(A)
190     LET A(I)=RND(98)+1
200   NEXT
210 END DEF
220 DEF WRITE(REF A)
230   FOR I=LBOUND(A) TO UBOUND(A)
240     PRINT A(I);
250   NEXT
260   PRINT
270 END DEF
280 DEF COCKTAILSORT(REF A)
290   LET ST=LBOUND(A)+1:LET EN=UBOUND(A):LET D,CH=1
300   DO
310     FOR J=ST TO EN STEP D
320       IF A(J-1)>A(J) THEN LET T=A(J-1):LET A(J-1)=A(J):LET A(J)=T:LET CH=J
330     NEXT
340     LET EN=ST:LET ST=CH-D:LET D=-1*D
350   LOOP UNTIL EN*D<ST*D
360 END DEF


bigToLeft=: (([ (>. , <.) {[email protected]]) , }[email protected]])/
smallToLeft=: (([ (<. , >.) {[email protected]]) , }[email protected]])/
cocktailSort=: |. @: (|. @: smallToLeft @: |. @: bigToLeft ^:_)


import Data.Graph.Inductive.Internal.Heap(
  Heap(..),insert,findMin,deleteMin)

-- heapsort is added in this module as an example application

build :: Ord a => [(a,b)] -> Heap a b
build = foldr insert Empty

toList :: Ord a => Heap a b -> [(a,b)]
toList Empty = []
toList h = x:toList r
           where (x,r) = (findMin h,deleteMin h)

heapsort :: Ord a => [a] -> [a]
heapsort = (map fst) . toList . build . map (\x->(x,x))


class HeapSort {
  @:generic
  private static function siftDown<T>(arr: Array<T>, start:Int, end:Int) {
    var root = start;
    while (root * 2 + 1 <= end) {
      var child = root * 2 + 1;
      if (child + 1 <= end && Reflect.compare(arr[child], arr[child + 1]) < 0)
        child++;
      if (Reflect.compare(arr[root], arr[child]) < 0) {
        var temp = arr[root];
        arr[root] = arr[child];
        arr[child] = temp;
        root = child;
      } else {
        break;
      }
    }
  }

  @:generic
  public static function sort<T>(arr:Array<T>) {
    if (arr.length > 1)
    {
      var start = (arr.length - 2) >> 1;
      while (start > 0) {
        siftDown(arr, start - 1, arr.length - 1);
        start--;
      }
    }

    var end = arr.length - 1;
    while (end > 0) {
      var temp = arr[end];
      arr[end] = arr[0];
      arr[0] = temp;
      siftDown(arr, 0, end - 1);
      end--;
    }
  }
}

class Main {
  static function main() {
    var integerArray = [1, 10, 2, 5, -1, 5, -19, 4, 23, 0];
    var floatArray = [1.0, -3.2, 5.2, 10.8, -5.7, 7.3,
                      3.5, 0.0, -4.1, -9.5];
    var stringArray = ['We', 'hold', 'these', 'truths', 'to',
                       'be', 'self-evident', 'that', 'all',
                       'men', 'are', 'created', 'equal'];
    Sys.println('Unsorted Integers: ' + integerArray);
    HeapSort.sort(integerArray);
    Sys.println('Sorted Integers:   ' + integerArray);
    Sys.println('Unsorted Floats:   ' + floatArray);
    HeapSort.sort(floatArray);
    Sys.println('Sorted Floats:     ' + floatArray);
    Sys.println('Unsorted Strings:  ' + stringArray);
    HeapSort.sort(stringArray);
    Sys.println('Sorted Strings:    ' + stringArray);
  }
}


public class BeadSort
{
	public static void main(String[] args)
	{
		BeadSort now=new BeadSort();
		int[] arr=new int[(int)(Math.random()*11)+5];
		for(int i=0;i<arr.length;i++)
			arr[i]=(int)(Math.random()*10);
		System.out.print("Unsorted: ");
		now.display1D(arr);

		int[] sort=now.beadSort(arr);
		System.out.print("Sorted: ");
		now.display1D(sort);
	}
	int[] beadSort(int[] arr)
	{
		int max=a[0];
		for(int i=1;i<arr.length;i++)
			if(arr[i]>max)
				max=arr[i];

		//Set up abacus
		char[][] grid=new char[arr.length][max];
		int[] levelcount=new int[max];
		for(int i=0;i<max;i++)
		{
			levelcount[i]=0;
			for(int j=0;j<arr.length;j++)
				grid[j][i]='_';
		}
		/*
		display1D(arr);
		display1D(levelcount);
		display2D(grid);
		*/

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

		return sorted;
	}
	void display1D(int[] arr)
	{
		for(int i=0;i<arr.length;i++)
			System.out.print(arr[i]+" ");
		System.out.println();
	}
	void display1D(char[] arr)
	{
		for(int i=0;i<arr.length;i++)
			System.out.print(arr[i]+" ");
		System.out.println();
	}
	void display2D(char[][] arr)
	{
		for(int i=0;i<arr.length;i++)
			display1D(arr[i]);
		System.out.println();
	}
}


#include <algorithm>
#include <string>
#include <cctype>

// compare character case-insensitive
struct icompare_char {
  bool operator()(char c1, char c2) {
    return std::toupper(c1) < std::toupper(c2);
  }
};

// return true if s1 comes before s2
struct compare {
  bool operator()(std::string const& s1, std::string const& s2) {
    if (s1.length() > s2.length())
      return true;
    if (s1.length() < s2.length())
      return false;
    return std::lexicographical_compare(s1.begin(), s1.end(),
                                        s2.begin(), s2.end(),
                                        icompare_char());
  }
};

int main() {
  std::string strings[8] = {"Here", "are", "some", "sample", "strings", "to", "be", "sorted"};
  std::sort(strings, strings+8, compare());
  return 0;
}


shared void run() {

	value strings = [
		"Cat", "apple", "Adam", "zero", "Xmas", "quit",
		"Level", "add", "Actor", "base", "butter"
	];

	value sorted = strings.sort((String x, String y) =>
			if(x.size == y.size)
			then increasing(x.lowercased, y.lowercased)
			else decreasing(x.size, y.size));

	sorted.each(print);
}


import StdEnv

less s1 s2
    | size s1 > size s2 = True
    | size s1 < size s2 = False
    | otherwise = lower s1 < lower s2
where
    lower :: String -> String
    lower s = {toLower c \\ c <-: s}

Start = sortBy less ["This", "is", "a", "set", "of", "strings", "to", "sort"]


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


  // Node 5.4.1 tested implementation (ES6)
"use strict";

let arr = [4, 9, 0, 3, 1, 5];
let isSorted = true;
while (isSorted){
    for (let i = 0; i< arr.length - 1;i++){
            if (arr[i] > arr[i + 1])
             {
                let temp = arr[i];
                arr[i] = arr[i + 1];
                arr[i+1] = temp;
                isSorted = true;
             }
    }

    if (!isSorted)
        break;

    isSorted = false;

    for (let j = arr.length - 1; j > 0; j--){
            if (arr[j-1] > arr[j])
             {
                let temp = arr[j];
                arr[j] = arr[j - 1];
                arr[j - 1] = temp;
                isSorted = true;
             }
    }
}
console.log(arr);

}


procedure main()                     #: demonstrate various ways to sort a list and string
   demosort(heapsort,[3, 14, 1, 5, 9, 2, 6, 3],"qwerty")
end

procedure heapsort(X,op)                            #: return sorted list ascending(or descending)
local head,tail

   op := sortop(op,X)                               # select how and what we sort

   every head := (tail := *X) / 2  to 1 by -1 do    # work back from from last parent node
      X := siftdown(X,op,head,tail)                 # sift down from head to make the heap

   every tail := *X to 2 by -1 do {                 # work between the beginning and the tail to final positions
      X[1] :=: X[tail]
      X := siftdown(X,op,1,tail-1)                  # re-sift next (previous) branch after shortening the heap
      }

   return X
end

procedure siftdown(X,op,root,tail)                  #: the value @root is moved "down" the path of max(min) value to its level
local child

   while (child :=  root * 2) <= tail do {          # move down the branch from root to tail

      if op(X[child],X[tail >= child + 1]) then     # choose the larger(smaller)
         child +:= 1                                # ... child

      if op(X[root],X[child]) then  {               # root out of order?
         X[child] :=: X[root]
         root := child                              # follow max(min) branch
         }
      else
         return X
      }
   return X
end


# ncols is the number of columns (i.e. vertical poles)
def column_sums(ncols):
  . as $abacus
  | reduce range(0; ncols) as $col
    ([];
     . + [reduce $abacus[] as $row
           (0; if $row > $col then .+1 else . end)]) ;


function beadsort(a::Vector{<:Integer})
    lo, hi = extrema(a)
    if lo < 1 throw(DomainError()) end
    len = length(a)
    abacus = falses(len, hi)
    for (i, v) in enumerate(a)
       abacus[i, 1:v] = true
    end
    for i in 1:hi
        v = sum(abacus[:, i])
        if v < len
            abacus[1:end-v, i] = false
            abacus[end-v+1:end, i] = true
        end
    end
    return collect(eltype(a), sum(abacus[i,:]) for i in 1:len)
end

v = rand(UInt8, 20)
println("# unsorted bytes: $v\n -> sorted bytes: $(beadsort(v))")
v = rand(1:2 ^ 10, 20)
println("# unsorted integers: $v\n -> sorted integers: $(beadsort(v))")


// version 1.1.2

fun beadSort(a: IntArray) {
    val n = a.size
    if (n < 2) return
    var max = a.max()!!
    val beads = ByteArray(max * n)
    /* mark the beads */
    for (i in 0 until n)
        for (j in 0 until a[i])
            beads[i * max + j] = 1

    for (j in 0 until max) {
        /* count how many beads are on each post */
        var sum = 0
        for (i in 0 until n) {
            sum += beads[i * max + j]
            beads[i * max + j] = 0
        }
        /* mark bottom sum beads */
        for (i in n - sum until n) beads[i * max + j] = 1
    }

    for (i in 0 until n) {
        var j = 0
        while (j < max && beads[i * max + j] == 1.toByte()) j++
        a[i] = j
    }
}

fun main(args: Array<String>) {
    val a  = intArrayOf(5, 3, 1, 7, 4, 1, 1, 20)
    println("Before sorting : ${a.contentToString()}")
    beadSort(a)
    println("After sorting  : ${a.contentToString()}")
}


(defn rosetta-compare [s1 s2]
  (let [len1 (count s1), len2 (count s2)]
    (if (= len1 len2)
      (compare (.toLowerCase s1) (.toLowerCase s2))
      (- len2 len1))))

(println
 (sort rosetta-compare
       ["Here" "are" "some" "sample" "strings" "to" "be" "sorted"]))


CL-USER> (defvar *strings*
                 (list "Cat" "apple" "Adam" "zero" "Xmas" "quit" "Level" "add" "Actor" "base" "butter"))
*STRINGS*
CL-USER> (sort *strings* #'string-lessp)
("Actor" "Adam" "add" "apple" "base" "butter" "Cat" "Level" "quit" "Xmas"
"zero")


# In case your jq does not have "until" defined:
def until(cond; next):
  def _until:
    if cond then . else (next|_until) end;
  _until;


function cocktailsort(a::Vector)
    b = copy(a)
    isordered = false
    lo, hi = 1, length(b)
    while !isordered && hi > lo
        isordered = true
        for i in lo+1:hi
            if b[i] < b[i-1]
                b[i-1], b[i] = b[i], b[i-1]
                isordered = false
            end
        end
        hi -= 1
        if isordered || hi ≤ lo break end
        for i in hi:-1:lo+1
            if b[i-1] > b[i]
                b[i-1], b[i] = b[i], b[i-1]
                isordered = false
            end
        end
        lo += 1
    end
    return b
end

v = rand(-10:10, 10)
println("# unordered: $v\n -> ordered: ", cocktailsort(v))


// version 1.1.0

fun cocktailSort(a: IntArray) {
    fun swap(i: Int, j: Int) {
        val temp = a[i]
        a[i] = a[j]
        a[j] = temp
    }
    do {
        var swapped = false
        for (i in 0 until a.size - 1)
            if (a[i] > a[i + 1]) {
                swap(i, i + 1)
                swapped = true
            }
        if (!swapped) break
        swapped = false
        for (i in a.size - 2 downTo 0)
            if (a[i] > a[i + 1]) {
                swap(i, i + 1)
                swapped = true
            }
    }
    while (swapped)
}

fun main(args: Array<String>) {
   val aa = arrayOf(
        intArrayOf(100, 2, 56, 200, -52, 3, 99, 33, 177, -199),
        intArrayOf(4, 65, 2, -31, 0, 99, 2, 83, 782, 1),
        intArrayOf(62, 83, 18, 53, 7, 17, 95, 86, 47, 69, 25, 28)
    )
    for (a in aa) {
        cocktailSort(a)
        println(a.joinToString(", "))
    }
}


swap=: C.~ <

siftDown=: 4 : 0
  'c e'=. x
  while. e > c=.1+2*s=.c do.
    before=. <&({&y)
    if. e > 1+c do. c=.c+ c before c+1 end.
    if. s before c do. y=. y swap c,s else. break. end.
  end.
  y
)

heapSort=: 3 : 0
  if. 1>: c=. # y do. y return. end.
  z=. siftDown&.>/ (c,~each i.<.c%2),<y        NB. heapify
  > ([ siftDown swap~)&.>/ (0,each}.i.c),z
)


(defn swap [l a b]
  (let [aval (get l a) bval (get l b)]
    (put l a bval)
    (put l b aval)))

(defn heap-sort [l]
  (def len (length l))
  # Invariant: heap[parent] <= heap[*children]
  (def heap (array/new (+ len 1)))
  (array/push heap nil)
  (def ROOT 1)

  # Returns the parent index of index, or nil if none
  (defn parent [idx]
    (assert (> idx 0))
    (if (= idx 1) nil (math/trunc (/ idx 2))))
  # Returns a tuple [a b] of the two child indices of idx
  (defn children [idx]
    (def a (* idx 2))
    (def b (+ a 1))
    (def l (length heap))
    # NOTE: `if` implicitly returns nil on false
    [(if (< a l) a) (if (< b l) b)])
  (defn check-invariants [idx]
    (def [a b] (children idx))
    (def p (parent idx))
    (assert (or (nil? a) (<= (get heap idx) (get heap a))))
    (assert (or (nil? b) (<= (get heap idx) (get heap b))))
    (assert (or (nil? p) (>= (get heap idx) (get heap p)))))
  (defn swim [idx]
    (def val (get heap idx))
    (def parent-idx (parent idx))
    (when (and (not (nil? parent-idx)) (< val (get heap parent-idx)))
      (swap heap parent-idx idx)
      (swim parent-idx)
    )
    (check-invariants idx))

  (defn sink [idx]
    (def [a b] (children idx))
    (def target-val (get heap idx))
    (def smaller-children @[])
    (defn handle-child [idx]
      (let [child-val (get heap idx)]
        (if (and (not (nil? idx)) (< child-val target-val))
          (array/push smaller-children idx))))
    (handle-child a)
    (handle-child b)
    (assert (<= (length smaller-children) 2))
    (def smallest-child (cond
      (empty? smaller-children) nil
      (= 1 (length smaller-children)) (get smaller-children 0)
      (< (get heap (get smaller-children 0)) (get heap (get smaller-children 1))) (get smaller-children 0)
      # NOTE: The `else` for final branch of `cond` is implicit
      (get smaller-children 1)
    ))
    (unless (nil? smallest-child)
      (swap heap smallest-child idx)
      (sink smallest-child)
      # Recheck invariants
      (check-invariants idx)))

  (defn insert [val]
    (def idx (length heap))
    (array/push heap val)
    (swim idx))

  (defn remove-smallest []
    (assert (> (length heap) 1))
    (def largest (get heap ROOT))
    (def new-root (array/pop heap))
    (when (> (length heap) 1)
      (put heap ROOT new-root)
      (sink ROOT))
    (assert (not (nil? largest)))
    largest)

  (each item l (insert item))

  (def res @[])
  (while (> (length heap) 1)
    (array/push res (remove-smallest)))
  res)

# NOTE: Makes a copy of input array. Output is mutable
(print (heap-sort [7 12 3 9 -1 17 6]))


-- Display message followed by all values of a table in one line
function show (msg, t)
    io.write(msg .. ":\t")
    for _, v in pairs(t) do io.write(v .. " ") end
    print()
end

-- Return a table of random numbers
function randList (length, lo, hi)
    local t = {}
    for i = 1, length do table.insert(t, math.random(lo, hi)) end
    return t
end

-- Count instances of numbers that appear in counting to each list value
function tally (list)
    local tal = {}
    for k, v in pairs(list) do
        for i = 1, v do
            if tal[i] then tal[i] = tal[i] + 1 else tal[i] = 1 end
        end
    end
    return tal
end

-- Sort a table of positive integers into descending order
function beadSort (numList)
    show("Before sort", numList)
    local abacus = tally(numList)
    show("Tally list", abacus)
    local sorted = tally(abacus)
    show("After sort", sorted)
end

-- Main procedure
math.randomseed(os.time())
beadSort(randList(10, 1, 10))


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


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

runSample(arg)
return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method bead_sort(harry = Rexx[]) public static binary returns Rexx[]
  MIN_ = 'MIN'
  MAX_ = 'MAX'
  beads = Rexx 0
  beads[MIN_] = 0
  beads[MAX_] = 0

  loop val over harry
    -- collect occurences of beads in indexed string indexed on value
    if val < beads[MIN_] then beads[MIN_] = val -- keep track of min value
    if val > beads[MAX_] then beads[MAX_] = val -- keep track of max value
    beads[val] = beads[val] + 1
    end val

  harry_sorted = Rexx[harry.length]
  bi = 0
  loop xx = beads[MIN_] to beads[MAX_]
    -- extract beads in value order and insert in result array
    if beads[xx] == 0 then iterate xx
    loop for beads[xx]
      harry_sorted[bi] = xx
      bi = bi + 1
      end
    end xx

  return harry_sorted

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method runSample(arg) public static
  unsorted = [734, 3, 1, 24, 324, -1024, -666, -1, 0, 324, 32, 0, 432, 42, 3, 4, 1, 1]
  sorted = bead_sort(unsorted)
  say arrayToString(unsorted)
  say arrayToString(sorted)
  return
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method arrayToString(harry = Rexx[]) private static
  list = Rexx ''
  loop vv over harry
    list = list vv
    end vv
  return '['list.space(1, ',')']'


import std.stdio, std.string, std.algorithm, std.typecons;

void main() {
    "here are Some sample strings to be sorted"
    .split
    .schwartzSort!q{ tuple(-a.length, a.toUpper) }
    .writeln;
}


program SortWithCustomComparator;

{$APPTYPE CONSOLE}

uses SysUtils, Types, Generics.Collections, Generics.Defaults;

var
  lArray: TStringDynArray;
begin
  lArray := TStringDynArray.Create('Here', 'are', 'some', 'sample', 'strings', 'to', 'be', 'sorted');

  TArray.Sort<string>(lArray , TDelegatedComparer<string>.Construct(
  function(const Left, Right: string): Integer
  begin
    //Returns ('Here', 'are', 'be', 'sample', 'some', 'sorted', 'strings', 'to')
    //Result := CompareStr(Left, Right);

    //Returns ('are', 'be', 'Here', 'sample', 'some', 'sorted', 'strings', 'to')
    Result := CompareText(Left, Right);
  end));
end.


/** returns a if it is nonzero, otherwise b() */
def nonzeroOr(a, b) { return if (a.isZero()) { b() } else { a } }

["Here", "are", "some", "sample", "strings", "to", "be", "sorted"] \
    .sort(fn a, b {
              nonzeroOr(b.size().op__cmp(a.size()),
                        fn { a.compareToIgnoreCase(b) })
          })


function cocktailSort( A )
  local swapped
  repeat
    swapped = false
    for i = 1, #A - 1 do
      if A[ i ] > A[ i+1 ] then
         A[ i ], A[ i+1 ] = A[ i+1 ] ,A[i]
         swapped=true
	   end
    end
    if swapped == false then
      break -- repeatd loop;
	end

     for i = #A - 1,1,-1 do
      if A[ i ] > A[ i+1 ] then
         A[ i ], A[ i+1 ] = A[ i+1 ] , A[ i ]
         swapped=true
	   end
    end

  until swapped==false
end


Module cocktailSort {
	k=(3,2,1)
	print k
	cocktailSort(k)
	print k
	k=("c","b","a")
	print k
	cocktailSortString(k)
	print k
	Dim a(5)
	a(0)=1,2,5,6,3
	print a()
	cocktailSort(a())
	print a()
	End
	Sub cocktailSort(a)
		\\ this is like Link a to a() but using new for a() - shadow any a()
		push &a : read new &a()
		local swapped, lenA2=len(a)-2
		do
			for i=0 to lenA2
			if a(i) > a(i+1) then swap a(i), a(i+1): swapped = true
			next
			if swapped then
				swapped~
				for i=lenA2 to 0
					if a(i) > a(i+1) then swap a(i), a(i+1): swapped = true
				next
			end if
		until not swapped
	End Sub
	Sub cocktailSortString(a)
		push &a : read new &a$()
		local swapped, lenA2=len(a)-2
		do
			for i=0 to lenA2
				if a$(i) > a$(i+1) then
					swap a$(i), a$(i+1)
					swapped = true
				end if
			next
			if swapped then
				swapped~
				for i=lenA2 to 0
					if a$(i) > a$(i+1) then
						swap a$(i), a$(i+1)
						swapped = true
					end if
				next
			end if
		until not swapped

	End Sub
}
cocktailSort


public static void heapSort(int[] a){
	int count = a.length;

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

	int end = count - 1;
	while(end > 0){
		//swap the root(maximum value) of the heap with the
		//last element of the heap
		int tmp = a[end];
		a[end] = a[0];
		a[0] = tmp;
		//put the heap back in max-heap order
		siftDown(a, 0, end - 1);
		//decrement the size of the heap so that the previous
		//max value will stay in its proper place
		end--;
	}
}

public static void heapify(int[] a, int count){
	//start is assigned the index in a of the last parent node
	int start = (count - 2) / 2; //binary heap

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

public static void siftDown(int[] a, int start, int end){
	//end represents the limit of how far down the heap to sift
	int root = start;

	while((root * 2 + 1) <= end){      //While the root has at least one child
		int child = root * 2 + 1;           //root*2+1 points to the left child
		//if the child has a sibling and the child's value is less than its sibling's...
		if(child + 1 <= end && a[child] < a[child + 1])
			child = child + 1;           //... then point to the right child instead
		if(a[root] < a[child]){     //out of max-heap order
			int tmp = a[root];
			a[root] = a[child];
			a[child] = tmp;
			root = child;                //repeat to continue sifting down the child now
		}else
			return;
	}
}


proc beadSort[T](a: var openarray[T]) =
  var max = low(T)
  var sum = 0

  for x in a:
    if x > max: max = x

  var beads = newSeq[int](max * a.len)

  for i in 0 ..< a.len:
    for j in 0 ..< a[i]:
      beads[i * max + j] = 1

  for j in 0 ..< max:
    sum = 0
    for i in 0 ..< a.len:
      sum += beads[i * max + j]
      beads[i * max + j] = 0

    for i in a.len - sum ..< a.len:
      beads[i * max + j] = 1

  for i in 0 ..< a.len:
    var j = 0
    while j < max and beads[i * max + j] > 0: inc j
    a[i] = j

var a = @[5, 3, 1, 7, 4, 1, 1, 20]
beadSort a
echo a


let rec columns l =
  match List.filter ((<>) []) l with
    [] -> []
  | l -> List.map List.hd l :: columns (List.map List.tl l)

let replicate n x = Array.to_list (Array.make n x)

let bead_sort l =
  List.map List.length (columns (columns (List.map (fun e -> replicate e 1) l)))


function sorted = beadsort(a)
  sorted = a;
  m = max(a);
  if ( any(a < 0) )
    error("can't sort");
  endif
  t = zeros(m, m);
  for i = 1:numel(a)
    t(i, 1:a(i)) = 1;
  endfor
  for i = 1:m
    s = sum(t(:, i));
    t(:, i) = 0;
    t(1:s, i) = 1;
  endfor
  for i = 1:numel(a)
    sorted(i) = sum(t(i, :));
  endfor
endfunction

beadsort([5, 7, 1, 3, 1, 1, 20])


program SortExample

    function main()
       	test1 string[] = ["Here", "are", "some", "sample", "strings", "to", "be", "sorted"];
	test1.sort(sortFunction);

	SysLib.writeStdout("Test 1:");
	for(i int from 1 to test1.getSize())
      	    SysLib.writeStdout(test1[i]);
	end

	test2 string[] = ["Cat", "apple", "Adam", "zero", "Xmas", "quit", "Level", "add", "Actor", "base", "butter"];
	test2.sort(sortFunction);

	SysLib.writeStdout("Test 2:");
	for(i int from 1 to test2.getSize())
	    SysLib.writeStdout(test2[i]);
	end
    end

    function sortFunction(a any in, b any in) returns (int)
	result int = (b as string).length() - (a as string).length();
	if (result == 0)
  	    case
		when ((a as string).toLowerCase() > (b as string).toLowerCase())
	  	    result = 1;
		when ((a as string).toLowerCase() < (b as string).toLowerCase())
		    result = -1;
		otherwise
		    result = 0;
	    end
	end

    	return result;
    end

end


import extensions;
import system'routines;
import system'culture;

public program()
{
    var items := new string[]{ "Here", "are", "some", "sample", "strings", "to", "be", "sorted" };

    console.printLine("Unsorted:          ", items.asEnumerable());

    console.printLine("Descending length: ", items.clone()
        .sort:(p,n => p.Length > n.Length).asEnumerable());

    console.printLine("Ascending order:   ", items.clone()
        .sort:(p,n => p.toUpper(invariantLocale) < n.toUpper(invariantLocale)).asEnumerable())
}


strs = ~w[this is a set of strings to sort This Is A Set Of Strings To Sort]

comparator = fn s1,s2 -> if String.length(s1)==String.length(s2),
                           do:   String.downcase(s1) <= String.downcase(s2),
                           else: String.length(s1) >= String.length(s2) end
IO.inspect Enum.sort(strs, comparator)

# or
IO.inspect Enum.sort_by(strs, fn str -> {-String.length(str), String.downcase(str)} end)


-module( sort_using_custom_comparator ).

-export( [task/0] ).

task() ->
	lists:sort( fun longest_first_case_insensitive/2, ["this", "is", "a", "set", "of", "strings", "to", "sort", "This", "Is", "A", "Set", "Of", "Strings", "To", "Sort"] ).

longest_first_case_insensitive( String1, String2 ) when erlang:length(String1) =:= erlang:length(String2) -> string:to_lower(String1) < string:to_lower(String2);
longest_first_case_insensitive( String1, String2 ) when erlang:length(String1) =< erlang:length(String2) -> false;
longest_first_case_insensitive( _String1, _String2 ) -> true.


arr := Array([17,3,72,0,36,2,3,8,40,0]):
len := numelems(arr):
swap := proc(arr, a, b)
	local temp := arr[a]:
	arr[a] := arr[b]:
	arr[b] := temp:
end proc:
while(true) do
	swapped := false:
	for i to len-1 do
		if arr[i] > arr[i+1] then:
			swap(arr, i, i+1):
			swapped := true:
		end if:
	end do:
	if (not swapped) then break: end if:
	swapped := false:
	for j from len-1 to 1 by -1 do
		if arr[j] > arr[j+1] then
			swap(arr,j,j+1):
			swapped := true:
		end if:
	end do:
	if (not swapped) then break: end if:
end do:
arr;


cocktailSort[A_List] := Module[ { swapped = True },
While[ swapped == True,
 swapped=False;
 For[ i = 1, i< Length[A]-1,i++,
   If[ A[[i]] > A[[i+1]], A[[i;;i+1]] = A[[i+1;;i;;-1]]; swapped=True;]
 ];
If[swapped == False, Break[]];
swapped=False;
For [ i= Length[A]-1, i > 0, i--,
  If[ A[[i]] > A[[i+1]], A[[i;;i+1]] = A[[i+1;;i;;-1]]; swapped = True;]
 ]]]


function list = cocktailSort(list)

    %We have to do this because the do...while loop doesn't exist in MATLAB
    swapped = true;

    while swapped

        %Bubble sort down the list
        swapped = false;
        for i = (1:numel(list)-1)
            if( list(i) > list(i+1) )
                list([i i+1]) = list([i+1 i]); %swap
                swapped = true;
            end
        end

        if ~swapped
            break
        end

        %Bubble sort up the list
        swapped = false;
        for i = (numel(list)-1:-1:1)
            if( list(i) > list(i+1) )
                list([i i+1]) = list([i+1 i]); %swap
                swapped = true;
            end %if
        end %for
    end %while
end %cocktail sort


function heapSort(arr) {
    heapify(arr)
    end = arr.length - 1
    while (end > 0) {
        [arr[end], arr[0]] = [arr[0], arr[end]]
        end--
        siftDown(arr, 0, end)
    }
}

function heapify(arr) {
    start = Math.floor(arr.length/2) - 1

    while (start >= 0) {
        siftDown(arr, start, arr.length - 1)
        start--
    }
}

function siftDown(arr, startPos, endPos) {
    let rootPos = startPos

    while (rootPos * 2 + 1 <= endPos) {
        childPos = rootPos * 2 + 1
        if (childPos + 1 <= endPos && arr[childPos] < arr[childPos + 1]) {
            childPos++
        }
        if (arr[rootPos] < arr[childPos]) {
            [arr[rootPos], arr[childPos]] = [arr[childPos], arr[rootPos]]
            rootPos = childPos
        } else {
            return
        }
    }
}
test('rosettacode', () => {
    arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8,]
    heapSort(arr)
    expect(arr).toStrictEqual([1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15])
})


in='10 -12 1 0 999 8 2 2 4 4'
 Do i=1 To words(in)
   z.i=word(in,i)
   End
 n=i-1
 init=0
 Call minmax

 beads.=0;
 Do i=1 To words(in)
   z=z.i
   beads.z+=1
   End
 j=0
 Do i=lo To hi
   Do While beads.i>0
     j+=1
     s.j=i
     beads.i-=1
     End;
   End;
 Call show ' Input:',z.,n
 Call show 'Sorted:',s.,n
 Exit

 minmax:
 Do i=1 To n
   If init=0 Then Do
     init=1
     lo=z.i
     hi=z.i
     End
   Else Do
     lo=min(lo,z.i)
     hi=max(hi,z.i)
     End
   End
 Return

show: Procedure Expose n
 Use Arg txt,a.
 ol=txtg>
 Do i=1 To n
   ol=ol format(a.i,3)
   End
 Say ol
 Return


FUNCTION beadSort RETURNS CHAR (
   i_c AS CHAR
):

   DEF VAR cresult   AS CHAR.
   DEF VAR ii        AS INT.
   DEF VAR inumbers  AS INT.
   DEF VAR irod      AS INT.
   DEF VAR irods     AS INT.
   DEF VAR crod      AS CHAR.
   DEF VAR cbeads    AS CHAR EXTENT.

   inumbers = NUM-ENTRIES( i_c ).

   /* determine number of rods needed */
   DO ii = 1 TO inumbers:
      irods = MAXIMUM( irods, INTEGER( ENTRY( ii, i_c ) ) ).
   END.

   /* put beads on rods */
   EXTENT( cbeads ) = inumbers.
   DO ii = 1 TO inumbers:
      cbeads[ ii ] = FILL( "X", INTEGER( ENTRY( ii, i_c ) ) ).
   END.

   /* drop beads on each rod */
   DO irod = 1 TO irods:
      crod = "".
      DO ii = 1 TO inumbers:
         crod = crod + SUBSTRING( cbeads[ ii ], irod, 1 ).
      END.
      crod = REPLACE( crod, " ", "" ).
      DO ii = 1 TO inumbers.
         SUBSTRING( cbeads[ ii ], irod, 1 ) = STRING( ii <= LENGTH( crod ), "X/ " ).
      END.
   END.

   /* get beads from rods */
   DO ii = 1 TO inumbers:
      cresult = cresult + "," + STRING( LENGTH( REPLACE( cbeads[ ii ], " ", "" ) ) ).
   END.

   RETURN SUBSTRING( cresult, 2 ).

END FUNCTION. /* beadSort */

MESSAGE
   "5,2,4,1,3,3,9  -> " beadSort( "5,2,4,1,3,3,9" ) SKIP
   "5,3,1,7,4,1,1  -> " beadSort( "5,3,1,7,4,1,1" ) SKIP(1)
   beadSort( "88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1" )
VIEW-AS ALERT-BOX.


beadsort(v)={
  my(sz=vecmax(v),M=matrix(#v,sz,i,j,v[i]>=j)); \\ Set up beads
  for(i=1,sz,M[,i]=countingSort(M[,i],0,1)~);   \\ Let them fall
  vector(#v,i,value(M[i,]))                     \\ Convert back to numbers
};

countingSort(v,mn,mx)={
  my(u=vector(#v),i=0);
  for(n=mn,mx,
    for(j=1,#v,if(v[j]==n,u[i++]=n))
  );
  u
};

value(v)={
  if(#v==0 || !v[1], return(0));
  if(v[#v], return(#v));
  my(left=1, right=#v, mid);
  while (right - left > 1,
    mid=(right+left)\2;
    if(v[mid], left=mid, right=mid)
  );
  left
};


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

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

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

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:        .asciz "Name : @  country : @ \n"
szMessSortName:     .asciz "Sort table for name of city :\n"
szMessSortCountry:  .asciz "Sort table for country : \n"
szCarriageReturn:   .asciz "\n"

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

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

    ldr x0,qAdrszMessSortName
    bl affichageMess

    ldr x0,qAdrptrTableCities     // address pointers table
    mov x1,0                      // not use in routine
    mov x2,NBELEMENTS - 1         // number of élements
    mov x3,#city_name             // sort by city name
    mov x4,#'A'                   // alphanumeric
    ldr x5,qAdrptrTableExtraSort
    bl mergeSort
    ldr x0,qAdrptrTableCities     // address table
    bl displayTable

    ldr x0,qAdrszMessSortCountry
    bl affichageMess

    ldr x0,qAdrptrTableCities     // address table
    mov x1,0                      // not use in routine
    mov x2,NBELEMENTS - 1         // number of élements
    mov x3,#city_country          // sort by city country
    mov x4,#'A'                   // alphanumeric
    ldr x5,qAdrptrTableExtraSort
    bl mergeSort
    ldr x0,qAdrptrTableCities     // address table
    bl displayTable

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

qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableCities:          .quad TableCities
qAdrszMessSortName:        .quad szMessSortName
qAdrptrTableExtraSort:     .quad ptrTableExtraSort
qAdrszMessSortCountry:     .quad szMessSortCountry
qAdrptrTableCities:        .quad ptrTableCities
/******************************************************************/
/*      merge sort                                                */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the index of first element */
/* x2 contains the number of element */
/* x3 contains the offset of area sort */
/* x4 contains the type of area sort N numeric A alpha */
/* x5 contains address extra area */
mergeSort:
    stp x3,lr,[sp,-16]!    // save  registers
    stp x4,x5,[sp,-16]!    // save  registers
    stp x6,x7,[sp,-16]!    // save  registers
    stp x8,x9,[sp,-16]!    // save  registers
    stp x10,x11,[sp,-16]!  // save  registers
    mov x6,x1              // save index first element
    mov x7,x2              // save number of element
    mov x11,x0             // save address table
    cmp x2,x1              // end ?
    ble 100f
    add x9,x2,x1
    lsr x9,x9,1            // number of element of each subset
    mov x2,x9
    bl mergeSort
    mov x1,x9              // restaur number of element of each subset
    add x1,x1,1
    mov x2,x7              // restaur  number of element
    bl mergeSort           // sort first subset
    add x10,x9,1
1:
    sub x1,x10,1
    sub x8,x10,1
    ldr x2,[x0,x1,lsl 3]
    str x2,[x5,x8,lsl 3]
    sub x10,x10,1
    cmp x10,x6
    bgt 1b
    mov x10,x9
2:
    add x1,x10,1
    add x8,x7,x9
    sub x8,x8,x10
    ldr x2,[x0,x1,lsl 3]
    str x2,[x5,x8,lsl 3]
    add x10,x10,1
    cmp x10,x7
    blt 2b

    mov x10,x6            //k
    mov x1,x6             // i
    mov x2,x7             // j
3:
    mov x0,x5             // table address x1 = i x2 = j x3 = area sort offeset
    bl comparArea
    cmp x0,0
    bgt 5f
    blt 4f
                          // if equal and  i < pivot
    cmp x1,x9
    ble 4f                // inverse to stable
    b 5f
4:                        // store element subset 1
    mov x0,x5
    ldr x6,[x5,x1, lsl 3]
    str x6,[x11,x10, lsl 3]
    add x1,x1,1
    b 6f
5:                        // store element subset 2
    mov x0,x5
    ldr x6,[x5,x2, lsl 3]
    str x6,[x11,x10, lsl 3]
    sub x2,x2,1
6:
    add x10,x10,1
    cmp x10,x7
    ble 3b
    mov x0,x11

100:
    ldp x10,x11,[sp],16   // restaur  2 registers
    ldp x8,x9,[sp],16     // restaur  2 registers
    ldp x6,x7,[sp],16     // restaur  2 registers
    ldp x4,x5,[sp],16     // restaur  2 registers
    ldp x3,lr,[sp],16     // restaur  2 registers
    ret                   // return to address lr x30
/******************************************************************/
/*      comparison sort area                                */
/******************************************************************/
/* x0 contains the address of table */
/* x1 indice area sort 1 */
/* x2 indice area sort 2 */
/* x3 contains the offset of area sort */
/* x4 contains the type of area sort N numeric A alpha */
comparArea:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    stp x4,x5,[sp,-16]!          // save  registers
    stp x6,x7,[sp,-16]!          // save  registers
    stp x8,x9,[sp,-16]!          // save  registers

    ldr x1,[x0,x1,lsl 3]         // load pointer element 1
    ldr x6,[x1,x3]               // load area sort element 1
    ldr x2,[x0,x2,lsl 3]         // load pointer element 2
    ldr x7,[x2,x3]               // load area sort element 2
    cmp x4,'A'                   // numeric or alpha ?
    beq 1f
    cmp x6,x7                    // compare numeric value
    blt 10f
    bgt 11f
    b 12f
1:                               // else compar alpha string
    mov x8,#0
2:
    ldrb w9,[x6,x8]              // byte string 1
    ldrb w5,[x7,x8]              // byte string 2
    cmp w9,w5
    bgt 11f
    blt 10f

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

10:                              // lower
    mov x0,-1
    b 100f
11:                              // highter
    mov x0,1
    b 100f
12:                              // equal
    mov x0,0
100:
    ldp x8,x9,[sp],16            // restaur  2 registers
    ldp x6,x7,[sp],16            // restaur  2 registers
    ldp x4,x5,[sp],16            // restaur  2 registers
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30

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


include sort.e
include wildcard.e
include misc.e

function my_compare(sequence a, sequence b)
    if length(a)!=length(b) then
        return -compare(length(a),length(b))
    else
        return compare(lower(a),lower(b))
    end if
end function

sequence strings
strings = reverse({ "Here", "are", "some", "sample", "strings", "to", "be", "sorted" })

puts(1,"Unsorted:\n")
pretty_print(1,strings,{2})

puts(1,"\n\nSorted:\n")
pretty_print(1,custom_sort(routine_id("my_compare"),strings),{2})


let myCompare (s1:string) (s2:string) =
  match compare s2.Length s1.Length with
    | 0 -> compare (s1.ToLower()) (s2.ToLower())
    | X -> X

let strings = ["Here"; "are"; "some"; "sample"; "strings"; "to"; "be"; "sorted"]

let sortedStrings = List.sortWith myCompare strings

printfn "%A" sortedStrings


: my-compare ( s1 s2 -- <=> )
    2dup [ length ] compare invert-comparison
    dup +eq+ = [ drop [ >lower ] compare ] [ 2nip ] if ;

{ "this" "is" "a" "set" "of" "strings" "to" "sort" } [ my-compare ] sort


fn cocktailSort arr =
(
    local swapped = true
    while swapped do
    (
        swapped = false
        for i in 1 to (arr.count-1) do
        (
            if arr[i] > arr[i+1] then
            (
                swap arr[i] arr[i+1]
                swapped = true
            )
        )
        if not swapped then exit
        for i in (arr.count-1) to 1 by -1 do
        (
            if arr[i] > arr[i+1] then
            (
                swap arr[i] arr[i+1]
                swapped = true
            )
        )
    )
    return arr
)


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

placesList = [String -
    "UK  London",     "US  New York"   -
  , "US  Boston",     "US  Washington" -
  , "UK  Washington", "US  Birmingham" -
  , "UK  Birmingham", "UK  Boston"     -
]
sortedList = cocktailSort(String[] Arrays.copyOf(placesList, placesList.length))

lists = [placesList, sortedList]
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 cocktailSort(A = String[]) public constant binary returns String[]

  Alength = A.length
  swapped = isFalse
  loop label swapped until \swapped
    swapped = isFalse
    loop i_ = 0 to Alength - 2
      if A[i_].compareTo(A[i_ + 1]) > 0 then do
        swap      = A[i_ + 1]
        A[i_ + 1] = A[i_]
        A[i_]     = swap
        swapped = isTrue
        end
      end i_
    if \swapped then do
      leave swapped
      end
    swapped = isFalse
    loop i_ = Alength - 2 to 0 by -1
      if A[i_].compareTo(A[i_ + 1]) > 0 then do
        swap      = A[i_ + 1]
        A[i_ + 1] = A[i_]
        A[i_]     = swap
        swapped = isTrue
        end
      end i_
    end swapped

  return A

method isTrue public constant binary returns boolean
  return 1 == 1

method isFalse public constant binary returns boolean
  return \isTrue


def swap($a; $i; $j):
  $a
  | .[$i] as $t
  | .[$i] = .[$j]
  | .[$j] = $t ;

def siftDown($a; $start; $iend):
  { $a, root: $start }
  | until( .stop or (.root*2 + 1 > $iend);
      .child = .root*2 + 1
      | if .child + 1 <= $iend and .a[.child] < .a[.child+1]
        then .child += 1
	else .
	end
        | if .a[.root] < .a[.child]
          then
	  .a = swap(.a; .root; .child)
          | .root = .child
          else .stop = true
          end)
  | .a ;

def heapify:
  length as $count
  | {a: ., start: ((($count - 2)/2)|floor)}
  | until(.start < 0;
        .a = siftDown(.a; .start; $count - 1)
        | .start += -1 )
  | .a ;

def heapSort:
  { a: heapify,
    iend: (length - 1) }
  | until( .iend <= 0;
        .a = swap(.a; 0; .iend)
        | .iend += -1
        | .a = siftDown(.a; 0; .iend) )
  | .a ;

[4, 65, 2, -31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3]
|
 "Before: \(.)",
 "After : \(heapSort)\n"


function swap(a, i, j)
    a[i], a[j] = a[j], a[i]
end

function pd!(a, first, last)
    while (c = 2 * first - 1) < last
        if c < last && a[c] < a[c + 1]
            c += 1
        end
        if a[first] < a[c]
            swap(a, c, first)
            first = c
        else
            break
        end
    end
end

function heapify!(a, n)
    f = div(n, 2)
    while f >= 1
        pd!(a, f, n)
        f -= 1
    end
end

function heapsort!(a)
    n = length(a)
    heapify!(a, n)
    l = n
    while l > 1
        swap(a, 1, l)
        l -= 1
        pd!(a, 1, l)
    end
    return a
end

using Random: shuffle
a = shuffle(collect(1:12))
println("Unsorted: $a")
println("Heap sorted: ", heapsort!(a))


program BDS;
const MAX = 1000;
type
    type_matrix = record
	lin,col:integer;
	matrix: array [1..MAX,1..MAX] of boolean;
    end;

    type_vector = record
	size:integer;
	vector: array[1..MAX] of integer;
    end;

procedure BeadSort(var v:type_vector);
var
    i,j,k,sum:integer;
    m:type_matrix;
begin
    m.lin:=v.size;

    (* the number of columns is equal to the greatest element *)
    m.col:=0;
    for i:=1 to v.size do
	if v.vector[i] > m.col then
	    m.col:=v.vector[i];

    (* initializing the matrix *)
    for j:=1 to m.lin do
	begin
	    k:=1;
	    for i:=m.col downto 1 do
		begin
		    if v.vector[j] >= k then
			m.matrix[i,j]:=TRUE
		    else
			m.matrix[i,j]:=FALSE;
		    k:=k+1;
		end;
	end;

    (* Sort the matrix *)
    for i:=1 to m.col do
	begin
	    (* Count the beads and set the line equal FALSE *)
	    sum:=0;
	    for j:=1 to m.lin do
		begin
		    if m.matrix[i,j] then
			sum:=sum+1;
		    m.matrix[i,j]:=FALSE;
		end;

	    (* The line receives the bead sorted *)
	    for j:=m.lin downto m.lin-sum+1 do
		m.matrix[i,j]:=TRUE;
	end;

    (* Convert the sorted bead matrix to a sorted vector *)
    for j:=1 to m.lin do
	begin
	    v.vector[j]:=0;
	    i:=m.col;
	    while (m.matrix[i,j] = TRUE)and(i>=1) do
		begin
		    v.vector[j]+=1;
		    i:=i-1;
		end;
	end;
end;

procedure print_vector(var v:type_vector);
var i:integer;
begin
    for i:=1 to v.size do
	write(v.vector[i],' ');
    writeln;
end;

var
    i:integer;
    v:type_vector;
begin
    writeln('How many numbers do you want to sort?');
    readln(v.size);
    writeln('Write the numbers:');

    for i:=1 to v.size do
	read(v.vector[i]);

    writeln('Before sort:');
    print_vector(v);

    BeadSort(v);

    writeln('After sort:');
    print_vector(v);
end.


set aTable to "UK	London
US	New York
US	Birmingham
UK	Birmingham"

-- -s = stable sort; -t sets the field separator, -k sets the sort "column" range in field numbers.
set stableSortedOnColumn2 to (do shell script ("sort -st'" & tab & "' -k2,2 <<<" & quoted form of aTable))
set stableSortedOnColumn1 to (do shell script ("sort -st'" & tab & "' -k1,1 <<<" & quoted form of aTable))
return "Stable sorted on column 2:" & (linefeed & stableSortedOnColumn2) & (linefeed & linefeed & ¬
    "Stable sorted on column 1:") & (linefeed & stableSortedOnColumn1)


Table =
(
UK, London
US, New York
US, Birmingham
UK, Birmingham
)

Gui, Margin, 6
Gui, -MinimizeBox
Gui, Add, ListView, r5 w260 Grid, Orig.Position|Country|City
Loop, Parse, Table, `n, `r
{
    StringSplit, out, A_LoopField, `,, %A_Space%
    LV_Add("", A_Index, out1, out2)
}
LV_ModifyCol(1, "77 Center")
LV_ModifyCol(2, "100 Center")
LV_ModifyCol(3, 79)
Gui, Add, Button, w80, Restore Order
Gui, Add, Button, x+10 wp, Sort Countries
Gui, Add, Button, x+10 wp, Sort Cities
Gui, Show,, Sort stability
Return

GuiClose:
GuiEscape:
ExitApp

ButtonRestoreOrder:
    LV_ModifyCol(1, "Sort")
Return

ButtonSortCountries:
    LV_ModifyCol(2, "Sort")
Return

ButtonSortCities:
    LV_ModifyCol(3, "Sort")
Return


class Main
{
  public static Void main ()
  {
    // sample strings from Lisp example
    strs := ["Cat", "apple", "Adam", "zero", "Xmas", "quit",
             "Level", "add", "Actor", "base", "butter"]

    sorted := strs.dup // make a copy of original list
    sorted.sort |Str a, Str b -> Int|  // sort using custom comparator
    {
      if (b.size == a.size)           // if size is same
        return a.compareIgnoreCase(b) // then sort in ascending lexicographic order, ignoring case
      else
        return b.size <=> a.size      // else sort in descending size order
    }
    echo ("Started with : " + strs.join(" "))
    echo ("Finished with: " + sorted.join(" "))
  }
}


module sorts_with_custom_comparator
  implicit none
contains
  subroutine a_sort(a, cc)
    character(len=*), dimension(:), intent(inout) :: a
    interface
       integer function cc(a, b)
         character(len=*), intent(in) :: a, b
       end function cc
    end interface

    integer :: i, j, increment
    character(len=max(len(a), 10)) :: temp

    increment = size(a) / 2
    do while ( increment > 0 )
       do i = increment+1, size(a)
          j = i
          temp = a(i)
          do while ( j >= increment+1 .and. cc(a(j-increment), temp) > 0)
             a(j) = a(j-increment)
             j = j - increment
          end do
          a(j) = temp
       end do
       if ( increment == 2 ) then
          increment = 1
       else
          increment = increment * 5 / 11
       end if
    end do
  end subroutine a_sort
end module sorts_with_custom_comparator


' version 23-10-2016
' compile with: fbc -s console

#Include Once "crt/stdlib.bi" ' for qsort

Function mycmp Cdecl (s1 As Any Pointer, s2 As Any Pointer) As Long

    ' -1 no swap first element before second element
    '  0 no swap needed, don't care
    '  1 swap first element after second element

    Dim As String str1 = *Cast(String Ptr, s1)
    Dim As String str2 = *Cast(String Ptr, s2)

    Dim As Long l1 = Len(str1), l2 = Len(str2)
    If (l1 > l2) Then Return -1 ' descending
    If (l1 < l2) Then Return  1 '

    ' there equal length, sort ascending
    If UCase(str1) = UCase(str2) Then
        If str1 > str2 Then Return 1
    Else
        If UCase(str1) > UCase(str2) Then Return 1
    End If

    Return 0

End Function

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

Dim As String words(0 To ...) = {"Here", "are", "some", "sample", _
                                 "strings", "to", "be", "sorted" }

Dim As ULong array_size = UBound(words) - LBound(words) + 1

qsort(@words(0), array_size, SizeOf(String), @mycmp)

For i As Integer = 0 To UBound(words)
    Print words(i)
Next
Print

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


template trySwap(): untyped =
  if a[i] < a[i-1]:
    swap a[i], a[i-1]
    t = false

proc cocktailSort[T](a: var openarray[T]) =
  var t = false
  var l = a.len
  while not t:
    t = true
    for i in 1 ..< l: trySwap
    if t: break
    for i in countdown(l-1, 1): trySwap

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


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

    function : CocktailSort(a : Int[]) ~ Nil {
      swapped : Bool;
      do {
        swapped := false;
        continue := true;
        for (i := 0; i <= a->Size()  - 2 & continue; i += 1;) {
          if(a[i] > a[i + 1]) {
            temp := a[i];
            a[i] := a[i+1];
            a[i+1] := temp;
            swapped := true;
          };
        };

        if(swapped <> true) {
          continue := false;
        };

        swapped := false;
        for(i := a->Size() - 2; i >= 0; i -= 1;){
          if(a[i] > a[i + 1]) {
            temp := a[i];
            a[i] := a[i+1];
            a[i + 1] := temp;
            swapped := true;
          };
        };
      }
      while(swapped);
    }
  }
}


// version 1.1.0

fun heapSort(a: IntArray) {
    heapify(a)
    var end = a.size - 1
    while (end > 0) {
        val temp = a[end]
        a[end] = a[0]
        a[0] = temp
        end--
        siftDown(a, 0, end)
    }
}

fun heapify(a: IntArray) {
    var start = (a.size - 2) / 2
    while (start >= 0) {
        siftDown(a, start, a.size - 1)
        start--
    }
}

fun siftDown(a: IntArray, start: Int, end: Int) {
    var root = start
    while (root * 2 + 1 <= end) {
        var child = root * 2 + 1
        if (child + 1 <= end && a[child] < a[child + 1]) child++
        if (a[root] < a[child]) {
            val temp = a[root]
            a[root] = a[child]
            a[child] = temp
            root = child
        }
        else return
    }
}

fun main(args: Array<String>) {
    val aa = arrayOf(
        intArrayOf(100, 2, 56, 200, -52, 3, 99, 33, 177, -199),
        intArrayOf(4, 65, 2, -31, 0, 99, 2, 83, 782, 1),
        intArrayOf(12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8)
    )
    for (a in aa) {
        heapSort(a)
        println(a.joinToString(", "))
    }
}


sub beadsort {
    my @data = @_;

    my @columns;
    my @rows;

    for my $datum (@data) {
        for my $column ( 0 .. $datum-1 ) {
            ++ $rows[ $columns[$column]++ ];
        }
    }

    return reverse @rows;
}

beadsort 5, 7, 1, 3, 1, 1, 20;


with javascript_semantics

function beadsort(sequence a)
    sequence poles = repeat(0,max(a))
    for i=1 to length(a) do
        poles[1..a[i]] = sq_add(poles[1..a[i]],1)
    end for
    a[1..$] = 0
    for i=1 to length(poles) do
        a[1..poles[i]] = sq_add(a[1..poles[i]],1)
    end for
    return a
end function

?beadsort({5, 3, 1, 7, 4, 1, 1, 20})


<?php
function columns($arr) {
    if (count($arr) == 0)
        return array();
    else if (count($arr) == 1)
        return array_chunk($arr[0], 1);

    array_unshift($arr, NULL);
    // array_map(NULL, $arr[0], $arr[1], ...)
    $transpose = call_user_func_array('array_map', $arr);
    return array_map('array_filter', $transpose);
}

function beadsort($arr) {
    foreach ($arr as $e)
        $poles []= array_fill(0, $e, 1);
    return array_map('count', columns(columns($poles)));
}

print_r(beadsort(array(5,3,1,7,4,1,1)));
?>


# syntax: GAWK -f SORT_STABILITY.AWK [-v width=x] -v field=x SORT_STABILITY.TXT
#
# sort by country: GAWK -f SORT_STABILITY.AWK -v field=1 SORT_STABILITY.TXT
# sort by city:    GAWK -f SORT_STABILITY.AWK -v field=2 SORT_STABILITY.TXT
#
# awk sort is not stable. Stability may be achieved by appending the
# record number, I.E. NR, to each key.
#
BEGIN {
    FIELDWIDTHS = "4 20" # 2 fields: country city
    PROCINFO["sorted_in"] = "@ind_str_asc"
    if (width == "") {
      width = 6
    }
}
{ arr[$field sprintf("%0*d",width,NR)] = $0 }
END {
    if (length(NR) > width) {
      printf("error: sort may still be unstable; change width to %d\n",length(NR))
      exit(1)
    }
    printf("after sorting on field %d:\n",field)
    for (i in arr) {
      printf("%s\n",arr[i])
    }
    exit(0)
}


cities = [ {"UK", "London"},
           {"US", "New York"},
           {"US", "Birmingham"},
           {"UK", "Birmingham"} ]

IO.inspect Enum.sort(cities)
IO.inspect Enum.sort(cities, fn a,b -> elem(a,0) >= elem(b,0) end)
IO.inspect Enum.sort_by(cities, fn {country, _city} -> country end)
IO.inspect Enum.sort_by(cities, fn {_country, city} -> city end)


f = {|a,b|
     len = length[b] <=> length[a]
     if len != 0
        return len
     else
        return lexicalCompare[a,b]
    }

words = split[%r/\s+/, "Here are some sample strings to be sorted"]
println[sort[words, f]]


def preceeds( a, b ) = b.length() < a.length() or b.length() == a.length() and a.compareToIgnoreCase( b ) < 0

println( ["here", "are", "Some", "sample", "strings", "to", "be", "sorted"].sortWith(preceeds) )


package main

import (
    "fmt"
    "sort"
    "strings"
)

type sortable []string

func (s sortable) Len() int      { return len(s) }
func (s sortable) Swap(i, j int) { s[i], s[j] = s[j], s[i] }
func (s sortable) Less(i, j int) bool {
    a, b := s[i], s[j]
    if len(a) != len(b) {
        return len(a) > len(b)
    }
    return strings.ToLower(a) < strings.ToLower(b)
}

func main() {
    var s sortable = strings.Fields("To tell your name the livelong day To an admiring bog")
    fmt.Println(s, "(original)")

    sort.Sort(s)
    fmt.Println(s, "(sorted)")
}


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

let cocktail_sort a =
  let begin_ = ref(-1)
  and end_ = ref(Array.length a - 2) in
  let swapped = ref true in
  try while !swapped do
    swapped := false;
    incr begin_;
    for i = !begin_ to !end_ do
      if a.(i) > a.(i+1) then begin
        swap a (i) (i+1);
        swapped := true;
      end;
    done;
    if !swapped = false then raise Exit;
    swapped := false;
    decr end_;
    for i = !end_ downto !begin_ do
      if a.(i) > a.(i+1) then begin
        swap a (i) (i+1);
        swapped := true
      end;
    done;
  done with Exit -> ()
;;

let () =
  let a = [| 3; 7; 4; 9; 6; 1; 8; 5; 2; |] in
  cocktail_sort a;
  Array.iter (Printf.printf " %d") a;
  print_newline();
;;


wikiSample=1    'comment out for random array

data 6, 5, 3, 1, 8, 7, 2, 4
    itemCount = 20
if wikiSample then itemCount = 8
    dim A(itemCount)
    for i = 1 to itemCount
        A(i) = int(rnd(1) * 100)
        if wikiSample then read tmp: A(i)=tmp
    next i

    print "Before Sort"
    call printArray itemCount

    call heapSort itemCount

    print "After Sort"
    call printArray itemCount
end

'------------------------------------------
sub heapSort count
    call heapify count

    print "the heap"
    call printArray  count

    theEnd = count
    while theEnd > 1
        call swap theEnd, 1
        call siftDown 1, theEnd-1
        theEnd = theEnd - 1
    wend
end sub

sub heapify count
    start = int(count / 2)
    while start >= 1
         call siftDown start, count
         start = start - 1
    wend
end sub

sub siftDown start, theEnd
    root = start
    while root * 2 <= theEnd
        child = root * 2
        swap = root
        if A(swap) < A(child) then
            swap = child
        end if
        if child+1 <= theEnd  then
            if A(swap) < A(child+1) then
                swap = child + 1
            end if
        end if
        if swap <> root then
            call swap root, swap
            root = swap
        else
            exit sub
        end if
    wend
end sub

sub swap a,b
    tmp = A(a)
    A(a) = A(b)
    A(b) = tmp
end sub

'===========================================
sub printArray itemCount
    for i = 1 to itemCount
        print using("###", A(i));
    next i
    print
end sub


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


/* Handles both negative and positive values. */

maxval: procedure (z) returns (fixed binary);
   declare z(*) fixed binary;
   declare (maxv initial (0), i) fixed binary;
   do i = lbound(z,1) to hbound(z,1);
      maxv = max(z(i), maxv);
   end;
   put skip data (maxv); put skip;
   return (maxv);
end maxval;
minval: procedure (z) returns (fixed binary);
   declare z(*) fixed binary;
   declare (minv initial (0), i) fixed binary;

   do i = lbound(z,1) to hbound(z,1);
      if z(i) < 0 then minv = min(z(i), minv);
   end;
   put skip data (minv); put skip;
   return (minv);
end minval;

/* To deal with negative values, array elements are incremented */
/* by the greatest (in magnitude) negative value, thus making   */
/* them positive. The resultant values are stored in an         */
/* unsigned array (PL/I provides both signed and unsigned data  */
/* types). At procedure end, the array values are restored to   */
/* original values.                                             */

(subrg, fofl, size, stringrange, stringsize):
beadsort: procedure (z);                        /* 8-1-2010 */
   declare (z(*)) fixed binary;
   declare b(maxval(z)-minval(z)+1) bit (maxval(z)-minval(z)+1) aligned;
   declare (i, j, k, m, n) fixed binary;
   declare a(hbound(z,1)) fixed binary unsigned;
   declare offset fixed binary initial (minval(z));

   PUT SKIP LIST('CHECKPOINT A'); PUT SKIP;
   n = hbound(z,1);
   m = hbound(b,1);

   if offset < 0 then
      a = z - offset;
   else
      a = z;

   b = '0'b;

   do i = 1 to n;
      substr(b(i), 1, a(i)) = copy('1'b, a(i));
   end;
   do j = 1 to m; put skip list (b(j)); end;

   do j = 1 to m;
      k = 0;
      do i =1 to n;
         if substr(b(i), j, 1) then k = k + 1;
      end;
      do i = 1 to n;
         substr(b(i), j, 1) = (i <= k);
      end;
   end;
   put skip;
   do j = 1 to m; put skip list (b(j)); end;

   do i = 1 to n;
      k = 0;
      do j = 1 to m; k = k + substr(b(i), j, 1); end;
      a(i) = k;
   end;
   if offset < 0 then z = a + offset; else z = a;

end beadsort;


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

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


def strings = "Here are some sample strings to be sorted".split()
strings.sort { x, y ->
    y.length() <=> x.length() ?: x.compareToIgnoreCase(y)
}
println strings


function sl = cocktailsort(l)
  swapped = true;
  while(swapped)
    swapped = false;
    for i = 1:(length(l)-1)
      if ( l(i) > l(i+1) )
	t = l(i);
	l(i) = l(i+1);
	l(i+1) = t;
	swapped = true;
      endif
    endfor
    if ( !swapped )
      break;
    endif
    swapped = false;
    for i = (length(l)-1):-1:1
      if ( l(i) > l(i+1) )
	t = l(i);
	l(i) = l(i+1);
	l(i+1) = t;
	swapped = true;
      endif
    endfor
  endwhile
  sl = l;
endfunction


/* Rexx */

placesList = .array~of( -
    "UK  London",     "US  New York"   , "US  Boston",     "US  Washington" -
  , "UK  Washington", "US  Birmingham" , "UK  Birmingham", "UK  Boston"     -
)

sortedList = cocktailSort(placesList~allItems())

lists = .array~of(placesList, sortedList)
loop ln = 1 to lists~items()
  cl = lists[ln]
  loop ct = 1 to cl~items()
    say cl[ct]
    end ct
    say
  end ln

return
exit

::routine cocktailSort
  use arg A

  Alength = A~items()
  swapped = .false
  loop label swaps until \swapped
    swapped = .false
    loop i_ = 1 to Alength - 1
      if A[i_] > A[i_ + 1] then do
        swap      = A[i_ + 1]
        A[i_ + 1] = A[i_]
        A[i_]     = swap
        swapped = .true
        end
      end i_
    if \swapped then do
      leave swaps
      end
    swapped = .false
    loop i_ = Alength - 1 to 1 by -1
      if A[i_] > A[i_ + 1] then do
        swap      = A[i_ + 1]
        A[i_ + 1] = A[i_]
        A[i_]     = swap
        swapped = .true
        end
      end i_
    end swaps

  return A


def siftDown(a, start, end):
   // (end represents the limit of how far down the heap to sift)
   var root = start

   while root * 2 + 1 <= end:           // (While the root has at least one child)
      var child = root * 2 + 1          // (root*2+1 points to the left child)
      // (If the child has a sibling and the child's value is less than its sibling's...)
      if child + 1 <= end and a[child] < a[child + 1]:
         child += 1                     // (... then point to the right child instead)
      if a[root] < a[child]:            // (out of max-heap order)
         let r = a[root]                // swap(a[root], a[child])
         a[root] = a[child]
         a[child] = r
         root = child                   // (repeat to continue sifting down the child now)
      else:
         return

def heapify(a, count):
   //(start is assigned the index in a of the last parent node)
   var start = (count - 2) >> 1

   while start >= 0:
      // (sift down the node at index start to the proper place
      //  such that all nodes below the start index are in heap order)
      siftDown(a, start, count-1)
      start -= 1
   // (after sifting down the root all nodes/elements are in heap order)

def heapSort(a):
   // input: an unordered array a of length count
   let count = a.length
   // (first place a in max-heap order)
   heapify(a, count)

   var end = count - 1
   while end > 0:
      //(swap the root(maximum value) of the heap with the last element of the heap)
      let z = a[0]
      a[0] = a[end]
      a[end] = z
      //(decrement the size of the heap so that the previous max value will stay in its proper place)
      end -= 1
      // (put the heap back in max-heap order)
      siftDown(a, 0, end)

let inputi = [1,10,2,5,-1,5,-19,4,23,0]
print ("input:  " + inputi)
heapSort(inputi)
print ("sorted: " + inputi)
let inputf = [1,-3.2,5.2,10.8,-5.7,7.3,3.5,0,-4.1,-9.5]
print ("input:  " + inputf)
heapSort(inputf)
print ("sorted: " + inputf)
let inputs = ["We","hold","these","truths","to","be","self-evident","that","all","men","are","created","equal"]
print ("input:  " + inputs)
heapSort(inputs)
print ("sorted: " + inputs)


Public Sub heapsort(pavIn As Variant)
  Dim liCount As Integer, liEnd As Integer
  Dim lvTemp As Variant
  liCount = UBound(pavIn) + 1

  heapify pavIn, liCount

  liEnd = liCount - 1
  While liEnd > 0
    lvTemp = pavIn(liEnd)
    pavIn(liEnd) = pavIn(0)
    pavIn(0) = lvTemp
    liEnd = liEnd -1
    siftDown pavIn,0, liEnd
  Wend
End Sub

Private Sub heapify(pavIn As Variant,piCount As Integer)
  Dim liStart As Integer
  liStart = (piCount - 2) / 2
  While liStart >=0
    siftDown pavIn, liStart, piCount -1
    liStart = liStart - 1
  Wend
End Sub

Private Sub siftDown(pavIn As Variant, piStart As Integer, piEnd As Integer)
  Dim liRoot As Integer, liChild As Integer
  Dim lvTemp As Variant
  liRoot = piStart
  While liRoot *2 + 1 <= piEnd
    liChild = liRoot *2 + 1
    If liChild +1 <= piEnd And pavIn(liChild) < pavIn(liChild + 1) Then
      liChild = liChild + 1
    End If
    If pavIn(liRoot) < pavIn(liChild) Then
      lvTemp = pavIn(liRoot)
      pavIn(liRoot) = pavIn(liChild)
      pavIn(liChild) = lvTemp
      liRoot = liChild
    Else
      Exit sub
    End if
  wend
End Sub


#MAXNUM=100

Dim MyData(Random(15)+5)
Global Dim Abacus(0,0)

Declare BeadSort(Array InData(1))
Declare PresentData(Array InData(1))

If OpenConsole()
  Define i
  ;- Generate a random array
  For i=0 To ArraySize(MyData())
    MyData(i)=Random(#MAXNUM)
  Next i
  PresentData(MyData())
  ;
  ;- Sort the array
  BeadSort(MyData())
  PresentData(MyData())
  ;
  Print("Press ENTER to exit"): Input()
EndIf

Procedure LetFallDown(x)
  Protected y=ArraySize(Abacus(),2)-1
  Protected ylim=y
  While y>=0
    If Abacus(x,y) And Not Abacus(x,y+1)
      Swap Abacus(x,y), Abacus(x,y+1)
      If y<ylim: y+1: Continue: EndIf
    Else
      y-1
    EndIf
  Wend
EndProcedure

Procedure BeadSort(Array n(1))
  Protected i, j, k
  NewList T()
  Dim Abacus(#MAXNUM,ArraySize(N()))
  ;- Set up the abacus
  For i=0 To ArraySize(Abacus(),2)
    For j=1 To N(i)
      Abacus(j,i)=#True
    Next
  Next
  ;- sort it in threads to simulate free beads falling down
  For i=0 To #MAXNUM
    AddElement(T()): T()=CreateThread(@LetFallDown(),i)
  Next
  ForEach T()
    WaitThread(T())
  Next
  ;- send it back to a normal array
  For j=0 To ArraySize(Abacus(),2)
    k=0
    For i=0 To ArraySize(Abacus())
      k+Abacus(i,j)
    Next
    N(j)=k
  Next
EndProcedure

Procedure PresentData(Array InData(1))
  Protected n, m, sum
  PrintN(#CRLF$+"The array is;")
  For n=0 To ArraySize(InData())
    m=InData(n): sum+m
    Print(Str(m)+" ")
  Next
  PrintN(#CRLF$+"And its sum= "+Str(sum))
EndProcedure


# According to section 21.18 of the reference manual, Sort is not stable (it's a Shell sort).
# However, SortingPerm is stable. We will see it on an example, showing indexes of elements after the sort.

n := 20;
L := List([1 .. n], i -> Random("AB"));
# "AABABBBABBABAABABBAB"

p := SortingPerm(L);
# (3,10,15,17,18,19,9,14,7,13,6,12,16,8,4)(5,11)

a := Permuted(L, p);;
b := Permuted([1 .. n], p);;

PrintArray(TransposedMat(List([1 .. n], i -> [a[i], b[i]])));
# [ [  'A',  'A',  'A',  'A',  'A',  'A',  'A',  'A',  'A',  'B',  'B',  'B',  'B',  'B',  'B',  'B',  'B',  'B',  'B',  'B' ],
#   [    1,    2,    4,    8,   11,   13,   14,   16,   19,    3,    5,    6,    7,    9,   10,   12,   15,   17,   18,   20 ] ]


import Data.Char (toLower)
import Data.List (sortBy)
import Data.Ord (comparing)

-------------------- CUSTOM COMPARATORS ------------------

lengthThenAZ :: String -> String -> Ordering
lengthThenAZ = comparing length <> comparing (fmap toLower)

descLengthThenAZ :: String -> String -> Ordering
descLengthThenAZ =
  flip (comparing length)
    <> comparing (fmap toLower)

--------------------------- TEST -------------------------
main :: IO ()
main =
  mapM_
    putStrLn
    ( fmap
        unlines
        ( [sortBy] <*> [lengthThenAZ, descLengthThenAZ]
            <*> [ [ "Here",
                    "are",
                    "some",
                    "sample",
                    "strings",
                    "to",
                    "be",
                    "sorted"
                  ]
                ]
        )
    )


procedure main()                     #: demonstrate various ways to sort a list and string
   write("Sorting Demo for custom comparator")
   L := ["Here", "are", "some", "sample", "strings", "to", "be", "sorted"]
   write("  Unsorted Input : ")
   every write("    ",image(!L))
   shellsort(L,cmptask)                # most of the RC sorts will work here
   write("  Sorted Output : ")
   every write("    ",image(!L))
end

procedure cmptask(a,b)   # sort by descending length and ascending lexicographic order for strings of equal length
if (*a > *b) | ((*a = *b) & (map(a) << map(b))) then return b
end


declare
  proc {CocktailSort Arr}
     proc {Swap I J}
        Arr.J := (Arr.I := Arr.J) %% assignment returns the old value
     end
     IsSorted = {NewCell false}
     Up = {List.number {Array.low Arr} {Array.high Arr}-1 1}
     Down = {Reverse Up}
  in
     for until:@IsSorted break:Break do
	for Range in [Up Down] do
	   IsSorted := true
	   for I in Range do
	      if Arr.I > Arr.(I+1) then
		 IsSorted := false
		 {Swap I I+1}
	      end
	   end
	   if @IsSorted then {Break} end
	end
     end
  end
  Arr = {Tuple.toArray unit(10 9 8 7 6 5 4 3 2 1)}
in
  {CocktailSort Arr}
  {Inspect Arr}


cocktailSort(v)={
  while(1,
    my(done=1);
    for(i=2,#v,
      if(v[i-1]>v[i],
        my(t=v[i-1]);
        v[i-1]=v[i];
        v[i]=t;
        done=0
      )
    );
    if(done, return(v));
    done=1;
    forstep(i=#v,2,-1,
      if(v[i-1]>v[i],
        my(t=v[i-1]);
        v[i-1]=v[i];
        v[i]=t;
        done=0
      )
    );
    if(done, return(v))
  )
};


divert(-1)

define(`randSeed',141592653)
define(`setRand',
   `define(`randSeed',ifelse(eval($1<10000),1,`eval(20000-$1)',`$1'))')
define(`rand_t',`eval(randSeed^(randSeed>>13))')
define(`random',
   `define(`randSeed',eval((rand_t^(rand_t<<18))&0x7fffffff))randSeed')

define(`set',`define(`$1[$2]',`$3')')
define(`get',`defn(`$1[$2]')')
define(`new',`set($1,size,0)')
dnl  for the heap calculations, it's easier if origin is 0, so set value first
define(`append',
   `set($1,get($1,size),$2)`'set($1,size,incr(get($1,size)))')

dnl  swap(<name>,<j>,<name>[<j>],<k>)  using arg stack for the temporary
define(`swap',`set($1,$2,get($1,$4))`'set($1,$4,$3)')

define(`deck',
   `new($1)for(`x',1,$2,
         `append(`$1',eval(random%100))')')
define(`show',
   `for(`x',0,decr(get($1,size)),`get($1,x) ')')
define(`for',
   `ifelse($#,0,``$0'',
   `ifelse(eval($2<=$3),1,
   `pushdef(`$1',$2)$4`'popdef(`$1')$0(`$1',incr($2),$3,`$4')')')')

define(`ifywork',
   `ifelse(eval($2>=0),1,
      `siftdown($1,$2,$3)`'ifywork($1,decr($2),$3)')')
define(`heapify',
   `define(`start',eval((get($1,size)-2)/2))`'ifywork($1,start,
      decr(get($1,size)))')
define(`siftdown',
   `define(`child',eval($2*2+1))`'ifelse(eval(child<=$3),1,
       `ifelse(eval(child+1<=$3),1,
       `ifelse(eval(get($1,child)<get($1,incr(child))),1,
       `define(`child',
           incr(child))')')`'ifelse(eval(get($1,$2)<get($1,child)),1,
       `swap($1,$2,get($1,$2),child)`'siftdown($1,child,$3)')')')
define(`sortwork',
   `ifelse($2,0,
      `',
      `swap($1,0,get($1,0),$2)`'siftdown($1,0,decr($2))`'sortwork($1,
            decr($2))')')

define(`heapsort',
   `heapify($1)`'sortwork($1,decr(get($1,size)))')

divert
deck(`a',10)
show(`a')
heapsort(`a')
show(`a')


swap := proc(arr, a, b)
	local temp:
	temp := arr[a]:
	arr[a] := arr[b]:
	arr[b] := temp:
end proc:
heapify := proc(toSort, n, i)
	local largest, l, r, holder:
	largest := i:
	l := 2*i:
	r := 2*i+1:
	if (l <= n and toSort[l] > toSort[largest]) then
		largest := l:
	end if:
	if (r <= n and toSort[r] > toSort[largest]) then
		largest := r:
	end if:
	if (not largest = i) then
		swap(toSort, i, largest);
		heapify(toSort, n, largest):
	end if:
end proc:
heapsort := proc(arr)
	local n,i:
	n := numelems(arr):
	for i from trunc(n/2) to 1 by -1 do
		heapify(arr, n, i):
	end do:
	for i from n to 2 by -1 do
		swap(arr, 1, i):
		heapify(arr, i-1, 1):
	end do:
end proc:
arr := Array([17,3,72,0,36,2,3,8,40,0]);
heapsort(arr);
arr;


#!/bin/python3
from itertools import zip_longest

# This is wrong, it works only on specific examples
def beadsort(l):
    return list(map(sum, zip_longest(*[[1] * e for e in l], fillvalue=0)))

# Demonstration code:
print(beadsort([5,3,1,7,4,1,1]))