--------------------
-- Sample sorting algorithms
-- Fritz Ruehr, WU CS 454, Spring 03
-------------------

--------------------
-- Type signatures for sort functions
-- (note: not the generic versions yet)

isort, ssort, ssort', msort, msort', qsort, qsort', tsort, tsort' {-, hsort -} 
  :: Ord a => [a] -> [a]


--------------------
-- Insertion sort [easy split, hard join; one and many]
--------------------

isort [] = []
isort (x:xs) = ins x (isort xs)

ins a [] = [a]
ins a (b:bs) = if a <= b then a:b:bs 
                         else b:ins a bs


--------------------
-- Selection sort [hard split, easy join; one and many]
--------------------

ssort [] = []
ssort xs = m : ssort (xs \\ m)
           where m = minimum xs

[]     \\ x = []
(a:as) \\ x = if a==x then as
                      else a: (as \\ x)

-- using a tupling technique for minimum

ssort' [] = []
ssort' (x:xs) = m : ssort' (rest)
                where (m,rest) = minl (x,xs)

minl (m,[]) = (m,[])
minl (m,x:xs) = if m <=x then let (n,ys) = minl (m,xs) in (n,x:ys)
                         else let (n,ys) = minl (x,xs) in (n,m:ys)


--------------------
-- Merge sort [easy split, hard join; half and half]
--------------------

msort []  = []
msort [x] = [x]
msort xs  = merge (both msort (split xs))

split (x:y:rest) = each (x:) (y:) (split rest)
split xs = (xs,[])

merge (xs,[]) = xs
merge ([],ys) = ys
merge (x:xs,y:ys) = if x<y then x: merge (xs,y:ys)
                           else y: merge (x:xs,ys)

-- bottom-up mergesort

msort' l = ms (itemize l)
           where ms [r] = r
                 ms  l  = ms (mpairs l)

mpairs [] = []
mpairs x@[l] = x
mpairs (l1:l2:rest) = merge (l1,l2) : mpairs rest

itemize [] = []
itemize (x:xs) = [x] : itemize xs


--------------------
-- Quick sort [hard split, easy join; half and half]
--------------------

qsort [] = []
qsort (x:xs) = qsort [y | y<-xs, y<x] ++ x :
               qsort [y | y<-xs, y>=x]

-- using accumulation

qsort' [] = []
qsort' xs = qs xs []
            where qs []     acc = acc
                  qs (x:xs) acc = qs as (x : qs bs acc)
                                  where (as,bs) = partition (<x) xs

partition p [] = ([],[])
partition p (x:rest) = switch (p x) (x:) (partition p rest)


--------------------
-- Tree sort [hard split, easy join; rec. structure]
--------------------

data BTree a = Leaf | Node a (BTree a) (BTree a) deriving Show

insert x Leaf = Node x Leaf Leaf
insert x (Node a b c) = if x<=a then Node a (insert x b) c
                                else Node a b (insert x c)

inorder Leaf = []
inorder (Node a b c) = inorder b ++ a : inorder c

tsort = inorder . foldl (flip insert) Leaf

-- using accumulation

inord acc Leaf = acc
inord acc (Node a b c) = inord (a:inord acc c) b

tsort' = inord [] . foldl (flip insert) Leaf


--------------------
-- Some pairing utilities

both f (x,y) = (f x, f y)

each f g (x,y) = (f x, g y)

switch b f (x,y) = if b then (f x,y) else (x, f y)


--------------------
-- Test data and generators
--------------------

tests   = [ [], [100], [10,1], [7,2,4,8,10,1,3,5,6,9]  ]

test    = tests !! 3

results = [ [], [100], [1,10], [1..10] ]

sorts :: Ord a => [ [a] -> [a] ]
sorts   = [ isort, ssort, msort, qsort ]

check   = and [sort t == r | sort<-sorts, (t,r) <- zip tests results]

-- generating interesting larger tests

test2 = test ++ test

grow test = concat (trans (tab (\i j->i*10+j) test test))

big    = grow test
bigger = grow test ++ grow test

tab f xs ys = map (flip map ys . f) xs

trans [] = []
trans [xs] = map (:[]) xs
trans (xs:xss) = zipWith (:) xs (trans xss)

	
{- --------------------
   Speed comparisons
   --------------------
   
   algm		test	test2	  big	bigger
   -----	----	-----	 -----	------
   isort	 364	 1184	 25735	100985
   ssort	 730	 2684	 63316	251471
   ssort'	 672	 2532	 60612	241212
   msort	 321	  809	  5733	 13080
   msort'	 319	  732	  5158	 11748
   qsort	 508	 1300	 10516	 24430
   qsort'	 317	  755	  5597	 12721
   tsort	 374	  913	  6923	 15881
   tsort'	 355	  865	  6595	 15125
   
   -------------------- -}