# Ticket #3909: containers-pqueue.5.patch

File containers-pqueue.5.patch, 47.8 KB (added by , 8 years ago) |
---|

Line | |
---|---|

1 | Tue Mar 9 15:54:55 CST 2010 wasserman.louis@gmail.com |

2 | * Priority queues for containers |

3 | |

4 | Tue Mar 9 15:55:17 CST 2010 wasserman.louis@gmail.com |

5 | * Pairing queues for containers |

6 | |

7 | New patches: |

8 | |

9 | [Priority queues for containers |

10 | wasserman.louis@gmail.com**20100309215455 |

11 | Ignore-this: f653aaa1e6587a5836431bc2f05a9bec |

12 | ] { |

13 | adddir ./Data/PQueue |

14 | addfile ./Data/PQueue/Max.hs |

15 | hunk ./Data/PQueue/Max.hs 1 |

16 | +{-# LANGUAGE CPP #-} |

17 | hunk ./Data/PQueue/Max.hs 3 |

18 | +----------------------------------------------------------------------------- |

19 | +-- | |

20 | +-- Module : Data.PQueue.Max |

21 | +-- Copyright : (c) Louis Wasserman 2010 |

22 | +-- License : BSD-style |

23 | +-- Maintainer : libraries@haskell.org |

24 | +-- Stability : experimental |

25 | +-- Portability : portable |

26 | +-- |

27 | +-- General purpose priority queue, supporting extract-maximum operations. |

28 | +-- |

29 | +-- An amortized running time is given for each operation, with /n/ referring |

30 | +-- to the length of the sequence and /i/ being the integral index used by |

31 | +-- some operations. These bounds hold even in a persistent (shared) setting. |

32 | +-- |

33 | +-- This implementation is based on a binomial heap augmented with a global root. |

34 | +-- The spine of the heap is maintained strictly, ensuring that computations happen |

35 | +-- as they are performed. Note that this module is a small wrapper around |

36 | +-- "Data.PQueue.Min". |

37 | +-- |

38 | +-- /WARNING:/ 'toList' and 'toDescList' are /not/ equivalent, unlike for example |

39 | +-- "Data.Map". |

40 | +----------------------------------------------------------------------------- |

41 | +module Data.PQueue.Max( |

42 | + MaxQueue, |

43 | + -- * Basic operations |

44 | + empty, |

45 | + null, |

46 | + size, |

47 | + -- * Query operations |

48 | + top, |

49 | + delete, |

50 | + extract, |

51 | + -- * Construction operations |

52 | + singleton, |

53 | + insert, |

54 | + union, |

55 | + unions, |

56 | + -- * Extracting elements |

57 | + (!!), |

58 | + take, |

59 | + drop, |

60 | + splitAt, |

61 | + takeWhile, |

62 | + dropWhile, |

63 | + span, |

64 | + break, |

65 | + filter, |

66 | + partition, |

67 | + -- * Fold\/Functor\/Traversable variations |

68 | + mapMonotonic, |

69 | + foldrDesc, |

70 | + foldlDesc, |

71 | + traverseMonotonic, |

72 | + -- * List operations |

73 | + toList, |

74 | + toDescList, |

75 | + fromList, |

76 | + fromDescList) where |

77 | + |

78 | +import Control.Applicative (Applicative(..), (<$>)) |

79 | + |

80 | +import Data.Monoid |

81 | +import Data.Foldable hiding (toList) |

82 | +import Data.Traversable |

83 | +import Data.Ord |

84 | + |

85 | +import qualified Data.PQueue.Min as Min |

86 | + |

87 | +import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) |

88 | + |

89 | +#ifdef __GLASGOW_HASKELL__ |

90 | +import GHC.Exts (build) |

91 | +import Text.Read (Lexeme(Ident), lexP, parens, prec, |

92 | + readPrec, readListPrec, readListPrecDefault) |

93 | +#endif |

94 | + |

95 | +-- | A priority queue implementation. Implemented as a wrapper around "Data.PQueue.Min". |

96 | +-- /Warning/: the 'Functor', 'Foldable', and 'Traversable' instances of this type /ignore ordering/. |

97 | +-- For 'Functor', it is guaranteed that if @f@ is a monotonic function, then @'fmap' f@ on a valid |

98 | +-- 'MaxQueue' will return a valid 'MaxQueue'. An analogous guarantee holds for 'traverse'. (Note: |

99 | +-- if passed constant-time operations, every function in 'Functor', 'Foldable', and 'Traversable' |

100 | +-- will run in /O(n)/.) |

101 | +-- |

102 | +-- If you wish to perform folds on a priority queue that respect order, use 'foldrDesc' or |

103 | +-- 'foldlDesc'. |

104 | +newtype MaxQueue a = MaxQ {unMaxQ :: Min.MinQueue (Down a)} |

105 | +newtype Down a = Down {unDown :: a} deriving (Eq) |

106 | + |

107 | +instance Ord a => Ord (Down a) where |

108 | + Down x `compare` Down y = compare y x |

109 | + Down x <= Down y = y <= x |

110 | + Down x < Down y = y < x |

111 | + Down x >= Down y = y >= x |

112 | + Down x > Down y = y > x |

113 | + |

114 | +instance Ord a => Eq (MaxQueue a) where |

115 | + MaxQ q1 == MaxQ q2 = q1 == q2 |

116 | + |

117 | +instance Ord a => Ord (MaxQueue a) where |

118 | + MaxQ q1 `compare` MaxQ q2 = q1 `compare` q2 |

119 | + |

120 | +instance (Ord a, Show a) => Show (MaxQueue a) where |

121 | + showsPrec p xs = showParen (p > 10) $ |

122 | + showString "fromDescList " . shows (toDescList xs) |

123 | + |

124 | +instance Read a => Read (MaxQueue a) where |

125 | +#ifdef __GLASGOW_HASKELL__ |

126 | + readPrec = parens $ prec 10 $ do |

127 | + Ident "fromDescList" <- lexP |

128 | + xs <- readPrec |

129 | + return (fromDescList xs) |

130 | + |

131 | + readListPrec = readListPrecDefault |

132 | +#else |

133 | + readsPrec p = readParen (p > 10) $ \ r -> do |

134 | + ("fromDescList",s) <- lex r |

135 | + (xs,t) <- reads s |

136 | + return (fromDescList xs,t) |

137 | +#endif |

138 | + |

139 | +instance Ord a => Monoid (MaxQueue a) where |

140 | + mempty = empty |

141 | + mappend = union |

142 | + |

143 | +-- | /O(1)/. The empty priority queue. |

144 | +empty :: MaxQueue a |

145 | +empty = MaxQ Min.empty |

146 | + |

147 | +-- | /O(1)/. Is this the empty priority queue? |

148 | +null :: MaxQueue a -> Bool |

149 | +null (MaxQ q) = Min.null q |

150 | + |

151 | +-- | /O(1)/. The number of elements in the queue. |

152 | +size :: MaxQueue a -> Int |

153 | +size (MaxQ q) = Min.size q |

154 | + |

155 | +-- | /O(log n)/. The top (maximum) element of the queue, if there is one. |

156 | +top :: Ord a => MaxQueue a -> Maybe a |

157 | +top = fmap fst . extract |

158 | + |

159 | +-- | /O(log n)/. Extract the top (maximum) element of the sequence, if there is one. |

160 | +extract :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) |

161 | +extract (MaxQ q) = case Min.extract q of |

162 | + Nothing -> Nothing |

