Posts Tagged ‘sort’

Programming Praxis – Dutch National Flag

March 5, 2013

In today’s Programming Praxis exercise, our goal is to implement a sorting algorithm for lists with three different elements that works in linear time. Let’s get started, shall we?

import qualified Data.Vector as V

We’re only allowed to use index and swap operations. Swap isn’t defined in the Vector package, but is easy to express as a bulk update.

swap :: Int -> Int -> V.Vector a -> V.Vector a
swap i j a = a V.// [(i,a V.! j), (j,a V.! i)]

To sort the array, we keep track of where the next red and blue elements should be inserted, as well as the current index. When encountering red and blue elements, they are shifted to the correct location. If the element was blue, we have to test again since it could be anything. If it was red, the element that’s swapped to the current location will always be white, so we can move on. Once we reach the start of the group of blue elements at the end we can stop.

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)

Some tests to see if everything is working properly:

test :: String -> Bool
test x = flag (V.fromList x) == V.fromList
  (filter (== 'R') x ++ filter (== 'W') x ++ filter (== 'B') x)

main :: IO ()
main = do print $ test ""
          print $ test "W"
          print $ test "R"
          print $ test "B"
          print $ test "RWB"
          print $ test "BWR"
          print $ test "RWBR"
          print $ test "WRBRBRBWRWBWBRBWRBWRBWRBWBBBRBRWBRWB"

Programming Praxis – Hett’s Problem 1.28

August 9, 2011

In today’s Programming Praxis, our goal is to sort a list of lists by length and by length frequency. Let’s get started, shall we?

A quick import:

import qualified Data.List.Key as K

Sorting by length is trivial.

byLength :: [[a]] -> [[a]]
byLength = K.sort length

Sorting by frequency of the list lengths is a bit more complicated since we need to group and ungroup the lists, but still a one-liner.

byLengthFreq :: [[a]] -> [[a]]
byLengthFreq = concat . byLength . K.group length . byLength

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ byLength ["abc","de","fgh","de","ijkl","mn","o"]
                        == ["o","de","de","mn","abc","fgh","ijkl"]
          print $ byLengthFreq ["abc","de","fgh","de","ijkl","mn","o"] 
                            == ["o","ijkl","abc","fgh","de","de","mn"]

Programming Praxis – Two Bad Sorts

May 17, 2011

In today’s Programming Praxis exercise, our task is to implement two inefficient sorting algorithms. Let’s get started, shall we?

Some imports:

import Control.Arrow
import System.Random
import System.Random.Shuffle

Stoogesort is fairly bad at O(n^2.7).

stoogesort :: Ord a => [a] -> [a]
stoogesort []       = []
stoogesort xs@(h:t) = f $ if last xs < h then last xs : init t ++ [h] else xs
    where f = if length xs > 2 then s first 2 . s second 1 . s first 2 else id
          s p n = uncurry (++) . p stoogesort . splitAt (div (n * length xs) 3)

Bogosort is more interesting. It has the potential of sorting a list in O(n). The chance of this happening, however, is pretty low. The resulting average performance is a terrible O(n*n!).

bogosort :: Ord a => [a] -> IO [a]
bogosort [] = return []
bogosort xs = if and $ zipWith (<=) xs (tail xs) then return xs
              else bogosort . shuffle' xs (length xs) =<< newStdGen

Some tests to see if everything is working properly:

main :: IO ()
main = do print . (== [1..5]) =<< bogosort [3,1,5,4,2]
          print $ stoogesort [3,1,5,4,2] == [1..5]

Seems like it is. Having said that, never use either of these in practice.

Programming Praxis – Topological Sort

November 19, 2010

In today’s Programming Praxis exercise, our goal is to write two functions related to directed acyclical graphs (DAGs). The first one is to check whether a given directed graph is acyclical. The second is to perform a topological sort of a DAG, which means to sort it so that no node precedes a node that leads to it. Let’s get started, shall we?

A quick import:

import Data.List

The following function is just a bit of syntactic sugar for an operation I use a few times.

with :: (a -> b) -> [a] -> (b -> b -> Bool) -> b -> [a]
with t xs eq x = filter ((eq x) . t) xs

Both functions need to find vertices with no incoming edges.

noIncoming :: Eq a => [(a, a)] -> [a] -> Maybe a
noIncoming es = find (null . with snd es (==))

Checking if a graph is cyclical is a simple matter of recursively removing nodes with no incoming edges to see if any remain, which would mean that the graph is cyclical.

isCyclic :: Eq a => [(a, a)] -> Bool
isCyclic = not . null . until (\x -> remove x == x) remove where
    remove es = maybe es (with fst es (/=)) . noIncoming es $ map fst es

The process for topologically sorting a list is roughly similar: Find a vertex with no incoming edges, remove the edges leading from it and repeat, returning the vertices in the correct order.

tsort :: Eq a => [(a, a)] -> [a]
tsort xs = if isCyclic xs then error "cannot sort cyclic list"
           else f xs . nub . uncurry (++) $ unzip xs where
    f es vs = maybe [] (\v -> v : f (with fst es (/=) v) (delete v vs)) $
              noIncoming es vs

Some tests to see if everything is working correctly:

main :: IO ()
main = do print $ isCyclic [(3,8),(3,10),(5,11),(7,8)
                           ,(7,11),(11,2),(11,9),(11,10)]
          print $ isCyclic [(3,8),(3,10),(5,11),(7,8),(7,11)
                           ,(10,5),(11,2),(11,9),(11,10)]
          print $ tsort [(3,8),(3,10),(5,11),(7,8)
                        ,(7,11),(11,2),(11,9),(11,10)]

We get a different order than the Scheme solution, but as the exercise mentions there are many different possible sorts. Since we’re using a different algorithm, we get different results.

Programming Praxis – Two Sub-Quadratic Sorts

October 31, 2009

In yesterday’s Programming Praxis problem we have to implement two sort algorithms. Let’s get started.

First, some imports:

import Control.Monad
import Data.List
import Data.List.HT
import Data.Array.IO
import Data.Array.MArray

For the Comb sort algorithm, we’re going to need a function to swap two elements of an array.

swap :: (MArray a e m, Ix i, Ord e) => i -> i -> a i e -> m ()
swap i j a = do x <- readArray a i
                y <- readArray a j
                when (y < x) $ writeArray a i y >> writeArray a j x

The Comb sort algorithm itself:

combSort :: Ord a => [a] -> IO [a]
combSort [] = return []
combSort xs = comb (s-1) =<< newListArray (1, s) xs where
    comb :: Ord a => Int -> IOArray Int a -> IO [a]
    comb 0 a = getElems a
    comb n a = mapM_ (\i -> swap i (i+n) a) [1..s-n] >> comb (n-1) a
    s = length xs

We don’t need array access for the Shell sort algorithm, so that saves some code. It’s in the IO monad so we can use the same test function, but the algorithm itself is pure.

shellSort :: Ord a => [a] -> IO [a]
shellSort [] = return []
shellSort xs = return $ shell (last . takeWhile (< length xs) $
                               iterate (succ . (*3)) 1) xs where
    shell 1 = foldr insert []
    shell n = shell (div (n-1) 3) . concatMap (shell 1) . sliceHorizontal n

A little test harness to see of everything’s working:

test :: ([Int] -> IO [Int]) -> IO ()
test f = do print . null =<< f []
            print . (== [1..9]) =<< f [4,7,3,9,1,5,2,6,8]

main :: IO ()
main = do test combSort
          test shellSort

Looks like it is.