public
Last active

Scheduled Merge Sort

  • Download Gist
gistfile1.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
{-# LANGUAGE BangPatterns #-}
 
module ScheduledMergeSort where
 
import Control.DeepSeq
 
newtype Schedule a = Schedule [[a]] deriving Show
data Segment a = Segment [a] (Schedule a) deriving Show
data MergeSort a = MergeSort Int [Segment a] deriving Show
 
instance NFData (Segment a)
 
mrg :: Ord a => [a] -> [a] -> [a]
mrg [] ys = ys
mrg xs [] = xs
mrg xs@(x:xs') ys@(y:ys')
| x <= y = x:mrg xs' ys
| otherwise = y:mrg xs ys'
 
exec1 :: Schedule a -> Schedule a
exec1 (Schedule []) = Schedule []
exec1 (Schedule ([]:sched)) = exec1 (Schedule sched)
exec1 (Schedule ((_:xs):sched)) = Schedule (xs:sched)
 
exec2 :: Segment a -> Segment a
exec2 (Segment xs sched) = Segment xs sched2
where
!sched1 = exec1 sched
!sched2 = exec1 sched1
 
empty :: MergeSort a
empty = MergeSort 0 []
 
add :: Ord a => a -> MergeSort a -> MergeSort a
add x (MergeSort size segs) = MergeSort (size + 1) (map exec2 $!! segs')
where
segs' = addSeg [x] segs size []
addSeg :: Ord a => [a] -> [Segment a] -> Int -> [[a]] -> [Segment a]
addSeg xs segs size rsched
| size `mod` 2 == 0 = Segment xs (Schedule (reverse rsched)) : segs
| otherwise = addSeg xs'' segs' (size `div` 2) (xs'':rsched)
where
(Segment xs' (Schedule [])) : segs' = segs
xs'' = mrg xs xs'
 
sort :: Ord a => MergeSort a -> [a]
sort (MergeSort _ segs) = mrgAll [] segs
where
mrgAll xs [] = xs
mrgAll xs (Segment xs' _ : segs') = mrgAll (mrg xs xs') segs'
 
infixl 0 >-
(>-) :: a -> (a -> b) -> b
a >- f = f a

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.