163 | + Just (Down x, q') |

164 | + -> Just (x, MaxQ q') |

165 | + |

166 | +-- | /O(log n)/. Delete the top (maximum) element of the sequence, if there is one. |

167 | +delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) |

168 | +delete = fmap snd . extract |

169 | + |

170 | +-- | /O(1)/. Construct a priority queue with a single element. |

171 | +singleton :: a -> MaxQueue a |

172 | +singleton = MaxQ . Min.singleton . Down |

173 | + |

174 | +-- | /O(1)/. Insert an element into the priority queue. |

175 | +insert :: Ord a => a -> MaxQueue a -> MaxQueue a |

176 | +insert x (MaxQ q) = MaxQ (Min.insert (Down x) q) |

177 | + |

178 | +-- | /O(log (min(n,m)))/. Take the union of two priority queues. |

179 | +union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a |

180 | +MaxQ q1 `union` MaxQ q2 = MaxQ (Min.union q1 q2) |

181 | + |

182 | +-- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. |

183 | +unions :: Ord a => [MaxQueue a] -> MaxQueue a |

184 | +unions = foldl union empty |

185 | + |

186 | +-- | /O(k log n)/. Returns the @(k+1)@th largest element of the queue. |

187 | +(!!) :: Ord a => MaxQueue a -> Int -> a |

188 | +MaxQ q !! n = unDown ((Min.!!) q n) |

189 | + |

190 | +{-# INLINE take #-} |

191 | +-- | /O(k log n)/. Returns the list of the @k@ largest elements of the queue, in descending order, or |

192 | +-- all elements of the queue, if @k >= n@. |

193 | +take :: Ord a => Int -> MaxQueue a -> [a] |

194 | +take k (MaxQ q) = [a | Down a <- Min.take k q] |

195 | + |

196 | +-- | /O(k log n)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. |

197 | +drop :: Ord a => Int -> MaxQueue a -> MaxQueue a |

198 | +drop k (MaxQ q) = MaxQ (Min.drop k q) |

199 | + |

200 | +-- | /O(k log n)/. Equivalent to @(take k queue, drop k queue)@. |

201 | +splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) |

202 | +splitAt k (MaxQ q) = (map unDown xs, MaxQ q') where |

203 | + (xs, q') = Min.splitAt k q |

204 | + |

205 | +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the |

206 | +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. |

207 | +takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] |

208 | +takeWhile p (MaxQ q) = map unDown (Min.takeWhile (p . unDown) q) |

209 | + |

210 | +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. |

211 | +-- |

212 | +dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a |

213 | +dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q) |

214 | + |

215 | +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where |

216 | +-- first element is longest prefix (possibly empty) of @queue@ of elements that |

217 | +-- satisfy @p@ and second element is the remainder of the queue. |

218 | +-- |

219 | +span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) |

220 | +span p (MaxQ q) = (map unDown xs, MaxQ q') where |

221 | + (xs, q') = Min.span (p . unDown) q |

222 | + |

223 | +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where |

224 | +-- first element is longest prefix (possibly empty) of @queue@ of elements that |

225 | +-- /do not satisfy/ @p@ and second element is the remainder of the queue. |

226 | +break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) |

227 | +break p = span (not . p) |

228 | + |

229 | +filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a |

230 | +filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q) |

231 | + |

232 | +partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) |

233 | +partition p (MaxQ q) = (MaxQ q0, MaxQ q1) |

234 | + where (q0, q1) = Min.partition (p . unDown) q |

235 | + |

236 | +-- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, |

237 | +-- as in 'fmap'. If it is not, the result is undefined. |

238 | +mapMonotonic :: (a -> b) -> MaxQueue a -> MaxQueue b |

239 | +mapMonotonic = fmap |

240 | + |

241 | +-- | /O(n)/. Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation. |

242 | +-- If the function is not monotonic, the result is undefined. |

243 | +traverseMonotonic :: Applicative f => (a -> f b) -> MaxQueue a -> f (MaxQueue b) |

244 | +traverseMonotonic = traverse |

245 | + |

246 | +instance Functor Down where |

247 | + fmap f (Down a) = Down (f a) |

248 | + |

249 | +instance Foldable Down where |

250 | + foldr f z (Down a) = a `f` z |

251 | + foldl f z (Down a) = z `f` a |

252 | + |

253 | +instance Traversable Down where |

254 | + traverse f (Down a) = Down <$> f a |

255 | + |

256 | +instance Functor MaxQueue where |

257 | + fmap f (MaxQ q) = MaxQ (fmap (fmap f) q) |

258 | + |

259 | +instance Foldable MaxQueue where |

260 | + foldr f z (MaxQ q) = foldr (flip (foldr f)) z q |

261 | + foldl f z (MaxQ q) = foldl (foldl f) z q |

262 | + |

263 | +instance Traversable MaxQueue where |

264 | + traverse f (MaxQ q) = MaxQ <$> traverse (traverse f) q |

265 | + |

266 | +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. |

267 | +foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b |

268 | +foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q |

269 | + |

270 | +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. |

271 | +foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b |

272 | +foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q |

273 | + |

