Dutch National Flag
March 5, 2013
We begin with the examine and swap functions:
(define examine vector-ref)
(define (swap! xs p1 p2)
(let ((t (vector-ref xs p1)))
(vector-set! xs p1 (vector-ref xs p2))
(vector-set! xs p2 t))
xs)
Although it’s usually stated as a sorting problem, this is actually a partitioning problem. The usual solution is to maintain three pointers: a red pointer that initially points to the first location in the array, a white pointer that initially points to the first location in the array, and a blue pointer that initially points to the last location in the array. Then the array is scanned from left to right. Each time you encounter a red element, swap it with the current red pointer and increment the red and white pointers. Each time you encounter a blue symbol, swap it with the current blue pointer and decrement the blue pointer. Each time you encounter a white symbol, leave it where it is and increment the white pointer. The scan stops when the white pointer crosses the blue pointer, at which point the arrays is partitioned as requested:
(define (dutch-national-flag xs)
(let loop ((r 0) (w 0) (b (- (vector-length xs) 1)))
(if (< b w) xs
(case (examine xs w)
((#\R) (set! xs (swap! xs r w))
(loop (+ r 1) (+ w 1) b))
((#\W) (loop r (+ w 1) b))
((#\B) (set! xs (swap! xs b w))
(loop r w (- b 1)))))))
Here’s an example, augmented with the values at each step of the loop so you can see how the pointers track:
> (dutch-national-flag #(#\B #\W #\B #\R #\W #\R #\B))
0 0 6 #(B W B R W R B)
0 0 5 #(B W B R W R B)
0 0 4 #(R W B R W B B)
1 1 4 #(R W B R W B B)
1 2 4 #(R W B R W B B)
1 2 3 #(R W W R B B B)
1 3 3 #(R W W R B B B)
2 4 3 #(R R W W B B B)
#(R R W W B B B)
This is exactly the same algorithm as the “fat pivot” partition that is sometimes used in quicksort, which brings together all the array elements equal to the pivot instead of leaving them in place on one side or the other; the same algorithm is also used in ternary search tries. You can run the program at http://programmingpraxis.codepad.org/0UFUJWc0.
The original source of the exercise is Dijkstra’s book A Discipline of Programming, published by Prentice Hall in 1976.
Programming Praxis 
[…] today’s Programming Praxis exercise, our goal is to implement a sorting algorithm for lists with three […]
My Haskell solution (see http://bonsaicode.wordpress.com/2013/03/05/dutch-national-flag/ for a version with comments):
import qualified Data.Vector as V swap :: Int -> Int -> V.Vector a -> V.Vector a swap i j a = a V.// [(i,a V.! j), (j,a V.! i)] flag :: V.Vector Char -> V.Vector Char flag xs = f (0, V.length xs - 1) xs 0 where f (r,b) a n = if n > b then a else case a V.! n of 'R' -> f (r+1,b ) (swap n r a) (n+1) 'B' -> f (r, b-1) (swap n b a) n _ -> f (r, b ) a (n+1)[…] Question is from here: […]
My java solution here.
My python solution here( https://github.com/seckcoder/geass/blob/master/dnf4.py ). Actually I implemented the Dutch National Flag Algorithm for 4 colors.
[…] Pages: 1 2 […]
Here’s mine: Partitioning the Dutch national flag
This time, I have both a Racket version and a JavaScript version. The JavaScript has an HTML5 canvas visualizer which was pretty neat to write. It will show the blocks as it sorts, along with the three labels. Let me know if you have any problems running it, I haven’t tested it on anything but Win7/Chrome.
A Common Lisp implementation:
(use-package :iterate) ;; (arotatef a i j k) -> (rotatef (aref a i) (aref a j) (aref a k)) (defmacro arotatef (a &rest indices) `(rotatef ,@(mapcar (lambda (i) `(aref ,a ,i)) indices))) (defun rwb-sort (a) (iter (with next-red = 0) (with next-white = 0) (with next-blue = 0) (for x in-vector a) (ecase x (red (arotatef a next-blue next-white next-red) (incf next-red) (incf next-white) (incf next-blue)) (white (arotatef a next-blue next-white) (incf next-white) (incf next-blue)) (blue (incf next-blue))))) (let ((rwb '(red white blue))) (defun random-rwb () (elt rwb (random 3)))) (defun random-rwb-array (n) (iter (repeat n) (collect (random-rwb) :result-type 'vector)))) (defun test (n) (let ((a (random-rwb-array n))) (rwb-sort a) a))My version in python without peaking at the solution. For some reason, I had the idea of starting in the middle. def swap(arr, i, j): arr[i], arr[j] = arr[j], arr[i] def dutch_flag(x): ''' >>> dutch_flag (['b', 'r', 'r', 'w', 'r', 'w', 'b', 'w', 'w', 'r']) ['r', 'r', 'r', 'r', 'w', 'w', 'w', 'w', 'b', 'b'] ''' l, u = 0, len(x) - 1 m1 = (u + l) / 2 m2 = (u + l) / 2 while m1 >= l: if x[m1] == 'r': swap(x, m1, l) l = l + 1 elif x[m1] == 'b': swap(x, m1, u) u = u - 1 elif x[m1] == 'w': m1 = m1 - 1 while m2 <= u: if x[m2] == 'r': swap(x, m2, l) l = l + 1 elif x[m2] == 'b': swap(x, m2, u) u = u - 1 elif x[m2] == 'w': m2 = m2 + 1 return xDijkstra had really nothing better to do (not like me :-p).
Clojure/Script (try online at http://clojurescript.net/).
(defn sort-flag [cs] (let [a (into-array cs)] (letfn [(swp [i1 i2] (let [v1 (aget a i1)] (aset a i1 (aget a i2)) (aset a i2 v1)))] (loop [reds 0, i 0, blues (dec (count a))] (when (<= i blues) (case (aget a i) :red (do (swp i reds) (recur (inc reds) (inc i) blues)) :white (recur reds (inc i) blues) :blue (do (swp i blues) (recur reds i (dec blues))))))) (into [] a)))Tests:
=> (sort-flag [:blue :red :white])
[:red :white :blue]
=> (sort-flag [:blue :red :white :red :blue :white :blue :red])
[:red :red :red :white :white :blue :blue :blue]
=> (sort-flag [:white :blue :red :white :red :blue :white :blue :red])
[:red :red :red :white :white :white :blue :blue :blue]
=> (sort-flag [:white :blue :red :white :red :blue :white :blue :red :white])
[:red :red :red :white :white :white :white :blue :blue :blue]