home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / demos / fastsort.hs < prev    next >
Text File  |  1995-02-14  |  1KB  |  42 lines
  1. {- list sorting: see L.C.Paulson, ML for the working programmer, Cambidge, p100
  2. -- The list is split into ascending chunks which are then merged in pairs.
  3.  
  4. samsort l = sorting [] 0 l
  5.   where    sorting ls k []        = head(mergepairs ls 0)
  6.     sorting    ls k (x:xs)    = sorting (mergepairs (run:ls) kinc) kinc tl
  7.       where    (run, tl)    = nextrun [x] xs
  8.         kinc        = k+1
  9.     nextrun run []        = (reverse run, [])
  10.     nextrun    rs@(r:_) xl@(x:xs)
  11.         | x<r        = (reverse rs, xl)
  12.         | otherwise    = nextrun (x:rs) xs
  13.     mergepairs [l] _ = [l]
  14.     mergepairs lx@(l1:l2:ls) k
  15.         | k`mod`2 == 1    = lx
  16.         | otherwise    = mergepairs((merge l1 l2):ls) (k/2)
  17. -}
  18.  
  19. -- this mergesort uses a partioning mechanism like quicksort to build
  20. -- longer initial sequences. It also uses a non-counting mergePairs.
  21. -- Bob Buckley 30-MAR-93 (Bob.Buckley@levels.unisa.edu.au)
  22.  
  23. msort xs = mergePhase (runPhase xs)
  24.   where    mergePhase [x]        = x
  25.     mergePhase [x,y]    = merge x y    -- redundant case
  26.     mergePhase l        = mergePhase (mergePairs l)
  27.     mergePairs [x1,x2]    = [merge x1 x2]    -- redundant case
  28.     mergePairs (x1:x2:xs)    = merge x1 x2 : mergePairs xs
  29.     mergePairs l        = l        -- note: l=[] or l=[_]
  30.     runPhase []    = [[]]
  31.     runPhase (e:es) = takeAsc [e] es
  32.     takeAsc asc []    = [reverse asc]
  33.     takeAsc xs@(x:_) zs@(z:zr)
  34.         | x<=z        = takeAsc (z:xs) zr
  35.         | otherwise    = takeDec xs [z] zr
  36.     takeDec asc dec []    = [merge (reverse asc) dec]
  37.     takeDec xs@(x:_) ys@(y:_) zs@(z:zr)
  38.         | z<y        = takeDec xs (z:ys) zr
  39.         | x<=z        = takeDec (z:xs) ys zr
  40.         | otherwise    = merge (reverse xs) ys : runPhase zs
  41.  
  42.