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