274 | +{-# INLINE toDescList #-} |

275 | +-- | /O(n log n)/. Extracts the elements of the priority queue in descending order. |

276 | +toDescList :: Ord a => MaxQueue a -> [a] |

277 | +#ifdef __GLASGOW_HASKELL__ |

278 | +toDescList q = build (\ c nil -> foldrDesc c nil q) |

279 | +#else |

280 | +toDescList = foldrDesc (:) [] |

281 | +#endif |

282 | + |

283 | +{-# INLINE toList #-} |

284 | +-- | /O(n)/. Returns the elements of the priority queue in no particular order. |

285 | +toList :: MaxQueue a -> [a] |

286 | +#ifdef __GLASGOW_HASKELL__ |

287 | +toList q = build (\ c nil -> foldr c nil q) |

288 | +#else |

289 | +toList = foldr (:) [] |

290 | +#endif |

291 | + |

292 | +{-# INLINE fromDescList #-} |

293 | +-- | /O(n)/. Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. |

294 | +fromDescList :: [a] -> MaxQueue a |

295 | +fromDescList = MaxQ . Min.fromAscList . map Down |

296 | + |

297 | +{-# INLINE fromList #-} |

298 | +-- | /O(n log n)/. Constructs a priority queue from an unordered list. |

299 | +fromList :: Ord a => [a] -> MaxQueue a |

300 | +fromList = foldr insert empty |

301 | addfile ./Data/PQueue/Min.hs |

302 | hunk ./Data/PQueue/Min.hs 1 |

303 | +{-# LANGUAGE CPP #-} |

304 | hunk ./Data/PQueue/Min.hs 3 |

305 | +----------------------------------------------------------------------------- |

306 | +-- | |

307 | +-- Module : Data.PQueue.Min |

308 | +-- Copyright : (c) Louis Wasserman 2010 |

309 | +-- License : BSD-style |

310 | +-- Maintainer : libraries@haskell.org |

311 | +-- Stability : experimental |

312 | +-- Portability : portable |

313 | +-- |

314 | +-- General purpose priority queue, supporting extract-minimum operations. |

315 | +-- |

316 | +-- An amortized running time is given for each operation, with /n/ referring |

317 | +-- to the length of the sequence and /i/ being the integral index used by |

318 | +-- some operations. These bounds hold even in a persistent (shared) setting. |

319 | +-- |

320 | +-- This implementation is based on a binomial heap augmented with a global root. |

321 | +-- The spine of the heap is maintained strictly, ensuring that computations happen |

322 | +-- as they are performed. |

323 | +-- |

324 | +-- /WARNING:/ 'toList' and 'toAscList' are /not/ equivalent, unlike for example |

325 | +-- "Data.Map". |

326 | +----------------------------------------------------------------------------- |

327 | +module Data.PQueue.Min ( |

328 | + MinQueue, |

329 | + -- * Basic operations |

330 | + empty, |

331 | + null, |

332 | + size, |

333 | + -- * Query operations |

334 | + top, |

335 | + delete, |

336 | + extract, |

337 | + -- * Construction operations |

338 | + singleton, |

339 | + insert, |

340 | + union, |

341 | + unions, |

342 | + -- * Extracting elements |

343 | + (!!), |

344 | + take, |

345 | + drop, |

346 | + splitAt, |

347 | + takeWhile, |

348 | + dropWhile, |

349 | + span, |

350 | + break, |

351 | + filter, |

352 | + partition, |

353 | + -- * Fold\/Functor\/Traversable variations |

354 | + mapMonotonic, |

355 | + foldrAsc, |

356 | + foldlAsc, |

357 | + traverseMonotonic, |

358 | + -- * List operations |

359 | + toList, |

360 | + toAscList, |

361 | + fromList, |

362 | + fromAscList) where |

363 | + |

364 | +import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) |

365 | + |

366 | +import Control.Applicative (Applicative(..), (<$>)) |

367 | + |

368 | +import Data.Monoid |

369 | +import Data.Foldable hiding (toList) |

370 | +import Data.Traversable |

371 | + |

372 | +import qualified Data.List as List |

373 | + |

374 | +#ifdef __GLASGOW_HASKELL__ |

375 | +import GHC.Exts (build) |

376 | +import Text.Read (Lexeme(Ident), lexP, parens, prec, |

377 | + readPrec, readListPrec, readListPrecDefault) |

378 | +#else |

379 | + |

380 | +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] |

381 | +build f = f (:) [] |

382 | + |

383 | +#endif |

384 | + |

385 | +-- | A priority queue implementation. Implemented as a find-min wrapper around a binomial heap. |

386 | +-- /Warning/: the 'Functor', 'Foldable', and 'Traversable' instances of this type /ignore ordering/. |

387 | +-- For 'Functor', it is guaranteed that if @f@ is a monotonic function, then @'fmap' f@ on a valid |

388 | +-- 'MinQueue' will return a valid 'MinQueue'. An analogous guarantee holds for 'traverse'. (Note: |

389 | +-- if passed constant-time operations, every function in 'Functor', 'Foldable', and 'Traversable' |

390 | +-- will run in /O(n)/.) |

391 | +-- |

392 | +-- If you wish to perform folds on a priority queue that respect order, use 'foldrAsc' or |

393 | +-- 'foldlAsc'. |

394 | +-- |

395 | +-- For any operation @op@ in 'Eq' or 'Ord', @queue1 `op` queue2@ is equivalent to |

396 | +-- @toAscList queue1 `op` toAscList queue2@. |

397 | +data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int a !(BinomHeap a) |

398 | +type BinomHeap a = BinomForest a Zero |

399 | + |

400 | +instance Ord a => Eq (MinQueue a) where |

401 | + Empty == Empty = True |

402 | + MinQueue n1 x1 q1 == MinQueue n2 x2 q2 |

403 | + = n1 == n2 && x1 == x2 && foldr (&&) True |

404 | + (zipWith (==) (heapToList q1) (heapToList q2)) |

405 | + _ == _ = False |

406 | + |

407 | +instance Ord a => Ord (MinQueue a) where |

408 | + Empty `compare` Empty = EQ |

409 | + Empty `compare` _ = LT |

410 | + _ `compare` Empty = GT |

411 | + MinQueue n1 x1 q1 `compare` MinQueue n2 x2 q2 = |

412 | + compare x1 x2 `mappend` foldr mappend (compare n1 n2) (zipWith compare (heapToList q1) (heapToList q1)) |

413 | + -- We compare their first elements, then their other elements up to the smaller queue's length, |

414 | + -- and then the longer queue wins. |

415 | + -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. |

416 | + |

417 | +heapToList :: Ord a => BinomHeap a -> [a] |

418 | +heapToList q = build (\ c nil -> foldrUnfold c nil extractHeap q) |

419 | + |

420 | +instance (Ord a, Show a) => Show (MinQueue a) where |

421 | + showsPrec p xs = showParen (p > 10) $ |

422 | + showString "fromAscList " . shows (toAscList xs) |

423 | + |

424 | +instance Read a => Read (MinQueue a) where |

425 | +#ifdef __GLASGOW_HASKELL__ |

426 | + readPrec = parens $ prec 10 $ do |

427 | + Ident "fromAscList" <- lexP |

428 | + xs <- readPrec |

429 | + return (fromAscList xs) |

430 | + |

431 | + readListPrec = readListPrecDefault |

432 | +#else |

433 | + readsPrec p = readParen (p > 10) $ \ r -> do |

434 | + ("fromAscList",s) <- lex r |

435 | + (xs,t) <- reads s |

436 | + return (fromAscList xs,t) |

437 | +#endif |

438 | + |

439 | +instance Ord a => Monoid (MinQueue a) where |

440 | + mempty = Empty |

441 | + mappend = union |

442 | + mconcat = unions |

443 | + |

444 | +-- We implement tree ranks in the type system with a nicely elegant approach, as follows. |

445 | +-- The goal is to have the type system automatically guarantee that our binomial forest |

446 | +-- has the correct binomial structure. |

447 | +-- |

448 | +-- In the traditional set-theoretic construction of the natural numbers, we define |

449 | +-- each number to be the set of numbers less than it, and zero to be the empty set, |

450 | +-- as follows: |

451 | +-- |

452 | +-- 0 = {} 1 = {0} 2 = {0, 1} 3={0, 1, 2} ... |

453 | +-- |

454 | +-- Binomial trees have a similar structure: a tree of rank @k@ has one child of each |

455 | +-- rank less than @k@. Let's define the type @rk@ corresponding to rank @k@ to refer |

456 | +-- to a collection of binomial trees of ranks @0..k-1@. Then we can say that |

457 | +-- |

458 | +-- > data Succ e rk = Succ (BinomTree e rk) rk |

459 | +-- |

460 | +-- and this behaves exactly as the successor operator for ranks should behave. Furthermore, |

461 | +-- we immediately obtain that |

462 | +-- |

463 | +-- > data BinomTree e rk = BinomTree e rk |

464 | +-- |

465 | +-- which is nice and compact. |

466 | +data BinomForest e rk = Nil | Skip !(BinomForest' e rk) | Cons {-# UNPACK #-} !(BinomTree e rk) !(BinomForest' e rk) |

467 | +type BinomForest' e rk = BinomForest e (Succ e rk) |

468 | + |

469 | +data BinomTree e rk = BinomTree e rk |

470 | +type BinomTree' e rk = BinomTree e (Succ e rk) |

471 | +data Succ e rk = Succ {-# UNPACK #-} !(BinomTree e rk) rk |

472 | +type Zero = () |

473 | + |

474 | +-- basics |

475 | + |

476 | +-- | /O(1)/. The empty priority queue. |

477 | +empty :: MinQueue a |

478 | +empty = Empty |

479 | + |

480 | +-- | /O(1)/. Is this the empty priority queue? |

481 | +null :: MinQueue a -> Bool |

482 | +null Empty = True |

483 | +null _ = False |

484 | + |

485 | +-- | /O(1)/. The number of elements in the queue. |

486 | +size :: MinQueue a -> Int |

487 | +size Empty = 0 |

488 | +size (MinQueue n _ _) = n |

489 | + |

490 | +-- queries |

491 | +-- | /O(1)/. View the top (minimum) element of the queue, if there is one. |

492 | +top :: Ord a => MinQueue a -> Maybe a |

493 | +top = fmap fst . extract |

494 | + |

495 | +-- | /O(log n)/. Delete the top element of the sequence, if there is one. |

496 | +delete :: Ord a => MinQueue a -> Maybe (MinQueue a) |

497 | +delete = fmap snd . extract |

498 | + |

499 | +-- | /O(log n)/. Extract the top (minimum) element of the sequence, if there is one. |

500 | +extract :: Ord a => MinQueue a -> Maybe (a, MinQueue a) |

501 | +extract Empty = Nothing |

502 | +extract (MinQueue n x ts) = Just (x, case extractBin (<=) ts of |

503 | + NoExtract -> Empty |

504 | + YesExtract x' _ ts' -> MinQueue (n-1) x' ts') |

505 | + |

506 | +-- | /O(1)/. Construct a priority queue with a single element. |

507 | +singleton :: a -> MinQueue a |

508 | +singleton x = MinQueue 1 x Nil |

509 | + |

510 | +-- | /O(1)/. Insert an element into the priority queue. |

511 | +insert :: Ord a => a -> MinQueue a -> MinQueue a |

512 | +insert x' (MinQueue n x f) |

513 | + | x' <= x = MinQueue (n+1) x' (insertBin x f) |

514 | + | otherwise = MinQueue (n+1) x (insertBin x' f) |

515 | + where insertBin = carry1 (<=) . tip |

516 | +insert x Empty = singleton x |

517 | + |

518 | +-- | /O(log (min(n,m)))/. Take the union of two priority queues. |

519 | +union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a |

520 | +union = union' (<=) |

521 | + |

522 | +-- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. |

523 | +unions :: Ord a => [MinQueue a] -> MinQueue a |

524 | +unions = foldl union Empty |

525 | + |

526 | +-- | Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest element in the queue. |

527 | +(!!) :: Ord a => MinQueue a -> Int -> a |

528 | +q !! n | n >= size q |

529 | + = error "Data.PQueue.Min.!!: index too large" |

530 | +q !! n = (List.!!) (toAscList q) n |

531 | + |

532 | +{-# INLINE takeWhile #-} |

533 | +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the |

534 | +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. |

535 | +takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] |

536 | +takeWhile p queue = foldWhileFB p (toAscList queue) |

537 | + |

538 | +{-# INLINE foldWhileFB #-} |

539 | +foldWhileFB :: (a -> Bool) -> [a] -> [a] |

540 | +foldWhileFB p xs = build (\ c nil -> let |

541 | + consWhile x xs |

542 | + | p x = x `c` xs |

543 | + | otherwise = nil |

544 | + in foldr consWhile nil xs) |

545 | + |

546 | +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. |

547 | +dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a |

548 | +dropWhile p = drop' where |

549 | + drop' q = case extract q of |

550 | + Just (x, q') |

551 | + | p x -> drop' q' |

552 | + _ -> q |

553 | + |

554 | +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where |

555 | +-- first element is longest prefix (possibly empty) of @queue@ of elements that |

556 | +-- satisfy @p@ and second element is the remainder of the queue. |

557 | +span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) |

558 | +span p queue = case extract queue of |

559 | + Just (x, q') | p x |

560 | + -> let (ys, q'') = span p q' in (x:ys, q'') |

561 | + _ -> ([], queue) |

562 | + |

563 | +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where |

564 | +-- first element is longest prefix (possibly empty) of @queue@ of elements that |

565 | +-- /do not satisfy/ @p@ and second element is the remainder of the queue. |

566 | +break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) |

567 | +break p = span (not . p) |

568 | + |

569 | +{-# INLINE take #-} |

570 | +-- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, |

571 | +-- or all elements of @queue@ itself if @k >= 'size' queue@. |

572 | +take :: Ord a => Int -> MinQueue a -> [a] |

573 | +take n = List.take n . toAscList |

574 | + |

575 | +-- | /O(k log n)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, |

576 | +-- or an empty queue if @k >= size 'queue'@. |

577 | +drop :: Ord a => Int -> MinQueue a -> MinQueue a |

578 | +drop n queue = n `seq` case delete queue of |

579 | + Just queue' |

580 | + | n > 0 -> drop (n-1) queue' |

581 | + _ -> queue |

582 | + |

583 | +-- | /O(k log n)/. Equivalent to @('take' k queue, 'drop' k queue)@. |

584 | +splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) |

585 | +splitAt n queue = n `seq` case extract queue of |

586 | + Just (x, queue') |

587 | + | n > 0 -> let (xs, queue'') = splitAt (n-1) queue' in (x:xs, queue'') |

588 | + _ -> ([], queue) |

589 | + |

590 | +-- | /O(n)/. Returns the queue with all elements not satisfying @p@ removed. |

591 | +filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a |

592 | +filter _ Empty = Empty |

593 | +filter p (MinQueue _ x ts) = if p x then insertMinQ x q' else q' |

594 | + where q' = filterQueue p (<=) (const Empty) Empty ts |

595 | + |

596 | +partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) |

597 | +partition _ Empty = (Empty, Empty) |

598 | +partition p (MinQueue _ x ts) = case partitionQueue p (<=) (const (Empty, Empty)) (Empty, Empty) ts of |

599 | + (q0, q1) | p x -> (insertMinQ x q0, q1) |

600 | + | otherwise -> (q0, insertMinQ x q1) |

601 | + |

602 | +-- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, |

603 | +-- as in 'fmap'. If it is not, the result is undefined. |

604 | +mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b |

605 | +mapMonotonic = fmap |

606 | + |

607 | +-- | /O(n)/. Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation. |

608 | +-- If the function is not monotonic, the result is undefined. |

609 | +traverseMonotonic :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) |

610 | +traverseMonotonic = traverse |

611 | + |

612 | +{-# INLINE toAscList #-} |

613 | +-- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. |

614 | +toAscList :: Ord a => MinQueue a -> [a] |

615 | +toAscList queue = build (\ c nil -> foldrAsc c nil queue) |

616 | + |

617 | +{-# INLINE toList #-} |

618 | +-- | /O(n)/. Returns the elements of the priority queue in no particular order. |

619 | +toList :: MinQueue a -> [a] |

620 | +toList q = build (\ c nil -> foldr c nil q) |

621 | + |

622 | +{-# INLINE foldrAsc #-} |

623 | +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. |

624 | +foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b |

625 | +foldrAsc f z q = case q of |

626 | + Empty -> z |

627 | + MinQueue _ x ts -> x `f` foldrUnfold f z extractHeap ts |

628 | + |

629 | +{-# INLINE foldrUnfold #-} |

630 | +foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c |

631 | +foldrUnfold c nil suc s0 = unf s0 where |

632 | + unf x = case suc x of |

633 | + Nothing -> nil |

634 | + Just (a, x') -> a `c` unf x' |

635 | + |

636 | +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order. |

637 | +foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b |

638 | +foldlAsc f z q = case extract q of |

639 | + Nothing -> z |

640 | + Just (x, q') -> foldlAsc f (z `f` x) q' |

641 | + |

642 | +{-# INLINE fromList #-} |

643 | +-- | /O(n)/. Constructs a priority queue from an unordered list. |

644 | +fromList :: Ord a => [a] -> MinQueue a |

645 | +fromList = foldr insert Empty |

646 | + |

647 | +{-# INLINE fromAscList #-} |

648 | +-- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. |

649 | +fromAscList :: [a] -> MinQueue a |

650 | +fromAscList = foldr insertMinQ Empty |

651 | + |

652 | +{-# INLINE union' #-} |

653 | +union' :: (a -> a -> Bool) -> MinQueue a -> MinQueue a -> MinQueue a |

654 | +union' _ Empty q = q |

655 | +union' _ q Empty = q |

656 | +union' (<=) (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) |

657 | + | x1 <= x2 = MinQueue (n1 + n2) x1 (carry (<=) (tip x2) f1 f2) |

658 | + | otherwise = MinQueue (n1 + n2) x2 (carry (<=) (tip x1) f1 f2) |

659 | + |

660 | +-- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. |

661 | +extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) |

662 | +extractHeap ts = case extractBin (<=) ts of |

663 | + NoExtract -> Nothing |

664 | + YesExtract x _ ts' |

665 | + -> Just (x, ts') |

666 | + |

667 | +-- | A specialized type intended to organize the return of extract-min queries |

668 | +-- from a binomial forest. We walk all the way through the forest, and then |

669 | +-- walk backwards. @Extract e rk@ is the result type of an extract-min |

670 | +-- operation that has walked as far backwards of rank @rk@ -- that is, it |

671 | +-- has visited every root of rank @>= rk@. |

672 | +-- |

673 | +-- The interpretation of @YesExtract minKey children forest@ is |

674 | +-- |

675 | +-- * @minKey@ is the key of the minimum root visited so far. It may have |

676 | +-- any rank @>= rk@. We will denote the root corresponding to |

677 | +-- @minKey@ as @minRoot@. |

678 | +-- |

679 | +-- * @children@ is those children of @minRoot@ which have not yet been |

680 | +-- merged with the rest of the forest. Specifically, these are |

681 | +-- the children with rank @< rk@. |

682 | +-- |

683 | +-- * @forest@ is an accumulating parameter that maintains the partial |

684 | +-- reconstruction of the binomial forest without @minRoot@. It is |

685 | +-- the union of all old roots with rank @>= rk@ (except @minRoot@), |

686 | +-- with the set of all children of @minRoot@ with rank @>= rk@. |

687 | +-- Note that @forest@ is lazy, so if we discover a smaller key |

688 | +-- than @minKey@ later, we haven't wasted significant work. |

689 | +data Extract e rk = NoExtract | YesExtract e rk (BinomForest e rk) |

690 | + |

691 | +-- | Walks backward from the biggest key in the forest, as far as rank @rk@. |

692 | +-- Returns its progress. Each successive application of @extractBin@ takes |

693 | +-- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. |

694 | +extractBin :: (e -> e -> Bool) -> BinomForest e rk -> Extract e rk |

695 | +extractBin _ Nil = NoExtract |

696 | +extractBin (<=) (Skip f) = case extractBin (<=) f of |

697 | + NoExtract -> NoExtract |

698 | + YesExtract minKey (Succ kChild kChildren) f' -> |

699 | + YesExtract minKey kChildren (Cons kChild f') |

700 | +extractBin (<=) (Cons t@(BinomTree x ts) f) = case extractBin (<=) f of |

701 | + YesExtract minKey (Succ kChild kChildren) f' |

702 | + | minKey < x -> YesExtract minKey kChildren (Skip (carry1 (<=) (t `cat` kChild) f')) |

703 | + _ -> YesExtract x ts (Skip f) |

704 | + where cat = joinBin (<=) |

705 | + a < b = not (b <= a) |

706 | + |

707 | +filterQueue :: (a -> Bool) -> (a -> a -> Bool) -> (rk -> MinQueue a) -> MinQueue a -> BinomForest a rk -> MinQueue a |

708 | +filterQueue p (<=) fCh q0 forest = q0 `seq` case forest of |

709 | + Nil -> q0 |

710 | + Skip forest' -> filterQueue p (<=) fCh' q0 forest' |

711 | + Cons t forest' -> filterQueue p (<=) fCh' (union' (<=) (filterT t) q0) forest' |

712 | + where fCh' (Succ t tss) = union' (<=) (filterT t) (fCh tss) |

713 | + filterT (BinomTree x ts) |

714 | + | p x = insertMinQ x (fCh ts) |

715 | + | otherwise = fCh ts |

716 | + |

717 | +type Partition a = (MinQueue a, MinQueue a) |

718 | + |

719 | +partitionQueue :: (a -> Bool) -> (a -> a -> Bool) -> (rk -> Partition a) -> Partition a -> |

720 | + BinomForest a rk -> Partition a |

721 | +partitionQueue p (<=) fCh (q0, q1) forest = q0 `seq` q1 `seq` case forest of |

722 | + Nil -> (q0, q1) |

723 | + Skip forest' -> partitionQueue p (<=) fCh' (q0, q1) forest' |

724 | + Cons t forest' -> partitionQueue p (<=) fCh' (both (union' (<=)) (partitionT t) (q0, q1)) forest' |

725 | + where both f (x1, x2) (y1, y2) = (f x1 y1, f x2 y2) |

726 | + fCh' (Succ t tss) = both (union' (<=)) (partitionT t) (fCh tss) |

727 | + partitionT (BinomTree x ts) = case fCh ts of |

728 | + (q0, q1) |

729 | + | p x -> (insertMinQ x q0, q1) |

730 | + | otherwise -> (q0, insertMinQ x q1) |

731 | + |

732 | +{-# INLINE tip #-} |

733 | +-- | Constructs a binomial tree of rank 0. |

734 | +tip :: e -> BinomTree e () |

735 | +tip x = BinomTree x () |

736 | + |

737 | +-- | Given two binomial forests starting at rank @rk@, takes their union. |

738 | +-- Each successive application of this function costs /O(1)/, so applying it |

739 | +-- from the beginning costs /O(log n)/. |

740 | +merge :: (e -> e -> Bool) -> BinomForest e rk -> BinomForest e rk -> BinomForest e rk |

741 | +merge (<=) f1 f2 = case (f1, f2) of |

742 | + (Nil, _) -> f2 |

743 | + (_, Nil) -> f1 |

744 | + (Skip f1', Skip f2') |

745 | + -> Skip (merge (<=) f1' f2') |

746 | + (Skip f1', Cons t2 f2') |

747 | + -> Cons t2 (merge (<=) f1' f2') |

748 | + (Cons t1 f1', Skip f2') |

749 | + -> Cons t1 (merge (<=) f1' f2') |

750 | + (Cons t1 f1', Cons t2 f2') |

751 | + -> Skip (carry (<=) (t1 `cat` t2) f1' f2') |

752 | + where cat = joinBin (<=) |

753 | + |

754 | +-- | Merges two binomial forests with another tree. If we are thinking of the trees |

755 | +-- in the binomial forest as binary digits, this corresponds to a carry operation. |

756 | +-- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/. |

757 | +carry :: (e -> e -> Bool) -> BinomTree e rk -> BinomForest e rk -> BinomForest e rk -> BinomForest e rk |

758 | +carry (<=) t0 f1 f2 = t0 `seq` case (f1, f2) of |

759 | + (Nil, Nil) -> Cons t0 Nil |

760 | + (Nil, Skip f2') -> Cons t0 f2' |

761 | + (Skip f1', Nil) -> Cons t0 f1' |

762 | + (Nil, Cons t2 f2') -> Skip (carry1 (<=) (t0 `cat` t2) f2') |

763 | + (Cons t1 f1', Nil) -> Skip (carry1 (<=) (t0 `cat` t1) f1') |

764 | + (Skip f1', Skip f2') -> Cons t0 (merge (<=) f1' f2') |

765 | + (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2') |

766 | + (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2') |

767 | + (Cons t1 f1', Cons t2 f2') |

768 | + -> Cons t0 (mergeCarry t1 t2 f1' f2') |

769 | + where cat = joinBin (<=) |

770 | + mergeCarry tA tB f1 f2 = carry (<=) (tA `cat` tB) f1 f2 |

771 | + |

772 | +-- | Merges a binomial tree into a binomial forest. If we are thinking |

773 | +-- of the trees in the binomial forest as binary digits, this corresponds |

774 | +-- to adding a power of 2. This costs amortized /O(1)/ time. |

775 | +carry1 :: (e -> e -> Bool) -> BinomTree e rk -> BinomForest e rk -> BinomForest e rk |

776 | +carry1 (<=) t f = t `seq` case f of |

777 | + Nil -> Cons t Nil |

778 | + Skip f -> Cons t f |

779 | + Cons t' f' -> Skip (carry1 (<=) (t `cat` t') f') |

780 | + where cat = joinBin (<=) |

781 | + |

782 | +-- | The carrying operation: takes two binomial heaps of the same rank @k@ |

783 | +-- and returns one of rank @k+1@. Takes /O(1)/ time. |

784 | +joinBin :: (e -> e -> Bool) -> BinomTree e rk -> BinomTree e rk -> BinomTree' e rk |

785 | +joinBin (<=) t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) |

786 | + | x1 <= x2 = BinomTree x1 (Succ t2 ts1) |

787 | + | otherwise = BinomTree x2 (Succ t1 ts2) |

788 | + |

789 | +instance Functor MinQueue where |

790 | + fmap _ Empty = Empty |

791 | + fmap f (MinQueue n x forest) = MinQueue n (f x) (fmap2 f (const ()) forest) |

792 | + |

793 | +class Bifunctor f where |

794 | + fmap2 :: (x -> x') -> (y -> y') -> f x y -> f x' y' |

795 | + |

796 | +instance Bifunctor BinomForest where |

797 | + fmap2 f g ts = case ts of |

798 | + Nil -> Nil |

799 | + Skip ts' -> Skip (fmap2 f g' ts') |

800 | + Cons t ts' -> Cons (fmap2 f g t) (fmap2 f g' ts') |

801 | + where g' = fmap2 f g |

802 | + |

803 | +instance Bifunctor BinomTree where |

804 | + fmap2 f g (BinomTree x ts) = BinomTree (f x) (g ts) |

805 | + |

806 | +instance Bifunctor Succ where |

807 | + fmap2 f g (Succ t ts) = Succ (fmap2 f g t) (g ts) |

808 | + |

809 | +instance Foldable MinQueue where |

810 | + foldr _ z Empty = z |

811 | + foldr f z (MinQueue _ x ts) = x `f` foldr2 f (const id) z ts |

812 | + foldl _ z Empty = z |

813 | + foldl f z (MinQueue _ x ts) = foldl2 f const (z `f` x) ts |

814 | + foldl1 f Empty = error "Error: foldl1 called on an empty queue" |

815 | + foldl1 f (MinQueue _ x ts) = foldl2 f const x ts |

816 | + |

817 | +class Bifoldable f where |

818 | + foldr2 :: (a -> c -> c) -> (b -> c -> c) -> c -> f a b -> c |

819 | + foldl2 :: (c -> a -> c) -> (c -> b -> c) -> c -> f a b -> c |

820 | + |

821 | +instance Bifoldable BinomForest where |

822 | + foldr2 f g z ts = case ts of |

823 | + Nil -> z |

824 | + Skip ts' -> foldr2 f g' z ts' |

825 | + Cons t ts' -> foldr2 f g (foldr2 f g' z ts') t |

826 | + where g' = flip (foldr2 f g) |

827 | + foldl2 f g z ts = case ts of |

828 | + Nil -> z |

829 | + Skip ts' -> foldl2 f g' z ts' |

830 | + Cons t ts' -> foldl2 f g' (foldl2 f g z t) ts' |

831 | + where g' = foldl2 f g |

832 | + |

833 | +instance Bifoldable BinomTree where |

834 | + foldr2 f g z (BinomTree x ts) = x `f` (ts `g` z) |

835 | + foldl2 f g z (BinomTree x ts) = z `f` x `g` ts |

836 | + |

837 | +instance Bifoldable Succ where |

838 | + foldr2 f g z (Succ t ts) = foldr2 f g (ts `g` z) t |

839 | + foldl2 f g z (Succ t ts) = foldl2 f g z t `g` ts |

840 | + |

841 | +instance Traversable MinQueue where |

842 | + traverse _ Empty = pure Empty |

843 | + traverse f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse2 f (const (pure ())) ts |

844 | + |

845 | +class Bitraversable t where |

846 | + traverse2 :: Applicative f => (a -> f a') -> (b -> f b') -> |

847 | + t a b -> f (t a' b') |

848 | + |

849 | +instance Bitraversable BinomForest where |

850 | + traverse2 f g ts = case ts of |

851 | + Nil -> pure Nil |

852 | + Skip ts' -> Skip <$> traverse2 f g' ts' |

853 | + Cons t ts' -> Cons <$> traverse2 f g t <*> traverse2 f g' ts' |

854 | + where g' = traverse2 f g |

855 | + |

856 | +instance Bitraversable BinomTree where |

857 | + traverse2 f g (BinomTree x ts) = BinomTree <$> f x <*> g ts |

858 | + |

859 | +instance Bitraversable Succ where |

860 | + traverse2 f g (Succ t ts) = Succ <$> traverse2 f g t <*> g ts |

861 | + |

862 | +insertMinQ :: a -> MinQueue a -> MinQueue a |

863 | +insertMinQ x Empty = singleton x |

864 | +insertMinQ x (MinQueue n x' f) = MinQueue (n+1) x (insertMin (tip x') f) |

865 | + |

866 | +-- | @insertMin t f@ assumes that the root of @t@ compares as less than |

867 | +-- every other root in @f@, and merges accordingly. |

868 | +insertMin :: BinomTree e rk -> BinomForest e rk -> BinomForest e rk |

869 | +insertMin t Nil = Cons t Nil |

870 | +insertMin t (Skip f) = Cons t f |

871 | +insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f) |

872 | hunk ./containers.cabal 36 |

873 | Data.Graph |

874 | Data.Sequence |

875 | Data.Tree |

876 | + Data.PQueue.Min |

877 | + Data.PQueue.Max |

878 | + Data.PQueue |

879 | } |

880 | if impl(ghc) { |

881 | extensions: DeriveDataTypeable, MagicHash, Rank2Types |

882 | } |

883 | [Pairing queues for containers |

884 | wasserman.louis@gmail.com**20100309215517 |

885 | Ignore-this: a6590ad2ef6609ca45ead31548efbf3c |

886 | ] { |

887 | addfile ./Data/PQueue/Pairing.hs |

888 | hunk ./Data/PQueue/Pairing.hs 1 |

889 | - |

890 | +{-# LANGUAGE CPP #-} |

891 | + |

892 | +----------------------------------------------------------------------------- |

893 | +-- | |

894 | +-- Module : Data.PQueue.Pairing |

895 | +-- Copyright : (c) Louis Wasserman 2010 |

896 | +-- License : BSD-style |

897 | +-- Maintainer : libraries@haskell.org |

898 | +-- Stability : experimental |

899 | +-- Portability : portable |

900 | +-- |

901 | +-- General-purpose priority queue implementation built on a min-pairing-heap. |

902 | +-- |

903 | +-- This implementation is extremely speedy, especially when used in a single-threaded |

904 | +-- fashion. However, the amortized bounds are only valid in a single-threaded context, |

905 | +-- and the worst-case performance of |deleteMin| is /O(n)/. However, when used in |

906 | +-- a single-threaded context, this can be twice as fast as the binomial heap implementation. |

907 | +-- |

908 | +----------------------------------------------------------------------------- |

909 | +module Data.PQueue.Pairing ( |

910 | + PQueue, |

911 | + -- * Basic operations |

912 | + empty, |

913 | + null, |

914 | + size, |

915 | + -- * Query operations |

916 | + top, |

917 | + delete, |

918 | + extract, |

919 | + -- * Construction operations |

920 | + singleton, |

921 | + insert, |

922 | + union, |

923 | + unions, |

924 | +-- intersection, |

925 | +-- difference, |

926 | + -- * Extracting elements |

927 | + (!!), |

928 | + take, |

929 | + drop, |

930 | + splitAt, |

931 | + takeWhile, |

932 | + dropWhile, |

933 | + span, |

934 | + break, |

935 | + -- * Fold\/Functor\/Traversable variations |

936 | + mapMonotonic, |

937 | + foldrAsc, |

938 | + foldlAsc, |

939 | + traverseMonotonic, |

940 | + -- * Filter |

941 | + filter, |

942 | + partition, |

943 | + -- * List operations |

944 | + toList, |

945 | + toAscList, |

946 | + fromList, |

947 | + fromAscList) where |

948 | + |

949 | +import Control.Applicative hiding (empty) |

950 | + |

951 | +import Data.Maybe |

952 | +import Data.Monoid |

953 | +import Data.Foldable hiding (toList, foldl') |

954 | +import Data.Traversable |

955 | + |

956 | +import qualified Data.List as List |

957 | + |

958 | +import Prelude hiding (null, foldr, foldl, foldl1, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), |

959 | + filter) |

960 | + |

961 | +#ifdef __GLASGOW_HASKELL__ |

962 | +import GHC.Exts (build) |

963 | +import Text.Read (Lexeme(Ident), lexP, parens, prec, |

964 | + readPrec, readListPrec, readListPrecDefault) |

965 | +#else |

966 | + |

967 | +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] |

968 | +build f = f (:) [] |

969 | + |

970 | +#endif |

971 | + |

972 | +data PQueue a = Empty | PairQ {-# UNPACK #-} !Int {-# UNPACK #-} !(PHeap a) |

973 | +data PHeap a = PHeap a (PChildren a) |

974 | +data PChildren a = Zero | One {-# UNPACK #-} !(PHeap a) | Two {-# UNPACK #-} !(PHeap a) {-# UNPACK #-} !(PHeap a) |

975 | + |

976 | +instance Ord a => Eq (PQueue a) where |

977 | + Empty == Empty = True |

978 | + PairQ n1 t1 == PairQ n2 t2 = n1 == n2 && foldr (&&) True (zipWith (==) (heapToList t1) (heapToList t2)) |

979 | + -- This is a compromise between unrolling the entire thing by hand, and allocating unnecessary |

980 | + -- lists. |

981 | + _ == _ = False |

982 | + |

983 | +instance Ord a => Ord (PQueue a) where |

984 | + compare Empty Empty = EQ |

985 | + compare Empty PairQ{} = LT |

986 | + compare PairQ{} Empty = GT |

987 | + compare (PairQ n1 t1) (PairQ n2 t2) |

988 | + = foldr mappend (compare n1 n2) (zipWith compare (heapToList t1) (heapToList t2)) |

989 | + -- This is a compromise between unrolling the entire thing by hand, and allocating unnecessary |

990 | + -- lists. |

991 | + |

992 | +heapToList :: Ord a => PHeap a -> [a] |

993 | +heapToList t = build (\ c nil -> foldrAscH (<=) c nil t) |

994 | + |

995 | +instance Ord a => Monoid (PQueue a) where |

996 | + mempty = empty |

997 | + mappend = union |

998 | + mconcat = unions |

999 | + |

1000 | +instance (Ord a, Show a) => Show (PQueue a) where |

1001 | + showsPrec p xs = showParen (p > 10) $ |

1002 | + showString "fromAscList " . shows (toAscList xs) |

1003 | + |

1004 | +instance Read a => Read (PQueue a) where |

1005 | +#ifdef __GLASGOW_HASKELL__ |

1006 | + readPrec = parens $ prec 10 $ do |

1007 | + Ident "fromAscList" <- lexP |

1008 | + xs <- readPrec |

1009 | + return (fromAscList xs) |

1010 | + |

1011 | + readListPrec = readListPrecDefault |

1012 | +#else |

1013 | + readsPrec p = readParen (p > 10) $ \ r -> do |

1014 | + ("fromAscList",s) <- lex r |

1015 | + (xs,t) <- reads s |

1016 | + return (fromAscList xs,t) |

1017 | +#endif |

1018 | + |

1019 | +instance Functor PHeap where |

1020 | + fmap f (PHeap x ts) = PHeap (f x) (fmap f ts) |

1021 | + |

1022 | +instance Functor PChildren where |

1023 | + fmap _ Zero = Zero |

1024 | + fmap f (One t) = One (fmap f t) |

1025 | + fmap f (Two t1 t2) = Two (fmap f t1) (fmap f t2) |

1026 | + |

1027 | +instance Functor PQueue where |

1028 | + fmap _ Empty = Empty |

1029 | + fmap f (PairQ n t) = PairQ n (fmap f t) |

1030 | + |

1031 | +instance Foldable PHeap where |

1032 | + foldr f z (PHeap x ts) = x `f` foldr f z ts |

1033 | + foldl f z (PHeap x ts) = foldl f (z `f` x) ts |

1034 | + foldl1 f (PHeap x ts) = foldl f x ts |

1035 | + |

1036 | +instance Foldable PChildren where |

1037 | + foldr f z ts = case ts of |

1038 | + Zero -> z |

1039 | + One t -> foldr f z t |

1040 | + Two t1 t2 -> foldr f (foldr f z t2) t1 |

1041 | + |

1042 | +instance Foldable PQueue where |

1043 | + foldr _ z Empty = z |

1044 | + foldr f z (PairQ _ t) = foldr f z t |

1045 | + foldl _ z Empty = z |

1046 | + foldl f z (PairQ _ t) = foldl f z t |

1047 | + foldl1 f (PairQ _ t) = foldl1 f t |

1048 | + foldl1 _ _ = error "Error: foldl1 called on empty queue" |

1049 | + |

1050 | +instance Traversable PHeap where |

1051 | + traverse f (PHeap x t) = PHeap <$> f x <*> traverse f t |

1052 | + |

1053 | +instance Traversable PChildren where |

1054 | + traverse f ts = case ts of |

1055 | + Zero -> pure Zero |

1056 | + One t -> One <$> traverse f t |

1057 | + Two t1 t2 -> Two <$> traverse f t1 <*> traverse f t2 |

1058 | + |

1059 | +instance Traversable PQueue where |

1060 | + traverse _ Empty = pure Empty |

1061 | + traverse f (PairQ n t) = PairQ n <$> traverse f t |

1062 | + |

1063 | +-- | /O(1)/. The empty priority queue. |

1064 | +empty :: PQueue a |

1065 | +empty = Empty |

1066 | + |

1067 | +-- | /O(1)/. Is this the empty priority queue? |

1068 | +null :: PQueue a -> Bool |

1069 | +null Empty = True |

1070 | +null _ = False |

1071 | + |

1072 | +-- | /O(1)/. The number of elements in the queue. |

1073 | +size :: PQueue a -> Int |

1074 | +size Empty = 0 |

1075 | +size (PairQ n _) = n |

1076 | + |

1077 | +-- | /O(1)/. Construct a priority queue with a single element. |

1078 | +singleton :: a -> PQueue a |

1079 | +singleton = PairQ 1 . tip |

1080 | + |

1081 | +-- | /O(1)/. Insert an element into the priority queue. |

1082 | +insert :: Ord a => a -> PQueue a -> PQueue a |

1083 | +insert x Empty = singleton x |

1084 | +insert x (PairQ n q) = PairQ (n+1) (meldHeap (<=) (tip x) q) |

1085 | + |

1086 | +-- | /O(1)/. Take the union of two priority queues. |

1087 | +union :: Ord a => PQueue a -> PQueue a -> PQueue a |

1088 | +Empty `union` q = q |

1089 | +q `union` Empty = q |

1090 | +PairQ n1 q1 `union` PairQ n2 q2 = PairQ (n1 + n2) (meldHeap (<=) q1 q2) |

1091 | + |

1092 | +-- | /O(n)/. Takes the union of a list of priority queues. Produces a better-balanced |

1093 | +-- priority queue than /foldr union empty/, |

1094 | +unions :: Ord e => [PQueue e] -> PQueue e |

1095 | +unions = makeUnion0 (<=) |

1096 | + where makeUnion0 _ [] = Empty |

1097 | + makeUnion0 (<=) (Empty:qs) = makeUnion0 (<=) qs |

1098 | + makeUnion0 (<=) (PairQ n t:qs) = makeUnion10 n t qs where |

1099 | + makeUnion10 n t qs = n `seq` t `seq` case qs of |

1100 | + Empty:qs' -> makeUnion10 n t qs' |

1101 | + PairQ n' t':qs' -> makeUnion11 (n + n') t t' qs' |

1102 | + [] -> PairQ n t |

1103 | + makeUnion11 n t0 t1 qs = n `seq` t0 `seq` t1 `seq` case qs of |

1104 | + Empty:qs' -> makeUnion11 n t0 t1 qs' |

1105 | + PairQ n2 t2:qs' -> makeUnion10 (n + n2) (t0 `meld` (t1 `meld` t2)) qs' |

1106 | + [] -> PairQ n (t0 `meld` t1) |

1107 | + meld = meldHeap (<=) |

1108 | + |

1109 | +-- | /O(1)/. View the top (minimum) element of the queue, if there is one. |

1110 | +top :: Ord a => PQueue a -> Maybe a |

1111 | +top = fmap fst . extract |

1112 | + |

1113 | +-- | /O(log n)/. Extract the top (minimum) element of the sequence, if there is one. |

1114 | +extract :: Ord a => PQueue a -> Maybe (a, PQueue a) |

1115 | +extract Empty = Nothing |

1116 | +extract (PairQ n (PHeap x ts)) = |

1117 | + Just (x, case meldAll (<=) ts of |

1118 | + Nothing -> Empty |

1119 | + Just q' -> PairQ (n-1) q') |

1120 | + |

1121 | +-- | /O(log n)/. Delete the top element of the sequence, if there is one. |

1122 | +delete :: Ord a => PQueue a -> Maybe (PQueue a) |

1123 | +delete = fmap snd . extract |

1124 | + |

1125 | +tip :: e -> PHeap e |

1126 | +tip x = PHeap x Zero |

1127 | + |

1128 | +meldHeap :: (e -> e -> Bool) -> PHeap e -> PHeap e -> PHeap e |

1129 | +meldHeap (<=) = meld where |

1130 | + t1@(PHeap x1 ts1) `meld` t2@(PHeap x2 ts2) |

1131 | + | x1 <= x2 = PHeap x1 (cons t2 ts1) |

1132 | + | otherwise = PHeap x2 (cons t1 ts2) |

1133 | + cons t Zero = One t |

1134 | + cons t1 (One t0) = Two t0 t1 |

1135 | + cons t2 (Two t0 t1) = One ((t1 `meld` t2) `meld` t0) |

1136 | + |

1137 | +{-# INLINE meldAll #-} |

1138 | +meldAll :: (e -> e -> Bool) -> PChildren e -> Maybe (PHeap e) |

1139 | +meldAll _ Zero = Nothing |

1140 | +meldAll _ (One t) = Just t |

1141 | +meldAll (<=) (Two t0 t1) = Just $ meldHeap (<=) t0 t1 |

1142 | + |

1143 | +{-# INLINE fromAscList #-} |

1144 | +-- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. |

1145 | +fromAscList :: [a] -> PQueue a |

1146 | +fromAscList = foldr insMin empty |

1147 | + |

1148 | +insMin :: a -> PQueue a -> PQueue a |

1149 | +insMin x Empty = singleton x |

1150 | +insMin x (PairQ n t) = PairQ n (PHeap x (One t)) |

1151 | + |

1152 | +-- | /O(n)/. Produces a priority queue from an unordered list. Produces a slightly more balanced pairing |

1153 | +-- heap then @'foldr' 'insert' 'empty'@. |

1154 | +fromList :: Ord a => [a] -> PQueue a |

1155 | +fromList [] = Empty |

1156 | +fromList (x:xs) = fromListHelper (<=) x xs |

1157 | + |

1158 | +{-# NOINLINE fromListHelper #-} |

1159 | +fromListHelper :: (a -> a -> Bool) -> a -> [a] -> PQueue a |

1160 | +fromListHelper _ x [] = singleton x |

1161 | +fromListHelper (<=) x1 (x2:xs) = fromList0 2 (tip x1 `meld` tip x2) xs where |

1162 | + fromList0 n t xs = n `seq` t `seq` case xs of |

1163 | + [] -> PairQ n t |

1164 | + x:xs -> fromList1 (n+1) t x xs |

1165 | + fromList1 n t0 x1 xs = n `seq` t0 `seq` case xs of |

1166 | + [] -> PairQ (n+1) (tip x1 `meld` t0) |

1167 | + x2:xs -> fromList0 (n+1) ((tip x1 `meld` tip x2) `meld` t0) xs |

1168 | + meld = meldHeap (<=) |

1169 | + |

1170 | +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. |

1171 | +foldrAsc :: Ord a => (a -> b -> b) -> b -> PQueue a -> b |

1172 | +foldrAsc f z (PairQ _ t) = foldrAscH (<=) f z t |

1173 | +foldrAsc _ z _ = z |

1174 | + |

1175 | +foldrAscH :: (a -> a -> Bool) -> (a -> b -> b) -> b -> PHeap a -> b |

1176 | +foldrAscH (<=) f = flip foldrHelper where |

1177 | + foldrHelper (PHeap x ts) z = x `f` foldr foldrHelper z (meldAll (<=) ts) |

1178 | + |

1179 | +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order. |

1180 | +foldlAsc :: Ord a => (b -> a -> b) -> b -> PQueue a -> b |

1181 | +foldlAsc f z (PairQ _ t) = foldlAscH (<=) f z t |

1182 | +foldlAsc _ z _ = z |

1183 | + |

1184 | +foldlAscH :: (a -> a -> Bool) -> (b -> a -> b) -> b -> PHeap a -> b |

1185 | +foldlAscH (<=) f = foldlHelper where |

1186 | + foldlHelper z (PHeap x ts) = foldl foldlHelper (z `f` x) (meldAll (<=) ts) |

1187 | + |

1188 | +{-# INLINE toAscList #-} |

1189 | +-- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. |

1190 | +toAscList :: Ord a => PQueue a -> [a] |

1191 | +toAscList q = build (\ c nil -> foldrAsc c nil q) |

1192 | + |

1193 | +{-# INLINE toList #-} |

1194 | +-- | /O(n)/. Returns the elements of the priority queue in no particular order. |

1195 | +toList :: PQueue a -> [a] |

1196 | +toList q = build (\ c nil -> foldr c nil q) |

1197 | + |

1198 | +-- data Filter a = EmptyF | Filter {-# UNPACK #-} !Int {-# UNPACK #-} !(PHeap a) (PChildren a) |

1199 | + |

1200 | +filter :: Ord a => (a -> Bool) -> PQueue a -> PQueue a |

1201 | +filter _ Empty = Empty |

1202 | +filter p (PairQ _ t) = filterT t where |

1203 | + filterT (PHeap x ts) = (if p x then insMin x else id) $ case ts of |

1204 | + Zero -> Empty |

1205 | + One t -> filterT t |

1206 | + Two t0 t1 -> filterT t0 `union` filterT t1 |

1207 | + |

1208 | +partition :: Ord a => (a -> Bool) -> PQueue a -> (PQueue a, PQueue a) |

1209 | +partition _ Empty = (Empty, Empty) |

1210 | +partition p (PairQ _ t) = partitionT t where |

1211 | + partitionT (PHeap x ts) = case partitionCh ts of |

1212 | + (q0, q1) |

1213 | + | p x -> (insMin x q0, q1) |

1214 | + | otherwise -> (q0, insMin x q1) |

1215 | + partitionCh Zero = (Empty, Empty) |

1216 | + partitionCh (One t) = partitionT t |

1217 | + partitionCh (Two t0 t1) = case (partitionT t0, partitionT t1) of |

1218 | + ((q00, q01), (q10, q11)) -> |

1219 | + (q00 `union` q10, q01 `union` q11) |

1220 | + |

1221 | +-- | Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest element in the queue. |

1222 | +(!!) :: Ord a => PQueue a -> Int -> a |

1223 | +q !! n = (List.!!) (toAscList q) n |

1224 | + |

1225 | +{-# INLINE takeWhile #-} |

1226 | +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the |

1227 | +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. |

1228 | +takeWhile :: Ord a => (a -> Bool) -> PQueue a -> [a] |

1229 | +takeWhile p = List.takeWhile p . toAscList |

1230 | + |

1231 | +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. |

1232 | +dropWhile :: Ord a => (a -> Bool) -> PQueue a -> PQueue a |

1233 | +dropWhile p = dropWhileHelper where |

1234 | + dropWhileHelper q = case extract q of |

1235 | + Just (x, q') | p x -> dropWhile p q' |

1236 | + _ -> q |

1237 | + |

1238 | +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where |

1239 | +-- first element is longest prefix (possibly empty) of @queue@ of elements that |

1240 | +-- satisfy @p@ and second element is the remainder of the queue. |

1241 | +span :: Ord a => (a -> Bool) -> PQueue a -> ([a], PQueue a) |

1242 | +span p queue = case extract queue of |

1243 | + Just (x, q') | p x -> let (ys, q'') = span p q' in (x:ys, q'') |

1244 | + _ -> ([], queue) |

1245 | + |

1246 | +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where |

1247 | +-- first element is longest prefix (possibly empty) of @queue@ of elements that |

1248 | +-- /do not satisfy/ @p@ and second element is the remainder of the queue. |

1249 | +break :: Ord a => (a -> Bool) -> PQueue a -> ([a], PQueue a) |

1250 | +break p = span (not . p) |

1251 | + |

1252 | +{-# INLINE take #-} |

1253 | +-- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, |

1254 | +-- or all elements of @queue@ itself if @k >= 'size' queue@. |

1255 | +take :: Ord a => Int -> PQueue a -> [a] |

1256 | +take n = List.take n . toAscList |

1257 | + |

1258 | +-- | /O(k log n)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, |

1259 | +-- or an empty queue if @k >= size 'queue'@. |

1260 | +drop :: Ord a => Int -> PQueue a -> PQueue a |

1261 | +drop n queue |

1262 | + | n <= 0 = queue |

1263 | + | otherwise = case delete queue of |

1264 | + Nothing -> empty |

1265 | + Just queue' -> drop (n-1) queue' |

1266 | + |

1267 | +-- | /O(k log n)/. Equivalent to @('take' k queue, 'drop' k queue)@. |

1268 | +splitAt :: Ord a => Int -> PQueue a -> ([a], PQueue a) |

1269 | +splitAt n queue |

1270 | + | n <= 0 = ([], queue) |

1271 | + | otherwise = case extract queue of |

1272 | + Nothing -> ([], queue) |

1273 | + Just (x, queue') -> let (xs, queue'') = splitAt (n-1) queue' in (x:xs, queue'') |

1274 | + |

1275 | +-- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, |

1276 | +-- as in 'fmap'. If it is not, the result is undefined. |

1277 | +mapMonotonic :: (a -> b) -> PQueue a -> PQueue b |

1278 | +mapMonotonic = fmap |

1279 | + |

1280 | +-- | /O(n)/. Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation. |

1281 | +-- If the function is not monotonic, the result is undefined. |

1282 | +traverseMonotonic :: Applicative f => (a -> f b) -> PQueue a -> f (PQueue b) |

1283 | +traverseMonotonic = traverse |

1284 | } |

1285 | |

1286 | Context: |

1287 | |

1288 | [Tweak layout to work with the alternative layout rule |

1289 | Ian Lynagh <igloo@earth.li>**20091129154519] |

1290 | [Disable building Data.Sequence (and dependents) for nhc98. |

1291 | Malcolm.Wallace@cs.york.ac.uk**20091124025653 |

1292 | There is some subtlety of polymorphically recursive datatypes and |

1293 | type-class defaulting that nhc98's type system barfs over. |

1294 | ] |

1295 | [Fix another instance of non-ghc breakage. |

1296 | Malcolm.Wallace@cs.york.ac.uk**20091123092637] |

1297 | [Add #ifdef around ghc-only (<$) as member of Functor class. |

1298 | Malcolm.Wallace@cs.york.ac.uk**20091123085155] |

1299 | [Fix broken code in non-GHC branch of an ifdef. |

1300 | Malcolm.Wallace@cs.york.ac.uk**20091123084824] |

1301 | [doc bugfix: correct description of index argument |

1302 | Ross Paterson <ross@soi.city.ac.uk>**20091028105532 |

1303 | Ignore-this: 9790e7bf422c4cb528722c03cfa4fed9 |

1304 | |

1305 | As noted by iaefai on the libraries list. |

1306 | |

1307 | Please merge to STABLE. |

1308 | ] |

1309 | [Bump version to 0.3.0.0 |

1310 | Ian Lynagh <igloo@earth.li>**20090920141847] |

1311 | [update base dependency |

1312 | Ross Paterson <ross@soi.city.ac.uk>**20090916073125 |

1313 | Ignore-this: ad382ffc6c6a18c15364e6c072f19edb |

1314 | |

1315 | The package uses mkNoRepType and Data.Functor, which were not in the |

1316 | stable branch of base-4. |

1317 | ] |

1318 | [add fast version of <$ for Seq |

1319 | Ross Paterson <ross@soi.city.ac.uk>**20090916072812 |

1320 | Ignore-this: 5a39a7d31d39760ed589790b1118d240 |

1321 | ] |

1322 | [new methods for Data.Sequence (proposal #3271) |

1323 | Ross Paterson <ross@soi.city.ac.uk>**20090915173324 |

1324 | Ignore-this: cf17bedd709a6ab3448fd718dcdf62e7 |

1325 | |

1326 | Adds a lot of new methods to Data.Sequence, mostly paralleling those |

1327 | in Data.List. Several of these are significantly faster than versions |

1328 | implemented with the previous public interface. In particular, replicate |

1329 | takes O(log n) time and space instead of O(n). |

1330 | (by Louis Wasserman) |

1331 | ] |

1332 | [Fix "Cabal check" warnings |

1333 | Ian Lynagh <igloo@earth.li>**20090811215900] |

1334 | [TAG 2009-06-25 |

1335 | Ian Lynagh <igloo@earth.li>**20090625160202] |

1336 | Patch bundle hash: |

1337 | 9d207dcfbee69b4f5f0f7ed78038ae96109a6940 |