1 module Sorters 
    2 
    3 ( msort, msortwith
    4 , oemerge, oemerges
    5 , unimerge, unimerges
    6 , diff, dsplit
    7 , uniq, us
    8 , Plug(..), unplug
    9 ) 
   10 
   11 where
   12 
   13 import Trace
   14 
   15 infixl 5 `oemerge`
   16 infixl 5 `unimerge`
   17 
   18 msort :: Ord a => [a] -> [a]
   19 msort = oemerges . runs         -- todo: which is better?
   20         -- mrgsort
   21         
   22 
   23 -- utilities for sorting and merging -----------------------------------
   24 
   25 -- find runs
   26 runs :: Ord a => [a] -> [[a]]
   27 runs [] = []
   28 runs [x] = [[x]]
   29 runs (x : xs) = 
   30     let rrs @ (r @ (y:_) : rs) = runs xs
   31     in  if x <= y then (x : r) : rs
   32         else [x] : rrs
   33 
   34 
   35 mrgsort :: Ord a => [a] -> [a]
   36 mrgsort [] = []; mrgsort [x] = [x]
   37 mrgsort [x,y] = if x < y then [x,y] else [y,x]
   38 mrgsort xs = 
   39     let (as, bs) = conquer xs
   40     in oemerge (mrgsort as) (mrgsort bs)
   41 
   42 conquer [] = ([],[])
   43 conquer [x] = ([x], [])
   44 conquer (x : y : zs) = let (as, bs) = conquer zs in (x : as, y : bs)
   45 
   46 
   47 
   48 
   49 oemerge :: Ord a => [a] -> [a] -> [a]
   50 -- keeps duplicates
   51 oemerge [] ys = ys; oemerge xs [] = xs
   52 oemerge xxs @ (x : xs) yys @ (y : ys) = 
   53     if x < y then x : oemerge xs yys else y : oemerge xxs ys
   54 
   55 
   56 oemerges :: Ord a => [[a]] -> [a]
   57 oemerges [] = []
   58 oemerges [xs] = xs
   59 oemerges [xs,ys] = oemerge xs ys
   60 oemerges xss = 
   61         let (ass, bss) = conquer xss
   62         in oemerge (oemerges ass) (oemerges bss)
   63 
   64 
   65 unimerge :: Ord a => [a] -> [a] -> [a]
   66 -- removes duplicates
   67 unimerge xs [] = xs; unimerge [] ys = ys
   68 unimerge xxs @ (x : xs) yys @ (y : ys) = case compare x y of
   69         LT -> x : unimerge xs yys
   70         GT -> y : unimerge xxs ys
   71         EQ -> x : unimerge xs ys
   72 
   73 unimerges :: Ord a => [[a]] -> [a]
   74 -- removes duplicates
   75 unimerges [] = []
   76 unimerges [xs] = xs
   77 unimerges [xs,ys] = unimerge xs ys
   78 unimerges xss = 
   79         let (ass, bss) = conquer xss
   80         in unimerge (unimerges ass) (unimerges bss)
   81 
   82 
   83 
   84 
   85 uniq :: Ord a => [a] -> [a]
   86 -- arg must be sorted already
   87 uniq [] = []; uniq [x] = [x]
   88 uniq (x : yys @ (y : ys)) 
   89     = (if x == y then id else (x :)) (uniq yys)
   90 
   91 us :: Ord a => [a] -> [a]
   92 us = uniq . msort
   93 
   94 diff :: Ord a => [a] -> [a] -> [a]
   95 -- diff xs ys = all x <- xs that are not in ys
   96 -- args must be sorted, without duplicates
   97 diff [] ys = []; diff xs [] = xs
   98 diff xxs @ (x : xs) yys @ (y : ys)
   99     | x == y    =     diff  xs  ys
  100     | x < y     = x : diff  xs yys
  101     | otherwise =     diff xxs  ys
  102  
  103 dsplit :: Ord a => [a] -> [a] -> ([a],[a])
  104 -- dsplit xs ys = (as, bs) where as = xs intersect ys, bs = xs setminus ys
  105 dsplit [] ys = ([], [])
  106 dsplit xs [] = ([], xs)
  107 dsplit xxs @ (x : xs) yys @ (y : ys)
  108         | x == y    = let (as, bs) = dsplit xs  ys in (x : as, bs)
  109         | x <  y    = let (as, bs) = dsplit xs yys in (    as, x : bs)
  110         | otherwise = let (as, bs) = dsplit xxs ys in (    as, bs)
  111 
  112 ---------------------------------------------------------------------
  113 
  114 best :: Ord a => [a] -> [a]
  115 best = take 1 . reverse . msort
  116 
  117 ---------------------------------------------------------------------
  118 
  119 asc :: Ord b => [(a, b)] -> [(a, b)]
  120 -- show successive maxima, lazily
  121 asc [] = []
  122 asc ((x, c) : xs) = (x, c) : asc [ (x', c') | (x', c') <- xs, c' > c ]
  123 
  124 ascWith :: Ord b => (a -> b) -> [a] -> [a]
  125 ascWith f xs = [ x | (x, c) <- asc [ (x, f x) | x <- xs ] ]
  126 
  127 
  128 -----------------------------------------------------------------------
  129 
  130 data Plug a b = Plug a b deriving Show
  131 
  132 instance Eq a => Eq (Plug a b) where Plug x _ == Plug y _ = x == y
  133 instance Ord a => Ord (Plug a b) where Plug x _ < Plug y _ = x < y
  134 
  135 unplug :: Plug a b -> b; unplug (Plug x y) = y
  136 
  137 msortwith :: Ord b => (a -> b) -> [a] -> [a]
  138 msortwith f xs = map unplug . msort $ [ Plug (f x) x | x <- xs ]