schedulers - first approach

14_schedulers/Algo/Common.hs

@@ -0,0 +1,11 @@
+module Algo.Common where
+
+import Types
+import Heap
+
+updateHeap :: Time -> Time -> (Heap Unit, Heap Unit) -> (Heap Unit, Heap Unit)
+updateHeap start_t fin_t (h, nh) = if (div start_t Types.packet_t /= div fin_t Types.packet_t) then
+    let inc_rem x = x {rem_p = rem_p x + 1}  
+        restore x h = insert (x {rem_p = 1}) h in 
+        (foldr restore (fmap inc_rem h) nh, emptyHeap) -- "bring back" clients without available packets every 20ms 
+    else (h, nh)

14_schedulers/Algo/MaxMinRate.hs

@@ -0,0 +1,20 @@
+module Algo.MaxMinRate where
+
+import Types
+import Heap
+import Algo.Common
+
+createHeap :: [Time] -> Heap Unit
+createHeap [] = Nil
+createHeap (t:ts) = insert (Unit (fromIntegral t) t 1 0) $ createHeap ts -- we use 1/speed as metric 
+
+runUntilCycle :: Int -> [Int] -> Heap Unit
+runUntilCycle p ts = fst $ run 0 (h, emptyHeap) -- maintain two heaps - one for clients with remaining packets, one for clients without available packets
+    where h = createHeap ts
+          run :: Time -> (Heap Unit, Heap Unit) -> (Heap Unit, Heap Unit)
+          run curr_t (h, exh_h) | (mod curr_t p == 0) && (curr_t /= 0) = (h, exh_h) -- cycle found
+                                | otherwise = let (Just m,h') = deleteMax h in
+                                              run (curr_t + period m) $ updateHeap curr_t (curr_t + period m) $ insertDecreased m h' exh_h where
+                                                insertDecreased el h exh_h = if (rem_p el == 1) then 
+                                                    (h, insert el {sent_p = sent_p el + 1, rem_p = 0} exh_h) -- move best client to the "exhausted" heap if his rem_p is equal to zero 
+                                                else (insert el {sent_p = sent_p el + 1, rem_p = rem_p el - 1} h, exh_h) 

14_schedulers/Algo/MaxRate.hs

@@ -0,0 +1,20 @@
+module Algo.MaxRate where
+
+import Types
+import Heap
+import Algo.Common
+
+createHeap :: [Time] -> Heap Unit
+createHeap [] = Nil
+createHeap (t:ts) = insert (Unit (1 / (fromIntegral t)) t 1 0) $ createHeap ts -- we use speed as metric 
+
+runUntilCycle :: Int -> [Int] -> Heap Unit
+runUntilCycle p ts = fst $ run 0 (h, emptyHeap) -- maintain two heaps - one for clients with remaining packets, one for clients without available packets
+    where h = createHeap ts
+          run :: Time -> (Heap Unit, Heap Unit) -> (Heap Unit, Heap Unit)
+          run curr_t (h, exh_h) | (mod curr_t p == 0) && (curr_t /= 0) = (h, exh_h) -- cycle found
+                                | otherwise = let (Just m,h') = deleteMax h in
+                                              run (curr_t + period m) $ updateHeap curr_t (curr_t + period m) $ insertDecreased m h' exh_h where
+                                                insertDecreased el h exh_h = if (rem_p el == 1) then 
+                                                    (h, insert el {sent_p = sent_p el + 1, rem_p = 0} exh_h) -- move best client to the "exhausted" heap if his rem_p is equal to zero 
+                                                else (insert el {sent_p = sent_p el + 1, rem_p = rem_p el - 1} h, exh_h) 

14_schedulers/Algo/PF.hs

@@ -0,0 +1,31 @@
+module Algo.PF where
+
+import Types
+import Heap
+import qualified Algo.Common
+
+createHeap :: [Time] -> Heap Unit
+createHeap [] = Nil
+createHeap (t:ts) = insert (Unit (1 / (fromIntegral t) / 0.01) t 1 0) $ createHeap ts -- we use r/R as metric, where t is speeed, R - transmitted size 
+
+updateHeap :: Time -> Time -> (Heap Unit, Heap Unit) -> (Heap Unit, Heap Unit)
+updateHeap start_t fin_t (h, nh) = if (div start_t Types.packet_t /= div fin_t Types.packet_t) then
+    let inc_rem x = x {rem_p = rem_p x + 1}  
+        restore x h = insert (x {rem_p = 1}) h in 
+        (updateMetrics $ foldr restore (fmap inc_rem h) nh, emptyHeap) -- "bring back" clients without available packets every 20ms 
+    else fmap updateMetrics (h, nh)
+
+-- Rebuild tree to update metrics
+updateMetrics :: Heap Unit -> Heap Unit
+updateMetrics = foldr (\x h -> insert (x {metric = 1 / (fromIntegral $ (period x) * (sent_p x))}) h) emptyHeap 
+
+runUntilCycle :: Int -> [Int] -> Heap Unit
+runUntilCycle p ts = fst $ run 0 (h, emptyHeap) -- maintain two heaps - one for clients with remaining packets, one for clients without available packets
+    where h = createHeap ts
+          run :: Time -> (Heap Unit, Heap Unit) -> (Heap Unit, Heap Unit)
+          run curr_t (h, exh_h) | (mod curr_t p == 0) && (curr_t /= 0) = (h, exh_h) -- cycle found
+                                | otherwise = let (Just m,h') = deleteMax h in
+                                              run (curr_t + period m) $ updateHeap curr_t (curr_t + period m) $ insertDecreased m h' exh_h where
+                                                insertDecreased el h exh_h = if (rem_p el == 1) then 
+                                                    (h, insert el {sent_p = sent_p el + 1, rem_p = 0} exh_h) -- move best client to the "exhausted" heap if his rem_p is equal to zero 
+                                                else (insert el {sent_p = sent_p el + 1, rem_p = rem_p el - 1} h, exh_h) 

14_schedulers/Heap.hs

@@ -0,0 +1,58 @@
+module Heap where
+
+data Heap a = Nil | Node Int a (Heap a) (Heap a) deriving Show
+
+emptyHeap :: Heap a
+emptyHeap = Nil
+
+isEmpty :: Heap a -> Bool
+isEmpty Nil = True
+isEmpty _ = False
+
+size Nil = 0
+size (Node s _ _ _) = s
+
+root (Node _ x _ _) = x
+
+isHeap (Node s x hl hr) = s == 1 + sl + sr && sl >= sr &&
+    (isEmpty hl || x >= root hl) &&
+    (isEmpty hr || x >= root hr) &&
+    isHeap hl && isHeap hr
+    where (sl, sr) = (size hl, size hr)
+
+realign :: Heap a -> Heap a
+realign Nil = Nil
+realign h@(Node s x hl hr)
+    | size hl >= size hr = h
+    | otherwise = Node s x hr hl
+
+union :: Ord a => Heap a -> Heap a -> Heap a
+union h Nil = h
+union Nil h = h
+union h1@(Node s1 x h1l h1r) h2@(Node s2 y h2l h2r)
+    | x >= y = realign
+        (Node (s1+s2) x h1l (union h1r h2))
+    | otherwise = realign
+        (Node (s1+s2) y h2l (union h1 h2r))
+
+insert :: Ord a => a -> Heap a -> Heap a
+insert x h = union (Node 1 x Nil Nil) h
+
+findMax :: Heap a -> Maybe a
+findMax h = if isEmpty h then Nothing
+    else Just (root h)
+
+deleteMax :: Ord a => Heap a -> (Maybe a, Heap a)
+deleteMax Nil = (Nothing, Nil)
+deleteMax (Node _ x hl hr) = (Just x, union hl hr)
+
+instance Functor Heap where
+    fmap f Nil = Nil
+    fmap f (Node n x left right) = Node n (f x) left' right' where
+        left' = fmap f left
+        right' = fmap f right 
+
+instance Foldable Heap where
+    foldr _ acc Nil = acc
+    foldr f base (Node _ x left right) = f x $ foldr f acc right where
+        acc = foldr f base left

14_schedulers/Main.hs

@@ -0,0 +1,40 @@
+module Main where
+
+import Algo.MaxRate as MaxRate
+import Algo.MaxMinRate as MaxMinRate
+import Algo.PF as PF
+import Types
+import Heap
+
+main :: IO ()
+main = do
+    s <- getLine
+    let speeds = map read $ words s :: [Double]
+    let ts = map (ceiling . (* 1000) . (Types.packet_size/)) speeds -- ms
+
+    putStr "======\nMaxRate\n"
+    let max_rate_h = MaxRate.runUntilCycle packet_t ts
+    print $ getAverageSpeed max_rate_h
+    print $ getShare max_rate_h
+
+    putStr "======\nMaxMinRate\n"
+    let max_min_rate_h = MaxMinRate.runUntilCycle packet_t ts
+    print $ getAverageSpeed max_min_rate_h
+    print $ getShare max_min_rate_h
+
+    putStr "======\nPF\n"
+    let pf_h = PF.runUntilCycle packet_t ts
+    print pf_h
+    print $ getAverageSpeed pf_h
+    print $ getShare pf_h 
+
+getAverageSpeed :: Heap Unit -> Double
+getAverageSpeed h = summary_bytes / ((fromIntegral . getSummaryTime) h) where
+    summary_bytes = (foldr (\x result -> fromIntegral (1000 * (sent_p x)) + result) 0 h) 
+
+getSummaryTime :: Heap Unit -> Time
+getSummaryTime = foldr (\x result-> result + (sent_p x) * (period x)) 0 
+
+getShare :: Heap Unit -> [(Double, Double)]
+getShare h = foldr (\x lst -> (1000 / (fromIntegral $ period x), (fromIntegral $ (sent_p x) * (period x)) / sum_t) : lst) [] h where
+    sum_t = fromIntegral $ getSummaryTime h

14_schedulers/Types.hs

@@ -0,0 +1,18 @@
+module Types where
+
+type Time = Int -- ms
+
+packet_size = 1 :: Double -- kb
+cbr = 50 :: Double
+packet_t = (ceiling . (1000*) . (1/)) cbr :: Time
+
+data Unit = Unit {metric :: Double, 
+                  period :: Time, 
+                  rem_p :: Int, 
+                  sent_p :: Int} deriving Show
+
+instance Eq Unit where
+    (==) a b = (metric a) == (metric b)
+
+instance Ord Unit where
+    (<=) a b = (metric a) <= (metric b)