Progress.hs

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  -- ^ number of steps
    -> Int  -- ^ number of output positions
    -> 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)

{-
histogram :: Ord k => [k] -> (Int,[(k,Int)])
histogram ks = mapSnd toListByPriority (foldr f (0,Nil) ks) where
    f k (n,t) = (n - 1,insertWith (+) k (-1) t)
    mapSnd f (x,y) = (x,f y)

histogramP :: Ord k => [k] -> [(k,Double)]
histogramP ks = [ (x,toPercent $ fromIntegral y / t) | (x,y) <- hs] where
    (ti,hs) = histogram ks
    t = fromIntegral ti

p = progressNew 7 10
p2 = progressNew 12 7
s7 = "..xxw.."
s12 = ".x.y.xx...x."

toListByPriority :: Treap k p -> [(k,p)]
toListByPriority t = f t [] where
    f Nil rs = rs
    f (Fork k p t1 t2) rs = f t1 ((k,p):f t2 rs)
-}



data Treap k p = Nil | Fork k p (Treap k p) (Treap k p)
    deriving(Show)

{-
lookup :: Ord k => k -> Treap k p -> Maybe p
lookup k t = f t where
    f Nil = Nothing
    f (Fork k' p t1 t2) = case compare k k' of
        LT -> f t1
        GT -> f t2
        EQ -> Just p
-}

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)

{-
fromList [] = Nil
fromList ((k,p):rs) = insert k p (fromList rs)
-}

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

{-
insert :: (Ord k,Ord p) => k -> p -> Treap k p -> Treap k p
insert k p t = insertWith const k p t
-}



-- very simple priority queue


{-
data Heap a = Nil | Fork a (Heap a) (Heap a)

isEmpty Nil = True
isEmpty _ = False

minElem (Fork x a b) = Just (x,merge a b)
minElem _ = Nothing

insert x a = merge (Fork x Nil Nil) a

merge a Nil = a
merge Nil b = b
merge a@(Fork x _ _) b@(Fork y _ _)
    | x <= y = join a b
    | otherwise = join b a
    where
    join (Fork x a b) c = Fork x b (merge a c)


discard :: Ord a => a -> Heap a -> Heap a
discard b h = f h where
    f Nil = Nil
    f (Fork x h1 h2)
        | x < b = merge (f h1) (f h2)
        | otherwise = merge h1 h2

-}