#lang racket/base
(require racket/match racket/list)

;; the car of a pile is the "bottom", i.e. where we place a card
(define (place-greedily ps-in c <?)
  (let inr ((vr null) (ps ps-in))
    (match ps
      [(list) (reverse (cons (list c) vr))]
      [(list (and psh (list ph _ ...)) pst ...)
       #:when (<? c ph) (append (reverse (cons (cons c psh) vr)) pst)]
      [(list psh pst ...) (inr (cons psh vr) pst)])))

(define (patience-sort cs-in <?)
  ;; Scatter
  (define piles
    (let scatter ((cs cs-in) (ps null))
      (match cs [(list) ps] [(cons a d) (scatter d (place-greedily ps a <?))])))
  ;; Gather
  (let gather ((rv null) (ps piles))
    (match ps
      [(list) (reverse rv)]
      [(list psh pst ...)
       (let scan ((least psh) (seens null) (unseens pst))
         (define least-card (car least))
         (match* (unseens least)
           [((list) (list l)) (gather (cons l rv) seens)]
           [((list) (cons l lt)) (gather (cons l rv) (cons lt seens))]
           [((cons (and ush (cons u _)) ust) (cons l _))
            #:when (<? l u) (scan least (cons ush seens) ust)]
           [((cons ush ust) least) (scan ush (cons least seens) ust)]))])))

(patience-sort (shuffle (for/list ((_ 10)) (random 7))) <)


multi patience(*@deck) {
    my @stacks;
    for @deck -> $card {
        with @stacks.first: $card before *[*-1] -> $stack {
            $stack.push: $card;
        }
        else {
            @stacks.push: [$card];
        }
    }
    gather while @stacks {
        take .pop given min :by(*[*-1]), @stacks;
        @stacks .= grep: +*;
    }
}

say ~patience ^10 . pick(*);


/*REXX program sorts a list of things (or items) using the  patience sort  algorithm.   */
parse arg xxx;     say ' input: '      xxx       /*obtain a list of things from the C.L.*/
n= words(xxx);     #= 0;       !.= 1             /*N:  # of things;  #:  number of piles*/
@.=                                              /* [↓]  append or create a pile  (@.j) */
   do i=1  for n;              q= word(xxx, i)   /* [↓]  construct the piles of things. */
                do j=1  for #                    /*add the   Q   thing (item) to a pile.*/
                if q>word(@.j,1)  then iterate   /*Is this item greater?   Then skip it.*/
                @.j= q  @.j;           iterate i /*add this item to the top of the pile.*/
                end   /*j*/                      /* [↑]  find a pile, or make a new pile*/
   #= # + 1                                      /*increase the pile count.             */
   @.#= q                                        /*define a new pile.                   */
   end                /*i*/                      /*we are done with creating the piles. */
$=                                               /* [↓]   build a thingy list from piles*/
   do k=1  until  words($)==n                    /*pick off the smallest from the piles.*/
   _=                                            /*this is the smallest thingy so far···*/
          do m=1  for  #;     z= word(@.m, !.m)  /*traipse through many piles of items. */
          if z==''  then iterate                 /*Is this pile null?    Then skip pile.*/
          if _==''  then _= z                    /*assume this one is the low pile value*/
          if _>=z   then do;  _= z;  p= m;  end  /*found a low value in a pile of items.*/
          end   /*m*/                            /*the traipsing is done, we found a low*/
   $= $ _                                        /*add to the output thingy  ($)  list. */
   !.p= !.p + 1                                  /*bump the thingy pointer in pile  P.  */
   end          /*k*/                            /* [↑]  each iteration finds a low item*/
                                                 /* [↓]  string  $  has a leading blank.*/
say 'output: '       strip($)                    /*stick a fork in it,  we're all done. */


class Array
  def patience_sort
    piles = []
    each do |i|
      if (idx = piles.index{|pile| pile.last <= i})
        piles[idx] << i
      else
        piles << [i]    #create a new pile
      end
    end
    # merge piles
    result = []
    until piles.empty?
      first = piles.map(&:first)
      idx = first.index(first.min)
      result << piles[idx].shift
      piles.delete_at(idx) if piles[idx].empty?
    end
    result
  end
end

a = [4, 65, 2, -31, 0, 99, 83, 782, 1]
p a.patience_sort


import scala.collection.mutable

object PatienceSort extends App {
  def sort[A](source: Iterable[A])(implicit bound: A => Ordered[A]): Iterable[A] = {
    val  piles = mutable.ListBuffer[mutable.Stack[A]]()

    def PileOrdering: Ordering[mutable.Stack[A]] =
      (a: mutable.Stack[A], b: mutable.Stack[A]) => b.head.compare(a.head)

    // Use a priority queue, to simplify extracting minimum elements.
    val pq = new mutable.PriorityQueue[mutable.Stack[A]]()(PileOrdering)

    // Create ordered piles of elements
    for (elem <- source) {
      // Find leftmost "possible" pile
      // If there isn't a pile available, add a new one.
      piles.find(p => p.head >= elem) match {
        case Some(p) => p.push(elem)
        case _ => piles += mutable.Stack(elem)
      }
    }

    pq ++= piles

    // Return a new list, by taking the smallest stack head
    // until all stacks are empty.
    for (_ <- source) yield {
      val smallestList = pq.dequeue
      val smallestVal = smallestList.pop

      if (smallestList.nonEmpty) pq.enqueue(smallestList)
      smallestVal
    }
  }

  println(sort(List(4, 65, 2, -31, 0, 99, 83, 782, 1)))
}


(define-library (rosetta-code k-way-merge)

  (export k-way-merge)

  (import (scheme base))
  (import (scheme case-lambda))
  (import (only (srfi 1) car+cdr))
  (import (only (srfi 1) reverse!))
  (import (only (srfi 132) list-merge))
  (import (only (srfi 151) bitwise-xor))

  (begin

    ;;
    ;; The algorithm employed here is "tournament tree" as in the
    ;; following article, which is based on Knuth, volume 3.
    ;;
    ;;   https://en.wikipedia.org/w/index.php?title=K-way_merge_algorithm&oldid=1047851465#Tournament_Tree
    ;;
    ;; However, I store a winners tree instead of the recommended
    ;; losers tree. If the tree were stored as linked nodes, it would
    ;; probably be more efficient to store a losers tree. However, I
    ;; am storing the tree as a Scheme vector, and one can find an
    ;; opponent quickly by simply toggling the least significant bit
    ;; of a competitor's array index.
    ;;

    (define // truncate-quotient)

    (define-record-type <infinity>
      (make-infinity)
      infinity?)

    (define infinity (make-infinity))

    (define (next-power-of-two n)
      ;; This need not be a fast implementation. It can assume n >= 3,
      ;; because one can use an ordinary 2-way merge for n = 2.
      (let loop ((pow2 4))
        (if (<= n pow2)
            pow2
            (loop (+ pow2 pow2)))))

    (define (play-game <? x y)
      (cond ((infinity? x) #f)
            ((infinity? y) #t)
            (else (not (<? y x)))))

    (define (build-tree <? heads)
      ;; We do not use vector indices of zero. Thus our indexing is
      ;; 1-based.
      (let* ((total-external-nodes (next-power-of-two
                                    (vector-length heads)))
             (total-nodes (- (* 2 total-external-nodes) 1))
             (winners (make-vector (+ total-nodes 1))))
        (do ((i 0 (+ i 1)))
            ((= i total-external-nodes))
          (let ((j (+ total-external-nodes i)))
            (if (< i (vector-length heads))
                (let ((entry (cons (vector-ref heads i) i)))
                  (vector-set! winners j entry))
                (let ((entry (cons infinity i)))
                  (vector-set! winners j entry)))))
        (let loop ((istart total-external-nodes))
          (do ((i istart (+ i 2)))
              ((= i (+ istart istart)))
            (let* ((i1 i)
                   (i2 (bitwise-xor i 1))
                   (elem1 (car (vector-ref winners i1)))
                   (elem2 (car (vector-ref winners i2)))
                   (wins1? (play-game <? elem1 elem2))
                   (iwinner (if wins1? i1 i2))
                   (winner (vector-ref winners iwinner))
                   (iparent (// i 2)))
              (vector-set! winners iparent winner)))
          (if (= istart 2)
              winners
              (loop (// istart 2))))))

    (define (replay-games <? winners i)
      (let loop ((i i))
        (unless (= i 1)
          (let* ((i1 i)
                 (i2 (bitwise-xor i 1))
                 (elem1 (car (vector-ref winners i1)))
                 (elem2 (car (vector-ref winners i2)))
                 (wins1? (play-game <? elem1 elem2))
                 (iwinner (if wins1? i1 i2))
                 (winner (vector-ref winners iwinner))
                 (iparent (// i 2)))
            (vector-set! winners iparent winner)
            (loop iparent)))))

    (define (get-next lst)
      (if (null? lst)
          (values infinity lst)      ; End of list. Return a sentinel.
          (car+cdr lst)))

    (define (merge-lists <? lists)
      (let* ((heads (list->vector (map car lists)))
             (tails (list->vector (map cdr lists))))
        (let ((winners (build-tree <? heads)))
          (let loop ((outputs '()))
            (let-values (((winner-value winner-index)
                          (car+cdr (vector-ref winners 1))))
              (if (infinity? winner-value)
                  (reverse! outputs)
                  (let-values
                      (((hd tl)
                        (get-next (vector-ref tails winner-index))))
                    (vector-set! tails winner-index tl)
                    (let ((entry (cons hd winner-index))
                          (i (+ (// (vector-length winners) 2)
                                winner-index)))
                      (vector-set! winners i entry)
                      (replay-games <? winners i)
                      (loop (cons winner-value outputs))))))))))

    (define k-way-merge
      (case-lambda
        ((<? lst1) lst1)
        ((<? lst1 lst2) (list-merge <? lst1 lst2))
        ((<? . lists) (merge-lists <? lists))))

    )) ;; library (rosetta-code k-way-merge)

(define-library (rosetta-code patience-sort)

  (export patience-sort)

  (import (scheme base))
  (import (rosetta-code k-way-merge))

  (begin

    (define (find-pile <? x num-piles piles)
      ;;
      ;; Do a Bottenbruch search for the leftmost pile whose top is
      ;; greater than or equal to x. The search starts at 0 and ends
      ;; at (- num-piles 1). Return an index such that:
      ;;
      ;;   * if x is greater than the top element at the far right,
      ;;     then the index returned will be num-piles.
      ;;
      ;;   * otherwise, x is greater than every top element to the
      ;;     left of index, and less than or equal to the top elements
      ;;     at index and to the right of index.
      ;;
      ;; References:
      ;;
      ;;   * H. Bottenbruch, "Structure and use of ALGOL 60", Journal
      ;;     of the ACM, Volume 9, Issue 2, April 1962, pp.161-221.
      ;;     https://doi.org/10.1145/321119.321120
      ;;
      ;;     The general algorithm is described on pages 214 and 215.
      ;;
      ;;   * https://en.wikipedia.org/w/index.php?title=Binary_search_algorithm&oldid=1062988272#Alternative_procedure
      ;;
      (let loop ((j 0)
                 (k (- num-piles 1)))
        (if (= j k)
            (if (or (not (= j (- num-piles 1)))
                    (not (<? (car (vector-ref piles j)) x)))
                j                      ; x fits onto one of the piles.
                (+ j 1))               ; x needs a new pile.
            (let ((i (floor-quotient (+ j k) 2)))
              (if (<? (car (vector-ref piles i)) x)
                  ;; x is greater than the element at i.
                  (loop (+ i 1) k)
                  (loop j i))))))

    (define (resize-table table-size num-piles piles)
      ;; If necessary, allocate a new table of larger size.
      (if (not (= num-piles table-size))
          (values table-size piles)
          (let* ((new-size (* table-size 2))
                 (new-piles (make-vector new-size)))
            (vector-copy! new-piles 0 piles)
            (values new-size new-piles))))

    (define initial-table-size 64)

    (define (deal <? lst)
      (let loop ((lst lst)
                 (table-size initial-table-size)
                 (num-piles 0)
                 (piles (make-vector initial-table-size)))
        (cond ((null? lst) (values num-piles piles))
              ((zero? num-piles)
               (vector-set! piles 0 (list (car lst)))
               (loop (cdr lst) table-size 1 piles))
              (else
               (let* ((x (car lst))
                      (i (find-pile <? x num-piles piles)))
                 (if (= i num-piles)
                     (let-values (((table-size piles)
                                   (resize-table table-size num-piles
                                                 piles)))
                       ;; Start a new pile at the far right.
                       (vector-set! piles num-piles (list x))
                       (loop (cdr lst) table-size (+ num-piles 1)
                             piles))
                     (begin
                       (vector-set! piles i
                                    (cons x (vector-ref piles i)))
                       (loop (cdr lst) table-size num-piles
                             piles))))))))

    (define (patience-sort <? lst)
      (let-values (((num-piles piles) (deal <? lst)))
        (apply k-way-merge
               (cons <? (vector->list piles 0 num-piles)))))

    )) ;; library (rosetta-code patience-sort)

;;--------------------------------------------------------------------
;;
;; A little demonstration.
;;

(import (scheme base))
(import (scheme write))
(import (rosetta-code patience-sort))

(define example-numbers '(22 15 98 82 22 4 58 70 80 38 49 48 46 54 93
                             8 54 2 72 84 86 76 53 37 90))
(display "unsorted   ")
(write example-numbers)
(newline)
(display "sorted     ")
(write (patience-sort < example-numbers))
(newline)

;;--------------------------------------------------------------------


func patience(deck) {
  var stacks = [];
  deck.each { |card|
    given (stacks.first { card < .last }) { |stack|
      case (defined stack) {
        stack << card
      }
      default {
        stacks << [card]
      }
    }
  }

  gather {
    while (stacks) {
      take stacks.min_by { .last }.pop
      stacks.grep!{ !.is_empty }
    }
  }
}

var a = [4, 65, 2, -31, 0, 99, 83, 782, 1]
say patience(a)


structure PilePriority = struct
  type priority = int
  fun compare (x, y) = Int.compare (y, x) (* we want min-heap *)
  type item = int list
  val priority = hd
end

structure PQ = LeftPriorityQFn (PilePriority)

fun sort_into_piles n =
  let
    val piles = DynamicArray.array (length n, [])
    fun bsearch_piles x =
      let
        fun aux (lo, hi) =
          if lo > hi then
            lo
          else
            let
              val mid = (lo + hi) div 2
            in
              if hd (DynamicArray.sub (piles, mid)) < x then
                aux (mid+1, hi)
              else
                aux (lo, mid-1)
            end
      in
        aux (0, DynamicArray.bound piles)
      end
    fun f x =
      let
        val i = bsearch_piles x
      in
        DynamicArray.update (piles, i, x :: DynamicArray.sub (piles, i))
      end
  in
    app f n;
    piles
  end

fun merge_piles piles =
  let
    val heap = DynamicArray.foldl PQ.insert PQ.empty piles
    fun f (heap, acc) =
      case PQ.next heap of
        NONE => acc
      | SOME (x::xs, heap') =>
        f ((if null xs then heap' else PQ.insert (xs, heap')),
           x::acc)
  in
    rev (f (heap, []))
  end

fun patience_sort n =
  merge_piles (sort_into_piles n)


F _quicksort(&array, start, stop) -> N
   I stop - start > 0
      V pivot = array[start]
      V left = start
      V right = stop
      L left <= right
         L array[left] < pivot
            left++
         L array[right] > pivot
            right--
         I left <= right
            swap(&array[left], &array[right])
            left++
            right--
      _quicksort(&array, start, right)
      _quicksort(&array, left, stop)

F quicksort(&array)
   _quicksort(&array, 0, array.len - 1)

V arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
quicksort(&arr)
print(arr)


package require Tcl 8.6

proc patienceSort {items} {
    # Make the piles
    set piles {}
    foreach item $items {
	set p [lsearch -bisect -index end $piles $item]
	if {$p == -1} {
	    lappend piles [list $item]
	} else {
	    lset piles $p end+1 $item
	}
    }
    # Merge the piles; no suitable builtin, alas
    set indices [lrepeat [llength $piles] 0]
    set result {}
    while 1 {
	set j 0
	foreach pile $piles i $indices {
	    set val [lindex $pile $i]
	    if {$i < [llength $pile] && (![info exist min] || $min > $val)} {
		set k $j
		set next [incr i]
		set min $val
	    }
	    incr j
	}
	if {![info exist min]} break
	lappend result $min
	unset min
	lset indices $k $next
    }
    return $result
}


import "/sort" for Cmp

var patienceSort = Fn.new { |a|
    var size = a.count
    if (size < 2) return
    var cmp = Cmp.default(a[0])
    var piles = []
    for (e in a) {
        var outer = false
        for (pile in piles) {
            if (cmp.call(pile[-1], e) > 0) {
                pile.add(e)
                outer = true
                break
            }
        }
        if (!outer) piles.add([e])
    }
    for (i in 0...size) {
        var min = piles[0][-1]
        var minPileIndex = 0
        for (j in 1...piles.count) {
            if (cmp.call(piles[j][-1], min) < 0) {
                min = piles[j][-1]
                minPileIndex = j
            }
        }
        a[i] = min
        var minPile = piles[minPileIndex]
        minPile.removeAt(-1)
        if (minPile.count == 0) piles.removeAt(minPileIndex)
    }
}

var ia = [4, 65, 2, -31, 0, 99, 83, 782, 1]
patienceSort.call(ia)
System.print(ia)

var ca = ["n", "o", "n", "z", "e", "r", "o", "s", "u", "m"]
patienceSort.call(ca)
System.print(ca)

var sa = ["dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu"]
patienceSort.call(sa)
System.print(sa)


*        Quicksort                 14/09/2015 & 23/06/2016
QUICKSOR CSECT
         USING  QUICKSOR,R13       base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    prolog
         ST     R13,4(R15)         "
         ST     R15,8(R13)         "
         LR     R13,R15            "
         MVC    A,=A(1)            a(1)=1
         MVC    B,=A(NN)           b(1)=hbound(t)
         L      R6,=F'1'           k=1
       DO WHILE=(LTR,R6,NZ,R6)   do while k<>0    ==================
         LR     R1,R6              k
         SLA    R1,2               ~
         L      R10,A-4(R1)        l=a(k)
         LR     R1,R6              k
         SLA    R1,2               ~
         L      R11,B-4(R1)        m=b(k)
         BCTR   R6,0               k=k-1
         LR     R4,R11             m
         C      R4,=F'2'           if m<2
         BL     ITERATE            then iterate
         LR     R2,R10             l
         AR     R2,R11             +m
         BCTR   R2,0               -1
         ST     R2,X               x=l+m-1
         LR     R2,R11             m
         SRA    R2,1               m/2
         AR     R2,R10             +l
         ST     R2,Y               y=l+m/2
         L      R1,X               x
         SLA    R1,2               ~
         L      R4,T-4(R1)         r4=t(x)
         L      R1,Y               y
         SLA    R1,2               ~
         L      R5,T-4(R1)         r5=t(y)
         LR     R1,R10             l
         SLA    R1,2               ~
         L      R3,T-4(R1)         r3=t(l)
         IF     CR,R4,LT,R3        if t(x)<t(l)       ---+
         IF     CR,R5,LT,R4          if t(y)<t(x)        |
         LR     R7,R4                  p=t(x)            |
         L      R1,X                   x                 |
         SLA    R1,2                   ~                 |
         ST     R3,T-4(R1)             t(x)=t(l)         |
         ELSEIF CR,R5,GT,R3          elseif t(y)>t(l)    |
         LR     R7,R3                  p=t(l)            |
         ELSE   ,                    else                |
         LR     R7,R5                  p=t(y)            |
         L      R1,Y                   y                 |
         SLA    R1,2                   ~                 |
         ST     R3,T-4(R1)            t(y)=t(l)          |
         ENDIF  ,                    end if              |
         ELSE   ,                  else                  |
         IF     CR,R5,LT,R3          if t(y)<t(l)        |
         LR     R7,R3                  p=t(l)            |
         ELSEIF CR,R5,GT,R4          elseif t(y)>t(x)    |
         LR     R7,R4                  p=t(x)            |
         L      R1,X                   x                 |
         SLA    R1,2                   ~                 |
         ST     R3,T-4(R1)             t(x)=t(l)         |
         ELSE   ,                    else                |
         LR     R7,R5                  p=t(y)            |
         L      R1,Y                   y                 |
         SLA    R1,2                   ~                 |
         ST     R3,T-4(R1)             t(y)=t(l)         |
         ENDIF  ,                    end if              |
         ENDIF  ,                  end if             ---+
         LA     R8,1(R10)          i=l+1
         L      R9,X               j=x
FOREVER  EQU    *                  do forever  --------------------+
         LR     R1,R8                i                             |
         SLA    R1,2                 ~                             |
         LA     R2,T-4(R1)           @t(i)                         |
         L      R0,0(R2)             t(i)                          |
         DO WHILE=(CR,R8,LE,R9,AND,  while i<=j and   ---+         |   X
               CR,R0,LE,R7)                t(i)<=p       |         |
         AH     R8,=H'1'               i=i+1             |         |
         AH     R2,=H'4'               @t(i)             |         |
         L      R0,0(R2)               t(i)              |         |
         ENDDO  ,                    end while        ---+         |
         LR     R1,R9                j                             |
         SLA    R1,2                 ~                             |
         LA     R2,T-4(R1)           @t(j)                         |
         L      R0,0(R2)             t(j)                          |
         DO WHILE=(CR,R8,LT,R9,AND,  while i<j and    ---+         |   X
               CR,R0,GE,R7)                t(j)>=p       |         |
         SH     R9,=H'1'               j=j-1             |         |
         SH     R2,=H'4'               @t(j)             |         |
         L      R0,0(R2)               t(j)              |         |
         ENDDO  ,                    end while        ---+         |
         CR     R8,R9                if i>=j                       |
         BNL    LEAVE                then leave (segment finished) |
         LR     R1,R8                i                             |
         SLA    R1,2                 ~                             |
         LA     R2,T-4(R1)           @t(i)                         |
         LR     R1,R9                j                             |
         SLA    R1,2                 ~                             |
         LA     R3,T-4(R1)           @t(j)                         |
         L      R0,0(R2)             w=t(i)       +                |
         MVC    0(4,R2),0(R3)        t(i)=t(j)    |swap t(i),t(j)  |
         ST     R0,0(R3)             t(j)=w       +                |
         B      FOREVER            end do forever  ----------------+
LEAVE    EQU    *
         LR     R9,R8              j=i
         BCTR   R9,0               j=i-1
         LR     R1,R9              j
         SLA    R1,2               ~
         LA     R3,T-4(R1)         @t(j)
         L      R2,0(R3)           t(j)
         LR     R1,R10             l
         SLA    R1,2               ~
         ST     R2,T-4(R1)         t(l)=t(j)
         ST     R7,0(R3)           t(j)=p
         LA     R6,1(R6)           k=k+1
         LR     R1,R6              k
         SLA    R1,2               ~
         LA     R4,A-4(R1)         [email protected](k)
         LA     R5,B-4(R1)         [email protected](k)
         IF     C,R8,LE,Y          if i<=y           ----+
         ST     R8,0(R4)             a(k)=i              |
         L      R2,X                 x                   |
         SR     R2,R8                -i                  |
         LA     R2,1(R2)             +1                  |
         ST     R2,0(R5)             b(k)=x-i+1          |
         LA     R6,1(R6)             k=k+1               |
         ST     R10,4(R4)            a(k)=l              |
         LR     R2,R9                j                   |
         SR     R2,R10               -l                  |
         ST     R2,4(R5)             b(k)=j-l            |
         ELSE   ,                  else                  |
         ST     R10,4(R4)            a(k)=l              |
         LR     R2,R9                j                   |
         SR     R2,R10               -l                  |
         ST     R2,0(R5)             b(k)=j-l            |
         LA     R6,1(R6)             k=k+1               |
         ST     R8,4(R4)             a(k)=i              |
         L      R2,X                 x                   |
         SR     R2,R8                -i                  |
         LA     R2,1(R2)             +1                  |
         ST     R2,4(R5)             b(k)=x-i+1          |
         ENDIF  ,                  end if            ----+
ITERATE  EQU    *
       ENDDO    ,                  end while  =====================
*        ***    *********          print sorted table
         LA     R3,PG              ibuffer
         LA     R4,T               @t(i)
       DO WHILE=(C,R4,LE,=A(TEND)) do i=1 to hbound(t)
         L      R2,0(R4)             t(i)
         XDECO  R2,XD                edit t(i)
         MVC    0(4,R3),XD+8         put in buffer
         LA     R3,4(R3)             ibuffer=ibuffer+1
         LA     R4,4(R4)             i=i+1
       ENDDO    ,                  end do
         XPRNT  PG,80              print buffer
         L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    "
         XR     R15,R15            "
         BR     R14                exit
T        DC     F'10',F'9',F'9',F'6',F'7',F'16',F'1',F'16',F'17',F'15'
         DC     F'1',F'9',F'18',F'16',F'8',F'20',F'18',F'2',F'19',F'8'
TEND     DS     0F
NN       EQU    (TEND-T)/4)
A        DS     (NN)F              same size as T
B        DS     (NN)F              same size as T
X        DS     F
Y        DS     F
PG       DS     CL80
XD       DS     CL12
         YREGS
         END    QUICKSOR


fcn patienceSort(ns){
   piles:=L();
   foreach n in (ns){ newPile:=True;   // create list of sorted lists
      foreach p in (piles){
	 if(n>=p[-1]) { p.append(n); newPile=False; break; }
      }
      if(newPile)piles.append(L(n));
   }
   // merge sort the piles
   r:=Sink(List); while(piles){
      mins:=piles.apply("get",0).enumerate();
      min :=mins.reduce(fcn(a,b){ (a[1]<b[1]) and a or b },mins[0])[0];
      r.write(piles[min].pop(0));
      if(not piles[min]) piles.del(min);
   }
   r.close();
}


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

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

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

.align 4
TableNumber:      .quad   1,3,6,2,5,9,10,8,4,7,11
#TableNumber:     .quad   10,9,8,7,6,-5,4,3,2,1
                 .equ NBELEMENTS, (. - TableNumber) / 8
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:       .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              // entry of program
    ldr x0,qAdrTableNumber                         // address number table
    mov x1,0                                       // first element
    mov x2,NBELEMENTS                              // number of élements
    bl quickSort
    ldr x0,qAdrTableNumber                         // address number table
    bl displayTable

    ldr x0,qAdrTableNumber                         // address number table
    mov x1,NBELEMENTS                              // number of élements
    bl isSorted                                    // control sort
    cmp x0,1                                       // sorted ?
    beq 1f
    ldr x0,qAdrszMessSortNok                       // no !! error sort
    bl affichageMess
    b 100f
1:                                                 // yes
    ldr x0,qAdrszMessSortOk
    bl affichageMess
100:                                               // standard end of the program
    mov x0,0                                       // return code
    mov x8,EXIT                                    // request to exit program
    svc 0                                          // perform the system call

qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableNumber:          .quad TableNumber
qAdrszMessSortOk:         .quad szMessSortOk
qAdrszMessSortNok:        .quad szMessSortNok
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements  > 0  */
/* x0 return 0  if not sorted   1  if sorted */
isSorted:
    stp x2,lr,[sp,-16]!             // save  registers
    stp x3,x4,[sp,-16]!             // save  registers
    mov x2,0
    ldr x4,[x0,x2,lsl 3]
1:
    add x2,x2,1
    cmp x2,x1
    bge 99f
    ldr x3,[x0,x2, lsl 3]
    cmp x3,x4
    blt 98f
    mov x4,x3
    b 1b
98:
    mov x0,0                       // not sorted
    b 100f
99:
    mov x0,1                       // sorted
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/***************************************************/
/*   Appel récursif Tri Rapide quicksort           */
/***************************************************/
/* x0 contains the address of table */
/* x1 contains index of first item  */
/* x2 contains the number of elements  > 0  */
quickSort:
    stp x2,lr,[sp,-16]!             // save  registers
    stp x3,x4,[sp,-16]!             // save  registers
    str x5,   [sp,-16]!             // save  registers
    sub x2,x2,1                     // last item index
    cmp x1,x2                       // first > last ?
    bge 100f                        // yes -> end
    mov x4,x0                       // save x0
    mov x5,x2                       // save x2
    bl partition1                   // cutting into 2 parts
    mov x2,x0                       // index partition
    mov x0,x4                       // table address
    bl quickSort                    // sort lower part
    add x1,x2,1                     // index begin = index partition + 1
    add x2,x5,1                     // number of elements
    bl quickSort                    // sort higter part

 100:                               // end function
    ldr x5,   [sp],16               // restaur  1 register
    ldp x3,x4,[sp],16               // restaur  2 registers
    ldp x2,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30

/******************************************************************/
/*      Partition table elements                                */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains index of first item  */
/* x2 contains index of last item   */
partition1:
    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
    ldr x3,[x0,x2,lsl 3]            // load value last index
    mov x4,x1                       // init with first index
    mov x5,x1                       // init with first index
1:                                  // begin loop
    ldr x6,[x0,x5,lsl 3]            // load value
    cmp x6,x3                       // compare value
    bge 2f
    ldr x7,[x0,x4,lsl 3]            // if < swap value table
    str x6,[x0,x4,lsl 3]
    str x7,[x0,x5,lsl 3]
    add x4,x4,1                     // and increment index 1
2:
    add x5,x5,1                     // increment index 2
    cmp x5,x2                       // end ?
    blt 1b                          // no loop
    ldr x7,[x0,x4,lsl 3]            // swap value
    str x3,[x0,x4,lsl 3]
    str x7,[x0,x2,lsl 3]
    mov x0,x4                       // return index partition
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

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    mov x2,x0                        // table address
    mov x3,0
1:                                   // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv
    bl conversion10S                  // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc            // insert result at // character
    bl affichageMess                 // display message
    add x3,x3,1
    cmp x3,NBELEMENTS - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
    mov x0,x2
100:
    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"


report z_quicksort.

data(numbers) = value int4_table( ( 4 ) ( 65 ) ( 2 ) ( -31 ) ( 0 ) ( 99 ) ( 2 ) ( 83 ) ( 782 ) ( 1 ) ).
perform quicksort changing numbers.

write `[`.
loop at numbers assigning field-symbol(<numbers>).
  write <numbers>.
endloop.
write `]`.

form quicksort changing numbers type int4_table.
  data(less) = value int4_table( ).
  data(equal) = value int4_table( ).
  data(greater) = value int4_table( ).

  if lines( numbers ) > 1.
    data(pivot) = numbers[ lines( numbers ) / 2 ].

    loop at numbers assigning field-symbol(<number>).
      if <number> < pivot.
        append <number> to less.
      elseif <number> = pivot.
        append <number> to equal.
      elseif <number> > pivot.
        append <number> to greater.
      endif.
    endloop.

    perform quicksort changing less.
    perform quicksort changing greater.

    clear numbers.
    append lines of less to numbers.
    append lines of equal to numbers.
    append lines of greater to numbers.
  endif.
endform.


(defun partition (p xs)
   (if (endp xs)
       (mv nil nil)
       (mv-let (less more)
               (partition p (rest xs))
          (if (< (first xs) p)
              (mv (cons (first xs) less) more)
              (mv less (cons (first xs) more))))))

(defun qsort (xs)
   (if (endp xs)
       nil
       (mv-let (less more)
               (partition (first xs) (rest xs))
          (append (qsort less)
                  (list (first xs))
                  (qsort more)))))


DEFINE MAX_COUNT="100"
INT ARRAY stack(MAX_COUNT)
INT stackSize

PROC PrintArray(INT ARRAY a INT size)
  INT i

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

PROC InitStack()
  stackSize=0
RETURN

BYTE FUNC IsEmpty()
  IF stackSize=0 THEN
    RETURN (1)
  FI
RETURN (0)

PROC Push(INT low,high)
  stack(stackSize)=low  stackSize==+1
  stack(stackSize)=high stackSize==+1
RETURN

PROC Pop(INT POINTER low,high)
  stackSize==-1 high^=stack(stackSize)
  stackSize==-1 low^=stack(stackSize)
RETURN

INT FUNC Partition(INT ARRAY a INT low,high)
  INT part,v,i,tmp

  v=a(high)
  part=low-1

  FOR i=low TO high-1
  DO
    IF a(i)<=v THEN
      part==+1
      tmp=a(part) a(part)=a(i) a(i)=tmp
    FI
  OD

  part==+1
  tmp=a(part) a(part)=a(high) a(high)=tmp
RETURN (part)

PROC QuickSort(INT ARRAY a INT size)
  INT low,high,part

  InitStack()
  Push(0,size-1)
  WHILE IsEmpty()=0
  DO
    Pop(@low,@high)
    part=Partition(a,low,high)
    IF part-1>low THEN
      Push(low,part-1)
    FI
    IF part+1<high THEN
      Push(part+1,high)
    FI
  OD
RETURN

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

PROC Main()
  INT ARRAY
    a(10)=[1 4 65535 0 3 7 4 8 20 65530],
    b(21)=[10 9 8 7 6 5 4 3 2 1 0
      65535 65534 65533 65532 65531
      65530 65529 65528 65527 65526],
    c(8)=[101 102 103 104 105 106 107 108],
    d(12)=[1 65535 1 65535 1 65535 1
      65535 1 65535 1 65535]

  Test(a,10)
  Test(b,21)
  Test(c,8)
  Test(d,12)
RETURN


function quickSort (array:Array):Array
{
    if (array.length <= 1)
        return array;

    var pivot:Number = array[Math.round(array.length / 2)];

    return quickSort(array.filter(function (x:Number, index:int, array:Array):Boolean { return x <  pivot; })).concat(
            array.filter(function (x:Number, index:int, array:Array):Boolean { return x == pivot; })).concat(
        quickSort(array.filter(function (x:Number, index:int, array:Array):Boolean { return x > pivot; })));
}


-----------------------------------------------------------------------
-- Generic Quick_Sort procedure
-----------------------------------------------------------------------
generic
   type Element is private;
   type Index is (<>);
   type Element_Array is array(Index range <>) of Element;
   with function "<" (Left, Right : Element) return Boolean is <>;
procedure Quick_Sort(A : in out Element_Array);


#--- Swap function ---#
PROC swap = (REF []INT array, INT first, INT second) VOID:
(
    INT temp := array[first];
    array[first] := array[second];
    array[second]:= temp
);

#--- Quick sort 3 arg function ---#
PROC quick = (REF [] INT array, INT first, INT last) VOID:
(
    INT smaller := first + 1,
        larger  := last,
        pivot   := array[first];

    WHILE smaller <= larger DO
        WHILE array[smaller] < pivot   AND   smaller < last DO
            smaller +:= 1
        OD;
        WHILE array[larger]  > pivot   AND   larger > first DO
            larger  -:= 1
        OD;
        IF smaller < larger THEN
            swap(array, smaller, larger);
            smaller +:= 1;
            larger  -:= 1
        ELSE
            smaller +:= 1
        FI
    OD;

    swap(array, first, larger);

    IF first < larger-1 THEN
        quick(array, first, larger-1)
    FI;
    IF last > larger +1 THEN
        quick(array, larger+1, last)
    FI
);

#--- Quick sort 1 arg function ---#
PROC quicksort = (REF []INT array) VOID:
(
  IF UPB array > 1 THEN
    quick(array, 1, UPB array)
  FI
);

#***************************************************************#
main:
(
    [10]INT a;
    FOR i FROM 1 TO UPB a DO
        a[i] := ROUND(random*1000)
    OD;

    print(("Before:", a));
    quicksort(a);
    print((newline, newline));
    print(("After: ", a))
)


% Quicksorts in-place the array of integers v, from lb to ub %
procedure quicksort ( integer array v( * )
                    ; integer value lb, ub
                    ) ;
if ub > lb then begin
    % more than one element, so must sort %
    integer left, right, pivot;
    left   := lb;
    right  := ub;
    % choosing the middle element of the array as the pivot %
    pivot  := v( left + ( ( right + 1 ) - left ) div 2 );
    while begin
        while left  <= ub and v( left  ) < pivot do left  := left  + 1;
        while right >= lb and v( right ) > pivot do right := right - 1;
        left <= right
    end do begin
        integer swap;
        swap       := v( left  );
        v( left  ) := v( right );
        v( right ) := swap;
        left       := left  + 1;
        right      := right - 1
    end while_left_le_right ;
    quicksort( v, lb,   right );
    quicksort( v, left, ub    )
end quicksort ;


-- quickSort :: (Ord a) => [a] -> [a]
on quickSort(xs)
    if length of xs > 1 then
        set {h, t} to uncons(xs)

        -- lessOrEqual :: a -> Bool
        script lessOrEqual
            on |λ|(x)
                x ≤ h
            end |λ|
        end script

        set {less, more} to partition(lessOrEqual, t)

        quickSort(less) & h & quickSort(more)
    else
        xs
    end if
end quickSort

-- TEST -----------------------------------------------------------------------
on run

    quickSort([11.8, 14.1, 21.3, 8.5, 16.7, 5.7])

    --> {5.7, 8.5, 11.8, 14.1, 16.7, 21.3}

end run

-- GENERIC FUNCTIONS ----------------------------------------------------------

-- partition :: predicate -> List -> (Matches, nonMatches)
-- partition :: (a -> Bool) -> [a] -> ([a], [a])
on partition(f, xs)
    tell mReturn(f)
        set lst to {{}, {}}
        repeat with x in xs
            set v to contents of x
            set end of item ((|λ|(v) as integer) + 1) of lst to v
        end repeat
        return {item 2 of lst, item 1 of lst}
    end tell
end partition

-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    if length of xs > 0 then
        {item 1 of xs, rest of xs}
    else
        missing value
    end if
end uncons

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


(def qs (seq)
  (if (empty seq) nil
      (let pivot (car seq)
	(join (qs (keep [< _ pivot] (cdr seq)))
	      (list pivot)
	      (qs (keep [>= _ pivot] (cdr seq)))))))


/* ARM assembly Raspberry PI  */
/*  program quickSort.s   */
/* look pseudo code in wikipedia  quicksort */

/************************************/
/* Constantes                       */
/************************************/
.equ STDOUT, 1     @ Linux output console
.equ EXIT,   1     @ Linux syscall
.equ WRITE,  4     @ Linux syscall
/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .ascii "Value  : "
sMessValeur:        .fill 11, 1, ' '            @ size => 11
szCarriageReturn:   .asciz "\n"

.align 4
iGraine:  .int 123456
.equ NBELEMENTS,      10
#TableNumber:	     .int   9,5,6,1,2,3,10,8,4,7
#TableNumber:	     .int   1,3,5,2,4,6,10,8,4,7
#TableNumber:	     .int   1,3,5,2,4,6,10,8,4,7
#TableNumber:	     .int   1,2,3,4,5,6,10,8,4,7
TableNumber:	     .int   10,9,8,7,6,5,4,3,2,1
#TableNumber:	     .int   13,12,11,10,9,8,7,6,5,4,3,2,1
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              @ entry of program

1:
    ldr r0,iAdrTableNumber                         @ address number table

    mov r1,#0                                      @ indice first item
    mov r2,#NBELEMENTS                             @ number of élements
    bl triRapide                                   @ call quicksort
    ldr r0,iAdrTableNumber                         @ address number table
    bl displayTable

    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#NBELEMENTS                             @ number of élements
    bl isSorted                                    @ control sort
    cmp r0,#1                                      @ sorted ?
    beq 2f
    ldr r0,iAdrszMessSortNok                       @ no !! error sort
    bl affichageMess
    b 100f
2:                                                 @ yes
    ldr r0,iAdrszMessSortOk
    bl affichageMess
100:                                               @ standard end of the program
    mov r0, #0                                     @ return code
    mov r7, #EXIT                                  @ request to exit program
    svc #0                                         @ perform the system call

iAdrsMessValeur:          .int sMessValeur
iAdrszCarriageReturn:    .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrszMessSortOk:         .int szMessSortOk
iAdrszMessSortNok:        .int szMessSortNok
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements  > 0  */
/* r0 return 0  if not sorted   1  if sorted */
isSorted:
    push {r2-r4,lr}                                    @ save registers
    mov r2,#0
    ldr r4,[r0,r2,lsl #2]
1:
    add r2,#1
    cmp r2,r1
    movge r0,#1
    bge 100f
    ldr r3,[r0,r2, lsl #2]
    cmp r3,r4
    movlt r0,#0
    blt 100f
    mov r4,r3
    b 1b
100:
    pop {r2-r4,lr}
    bx lr                                              @ return

/***************************************************/
/*   Appel récursif Tri Rapide quicksort           */
/***************************************************/
/* r0 contains the address of table */
/* r1 contains index of first item  */
/* r2 contains the number of elements  > 0  */
triRapide:
    push {r2-r5,lr}                                   @ save registers
    sub r2,#1                                         @ last item index
    cmp r1,r2                                         @ first > last ?
    bge 100f                                          @ yes -> end
    mov r4,r0                                         @ save r0
    mov r5,r2                                         @ save r2
    bl partition1                                     @ cutting into 2 parts
    mov r2,r0                                         @ index partition
    mov r0,r4                                         @ table address
    bl triRapide                                      @ sort lower part
    add r1,r2,#1                                      @ index begin = index partition + 1
    add r2,r5,#1                                      @ number of elements
    bl triRapide                                      @ sort higter part

 100:                                                 @ end function
    pop {r2-r5,lr}                                    @ restaur  registers
    bx lr                                             @ return

/******************************************************************/
/*      Partition table elements                                */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains index of first item  */
/* r2 contains index of last item   */

partition1:
    push {r1-r7,lr}                                    @ save registers
    ldr r3,[r0,r2,lsl #2]                              @ load value last index
    mov r4,r1                                          @ init with first index
    mov r5,r1                                          @ init with first index
1:                                                     @ begin loop
    ldr r6,[r0,r5,lsl #2]                              @ load value
    cmp r6,r3                                          @ compare value
    ldrlt r7,[r0,r4,lsl #2]                            @ if < swap value table
    strlt r6,[r0,r4,lsl #2]
    strlt r7,[r0,r5,lsl #2]
    addlt r4,#1                                        @ and increment index 1
    add    r5,#1                                       @ increment index 2
    cmp r5,r2                                          @ end ?
    blt 1b                                             @ no loop
    ldr r7,[r0,r4,lsl #2]                              @ swap value
    str r3,[r0,r4,lsl #2]
    str r7,[r0,r2,lsl #2]
    mov r0,r4                                          @ return index partition
100:
    pop {r1-r7,lr}
    bx lr

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsMessValeur                             @ display value
    bl conversion10                                    @ call function
    ldr r0,iAdrsMessResult
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBELEMENTS - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
100:
    pop {r0-r3,lr}
    bx lr
/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {r0,r1,r2,r7,lr}                          @ save  registres
    mov r2,#0                                      @ counter length
1:                                                 @ loop length calculation
    ldrb r1,[r0,r2]                                @ read octet start position + index
    cmp r1,#0                                      @ if 0 its over
    addne r2,r2,#1                                 @ else add 1 in the length
    bne 1b                                         @ and loop
                                                   @ so here r2 contains the length of the message
    mov r1,r0                                      @ address message in r1
    mov r0,#STDOUT                                 @ code to write to the standard output Linux
    mov r7, #WRITE                                 @ code call system "write"
    svc #0                                         @ call systeme
    pop {r0,r1,r2,r7,lr}                           @ restaur des  2 registres */
    bx lr                                          @ return
/******************************************************************/
/*     Converting a register to a decimal unsigned                */
/******************************************************************/
/* r0 contains value and r1 address area   */
/* r0 return size of result (no zero final in area) */
/* area size => 11 bytes          */
.equ LGZONECAL,   10
conversion10:
    push {r1-r4,lr}                                 @ save registers
    mov r3,r1
    mov r2,#LGZONECAL

1:	                                            @ start loop
    bl divisionpar10U                               @ unsigned  r0 <- dividende. quotient ->r0 reste -> r1
    add r1,#48                                      @ digit
    strb r1,[r3,r2]                                 @ store digit on area
    cmp r0,#0                                       @ stop if quotient = 0
    subne r2,#1                                     @ else previous position
    bne 1b	                                    @ and loop
                                                    @ and move digit from left of area
    mov r4,#0
2:
    ldrb r1,[r3,r2]
    strb r1,[r3,r4]
    add r2,#1
    add r4,#1
    cmp r2,#LGZONECAL
    ble 2b
                                                      @ and move spaces in end on area
    mov r0,r4                                         @ result length
    mov r1,#' '                                       @ space
3:
    strb r1,[r3,r4]                                   @ store space in area
    add r4,#1                                         @ next position
    cmp r4,#LGZONECAL
    ble 3b                                            @ loop if r4 <= area size

100:
    pop {r1-r4,lr}                                    @ restaur registres
    bx lr                                             @return

/***************************************************/
/*   division par 10   unsigned                    */
/***************************************************/
/* r0 dividende   */
/* r0 quotient */
/* r1 remainder  */
divisionpar10U:
    push {r2,r3,r4, lr}
    mov r4,r0                                          @ save value
    //mov r3,#0xCCCD                                   @ r3 <- magic_number lower  raspberry 3
    //movt r3,#0xCCCC                                  @ r3 <- magic_number higter raspberry 3
    ldr r3,iMagicNumber                                @ r3 <- magic_number    raspberry 1 2
    umull r1, r2, r3, r0                               @ r1<- Lower32Bits(r1*r0) r2<- Upper32Bits(r1*r0)
    mov r0, r2, LSR #3                                 @ r2 <- r2 >> shift 3
    add r2,r0,r0, lsl #2                               @ r2 <- r0 * 5
    sub r1,r4,r2, lsl #1                               @ r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10)
    pop {r2,r3,r4,lr}
    bx lr                                              @ leave function
iMagicNumber:  	.int 0xCCCCCCCD


quickSort: function [items][
	if 2 > size items -> return items

	pivot: first items
	left:  select slice items 1 (size items)-1 'x -> x < pivot
	right: select slice items 1 (size items)-1 'x -> x >= pivot

	((quickSort left) ++ pivot) ++ quickSort right
]

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


(*------------------------------------------------------------------*)
(* Quicksort in ATS2, for non-linear lists.                         *)
(*------------------------------------------------------------------*)

#include "share/atspre_staload.hats"

#define NIL list_nil ()
#define ::  list_cons

(*------------------------------------------------------------------*)

(* A simple quicksort working on "garbage-collected" linked lists,
   with first element as pivot. This is meant as a demonstration, not
   as a superior sort algorithm.

   It is based on the "not-in-place" task pseudocode. *)

datatype comparison_result =
| first_is_less_than_second of ()
| first_is_equal_to_second of ()
| first_is_greater_than_second of ()

extern fun {a : [email protected]}
list_quicksort$comparison (x : a, y : a) :<> comparison_result

extern fun {a : [email protected]}
list_quicksort {n   : int}
               (lst : list (a, n)) :<> list (a, n)

(* -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - *)

implement {a}
list_quicksort {n} (lst) =
  let
    fun
    partition {n     : nat}
              .<n>.             (* Proof of termination. *)
              (lst   : list (a, n),
               pivot : a)
        :<> [n1, n2, n3 : int | n1 + n2 + n3 == n]
            @(list (a, n1), list (a, n2), list (a, n3)) =
      (* This implementation is *not* tail recursive. I may get a
         scolding for using ATS to risk stack overflow! However, I
         need more practice writing non-tail routines. :) Also, a lot
         of programmers in other languages would do it this
         way--especially if the lists are evaluated lazily. *)
      case+ lst of
      | NIL => @(NIL, NIL, NIL)
      | head :: tail =>
        let
          val @(lt, eq, gt) = partition (tail, pivot)
          prval () = lemma_list_param lt
          prval () = lemma_list_param eq
          prval () = lemma_list_param gt
        in
          case+ list_quicksort$comparison<a> (head, pivot) of
          | first_is_less_than_second ()    => @(head :: lt, eq, gt)
          | first_is_equal_to_second ()     => @(lt, head :: eq, gt)
          | first_is_greater_than_second () => @(lt, eq, head :: gt)
        end

    fun
    quicksort {n   : nat}
              .<n>.             (* Proof of termination. *)
              (lst : list (a, n))
        :<> list (a, n) =
      case+ lst of
      | NIL => lst
      | _ :: NIL => lst
      | head :: tail =>
        let
          (* We are careful here to run "partition" on "tail" rather
             than "lst", so the termination metric will be provably
             decreasing. (Really the compiler *forces* us to take such
             care, or else to change :<> to :<!ntm>) *)
          val pivot = head
          prval () = lemma_list_param tail
          val @(lt, eq, gt) = partition {n - 1} (tail, pivot)
          prval () = lemma_list_param lt
          prval () = lemma_list_param eq
          prval () = lemma_list_param gt
          val eq = pivot :: eq
          and lt = quicksort lt
          and gt = quicksort gt
        in
          lt + (eq + gt)
        end

    prval () = lemma_list_param lst
  in
    quicksort {n} lst
  end

(*------------------------------------------------------------------*)

val example_strings =
  $list ("choose", "any", "element", "of", "the", "array",
         "to", "be", "the", "pivot",
         "divide", "all", "other", "elements", "except",
         "the", "pivot", "into", "two", "partitions",
         "all", "elements", "less", "than", "the", "pivot",
         "must", "be", "in", "the", "first", "partition",
         "all", "elements", "greater", "than", "the", "pivot",
         "must", "be", "in", "the", "second", "partition",
         "use", "recursion", "to", "sort", "both", "partitions",
         "join", "the", "first", "sorted", "partition", "the",
         "pivot", "and", "the", "second", "sorted", "partition")

implement
list_quicksort$comparison<string> (x, y) =
  let
    val i = strcmp (x, y)
  in
    if i < 0 then
      first_is_less_than_second
    else if i = 0 then
      first_is_equal_to_second
    else
      first_is_greater_than_second
  end

implement
main0 () =
  let
    val sorted_strings = list_quicksort<string> example_strings

    fun
    print_strings {n       : nat} .<n>.
                  (strings : list (string, n),
                   i       : int) : void =
      case+ strings of
      | NIL => if i <> 1 then println! () else ()
      | head :: tail =>
        begin
          print! head;
          if i = 8 then
            begin
              println! ();
              print_strings (tail, 1)
            end
          else
            begin
              print! " ";
              print_strings (tail, succ i)
            end
        end
  in
    println! (length example_strings);
    println! (length sorted_strings);
    print_strings (sorted_strings, 1)
  end

(*------------------------------------------------------------------*)


a := [4, 65, 2, -31, 0, 99, 83, 782, 7]
for k, v in QuickSort(a)
	Out .= "," v
MsgBox, % SubStr(Out, 2)
return

QuickSort(a)
{
	if (a.MaxIndex() <= 1)
		return a
	Less := [], Same := [], More := []
	Pivot := a[1]
	for k, v in a
	{
		if (v < Pivot)
			less.Insert(v)
		else if (v > Pivot)
			more.Insert(v)
		else
			same.Insert(v)
	}
	Less := QuickSort(Less)
	Out := QuickSort(More)
	if (Same.MaxIndex())
		Out.Insert(1, Same*) ; insert all values of same at index 1
	if (Less.MaxIndex())
		Out.Insert(1, Less*) ; insert all values of less at index 1
	return Out
}


# the following qsort implementation extracted from:
#
#       ftp://ftp.armory.com/pub/lib/awk/qsort
#
# Copyleft GPLv2 John DuBois
#
# @(#) qsort 1.2.1 2005-10-21
# 1990 john h. dubois iii ([email protected])
#
# qsortArbIndByValue(): Sort an array according to the values of its elements.
#
# Input variables:
#
# Arr[] is an array of values with arbitrary (associative) indices.
#
# Output variables:
#
# k[] is returned with numeric indices 1..n.  The values assigned to these
# indices are the indices of Arr[], ordered so that if Arr[] is stepped
# through in the order Arr[k[1]] .. Arr[k[n]], it will be stepped through in
# order of the values of its elements.
#
# Return value: The number of elements in the arrays (n).
#
# NOTES:
#
# Full example for accessing results:
#
#       foolist["second"] = 2;
#       foolist["zero"] = 0;
#       foolist["third"] = 3;
#       foolist["first"] = 1;
#
#       outlist[1] = 0;
#       n = qsortArbIndByValue(foolist, outlist)
#
#       for (i = 1; i <= n; i++) {
#               printf("item at %s has value %d\n", outlist[i], foolist[outlist[i]]);
#       }
#      delete outlist;
#
function qsortArbIndByValue(Arr, k,
                            ArrInd, ElNum)
{
        ElNum = 0;
        for (ArrInd in Arr) {
                k[++ElNum] = ArrInd;
        }
        qsortSegment(Arr, k, 1, ElNum);
        return ElNum;
}
#
# qsortSegment(): Sort a segment of an array.
#
# Input variables:
#
# Arr[] contains data with arbitrary indices.
#
# k[] has indices 1..nelem, with the indices of Arr[] as values.
#
# Output variables:
#
# k[] is modified by this function.  The elements of Arr[] that are pointed to
# by k[start..end] are sorted, with the values of elements of k[] swapped
# so that when this function returns, Arr[k[start..end]] will be in order.
#
# Return value: None.
#
function qsortSegment(Arr, k, start, end,
                      left, right, sepval, tmp, tmpe, tmps)
{
        if ((end - start) < 1) {        # 0 or 1 elements
                return;
        }
        # handle two-element case explicitly for a tiny speedup
        if ((end - start) == 1) {
                if (Arr[tmps = k[start]] > Arr[tmpe = k[end]]) {
                        k[start] = tmpe;
                        k[end] = tmps;
                }
                return;
        }
        # Make sure comparisons act on these as numbers
        left = start + 0;
        right = end + 0;
        sepval = Arr[k[int((left + right) / 2)]];
        # Make every element <= sepval be to the left of every element > sepval
        while (left < right) {
                while (Arr[k[left]] < sepval) {
                        left++;
                }
                while (Arr[k[right]] > sepval) {
                        right--;
                }
                if (left < right) {
                        tmp = k[left];
                        k[left++] = k[right];
                        k[right--] = tmp;
                }
        }
        if (left == right)
                if (Arr[k[left]] < sepval) {
                        left++;
                } else {
                        right--;
                }
        if (start < right) {
                qsortSegment(Arr, k, start, right);
        }
        if (left < end) {
                qsortSegment(Arr, k, left, end);
        }
}


DECLARE SUB quicksort (arr() AS INTEGER, leftN AS INTEGER, rightN AS INTEGER)

DIM q(99) AS INTEGER
DIM n AS INTEGER

RANDOMIZE TIMER

FOR n = 0 TO 99
    q(n) = INT(RND * 9999)
NEXT

OPEN "output.txt" FOR OUTPUT AS 1
    FOR n = 0 TO 99
        PRINT #1, q(n),
    NEXT
    PRINT #1,
    quicksort q(), 0, 99
    FOR n = 0 TO 99
        PRINT #1, q(n),
    NEXT
CLOSE

SUB quicksort (arr() AS INTEGER, leftN AS INTEGER, rightN AS INTEGER)
    DIM pivot AS INTEGER, leftNIdx AS INTEGER, rightNIdx AS INTEGER
    leftNIdx = leftN
    rightNIdx = rightN
    IF (rightN - leftN) > 0 THEN
        pivot = (leftN + rightN) / 2
        WHILE (leftNIdx <= pivot) AND (rightNIdx >= pivot)
            WHILE (arr(leftNIdx) < arr(pivot)) AND (leftNIdx <= pivot)
                leftNIdx = leftNIdx + 1
            WEND
            WHILE (arr(rightNIdx) > arr(pivot)) AND (rightNIdx >= pivot)
                rightNIdx = rightNIdx - 1
            WEND
            SWAP arr(leftNIdx), arr(rightNIdx)
            leftNIdx = leftNIdx + 1
            rightNIdx = rightNIdx - 1
            IF (leftNIdx - 1) = pivot THEN
                rightNIdx = rightNIdx + 1
                pivot = rightNIdx
            ELSEIF (rightNIdx + 1) = pivot THEN
                leftNIdx = leftNIdx - 1
                pivot = leftNIdx
            END IF
        WEND
        quicksort arr(), leftN, pivot - 1
        quicksort arr(), pivot + 1, rightN
    END IF
END SUB


// This can be run using Cintcode BCPL freely available from www.cl.cam.ac.uk/users/mr10.

GET "libhdr.h"

LET quicksort(v, n) BE qsort(v+1, v+n)

AND qsort(l, r) BE
{ WHILE l+8<r DO
  { LET midpt = (l+r)/2
    // Select a good(ish) median value.
    LET val   = middle(!l, !midpt, !r)
    LET i = partition(val, l, r)
    // Only use recursion on the smaller partition.
    TEST i>midpt THEN { qsort(i, r);   r := i-1 }
                 ELSE { qsort(l, i-1); l := i   }
  }

  FOR p = l+1 TO r DO  // Now perform insertion sort.
   FOR q = p-1 TO l BY -1 TEST q!0<=q!1 THEN BREAK
                                        ELSE { LET t = q!0
                                               q!0 := q!1
                                               q!1 := t
                                             }
}

AND middle(a, b, c) = a<b -> b<c -> b,
                                    a<c -> c,
                                           a,
                             b<c -> a<c -> a,
                                           c,
                                    b

AND partition(median, p, q) = VALOF
{ LET t = ?
  WHILE !p < median DO p := p+1
  WHILE !q > median DO q := q-1
  IF p>=q RESULTIS p
  t  := !p
  !p := !q
  !q := t
  p, q := p+1, q-1
} REPEAT

LET start() = VALOF {
  LET v = VEC 1000
  FOR i = 1 TO 1000 DO v!i := randno(1_000_000)
  quicksort(v, 1000)
  FOR i = 1 TO 1000 DO
  { IF i MOD 10 = 0 DO newline()
    writef(" %i6", v!i)
  }
  newline()
}


beads 1 program Quicksort

calc main_init
	var arr = [1, 3, 5, 1, 7, 9, 8, 6, 4, 2]
	var arr2 = arr
	quicksort(arr, 1, tree_count(arr))
	var tempStr : str
	loop across:arr index:ix
		tempStr = tempStr & ' ' & to_str(arr[ix])
	log tempStr

calc quicksort(
	arr:array of num
	startIndex
	highIndex
	)
	if (startIndex < highIndex)
		var partitionIndex = partition(arr, startIndex, highIndex)
		quicksort(arr, startIndex, partitionIndex - 1)
		quicksort(arr, partitionIndex+1, highIndex)

calc partition(
	arr:array of num
	startIndex
	highIndex
	):num
	var pivot = arr[highIndex]
	var i = startIndex - 1
	var j = startIndex
	loop while:(j <= highIndex - 1)
		if arr[j] < pivot
			inc i
			swap arr[i] <=> arr[j]
		inc j
	swap arr[i+1] <=> arr[highIndex]
	return (i+1)


( ( Q
  =   Less Greater Equal pivot element
    .     !arg:%(?pivot:?Equal) %?arg
        & :?Less:?Greater
        &   whl
          ' ( !arg:%?element ?arg
            &   (.!element)+(.!pivot)               { BAD: 1900+90 adds to 1990,  GOOD: (.1900)+(.90) is sorted to (.90)+(.1900) }
              : (   (.!element)+(.!pivot)
                  & !element !Less:?Less
                |   (.!pivot)+(.!element)
                  & !element !Greater:?Greater
                | ?&!element !Equal:?Equal
                )
            )
        & Q$!Less !Equal Q$!Greater
      | !arg
  )
& out$Q$(1900 optimized variants of 4001/2 Quicksort (quick,sort) are (quick,sober) features of 90 languages)
);


#include <stdio.h>

void quicksort(int *A, int len);

int main (void) {
  int a[] = {4, 65, 2, -31, 0, 99, 2, 83, 782, 1};
  int n = sizeof a / sizeof a[0];

  int i;
  for (i = 0; i < n; i++) {
    printf("%d ", a[i]);
  }
  printf("\n");

  quicksort(a, n);

  for (i = 0; i < n; i++) {
    printf("%d ", a[i]);
  }
  printf("\n");

  return 0;
}

void quicksort(int *A, int len) {
  if (len < 2) return;

  int pivot = A[len / 2];

  int i, j;
  for (i = 0, j = len - 1; ; i++, j--) {
    while (A[i] < pivot) i++;
    while (A[j] > pivot) j--;

    if (i >= j) break;

    int temp = A[i];
    A[i]     = A[j];
    A[j]     = temp;
  }

  quicksort(A, i);
  quicksort(A + i, len - i);
}


//
// The Tripartite conditional enables Bentley-McIlroy 3-way Partitioning.
// This performs additional compares to isolate islands of keys equal to
// the pivot value.  Use unless key-equivalent classes are of small size.
//
#define Tripartite

namespace RosettaCode {
  using System;
  using System.Diagnostics;

  public class QuickSort<T> where T : IComparable {
    #region Constants
    public const UInt32 INSERTION_LIMIT_DEFAULT = 12;
    private const Int32 SAMPLES_MAX = 19;
    #endregion

    #region Properties
    public UInt32 InsertionLimit { get; }
    private T[] Samples { get; }
    private Int32 Left { get; set; }
    private Int32 Right { get; set; }
    private Int32 LeftMedian { get; set; }
    private Int32 RightMedian { get; set; }
    #endregion

    #region Constructors
    public QuickSort(UInt32 insertionLimit = INSERTION_LIMIT_DEFAULT) {
      this.InsertionLimit = insertionLimit;
      this.Samples = new T[SAMPLES_MAX];
    }
    #endregion

    #region Sort Methods
    public void Sort(T[] entries) {
      Sort(entries, 0, entries.Length - 1);
    }

    public void Sort(T[] entries, Int32 first, Int32 last) {
      var length = last + 1 - first;
      while (length > 1) {
        if (length < InsertionLimit) {
          InsertionSort<T>.Sort(entries, first, last);
          return;
        }

        Left = first;
        Right = last;
        var median = pivot(entries);
        partition(median, entries);
        //[Note]Right < Left

        var leftLength = Right + 1 - first;
        var rightLength = last + 1 - Left;

        //
        // First recurse over shorter partition, then loop
        // on the longer partition to elide tail recursion.
        //
        if (leftLength < rightLength) {
          Sort(entries, first, Right);
          first = Left;
          length = rightLength;
        }
        else {
          Sort(entries, Left, last);
          last = Right;
          length = leftLength;
        }
      }
    }

    /// Return an odd sample size proportional to the log of a large interval size.
    private static Int32 sampleSize(Int32 length, Int32 max = SAMPLES_MAX) {
      var logLen = (Int32)Math.Log10(length);
      var samples = Math.Min(2 * logLen + 1, max);
      return Math.Min(samples, length);
    }

    /// Estimate the median value of entries[Left:Right]
    /// <remarks>A sample median is used as an estimate the true median.</remarks>
    private T pivot(T[] entries) {
      var length = Right + 1 - Left;
      var samples = sampleSize(length);
      // Sample Linearly:
      for (var sample = 0; sample < samples; sample++) {
        // Guard against Arithmetic Overflow:
        var index = (Int64)length * sample / samples + Left;
        Samples[sample] = entries[index];
      }

      InsertionSort<T>.Sort(Samples, 0, samples - 1);
      return Samples[samples / 2];
    }

    private void partition(T median, T[] entries) {
      var first = Left;
      var last = Right;
#if Tripartite
      LeftMedian = first;
      RightMedian = last;
#endif
      while (true) {
        //[Assert]There exists some index >= Left where entries[index] >= median
        //[Assert]There exists some index <= Right where entries[index] <= median
        // So, there is no need for Left or Right bound checks
        while (median.CompareTo(entries[Left]) > 0) Left++;
        while (median.CompareTo(entries[Right]) < 0) Right--;

        //[Assert]entries[Right] <= median <= entries[Left]
        if (Right <= Left) break;

        Swap(entries, Left, Right);
        swapOut(median, entries);
        Left++;
        Right--;
        //[Assert]entries[first:Left - 1] <= median <= entries[Right + 1:last]
      }

      if (Left == Right) {
        Left++;
        Right--;
      }
      //[Assert]Right < Left
      swapIn(entries, first, last);

      //[Assert]entries[first:Right] <= median <= entries[Left:last]
      //[Assert]entries[Right + 1:Left - 1] == median when non-empty
    }
    #endregion

    #region Swap Methods
    [Conditional("Tripartite")]
    private void swapOut(T median, T[] entries) {
      if (median.CompareTo(entries[Left]) == 0) Swap(entries, LeftMedian++, Left);
      if (median.CompareTo(entries[Right]) == 0) Swap(entries, Right, RightMedian--);
    }

    [Conditional("Tripartite")]
    private void swapIn(T[] entries, Int32 first, Int32 last) {
      // Restore Median entries
      while (first < LeftMedian) Swap(entries, first++, Right--);
      while (RightMedian < last) Swap(entries, Left++, last--);
    }

    /// Swap entries at the left and right indicies.
    public void Swap(T[] entries, Int32 left, Int32 right) {
      Swap(ref entries[left], ref entries[right]);
    }

    /// Swap two entities of type T.
    public static void Swap(ref T e1, ref T e2) {
      var e = e1;
      e1 = e2;
      e2 = e;
    }
    #endregion
  }

  #region Insertion Sort
  static class InsertionSort<T> where T : IComparable {
    public static void Sort(T[] entries, Int32 first, Int32 last) {
      for (var next = first + 1; next <= last; next++)
        insert(entries, first, next);
    }

    /// Bubble next entry up to its sorted location, assuming entries[first:next - 1] are already sorted.
    private static void insert(T[] entries, Int32 first, Int32 next) {
      var entry = entries[next];
      while (next > first && entries[next - 1].CompareTo(entry) > 0)
        entries[next] = entries[--next];
      entries[next] = entry;
    }
  }
  #endregion
}


#include <iterator>
#include <algorithm> // for std::partition
#include <functional> // for std::less

// helper function for median of three
template<typename T>
 T median(T t1, T t2, T t3)
{
  if (t1 < t2)
  {
    if (t2 < t3)
      return t2;
    else if (t1 < t3)
      return t3;
    else
      return t1;
  }
  else
  {
    if (t1 < t3)
      return t1;
    else if (t2 < t3)
      return t3;
    else
      return t2;
  }
}

// helper object to get <= from <
template<typename Order> struct non_strict_op:
  public std::binary_function<typename Order::second_argument_type,
                              typename Order::first_argument_type,
                              bool>
{
  non_strict_op(Order o): order(o) {}
  bool operator()(typename Order::second_argument_type arg1,
                  typename Order::first_argument_type arg2) const
  {
    return !order(arg2, arg1);
  }
private:
  Order order;
};

template<typename Order> non_strict_op<Order> non_strict(Order o)
{
  return non_strict_op<Order>(o);
}

template<typename RandomAccessIterator,
         typename Order>
 void quicksort(RandomAccessIterator first, RandomAccessIterator last, Order order)
{
  if (first != last && first+1 != last)
  {
    typedef typename std::iterator_traits<RandomAccessIterator>::value_type value_type;
    RandomAccessIterator mid = first + (last - first)/2;
    value_type pivot = median(*first, *mid, *(last-1));
    RandomAccessIterator split1 = std::partition(first, last, std::bind2nd(order, pivot));
    RandomAccessIterator split2 = std::partition(split1, last, std::bind2nd(non_strict(order), pivot));
    quicksort(first, split1, order);
    quicksort(split2, last, order);
  }
}

template<typename RandomAccessIterator>
 void quicksort(RandomAccessIterator first, RandomAccessIterator last)
{
  quicksort(first, last, std::less<typename std::iterator_traits<RandomAccessIterator>::value_type>());
}


(defn qsort [L]
  (if (empty? L)
      '()
      (let [[pivot & L2] L]
           (lazy-cat (qsort (for [y L2 :when (<  y pivot)] y))
                     (list pivot)
                     (qsort (for [y L2 :when (>= y pivot)] y))))))


       IDENTIFICATION DIVISION.
       PROGRAM-ID. quicksort RECURSIVE.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  temp                   PIC S9(8).

       01  pivot                  PIC S9(8).

       01  left-most-idx          PIC 9(5).
       01  right-most-idx         PIC 9(5).

       01  left-idx               PIC 9(5).
       01  right-idx              PIC 9(5).

       LINKAGE SECTION.
       78  Arr-Length             VALUE 50.

       01  arr-area.
           03  arr                PIC S9(8) OCCURS Arr-Length TIMES.

       01  left-val               PIC 9(5).
       01  right-val              PIC 9(5).

       PROCEDURE DIVISION USING REFERENCE arr-area, OPTIONAL left-val,
               OPTIONAL right-val.
           IF left-val IS OMITTED OR right-val IS OMITTED
               MOVE 1 TO left-most-idx, left-idx
               MOVE Arr-Length TO right-most-idx, right-idx
           ELSE
               MOVE left-val TO left-most-idx, left-idx
               MOVE right-val TO right-most-idx, right-idx
           END-IF

           IF right-most-idx - left-most-idx < 1
               GOBACK
           END-IF

           COMPUTE pivot = arr ((left-most-idx + right-most-idx) / 2)

           PERFORM UNTIL left-idx > right-idx
               PERFORM VARYING left-idx FROM left-idx BY 1
                   UNTIL arr (left-idx) >= pivot
               END-PERFORM

               PERFORM VARYING right-idx FROM right-idx BY -1
                   UNTIL arr (right-idx) <= pivot
               END-PERFORM

               IF left-idx <= right-idx
                   MOVE arr (left-idx) TO temp
                   MOVE arr (right-idx) TO arr (left-idx)
                   MOVE temp TO arr (right-idx)

                   ADD 1 TO left-idx
                   SUBTRACT 1 FROM right-idx
               END-IF
           END-PERFORM

           CALL "quicksort" USING REFERENCE arr-area,
               CONTENT left-most-idx, right-idx
           CALL "quicksort" USING REFERENCE arr-area, CONTENT left-idx,
               right-most-idx

           GOBACK
           .


quicksort = ([x, xs...]) ->
  return [] unless x?
  smallerOrEqual = (a for a in xs when a <= x)
  larger = (a for a in xs when a > x)
  (quicksort smallerOrEqual).concat(x).concat(quicksort larger)


(defun quicksort (list &aux (pivot (car list)) )
  (if (cdr list)
      (nconc (quicksort (remove-if-not #'(lambda (x) (< x pivot)) list))
             (remove-if-not #'(lambda (x) (= x pivot)) list)
             (quicksort (remove-if-not #'(lambda (x) (> x pivot)) list)))
      list))


include "cowgol.coh";

# Comparator interface, on the model of C, i.e:
# foo < bar => -1, foo == bar => 0, foo > bar => 1
typedef CompRslt is int(-1, 1);
interface Comparator(foo: intptr, bar: intptr): (rslt: CompRslt);

# Quicksort an array of pointer-sized integers given a comparator function
# (This is the closest you can get to polymorphism in Cowgol).
# Because Cowgol does not support recursion, a pointer to free memory
# for a stack must also be given.
sub qsort(A: [intptr], len: intptr, comp: Comparator, stack: [intptr]) is
    # The partition function can be taken almost verbatim from Wikipedia
    sub partition(lo: intptr, hi: intptr): (p: intptr) is
        # This is not quite as bad as it looks: /2 compiles into a single shift
        # and "@bytesof intptr" is always power of 2 so compiles into shift(s).
        var pivot := [A + (hi/2 + lo/2) * @bytesof intptr];
        var i := lo - 1;
        var j := hi + 1;
        loop
            loop
                i := i + 1;
                if comp([A + i*@bytesof intptr], pivot) != -1 then
                    break;
                end if;
            end loop;
            loop
                j := j - 1;
                if comp([A + j*@bytesof intptr], pivot) != 1 then
                    break;
                end if;
            end loop;
            if i >= j then
                p := j;
                return;
            end if;
            var ii := i * @bytesof intptr;
            var jj := j * @bytesof intptr;
            var t := [A+ii];
            [A+ii] := [A+jj];
            [A+jj] := t;
        end loop;
    end sub;

    # Cowgol lacks recursion, so we'll have to solve it by implementing
    # the stack ourselves.
    var sp: intptr := 0; # stack index
    sub push(n: intptr) is
        sp := sp + 1;
        [stack] := n;
        stack := @next stack;
    end sub;
    sub pop(): (n: intptr) is
        sp := sp - 1;
        stack := @prev stack;
        n := [stack];
    end sub;

    # start by sorting [0..length-1]
    push(len-1);
    push(0);
    while sp != 0 loop
        var lo := pop();
        var hi := pop();
        if lo < hi then
            var p := partition(lo, hi);
            push(hi);   # note the order - we need to push the high pair
            push(p+1);  # first for it to be done last
            push(p);
            push(lo);
        end if;
    end loop;
end sub;

# Test: sort a list of numbers
sub NumComp implements Comparator is
    # Compare the inputs as numbers
    if foo < bar then rslt := -1;
    elseif foo > bar then rslt := 1;
    else rslt := 0;
    end if;
end sub;

# Numbers
var numbers: intptr[] := {
    65,13,4,84,29,5,96,73,5,11,17,76,38,26,44,20,36,12,44,51,79,8,99,7,19,95,26
};

# Room for the stack
var stackbuf: intptr[256];

# Sort the numbers in place
qsort(&numbers as [intptr], @sizeof numbers, NumComp, &stackbuf as [intptr]);

# Print the numbers (hopefully in order)
var i: @indexof numbers := 0;
while i < @sizeof numbers loop
    print_i32(numbers[i] as uint32);
    print_char(' ');
    i := i + 1;
end loop;
print_nl();


def quick_sort(a : Array(Int32)) : Array(Int32)
  return a if a.size <= 1
  p = a[0]
  lt, rt = a[1 .. -1].partition { |x| x < p }
  return quick_sort(lt) + [p] + quick_sort(rt)
end

a = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
puts quick_sort(a) # => [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]


-- quicksort using higher-order functions:

qsort :: [Int] -> [Int]
qsort []     = []
qsort (x:l)  = qsort (filter (<x) l) ++ x : qsort (filter (>=x) l)

goal = qsort [2,3,1,0]


import std.stdio : writefln, writeln;
import std.algorithm: filter;
import std.array;

T[] quickSort(T)(T[] xs) =>
  xs.length == 0 ? [] :
    xs[1 .. $].filter!(x => x< xs[0]).array.quickSort ~
    xs[0 .. 1] ~
    xs[1 .. $].filter!(x => x>=xs[0]).array.quickSort;

void main() =>
  [4, 65, 2, -31, 0, 99, 2, 83, 782, 1].quickSort.writeln;


quickSort(List a) {
  if (a.length <= 1) {
    return a;
  }

  var pivot = a[0];
  var less = [];
  var more = [];
  var pivotList = [];

  // Partition
  a.forEach((var i){
    if (i.compareTo(pivot) < 0) {
      less.add(i);
    } else if (i.compareTo(pivot) > 0) {
      more.add(i);
    } else {
      pivotList.add(i);
    }
  });

  // Recursively sort sublists
  less = quickSort(less);
  more = quickSort(more);

  // Concatenate results
  less.addAll(pivotList);
  less.addAll(more);
  return less;
}

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


def quicksort := {

    def swap(container, ixA, ixB) {
        def temp := container[ixA]
        container[ixA] := container[ixB]
        container[ixB] := temp
    }

    def partition(array, var first :int, var last :int) {
        if (last <= first) { return }

        # Choose a pivot
        def pivot := array[def pivotIndex := (first + last) // 2]

        # Move pivot to end temporarily
        swap(array, pivotIndex, last)

        var swapWith := first

        # Scan array except for pivot, and...
        for i in first..!last {
            if (array[i] <= pivot) {   # items ≤ the pivot
                swap(array, i, swapWith) # are moved to consecutive positions on the left
                swapWith += 1
            }
        }

        # Swap pivot into between-partition position.
        # Because of the swapping we know that everything before swapWith is less
        # than or equal to the pivot, and the item at swapWith (since it was not
        # swapped) is greater than the pivot, so inserting the pivot at swapWith
        # will preserve the partition.
        swap(array, swapWith, last)
        return swapWith
    }

    def quicksortR(array, first :int, last :int) {
        if (last <= first) { return }
        def pivot := partition(array, first, last)
        quicksortR(array, first, pivot - 1)
        quicksortR(array, pivot + 1, last)
    }

    def quicksort(array) { # returned from block
        quicksortR(array, 0, array.size() - 1)
    }
}


data[] = [ 29 4 72 44 55 26 27 77 92 5 ]
#
func qsort left right . .
  while left < right
    swap data[(left + right) / 2] data[left]
    mid = left
    for i = left + 1 to right
      if data[i] < data[left]
        mid += 1
        swap data[i] data[mid]
      .
    .
    swap data[left] data[mid]
    call qsort left mid - 1
    left = mid + 1
  .
.
#
call qsort 0 len data[] - 1
print data[]


(lib 'list) ;; list-partition

(define compare 0) ;; counter

(define (quicksort L compare-predicate: proc aux:  (part null))
(if  (<= (length L) 1) L
     (begin
     ;; counting the number of comparisons
     (set! compare (+ compare (length (rest L))))
      ;; pivot = first element of list
     (set! part (list-partition (rest L) proc (first L)))
     (append (quicksort (first part) proc )
            (list (first L))
            (quicksort (second part) proc)))))


#import <Foundation/Foundation.h>

void quicksortInPlace(MutableArray array, const long first, const long last)
  if first >= last
    return
  Value pivot = array[(first + last) / 2]
  left := first
  right := last
  while left <= right
    while array[left] < pivot
      left++
    while array[right] > pivot
      right--
    if left <= right
      array.exchangeObjectAtIndex: left++, withObjectAtIndex: right--

  quicksortInPlace(array, first, right)
  quicksortInPlace(array, left, last)

Array quicksort(Array unsorted)
  a := []
  a.addObjectsFromArray: unsorted
  quicksortInPlace(a, 0, a.count - 1)
  return a

int main(int argc, const char * argv[])
  autoreleasepool
    a := [1, 3, 5, 7, 9, 8, 6, 4, 2]
    Log( 'Unsorted: %@', a)
    Log( 'Sorted: %@', quicksort(a) )
    b := ['Emil', 'Peg', 'Helen', 'Juergen', 'David', 'Rick', 'Barb', 'Mike', 'Tom']
    Log( 'Unsorted: %@', b)
    Log( 'Sorted: %@', quicksort(b) )

  return 0


import extensions;
import system'routines;
import system'collections;

extension op
{
    quickSort()
    {
        if (self.isEmpty()) { ^ self };

        var pivot := self[0];

        auto less := new ArrayList();
        auto pivotList := new ArrayList();
        auto more := new ArrayList();

        self.forEach:(item)
        {
            if (item < pivot)
            {
                less.append(item)
            }
            else if (item > pivot)
            {
                more.append(item)
            }
            else
            {
                pivotList.append(item)
            }
        };

        less := less.quickSort();
        more := more.quickSort();

        less.appendRange(pivotList);
        less.appendRange(more);

        ^ less
    }
}

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

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


defmodule Sort do
  def qsort([]), do: []
  def qsort([h | t]) do
    {lesser, greater} = Enum.split_with(t, &(&1 < h))
    qsort(lesser) ++ [h] ++ qsort(greater)
  end
end


-module( quicksort ).

-export( [qsort/1] ).

qsort([]) -> [];
qsort([X|Xs]) ->
   qsort([ Y || Y <- Xs, Y < X]) ++ [X] ++ qsort([ Y || Y <- Xs, Y >= X]).


(require 'seq)

(defun quicksort (xs)
  (if (null xs)
      ()
    (let* ((head (car xs))
           (tail (cdr xs))
           (lower-part (quicksort (seq-filter (lambda (x) (<= x head)) tail)))
           (higher-part (quicksort (seq-filter (lambda (x) (> x head)) tail))))
      (append lower-part (list head) higher-part))))


PROGRAM QUICKSORT_DEMO

DIM ARRAY[21]

!$DYNAMIC
DIM QSTACK[0]

!$INCLUDE="PC.LIB"

PROCEDURE QSORT(ARRAY[],START,NUM)
  FIRST=START               ! initialize work variables
  LAST=START+NUM-1
  LOOP
    REPEAT
      TEMP=ARRAY[(LAST+FIRST) DIV 2]  ! seek midpoint
      I=FIRST
      J=LAST
      REPEAT     ! reverse both < and > below to sort descending
      WHILE ARRAY[I]<TEMP DO
        I=I+1
        END WHILE
        WHILE ARRAY[J]>TEMP DO
          J=J-1
        END WHILE
        EXIT IF I>J
        IF I<J THEN SWAP(ARRAY[I],ARRAY[J]) END IF
        I=I+1
        J=J-1
      UNTIL NOT(I<=J)
      IF I<LAST THEN             ! Done
         QSTACK[SP]=I            ! Push I
         QSTACK[SP+1]=LAST       ! Push Last
         SP=SP+2
      END IF
      LAST=J
    UNTIL NOT(FIRST<LAST)

    EXIT IF SP=0
    SP=SP-2
    FIRST=QSTACK[SP]            ! Pop First
    LAST=QSTACK[SP+1]           ! Pop Last
  END LOOP
END PROCEDURE

BEGIN
   RANDOMIZE(TIMER)              ! generate a new series each run

                                 ! create an array
   FOR X=1 TO 21 DO              ! fill with random numbers
       ARRAY[X]=RND(1)*500       ! between 0 and 500
   END FOR
   PRIMO=6                       ! sort starting here
   NUM=10                        ! sort this many elements
   CLS
   PRINT("Before Sorting:";TAB(31);"After sorting:")
   PRINT("===============";TAB(31);"==============")
   FOR X=1 TO 21 DO              ! show them before sorting
      IF X>=PRIMO AND X<=PRIMO+NUM-1 THEN
         PRINT("==>";)
      END IF
      PRINT(TAB(5);)
      WRITE("###.##";ARRAY[X])
   END FOR

! create a stack
!$DIM QSTACK[INT(NUM/5)+10]
   QSORT(ARRAY[],PRIMO,NUM)
!$ERASE QSTACK

   LOCATE(2,1)
   FOR X=1 TO 21 DO                ! print them after sorting
      LOCATE(2+X,30)
      IF X>=PRIMO AND X<=PRIMO+NUM-1 THEN
         PRINT("==>";)             ! point to sorted items
      END IF
      LOCATE(2+X,35)
      WRITE("###.##";ARRAY[X])
   END FOR
END PROGRAM


let rec qsort = function
    hd :: tl ->
        let less, greater = List.partition ((>=) hd) tl
        List.concat [qsort less; [hd]; qsort greater]
    | _ -> []


F insertion_sort(&l)
   L(i) 1 .< l.len
      V j = i - 1
      V key = l[i]
      L j >= 0 & l[j] > key
         l[j + 1] = l[j]
         j--
      l[j + 1] = key

V arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
insertion_sort(&arr)
print(arr)


: qsort ( seq -- seq )
    dup empty? [
      unclip [ [ < ] curry partition [ qsort ] [email protected] ] keep
      prefix append
    ] unless ;


*        Insertion sort            16/06/2016
INSSORT  CSECT
         USING  INSSORT,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    prolog
         ST     R13,4(R15)         "
         ST     R15,8(R13)         "
         LR     R13,R15            "
         LA     R6,2               i=2
         LA     R9,A+L'A           @a(2)
LOOPI    C      R6,N               do i=2 to n
         BH     ELOOPI             leave i
         L      R2,0(R9)           a(i)
         ST     R2,V               v=a(i)
         LR     R7,R6              j=i
         BCTR   R7,0               j=i-1
         LR     R8,R9              @a(i)
         S      R8,=A(L'A)         @a(j)
LOOPJ    LTR    R7,R7              do j=i-1 to 1 by -1 while j>0
         BNH    ELOOPJ             leave j
         L      R2,0(R8)           a(j)
         C      R2,V               a(j)>v
         BNH    ELOOPJ             leave j
         MVC    L'A(L'A,R8),0(R8)  a(j+1)=a(j)
         BCTR   R7,0               j=j-1
         S      R8,=A(L'A)         @a(j)
         B      LOOPJ              next j
ELOOPJ   MVC    L'A(L'A,R8),V      a(j+1)=v;
         LA     R6,1(R6)           i=i+1
         LA     R9,L'A(R9)         @a(i)
         B      LOOPI              next i
ELOOPI   LA     R9,PG              pgi=0
         LA     R6,1               i=1
         LA     R8,A               @a(1)
LOOPXI   C      R6,N               do i=1 to n
         BH     ELOOPXI            leave i
         L      R1,0(R8)           a(i)
         XDECO  R1,XDEC            edit a(i)
         MVC    0(4,R9),XDEC+8     output a(i)
         LA     R9,4(R9)           pgi=pgi+1
         LA     R6,1(R6)           i=i+1
         LA     R8,L'A(R8)         @a(i)
         B      LOOPXI             next i
ELOOPXI  XPRNT  PG,L'PG            print buffer
         L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    "
         XR     R15,R15            "
         BR     R14                exit
A  DC F'4',F'65',F'2',F'-31',F'0',F'99',F'2',F'83',F'782',F'1'
   DC F'45',F'82',F'69',F'82',F'104',F'58',F'88',F'112',F'89',F'74'
V        DS     F                  variable
N        DC     A((V-A)/L'A)       n=hbound(a)
PG       DC     CL80' '            buffer
XDEC     DS     CL12               for xdeco
         YREGS                     symbolics for registers
         END    INSSORT