; sort four

(define (permutations xs)
  (define (rev xs n ys)
    (if (zero? n) ys
      (rev (cdr xs) (- n 1) (cons (car xs) ys))))
  (let ((xs xs) (perms (list xs)))
    (define (perm n)
      (if (> n 1)
          (do ((j (- n 1) (- j 1)))
              ((zero? j) (perm (- n 1)))
            (perm (- n 1))
            (set! xs (rev xs n (list-tail xs n)))
            (set! perms (cons xs perms)))))
    (perm (length xs))
    perms))

(define (sort4 a b c d)
  (let ((ab (if (< a b) (list a b) (list b a)))
        (cd (if (< c d) (list c d) (list d c))))
    (let ((first #f) (mid1 #f) (mid2 #f) (last #f))
      (cond ((< (car ab) (car cd))
              (set! first (car ab))
              (set! mid1 (car cd)))
            (else
              (set! first (car cd))
              (set! mid1 (car ab))))
      (cond ((< (cadr ab) (cadr cd))
              (set! last (cadr cd))
              (set! mid2 (cadr ab)))
            (else
              (set! last (cadr ab))
              (set! mid2 (cadr cd))))
      (if (< mid1 mid2)
          (list first mid1 mid2 last)
          (list first mid2 mid1 last)))))

(for-each
  (lambda (xs)
    (display xs) (display " => ")
    (display (apply sort4 xs)) (newline))
  (permutations '(1 2 3 4)))