----------------------------------------
-- Generic Sorting in Haskell
-- Fritz Ruehr, Willamette University, October 2001
-- For the 3rd Annual CCSC Northwest Conference
----------------------------------------

--------------------
-- Insertion and quick sorts in Haskell

isort, qsort, qsort' :: Ord a => [a] -> [a]

isort = foldr ins []
ins x [] = [x]
ins x (y:ys) = if x<=y then x:(y:ys) else y : ins x ys

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

-- a more concise quicksort

qsort' []     = []
qsort' (x:xs) = rec (<x) ++ [x] ++ rec (>=x)
                where rec p = qsort' (filter p xs)


--------------------
-- Abstracting the ordering relation

type Reln a = a -> a -> Bool

sort :: [a] -> Reln a -> [a]

sort []     (<) = []
sort (x:xs) (<) = rec (<x) ++ [x] ++ rec (not.(<x))
                  where rec p = sort (filter p xs) (<)


-- > sort [2,7,9,4,3,8,5,1,4,6] (<)
-- [1,2,3,4,4,5,6,7,8,9]

-- > sort [2,7,9,4,3,8,5,1,4,6] (>)
-- [9,8,7,6,5,4,4,3,2,1]


--------------------
-- Sorting on extracted "fields"

by p f x y = p (f x) (f y)

incr, decr :: Ord a => Reln a
incr = (<)
decr = (>)

offices = [("Fritz", 404), ("Jim", 403), ("Jenny", 405)]

-- > sort offices (incr `by` fst)
-- [("Fritz",404),("Jenny",405),("Jim",403)]

-- > sort offices (decr `by` snd)
-- [("Jenny",405),("Fritz",404),("Jim",403)]


--------------------
-- Sorting by two simultaneous relations

type Pair a = (a,a)
pair f (x, y) = (f x, f y)

psort :: [a] -> Pair (Reln a) -> Pair [a]
psort = pair . sort

pprint (a,b) = putStr (show a ++ '\n' : show b)

-- > sort offices (incr `by` fst)
-- [("Fritz",404),("Jenny",405),("Jim",403)]

-- > pprint (psort offices (incr `by` fst, decr `by` snd))
-- [("Fritz",404),("Jenny",405),("Jim",403)]
-- [("Jenny",405),("Fritz",404),("Jim",403)]


--------------------
-- Courses database "schema"

data Level = Service | Core | Mid | Upper | Seminar  
             deriving (Eq,Ord,Show)

data Course = 
  Course { title:: String, number:: Int,
           instr:: String, level :: Level, cap:: Int }
  deriving Eq

instance Show Course where
  show (Course t n i l c) = 
    "CS " ++ show n ++ ": " ++ t ++ "\t" ++
    i ++ "\t" ++ "(cap = " ++ show c ++ ")"

report :: Show a => [a] -> IO()
report = putStr . unlines . map show


--------------------
-- The Courses database

courses = 

  [ Course  "Concepts"     130  "Temp"   Service  25,
    Course  "Ray Tracing"  140  "Jenny"  Core     20,
    Course  "Intro Prog"   231  "Staff"  Core     20,
    Course  "Data Struc"   241  "Staff"  Core     20,
    Course  "Prog Lang"    348  "Fritz"  Mid      20,
    Course  "Algorithms"   443  "Jenny"  Mid      20,
    Course  "GUI / Sim"    444  "Jim"    Upper    20,
    Course  "Automata"     446  "Fritz"  Mid      20,
    Course  "Graphics"     445  "Jenny"  Upper    20,
    Course  "Mach Learn"   448  "Jim"    Upper    20,
    Course  "Func Prog"    454  "Fritz"  Upper    10,
    Course  "Senior Sem"   496  "Staff"  Seminar  10  ]


--------------------
-- Derived lexicographic orderings

-- lexicographic sort (by two *sequential* relations)

andthen p q a b = p a b || not (p b a) && q a b

std = (incr `by` number)
itn = (incr `by` instr) `andthen` (incr `by` number)

-- > psort courses (std,itn) == 
--   (sort courses std, sort courses itn)
-- True

lexord :: [Reln a] -> Reln a
lexord = foldr1 andthen


--------------------
-- Example lexicographic sort

-- > report (sort courses itn)

-- CS 348: Prog Lang       Fritz   (cap = 20)
-- CS 446: Automata        Fritz   (cap = 20)
-- CS 454: Func Prog       Fritz   (cap = 10)
-- CS 140: Ray Tracing     Jenny   (cap = 20)
-- CS 443: Algorithms      Jenny   (cap = 20)
-- CS 445: Graphics        Jenny   (cap = 20)
-- CS 444: GUI / Sim       Jim     (cap = 20)
-- CS 448: Mach Learn      Jim     (cap = 20)
-- CS 231: Intro Prog      Staff   (cap = 20)
-- CS 241: Data Struc      Staff   (cap = 20)
-- CS 496: Senior Sem      Staff   (cap = 10)


--------------------
-- End of file
--------------------