Initial data commit

Task/Priority-queue/Haskell/priority-queue-1.hs

@@ -0,0 +1,3 @@
+import Data.PQueue.Prio.Min
+
+main = print (toList (fromList [(3, "Clear drains"),(4, "Feed cat"),(5, "Make tea"),(1, "Solve RC tasks"), (2, "Tax return")]))

Task/Priority-queue/Haskell/priority-queue-2.hs

@@ -0,0 +1,3 @@
+import qualified Data.Set as S
+
+main = print (S.toList (S.fromList [(3, "Clear drains"),(4, "Feed cat"),(5, "Make tea"),(1, "Solve RC tasks"), (2, "Tax return")]))

Task/Priority-queue/Haskell/priority-queue-3.hs

@@ -0,0 +1,43 @@
+data MinHeap a = Nil | MinHeap { v::a, cnt::Int, l::MinHeap a, r::MinHeap a }
+  deriving (Show, Eq)
+
+hPush :: (Ord a) => a -> MinHeap a -> MinHeap a
+hPush x Nil = MinHeap {v = x, cnt = 1, l = Nil, r = Nil}
+hPush x h = if x < vv -- insert element, try to keep the tree balanced
+  then if hLength (l h) <= hLength (r h)
+    then MinHeap { v=x, cnt=cc, l=hPush vv ll, r=rr }
+    else MinHeap { v=x, cnt=cc, l=ll, r=hPush vv rr }
+  else if hLength (l h) <= hLength (r h)
+    then MinHeap { v=vv, cnt=cc, l=hPush x ll, r=rr }
+    else MinHeap { v=vv, cnt=cc, l=ll, r=hPush x rr }
+  where (vv, cc, ll, rr) = (v h, 1 + cnt h, l h, r h)
+
+hPop :: (Ord a) => MinHeap a -> (a, MinHeap a)
+hPop h = (v h, pq) where -- just pop, heed not the tree balance
+  pq  | l h == Nil = r h
+    | r h == Nil = l h
+    | v (l h) <= v (r h) = let (vv,hh) = hPop (l h) in
+      MinHeap {v = vv, cnt = hLength hh + hLength (r h),
+        l = hh, r = r h}
+    | otherwise = let (vv,hh) = hPop (r h) in
+      MinHeap {v = vv, cnt = hLength hh + hLength (l h),
+        l = l h, r = hh}
+
+hLength :: (Ord a) => MinHeap a -> Int
+hLength Nil = 0
+hLength h = cnt h
+
+hFromList :: (Ord a) => [a] -> MinHeap a
+hFromList = foldl (flip hPush) Nil
+
+hToList :: (Ord a) => MinHeap a -> [a]
+hToList = unfoldr f where
+  f Nil = Nothing
+  f h = Just $ hPop h
+
+main = mapM_ print $ hToList $ hFromList [
+  (3, "Clear drains"),
+  (4, "Feed cat"),
+  (5, "Make tea"),
+  (1, "Solve RC tasks"),
+  (2, "Tax return")]

Task/Priority-queue/Haskell/priority-queue-4.hs

