Sorting in scheme following a pattern

Question

A little help, guys. How do you sort a list according to a certain pattern An example would be sorting a list of R,W,B where R comes first then W then B. Something like (sortf '(WRWBRWBB)) to (RRWWWBBB)

Any answer is greatly appreciated.

Answer 1

This is a functional version of the Dutch national flag problem . Here are my two cents - using the sort procedure with O(n log n) complexity:

(define sortf
  (let ((map '#hash((R . 0) (W . 1) (B . 2))))
    (lambda (lst)
      (sort lst
            (lambda (x y) (<= (hash-ref map x) (hash-ref map y)))))))

Using filter with O(4n) complexity:

(define (sortf lst)
  (append (filter (lambda (x) (eq? x 'R)) lst)
          (filter (lambda (x) (eq? x 'W)) lst)
          (filter (lambda (x) (eq? x 'B)) lst)))

Using partition with O(3n) complexity::

(define (sortf lst)
  (let-values (((reds others)
                (partition (lambda (x) (eq? x 'R)) lst)))
    (let-values (((whites blues)
                  (partition (lambda (x) (eq? x 'W)) others)))
      (append reds whites blues))))

The above solutions are written in a functional programming style, creating a new list with the answer. An optimal O(n) , single-pass imperative solution can be constructed if we represent the input as a vector, which allows referencing elements by index. In fact, this is how the original formulation of the problem was intended to be solved:

(define (swap! vec i j)
  (let ((tmp (vector-ref vec i)))
    (vector-set! vec i (vector-ref vec j))
    (vector-set! vec j tmp)))

(define (sortf vec)
  (let loop ([i 0]
             [p 0]
             [k (sub1 (vector-length vec))])
    (cond [(> i k) vec]
          [(eq? (vector-ref vec i) 'R)
           (swap! vec i p)
           (loop (add1 i) (add1 p) k)]
          [(eq? (vector-ref vec i) 'B)
           (swap! vec i k)
           (loop i p (sub1 k))]
          [else (loop (add1 i) p k)])))

Be aware that the previous solution mutates the input vector in-place. It's quite elegant, and works as expected:

(sortf (vector 'W 'R 'W 'B 'R 'W 'B 'B 'R))
=> '#(R R R W W W B B B)

Answer 2

This is a solution without using sort or higher order functions. (Ie no fun at all) This doesn't really sort but it solves your problem without using sort. named let and case are the most exotic forms in this solution.

I wouldn't have done it like this unless it's required not to use sort. I think lepple's answer is both elegant and easy to understand.

This solution is O(n) so it's probably faster than the others with very large number of balls.

#!r6rs
(import (rnrs base))

(define (sort-flag lst)
  ;; count iterates over lst and counts Rs, Ws, and Bs
  (let count ((lst lst) (rs 0) (ws 0) (bs 0))
    (if (null? lst)
        ;; When counting is done build makes a list of
        ;; Rs, Ws, and Bs using the frequency of the elements
        ;; The building is done in reverse making the loop a tail call
        (let build ((symbols '(B W R))
                    (cnts (list bs ws rs))
                    (tail '()))
          (if (null? symbols)
              tail ;; result is done
              (let ((element (car symbols)))
                (let build-element ((cnt (car cnts))
                                    (tail tail))
                  (if (= cnt 0)
                      (build (cdr symbols)
                             (cdr cnts)
                             tail)
                      (build-element (- cnt 1) 
                                     (cons element tail)))))))
        (case (car lst)
          ((R) (count (cdr lst) (+ 1 rs) ws bs)) 
          ((W) (count (cdr lst) rs (+ 1 ws) bs)) 
          ((B) (count (cdr lst) rs ws (+ 1 bs)))))))

Answer 3

Make a lookup eg

(define sort-lookup '((R . 1)(W . 2)(B . 3)))

(define (sort-proc a b)
  (< (cdr (assq a sort-lookup))
     (cdr (assq b sort-lookup))))

(list-sort sort-proc '(W R W B R W B B))

Runnable R6RS (IronScheme) solution here: http://eval.ironscheme.net/?id=110

Answer 4

You just use the built-in sort or the sort you already have and use a custom predicate.

(define (follow-order lst)
 (lambda (x y)
  (let loop ((inner lst))
  (cond ((null? inner) #f) 
        ((equal? x (car inner)) #t)
        ((equal? y (car inner)) #f)
        (else (loop (cdr inner)))))))

(sort '(WRWBRWB) (follow-order '(RWB)))

;Value 50: (rrwwwbb)