(macro grab!
  (lambda (body)
    (let ((x (cadr body))
          (y (caddr body))
          (z (gensym))
          (w (gensym)))
      `(let ((,z ,x) (,w ,y))
         (set-cdr! ,w (cdar ,z))
         (set-cdr! (car ,z) ,w)
         ,z))))

(macro tournament-play!
  (lambda (body)
    (let ((x (cadr body))
          (y (caddr body))
          (predicate (cadddr body)))
      `(if (,predicate (caar ,x) (caar ,y))
           (grab! ,x ,y)
           (grab! ,y ,x)))))

(define (sequential-tournament! forest predicate)
  (cond
    ((null? forest) '())
    ((null? (cdr forest)) (car forest))
    (else
      (let ((x (reverse! forest)))
        (do ((result x (tournament-play! result next predicate))
           (next (cdr x) after-next)
           (after-next (cddr x) (cdr after-next)))
          ((null? after-next)
           (car (tournament-play! result next predicate))))))))

(define (parallel-tournament! forest predicate)
  (define (tournament-round! so-far to-be-done)
    (cond ((null? to-be-done) so-far)
          ((null? (cdr to-be-done))
           (set-cdr! to-be-done so-far)
           to-be-done)
          (else
            (let* ((i (cdr to-be-done))
                   (j (cdr i))
                   (new (tournament-play! to-be-done i predicate)))
              (set-cdr! new so-far)
              (tournament-round! new j)))))
  (if (null? forest)
      '()
      (do ((x forest (tournament-round! '() x)))
          ((null? (cdr x)) (car x)))))

(define (make-tournament-sort! tournament1 tournament2)
  (lambda (plist predicate)
    (let ((p (tournament1 (map! list plist) predicate)))
      (do ((x p (cdr x)))
          ((null? x) p)
          (set-cdr! x (tournament2 (cdr x) predicate))))))

(define tournament-sort-p!
  (make-tournament-sort! parallel-tournament! parallel-tournament!))

(define tournament-sort-s!
  (make-tournament-sort! parallel-tournament! sequential-tournament!))

(define tournament-sort-s-s!
  (make-tournament-sort! sequential-tournament! sequential-tournament!))