@@ -0,0 +1,124 @@
+data MinHeap kv = MinHeapEmpty
+                  | MinHeapLeaf !kv
+                  | MinHeapNode !kv {-# UNPACK #-} !Int !(MinHeap a) !(MinHeap a)
+  deriving (Show, Eq)
+
+emptyPQ :: MinHeap kv
+emptyPQ = MinHeapEmpty
+
+isEmptyPQ :: PriorityQ kv -> Bool
+isEmptyPQ Mt = True
+isEmptyPQ _  = False
+
+sizePQ :: (Ord kv) => MinHeap kv -> Int
+sizePQ MinHeapEmpty = 0
+sizePQ (MinHeapLeaf _) = 1
+sizePQ (MinHeapNode _ cnt _ _) = cnt
+
+peekMinPQ :: MinHeap kv -> Maybe kv
+peekMinPQ MinHeapEmpty = Nothing
+peekMinPQ (MinHeapLeaf v) = Just v
+peekMinPQ (MinHeapNode v _ _ _) = Just v
+
+pushPQ :: (Ord kv) => kv -> MinHeap kv -> MinHeap kv
+pushPQ kv pq = insert kv 0 pq where -- insert element, keeping the tree balanced
+  insert kv _ MinHeapEmpty = MinHeapLeaf kv
+  insert kv _ (MinHeapLeaf vv) = if kv <= vv
+      then MinHeapNode kv 2 (MinHeapLeaf vv) MinHeapEmpty
+      else MinHeapNode vv 2 (MinHeapLeaf kv) MinHeapEmpty
+  insert kv msk (MinHeapNode vv cc ll rr) = if kv <= vv
+      then if nmsk >= 0
+        then MinHeapNode kv nc (insert vv nmsk ll) rr
+        else MinHeapNode kv nc ll (insert vv nmsk rr)
+      else if nmsk >= 0
+        then MinHeapNode vv nc (insert kv nmsk ll) rr
+        else MinHeapNode vv nc ll (insert kv nmsk rr)
+    where nc = cc + 1
+          nmsk = if msk /= 0 then msk `shiftL` 1 -- walk path to next
+                 else let s = floor $ (log $ fromIntegral nc) / log 2 in
+                      (nc `shiftL` ((finiteBitSize cc) - s)) .|. 1 --never 0 again
+
+siftdown :: (Ord kv) => kv -> Int -> MinHeap kv -> MinHeap kv -> MinHeap kv
+siftdown kv cnt lft rght = replace cnt lft rght where
+  replace cc ll rr = case rr of -- adj to put kv in current left/right
+    MinHeapEmpty -> -- means left is a MinHeapLeaf
+      case ll of { (MinHeapLeaf vl) ->
+        if kv <= vl
+          then MinHeapNode kv 2 ll MinHeapEmpty
+          else MinHeapNode vl 2 (MinHeapLeaf kv) MinHeapEmpty }
+    MinHeapLeaf vr ->
+      case ll of
+        MinHeapLeaf vl -> if vl <= vr
+          then if kv <= vl then MinHeapNode kv cc ll rr
+               else MinHeapNode vl cc (MinHeapLeaf kv) rr
+          else if kv <= vr then MinHeapNode kv cc ll rr
+               else MinHeapNode vr cc ll (MinHeapLeaf kv)
+        MinHeapNode vl ccl lll rrl -> if vl <= vr
+          then if kv <= vl then MinHeapNode kv cc ll rr
+               else MinHeapNode vl cc (replace ccl lll rrl) rr
+          else if kv <= vr then MinHeapNode kv cc ll rr
+               else MinHeapNode vr cc ll (MinHeapLeaf kv)
+    MinHeapNode vr ccr llr rrr -> case ll of
+      (MinHeapNode vl ccl lll rrl) -> -- right is node, so is left
+        if vl <= vr then
+          if kv <= vl then MinHeapNode kv cc ll rr
+          else MinHeapNode vl cc (replace ccl lll rrl) rr
+        else if kv <= vr then MinHeapNode kv cc ll rr
+             else MinHeapNode vr cc ll (replace ccr llr rrr)
+
+replaceMinPQ :: (Ord kv) => a -> MinHeap kv -> MinHeap kv
+replaceMinPQ _ MinHeapEmpty = MinHeapEmpty
+replaceMinPQ kv (MinHeapLeaf _) = MinHeapLeaf kv
+replaceMinPQ kv (MinHeapNode _ cc ll rr) = siftdown kv cc ll rr where
+
+deleteMinPQ :: (Ord kv) => MinHeap kv -> MinHeap kv
+deleteMinPQ MinHeapEmpty = MinHeapEmpty -- remove min keeping tree balanced
+deleteMinPQ pq = let (dkv, npq) = delete 0 pq in
+                 replaceMinPQ dkv npq where
+  delete _ (MinHeapLeaf vv) = (vv, MinHeapEmpty)
+  delete msk (MinHeapNode vv cc ll rr) =
+      if rr == MinHeapEmpty -- means left is MinHeapLeaf
+        then case ll of (MinHeapLeaf vl) -> (vl, MinHeapLeaf vv)
+      else if nmsk >= 0 -- means only deal with left
+             then let (dv, npq) = delete nmsk ll in
+                  (dv, MinHeapNode vv (cc - 1) npq rr)
+             else let (dv, npq) = delete nmsk rr in
+                  (dv, MinHeapNode vv (cc - 1) ll npq)
+    where nmsk = if msk /= 0 then msk `shiftL` 1 -- walk path to last
+                 else let s = floor $ (log $ fromIntegral cc) / log 2 in
+                      (cc `shiftL` ((finiteBitSize cc) - s)) .|. 1 --never 0 again
+
+adjustPQ :: (Ord kv) => (kv -> kv) -> MinHeap kv -> MinHeap kv
+adjustPQ f pq = adjust pq where -- applies function to every element and reheapifies
+  adjust MinHeapEmpty = MinHeapEmpty
+  adjust (MinHeapLeaf v) = MinHeapLeaf (f v)
+  adjust (MinHeapNode vv cc ll rr) = siftdown (f vv) cc (adjust ll) (adjust rr)
+
+fromListPQ :: (Ord kv) => [kv] -> MinHeap kv
+-- fromListPQ = foldl (flip pushPQ) MinHeapEmpty -- O(n log n) time; slow
+fromListPQ [] = MinHeapEmpty -- O(n) time using "adjust id" which is O(n)
+fromListPQ xs = let (_, pq) = build 1 xs in pq where
+  sz = length xs
+  szd2 = sz `div` 2
+  build _ [] = ([], MinHeapEmpty)
+  build lvl (x:xs') = if lvl > szd2 then (xs', MinHeapLeaf x)
+                      else let nlvl = lvl + lvl in
+                           let (xrl, pql) = build nlvl xs' in
+                           let (xrr, pqr) = if nlvl >= sz
+                                 then (xrl, MinHeapEmpty) -- no right leaf
+                                 else build (nlvl + 1) xrl in
+                           let cnt = sizePQ pql + sizePQ pqr + 1 in
+                           (xrr, siftdown x cnt pql pqr)
+
+popMinPQ :: (Ord kv) => MinHeap kv -> Maybe (kv, MinHeap kv)
+popMinPQ pq = case peekMinPQ pq of
+                Nothing -> Nothing
+                Just v -> Just (v, deleteMinPQ pq)
+
+toListPQ :: (Ord kv) => MinHeap kv -> [kv]
+toListPQ = unfoldr f where
+  f MinHeapEmpty = Nothing
+  f pq = popMinPQ pq
+
+sortPQ :: (Ord kv) => [kv] -> [kv]
+sortPQ ls = toListPQ $ fromListPQ ls

Task/Priority-queue/Haskell/priority-queue-5.hs

@@ -0,0 +1,104 @@
+data PriorityQ k v = Mt
+                     | Br !k v !(PriorityQ k v) !(PriorityQ k v)
+  deriving (Eq, Ord, Read, Show)
+
+emptyPQ :: PriorityQ k v
+emptyPQ = Mt
+
+isEmptyPQ :: PriorityQ k v -> Bool
+isEmptyPQ Mt = True
+isEmptyPQ _  = False
+
+-- The size function isn't from the ML code, but an implementation was
+-- suggested by Bertram Felgenhauer on Haskell Cafe, so it is included.
+
+-- Return number of elements in the priority queue.
+-- /O(log(n)^2)/
+sizePQ :: PriorityQ k v -> Int
+sizePQ Mt = 0
+sizePQ (Br _ _ pl pr) = 2 * n + rest n pl pr where
+  n = sizePQ pr
+  -- rest n p q, where n = sizePQ q, and sizePQ p - sizePQ q = 0 or 1
+  -- returns 1 + sizePQ p - sizePQ q.
+  rest :: Int -> PriorityQ k v -> PriorityQ k v -> Int
+  rest 0 Mt _ = 1
+  rest 0 _  _ = 2
+  rest n (Br _ _ ll lr) (Br _ _ rl rr) = case r of
+      0 -> rest d ll rl -- subtree sizes: (d or d+1), d; d, d
+      1 -> rest d lr rr -- subtree sizes: d+1, (d or d+1); d+1, d
+    where m1 = n - 1
+          d = m1 `shiftR` 1
+          r = m1 .&. 1
+
+peekMinPQ :: PriorityQ k v -> Maybe (k, v)
+peekMinPQ Mt           = Nothing
+peekMinPQ (Br k v _ _) = Just (k, v)
+
+pushPQ :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v
+pushPQ wk wv Mt           = Br wk wv Mt Mt
+pushPQ wk wv (Br vk vv pl pr)
+             | wk <= vk   = Br wk wv (pushPQ vk vv pr) pl
+             | otherwise  = Br vk vv (pushPQ wk wv pr) pl
+
+siftdown :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v -> PriorityQ k v
+siftdown wk wv Mt _          = Br wk wv Mt Mt
+siftdown wk wv (pl @ (Br vk vv _ _)) Mt
+    | wk <= vk               = Br wk wv pl Mt
+    | otherwise              = Br vk vv (Br wk wv Mt Mt) Mt
+siftdown wk wv (pl @ (Br vkl vvl pll plr)) (pr @ (Br vkr vvr prl prr))
+    | wk <= vkl && wk <= vkr = Br wk wv pl pr
+    | vkl <= vkr             = Br vkl vvl (siftdown wk wv pll plr) pr
+    | otherwise              = Br vkr vvr pl (siftdown wk wv prl prr)
+
+replaceMinPQ :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v
+replaceMinPQ wk wv Mt             = Mt
+replaceMinPQ wk wv (Br _ _ pl pr) = siftdown wk wv pl pr
+
+deleteMinPQ :: (Ord k) =>  PriorityQ k v -> PriorityQ k v
+deleteMinPQ Mt             = Mt
+deleteMinPQ (Br _ _ pr Mt) = pr
+deleteMinPQ (Br _ _ pl pr) = let (k, v, npl) = leftrem pl in
+                             siftdown k v pr npl where
+  leftrem (Br k v Mt Mt)             = (k, v, Mt)
+  leftrem (Br vk vv (Br k v _ _) Mt) = (k, v, Br vk vv Mt Mt)
+  leftrem (Br vk vv pl pr)           = let (k, v, npl) = leftrem pl in
+                                       (k, v, Br vk vv pr npl)
+
+-- the following function has been added to the ML code to apply a function
+--   to all the entries in the queue and reheapify in O(n) time
+adjustPQ :: (Ord k) => (k -> v -> (k, v)) -> PriorityQ k v -> PriorityQ k v
+adjustPQ f pq = adjust pq where -- applies function to every element and reheapifies
+  adjust Mt               = Mt
+  adjust (Br vk vv pl pr) = let (k, v) = f vk vv in
+                            siftdown k v (adjust pl) (adjust pr)
+
+fromListPQ :: (Ord k) => [(k, v)] -> PriorityQ k v
+-- fromListPQ = foldl (flip pushPQ) Mt -- O(n log n) time; slow
+fromListPQ [] = Mt -- O(n) time using adjust-from-bottom which is O(n)
+fromListPQ xs = let (pq, _) = build (length xs) xs in pq where
+  build 0 xs             = (Mt, xs)
+  build lvl ((k, v):xs') = let (pl, xrl) = build (lvl `shiftR` 1) xs'
+                               (pr, xrr) = build ((lvl - 1) `shiftR` 1) xrl in
+                           (siftdown k v pl pr, xrr)
+
+-- the following function has been added to merge two queues in O(m + n) time
+--   where m and n are the sizes of the two queues
+mergePQ :: (Ord k) => PriorityQ k v -> PriorityQ k v -> PriorityQ k v
+mergePQ pq1 Mt = pq1 -- from concatenated "dumb" list
+mergePQ Mt pq2 = pq2 -- in O(m + n) time where m,n are sizes pq1,pq2
+mergePQ pq1 pq2 = fromListPQ (zipper pq1 $ zipper pq2 []) where
+  zipper (Br wk wv Mt _) appndlst  = (wk, wv) : appndlst
+  zipper (Br wk wv pl Mt) appndlst = (wk, wv) : zipper pl appndlst
+  zipper (Br wk wv pl pr) appndlst = (wk, wv) : zipper pl (zipper pr appndlst)
+
+popMinPQ :: (Ord k) => PriorityQ k v -> Maybe ((k, v), PriorityQ k v)
+popMinPQ pq = case peekMinPQ pq of
+                Nothing -> Nothing
+                Just kv -> Just (kv, deleteMinPQ pq)
+
+toListPQ :: (Ord k) => PriorityQ k v -> [(k, v)]
+toListPQ Mt                  = [] -- unfoldr popMinPQ
+toListPQ pq @ (Br vk vv _ _) = (vk, vv) : (toListPQ $ deleteMinPQ pq)
+
+sortPQ :: (Ord k) => [(k, v)] -> [(k, v)]
+sortPQ ls = toListPQ $ fromListPQ ls

Task/Priority-queue/Haskell/priority-queue-6.hs

@@ -0,0 +1,18 @@
+testList = [ (3, "Clear drains"),
+             (4, "Feed cat"),
+             (5, "Make tea"),
+             (1, "Solve RC tasks"),
+             (2, "Tax return") ]
+
+testPQ = fromListPQ testList
+
+main = do -- slow build
+  mapM_ print $ toListPQ $ foldl (\pq (k, v) -> pushPQ k v pq) emptyPQ testList
+  putStrLn "" -- fast build
+  mapM_ print $ toListPQ $ fromListPQ testList
+  putStrLn "" -- combined fast sort
+  mapM_ print $ sortPQ testList
+  putStrLn "" -- test merge
+  mapM_ print $ toListPQ $ mergePQ testPQ testPQ
+  putStrLn "" -- test adjust
+  mapM_ print $ toListPQ $ adjustPQ (\x y -> (x * (-1), y)) testPQ