fork download
  1. ; stable sort
  2.  
  3. (define (range . args)
  4. (case (length args)
  5. ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  6. ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  7. ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  8. (let loop ((x(car args)) (xs '()))
  9. (if (le? (cadr args) x)
  10. (reverse xs)
  11. (loop (+ x (caddr args)) (cons x xs))))))
  12. (else (error 'range "unrecognized arguments"))))
  13.  
  14. (define (zip . xss) (apply map list xss))
  15.  
  16. (define xs '(
  17. (alfa zulu) (bravo yankee) (charlie xray) (delta whiskey) (echo uniform)
  18. (alfa tango) (bravo sierra) (charlie romeo) (delta papa) (echo oscar)))
  19.  
  20. (define (lt? a b)
  21. (string<?
  22. (symbol->string (car a))
  23. (symbol->string (car b))))
  24.  
  25. (define (qsort lt? xs)
  26. (if (or (null? xs) (null? (cdr xs))) xs
  27. (let ((pivot (car xs)))
  28. (let loop ((xs (cdr xs)) (lesser (list)) (equal-or-greater (list)))
  29. (if (null? xs) (append (qsort lt? lesser) (list pivot) (qsort lt? equal-or-greater))
  30. (if (lt? (car xs) pivot) (loop (cdr xs) (cons (car xs) lesser) equal-or-greater)
  31. (loop (cdr xs) lesser (cons (car xs) equal-or-greater))))))))
  32.  
  33. (display (qsort lt? xs)) (newline)
  34.  
  35. (define (stable-sort sort lt? xs)
  36. (define (less? a b)
  37. (or (lt? (cadr a) (cadr b))
  38. (and (not (lt? (cadr b) (cadr a)))
  39. (< (car a) (car b)))))
  40. (map cadr (sort less? (zip (range (length xs)) xs))))
  41.  
  42. (display (stable-sort qsort lt? xs)) (newline)
Success #stdin #stdout 0.04s 8260KB
stdin
Standard input is empty
stdout
((alfa zulu) (alfa tango) (bravo yankee) (bravo sierra) (charlie xray) (charlie romeo) (delta papa) (delta whiskey) (echo oscar) (echo uniform))
((alfa zulu) (alfa tango) (bravo yankee) (bravo sierra) (charlie xray) (charlie romeo) (delta whiskey) (delta papa) (echo uniform) (echo oscar))