module Util.Progress(
Progress(),
progressNew,
progressStep,
progressIOSteps,
progressIONew,
progressSteps
)where
import System.IO
import Data.IORef
data Progress k = Progress {
pTreap :: Treap k Double,
pIncrement,pDecrement,pBias,pTotal :: !Double
}
instance Show (Progress k) where
showsPrec n pr = showsPrec n (toPercent $ pTotal pr) . showChar '%'
progressIONew
:: Int
-> Int
-> Char
-> IO (IORef (Progress Char))
progressIONew nSteps nOut dChar = do
let (pr,is) = progressStep (progressNew (nSteps + 1) nOut) dChar
hPutStr stderr is
newIORef pr
progressIOSteps :: IORef (Progress Char) -> [Char] -> IO ()
progressIOSteps ref ks = do
pr <- readIORef ref
let (pr',os) = progressSteps pr ks
hPutStr stderr os
writeIORef ref pr'
progressNew
:: Int
-> Int
-> Progress k
progressNew nSteps nOut = Progress {
pTreap = Nil,
pBias = 0.5 / fromIntegral nOut ,
pTotal = 0,
pIncrement = 1.0 / fromIntegral nSteps,
pDecrement = 1.0 / fromIntegral nOut
}
progressSteps :: Ord k => Progress k -> [k] -> (Progress k,[k])
progressSteps pr ks = foldr fn (pr,[]) ks where
fn k (pr,ks) = (pr',ks' ++ ks) where
(pr',ks') = progressStep pr k
progressStep :: Ord k => Progress k -> k -> (Progress k,[k])
progressStep pr k = (pr { pTreap = ot, pBias = nb, pTotal = pTotal pr + pIncrement pr },ks) where
dec = pDecrement pr
itreap = insertWith (+) k (negate $ pIncrement pr) (pTreap pr)
(ot,nb,ks) = f (pBias pr pIncrement pr) itreap []
f b t ks | b <= negate dec = f (b + dec) (insertWith (+) k dec t) (k:ks)
| otherwise = (t,b,ks) where
Just (k,_,_) = extract t
toPercent :: Double -> Double
toPercent d = (/ 100) . fromInteger $ round (d * 10000)
data Treap k p = Nil | Fork k p (Treap k p) (Treap k p)
deriving(Show)
merge :: Ord p => Treap k p -> Treap k p -> Treap k p
merge Nil t = t
merge t Nil = t
merge a@(Fork kx x x1 x2) b@(Fork ky y y1 y2)
| x > y = Fork kx x x1 (merge x2 b)
| otherwise = Fork ky y (merge a y1) y2
extract :: (Ord k,Ord p) => Treap k p -> Maybe (k,p,Treap k p)
extract Nil = Nothing
extract (Fork kx x t1 t2) = Just (kx,x,merge t1 t2)
insertWith :: (Ord k,Ord p) => (p -> p -> p) -> k -> p -> Treap k p -> Treap k p
insertWith fp k p t = f t where
f Nil = Fork k p Nil Nil
f (Fork k' p' t1 t2) = case compare k k' of
LT -> ins k' p' (f t1) t2
GT -> ins k' p' t1 (f t2)
EQ -> ins k (fp p p') t1 t2
ins k p Nil Nil = Fork k p Nil Nil
ins k p (Fork k' p' l r) t2 | p > p' = Fork k' p' l (ins k p r t2)
ins k p t1 (Fork k' p' l r) | p > p' = Fork k' p' (ins k p t1 l) r
ins k p t1 t2 = Fork k p t1 t2