; qsort.mrc by Stevie-O
; QuickSort implementation
; 9-16-00 10:28pm: IT WORKS! IT WORKS! IT WORKS!
; 9-16-00 10:58pm: Release version. (All debugging crap removed, etc.)

;    Quicksort
; http://www.epaperpress.com/s_qui.html
; http://odin.ee.uwa.edu.au/~morris/Year2/PLDS210/niemann/s_qui.txt
; http://www.gamedev.net/reference/articles/article1073.asp 
;  ASP sucks, but that page rox!
; http://ironbark.bendigo.latrobe.edu.au/courses/bcomp/c103/sem296/lectures/Lecture2.html

; $qsort(list, C, comparison alias[, options])

; 'comparison alias' is an alias that takes two parameters and returns a value indicating their relative value:
; Return < 0 if Item1 comes first     (Item1 < Item2)
; Return = 0 if either can come first (Item1 == Item2)
; Return > 0 if Item2 comes first     (Item1 > Item2)

; Options are:
;   r - Reverse sort.

; Ex: $qsort(c A b, 32, casealpha)
; alias casealpha { return $calc($asc($1) - $asc($2)) }

alias qsort {
  if ($isalias($3) == $false) { echo $colour(info) -qti3 *** $!qsort: $3 isn't an alias | halt } 
  if ($numtok($1, $2) < 2) return $1
  return $qsort_i($1, $2, $3, $4)
}

; Some common sort functions:
;   qcomp sorts numerically
;   qalpha sorts single letters alphabetically, all uppercase letters first
;   qialpha is like qalpha, but it *i*gnores letter case

alias qcomp return $calc($1 - $2)
alias qalpha return $calc($asc($1) - $asc($2))
alias qialpha return $calc($asc($upper($1)) - $asc($upper($2)))


; ***************************************************************************************************
; *      Here are internally referenced aliases that nobody should EVER be calling directly.        *
; *      I probably should make them -l (local), but I've had problems with that in the past.       *
; ***************************************************************************************************

; $qscomp(alias, el1, el2, options)
alias qscomp { var %r 
  $1 $2 $3 | set %r $result 
  if (r isin $4) return $calc(-1 * %r)
  return %r
}

; $qsort_partition(list, C, comparison alias, LBound, UBound[, options])
; Returns <M><space><new list>

alias qsort_partition {
  var %i = $4, %j = $5, %A = $1, %piv = $int($calc(($4 + $5) / 2)), %v = $gettok($1, %piv, $2), %t, %opt = $6
  ; Swap out pivot element into the last space.
  set %t $gettok(%A, %j, $2) | set %A $puttok(%A, %v, %j, $2) | set %A $puttok(%A, %t, %piv, 32)
  ; The idea is this:
  ; Make sure everything to the left is <= %v, and everything to the right is >= %v
  while (%i < %j) {
    ; Find the first element that belongs after the pivot element.
    while (%i < %j) && ($qscomp($3, $gettok(%A, %i, $2), %v, %opt) <= 0) { inc %i }

    ; Now find the last element that belongs before the pivot element.
    while (%i < %j) && ($qscomp($3, $gettok(%A, %j, $2), %v, %opt) >= 0) { dec %j }

    ; Now, if they're on the wrong side of each other, swap 'em.
    if (%i >= %j) break
    ; swap elements
    set %t $gettok(%A, %i, $2) 
    set %A $puttok($puttok(%A, $gettok(%A, %j, $2), %i, $2), %t, %j, $2)
    set %A $puttok(%A, %t, %j, $2)
  }
  ; At this point, %i >= %j.

  ; Swap pivot element with 'bottom' pointer (unless, of course, they're the same)
  if ($5 != %i) {
    set %A $puttok(%A, $gettok(%A, %i, $2), $5, $2)
    set %A $puttok(%A, %v, %i, $2)
  }
  return %i %A 
}

; $qsort_I(list, C, comparison alias[, options])
alias qsort_I {
  var  %stack, %pop, %res, %M, %A = $1, %Lb = 1, %Ub = $numtok($1, $2), %ret, %opt = $4
  set  %stack %Lb $+ : $+ %Ub $+ :exit
  :qsort_call
  set %pop $gettok(%stack, 1, 32) | set  %Lb $gettok(%pop, 1, 58) | set  %Ub $gettok(%pop, 2, 58) | set  %ret $gettok(%pop, 3, 58)
  if (%Lb >= %Ub) goto qsort_return
  set %res $qsort_partition(%A, $2, $3, %Lb, %Ub, %opt)
  set  %M $gettok(%res, 1, 32) | set  %A $gettok(%res, 2-, 32)

  if ($len(%stack) >= 600) { echo $colour(info) -qti3 *** $!qsort: Stack overflow: $numtok(%stack, 0) recursions | halt }

  if (%Lb < $calc(%M - 1)) { set  %stack %Lb $+ : $+ $calc(%M - 1)  $+ :2 %stack | goto qsort_call }
  else goto nopop2
  :qsort_return2
  ; Remember...after the call, we have to restore data from the stack!!!!!
  set %pop $gettok(%stack, 1, 32) | set %Lb $gettok(%pop, 1, 58) | set %Ub $gettok(%pop, 2, 58) | set %ret $gettok(%pop, 3, 58)
  :nopop2

  if ($calc(%M + 1) < %Ub) { set  %stack $calc(%M + 1) $+ : $+ %Ub $+ :3 %stack | goto qsort_call }
  else goto nopop3
  :qsort_return3
  ; Once again, restore data from the stack
  set %pop $gettok(%stack, 1, 32) | set %Lb $gettok(%pop, 1, 58) | set %Ub $gettok(%pop, 2, 58) | set %ret $gettok(%pop, 3, 58)
  :nopop3

  :qsort_return

  ; Pop the entry off
  set  %stack $deltok(%stack, 1, 32) 
  ; Any more calls on stack?
  goto qsort_return [ $+ [ %ret ] ]

  :qsort_returnexit
  return %A
}

