; stable sort

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define (zip . xss) (apply map list xss))

(define xs '(
  (alfa zulu) (bravo yankee) (charlie xray) (delta whiskey) (echo uniform)
  (alfa tango) (bravo sierra) (charlie romeo) (delta papa) (echo oscar)))

(define (lt? a b)
  (string<?
    (symbol->string (car a))
    (symbol->string (car b))))

(define (qsort lt? xs)
  (if (or (null? xs) (null? (cdr xs))) xs
    (let ((pivot (car xs)))
      (let loop ((xs (cdr xs)) (lesser (list)) (equal-or-greater (list)))
        (if (null? xs) (append (qsort lt? lesser) (list pivot) (qsort lt? equal-or-greater))
          (if (lt? (car xs) pivot) (loop (cdr xs) (cons (car xs) lesser) equal-or-greater)
            (loop (cdr xs) lesser (cons (car xs) equal-or-greater))))))))

(display (qsort lt? xs)) (newline)

(define (stable-sort sort lt? xs)
  (define (less? a b)
    (or (lt? (cadr a) (cadr b))
        (and (not (lt? (cadr b) (cadr a)))
             (< (car a) (car b)))))
  (map cadr (sort less? (zip (range (length xs)) xs))))

(display (stable-sort qsort lt? xs)) (newline)