Algorithms in Haskell

closest.hs

import Data.List

type Point a = (a,a)

distance :: Floating a => Point a -> Point a -> a
distance (a,b) (c,d) = sqrt ((a-c)^ 2 + (b-d)^ 2)

min_distance_naive :: (Ord a, Floating a) => [Point a] -> a
min_distance_naive = foldr1 min . loop
  where
    loop []     = []
    loop (x:xs) = map (distance x) xs ++ loop xs

sortPoints :: (Ord a, Floating a) => (Point a -> a) -> [Point a] -> [Point a]
sortPoints _ [a]   = [a]
sortPoints coord l = merge (sortPoints coord lo) (sortPoints coord hi)
  where
    (lo, hi) = splitAt (length l `div` 2) l
    merge [] r = r
    merge l [] = l
    merge (l:ls) (r:rs) 
      | coord l < coord r = l : merge ls (r:rs)
      | otherwise         = r : merge (l:ls) rs

min_distance' :: (Ord a, Floating a) => [Point a] -> [Point a] -> a
min_distance' xs ys
  | length xs <= 3 = min_distance_naive xs
  | otherwise      = 
    let (xl, xr) = splitx xs
        (yl, yr) = splity ys 
    in find_min (min_distance' xl yl) (min_distance' xr yr) 

  where
    find_min l r = 
      let delta = min l r
          ys'   = filter (\(a,b) -> abs (a - fst pivot) < delta) ys
      in foldl' min delta $ loop ys'

    loop []     = []
    loop (x:xs) = map (distance x) (take 7 xs) ++ loop xs

    boundary xs = length xs `div` 2
    pivot = xs !! boundary xs
    splitx xs = splitAt (boundary xs) xs
    splity ys = partition (\(a,b) -> a < fst pivot) ys

min_distance :: (Ord a, Floating a) => [Point a] -> a
min_distance ps = min_distance' xs ys
  where
    xs = sortPoints fst ps
    ys = sortPoints snd ps
  

inversions.hs

inversions :: [Int] -> Int
inversions l = count $ aux l'
  where
    l'    = zipWith (,) l (repeat 0)
    count = foldr1 (+) . snd . unzip
    merge [] r  = r
    merge l []  = l
    merge (l:ls) (r:rs)
      | l <= r    = l : merge ls (r:rs)
      | otherwise = (fst r, snd r + length ls + 1) : merge (l:ls) rs

    aux :: [(Int,Int)] -> [(Int,Int)]
    aux [a] = [a]
    aux l   = let (lo, hi) = splitAt (length l `div` 2) l in
              merge (aux lo) (aux hi)

mergesort.hs

mergesort :: [Int] -> [Int]
mergesort [a]  = [a]
mergesort l = merge (mergesort lo) (mergesort hi)
  where
    (lo, hi) = splitAt (length l `div` 2) l
    merge [] r = r
    merge l [] = l
    merge (l:ls) (r:rs) 
      | l < r     = l : merge ls (r:rs)
      | otherwise = r : merge (l:ls) rs

quicksort3.hs

-- randomized quick sort with 3-way partition
module QuickSort (quicksort) where
import Data.Array.ST
import Control.Monad
import Control.Monad.ST
import System.Random

type QA s = STUArray s Int Int

swap :: Int -> Int -> QA s -> ST s ()
swap i j arr = do
  x <- readArray arr i
  y <- readArray arr j
  writeArray arr i y
  writeArray arr j x

partition :: QA s -> (Int, Int) -> ST s (Int, Int)
partition arr (lo, hi) = do
  x <- readArray arr lo
  (m1, m2) <- foldM (step x) (lo, lo) [succ lo .. hi]
  swap lo m1 arr
  return (m1, m2)
  where
    step = \x (i,j) k -> do
      y <- readArray arr k
      let i' = succ i
          j' = succ j in 
        if y < x then 
          do swap k j' arr; swap i' j' arr; return (i',j')
        else if y == x then
          do swap k j' arr; return (i,j')
        else 
          return (i,j)

quicksortST :: QA s -> (Int, Int) -> StdGen -> ST s ()
quicksortST arr (lo, hi) g = do
  when (lo < hi) $ do
    let (lo', g') = randomR (lo, hi) g
    swap lo lo' arr
    (m1, m2) <- partition arr (lo, hi)
    quicksortST arr (lo, m1 - 1) g'
    quicksortST arr (m2 + 1, hi) g'

quicksort :: [Int] -> [Int]
quicksort [] = []
quicksort l = runST $ do
  arr <- newListArray (1, length l) l :: ST s (QA s)
  bounds <- getBounds arr
  quicksortST arr bounds (mkStdGen 1)
  getElems arr