; patience sorting

(define (deal deck)
  (let loop ((deck deck) (selip (list)) (piles (list)))
    (cond ((null? deck) piles) ; no more cards in deck
          ((null? piles) ; add card to new pile
            (loop (cdr deck) (list)
                  (reverse (cons (list (car deck)) selip))))
          ((< (car deck) (caar piles)) ; found correct pile
            (loop (cdr deck) (list)
                  (append (reverse selip)
                          (list (cons (car deck) (car piles)))
                          (cdr piles))))
          (else ; continue search for correct pile
          (loop deck (cons (car piles) selip) (cdr piles))))))

(define (sort deck)
  (let loop1 ((xs (list)) (piles (deal deck)))
    (if (null? piles) (reverse xs)
      (let ((x (apply min (map car piles))))
        (let loop2 ((piles piles) (selip (list)))
          (if (= (caar piles) x)
              (loop1 (cons x xs)
                (append (reverse selip)
                        (if (null? (cdar piles)) (list)
                          (list (cdar piles)))
                        (cdr piles)))
              (loop2 (cdr piles) (cons (car piles) selip))))))))

(display (sort '(4 2 9 1 3 6 7 8 5))) (newline)

(define (insert xs xss)
  (if (null? xs) xss
    (let loop ((xss xss) (rev (list)))
      (if (null? xss) (reverse (cons xs rev))
        (if (< (car xs) (caar xss))
            (append (reverse rev) (list xs) xss)
            (loop (cdr xss) (cons (car xss) rev)))))))

(define (sort deck)
  (let loop ((xs (list)) (piles (deal deck)))
    (if (null? piles) (reverse xs)
      (loop (cons (caar piles) xs)
        (insert (cdar piles) (cdr piles))))))

(display (sort '(4 2 9 1 3 6 7 8 5))) (newline)

(1 2 3 4 5 6 7 8 9)
(1 2 3 4 5 6 7 8 9)