# Ticket #3909: containers-pqueue.patch

File containers-pqueue.patch, 22.1 KB (added by , 7 years ago) |
---|

Line | |
---|---|

1 | Thu Mar 4 08:59:15 CST 2010 wasserman.louis@gmail.com |

2 | * Data.PQueue with binomial heaps |

3 | |

4 | New patches: |

5 | |

6 | [Data.PQueue with binomial heaps |

7 | wasserman.louis@gmail.com**20100304145915 |

8 | Ignore-this: 31d532d51dda171d4ae2e484ffa3a8fb |

9 | ] { |

10 | addfile ./Data/PQueue.hs |

11 | hunk ./Data/PQueue.hs 1 |

12 | +{-# LANGUAGE ScopedTypeVariables, CPP, Rank2Types, ImplicitParams #-} |

13 | hunk ./Data/PQueue.hs 3 |

14 | +----------------------------------------------------------------------------- |

15 | +-- | |

16 | +-- Module : Data.PQueue |

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

18 | +-- License : BSD-style |

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

20 | +-- Stability : experimental |

21 | +-- Portability : portable |

22 | +-- |

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

24 | +-- |

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

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

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

28 | +-- |

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

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

31 | +-- as they are performed. |

32 | +-- |

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

34 | +-- "Data.Map". |

35 | +----------------------------------------------------------------------------- |

36 | +module Data.PQueue ( |

37 | + PQueue, |

38 | + -- * Basic operations |

39 | + empty, |

40 | + null, |

41 | + size, |

42 | + -- * Query operations |

43 | + ViewQ(..), |

44 | + top, |

45 | + delete, |

46 | + extract, |

47 | + -- * Construction operations |

48 | + singleton, |

49 | + insert, |

50 | + union, |

51 | + unions, |

52 | + intersection, |

53 | + difference, |

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

55 | + mapMonotonic, |

56 | + foldrQueue, |

57 | + foldlQueue, |

58 | + traverseMonotonic, |

59 | + -- * List operations |

60 | + toList, |

61 | + toAscList, |

62 | + fromList, |

63 | + fromAscList) where |

64 | + |

65 | +import Prelude hiding (null, foldr, foldl) |

66 | + |

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

68 | + |

69 | +import Data.Monoid |

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

71 | +import Data.Traversable |

72 | + |

73 | +#ifdef __GLASGOW_HASKELL__ |

74 | +import GHC.Exts (build) |

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

76 | + readPrec, readListPrec, readListPrecDefault) |

77 | +#endif |

78 | + |

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

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

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

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

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

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

85 | +-- |

86 | +-- If you wish to perform folds on a priority queue that respect order, it is advised that you apply |

87 | +-- your fold function to @toAscList queue@. |

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

89 | +type BinomHeap a = BinomForest a Zero |

90 | + |

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

92 | + q1 == q2 = toAscList q1 == toAscList q2 |

93 | + |

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

95 | + compare q1 q2 = compare (toAscList q1) (toAscList q2) |

96 | + |

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

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

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

100 | + |

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

102 | +#ifdef __GLASGOW_HASKELL__ |

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

104 | + Ident "fromAscList" <- lexP |

105 | + xs <- readPrec |

106 | + return (fromAscList xs) |

107 | + |

108 | + readListPrec = readListPrecDefault |

109 | +#else |

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

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

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

113 | + return (fromAscList xs,t) |

114 | +#endif |

115 | + |

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

117 | + mempty = Empty |

118 | + mappend = union |

119 | + |

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

121 | +-- |

122 | +-- A binomial tree of rank @0@ with elements of type @e@ has type @'BinomTree' e 'Zero'@. |

123 | +-- If a binomial tree of rank @k@ has type @BinomTree e k@, then a binomial tree of rank |

124 | +-- @k+1@ has type @'BinomTree' e ('Succ' e k)@. Therefore, we may justifiably label the |

125 | +-- second type argument as the /rank/ of the node. |

126 | +-- |

127 | +-- This is all in the type system. A /value/ of type @'Succ' e rk@, however, is a sequence |

128 | +-- of binomial trees of rank @0@ through @k-1@, which is exactly the type of the /collection of |

129 | +-- children/ of a node of rank @rk@. Therefore, @'BinomTree' e rk@, a binomial tree of rank |

130 | +-- @rk@, is exactly equivalent to @(e, rk)@. Cute! |

131 | +-- |

132 | +-- To implement binomial heaps, in which we may have at most one root of each rank, we define |

133 | +-- @'BinomForest' e rk@ to be a binomial forest of roots of rank at least @rk@. Since there is only |

134 | +-- one root of each rank, we may either have a binomial forest of rank @rk@ or not, and then |

135 | +-- a @BinomForest e (Succ e rk)@ contains the rest of the forest. We also have a 'Nil' constructor, |

136 | +-- for when we have no more roots. We maintain the invariant that @Nil@ always follows a @Cons@, but |

137 | +-- don't implement that in the type system. |

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

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

140 | + |

141 | +instance Ord e => Monoid (BinomForest e rk) where |

142 | + mempty = Nil |

143 | + mappend = merge (<=) |

144 | + |

145 | +data BinomTree e rk = BinomTree e rk |

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

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

148 | +type Zero = () |

149 | + |

150 | +-- basics |

151 | + |

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

153 | +empty :: PQueue a |

154 | +empty = Empty |

155 | + |

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

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

158 | +null Empty = True |

159 | +null _ = False |

160 | + |

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

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

163 | +size Empty = 0 |

164 | +size (PQueue n _ _) = n |

165 | + |

166 | +-- queries |

167 | + |

168 | +-- | View of the top of a sequence. Note: the 'Functor', 'Foldable', and 'Traversable' instances |

169 | +-- have the same caveats as the instances for 'PQueue'. |

170 | +data ViewQ a = EmptyQ -- ^ empty queue |

171 | + | a :^ PQueue a -- ^ the top (minimum) of the queue and the rest of the queue |

172 | + deriving (Eq, Ord, Read, Show) |

173 | + |

174 | +instance Functor ViewQ where |

175 | + fmap f (a :^ q) = f a :^ fmap f q |

176 | + fmap _ _ = EmptyQ |

177 | + |

178 | +instance Foldable ViewQ where |

179 | + foldr _ z EmptyQ = z |

180 | + foldr f z (a :^ q) = a `f` foldr f z q |

181 | + foldl _ z EmptyQ = z |

182 | + foldl f z (a :^ q) = foldl f (z `f` a) q |

183 | + |

184 | +instance Traversable ViewQ where |

185 | + traverse _ EmptyQ = pure EmptyQ |

186 | + traverse f (a :^ q) = (:^) <$> f a <*> traverse f q |

187 | + |

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

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

190 | +top q = case extract q of |

191 | + EmptyQ -> Nothing |

192 | + x :^ _ -> Just x |

193 | + |

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

195 | +extract :: Ord a => PQueue a -> ViewQ a |

196 | +extract Empty = EmptyQ |

197 | +extract (PQueue n x f) = x :^ delete' n f |

198 | + |

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

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

201 | +delete q = case extract q of |

202 | + EmptyQ -> Nothing |

203 | + _ :^ q' -> Just q' |

204 | + |

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

206 | +delete' :: Ord a => Int -> BinomHeap a -> PQueue a |

207 | +delete' n f = n `seq` case extractBin (<=) f of |

208 | + NoExtract -> Empty |

209 | + YesExtract x' _ f' |

210 | + -> PQueue (n-1) x' f' |

211 | + |

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

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

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

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

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

217 | +-- |

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

219 | +-- |

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

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

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

223 | +-- |

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

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

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

227 | +-- |

228 | +-- * @forest@ is a partial reconstruction of the binomial forest without |

229 | +-- @minRoot@. It is the union of all old roots with rank @>= rk@ |

230 | +-- (except @minRoot@), with the set of all children of @minRoot@ |

231 | +-- with rank @>= rk@. Note that @forest@ is lazy, so if we discover |

232 | +-- a smaller key than @minKey@ later, we haven't wasted significant |

233 | +-- work. |

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

235 | + |

236 | + |

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

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

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

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

241 | +extractBin _ Nil = NoExtract |

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

243 | + NoExtract -> NoExtract |

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

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

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

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

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

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

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

251 | + |

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

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

254 | +singleton x = PQueue 1 x Nil |

255 | + |

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

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

258 | +insert x' (PQueue n x f) |

259 | + | x' <= x = PQueue (n+1) x' (insertBin x f) |

260 | + | otherwise = PQueue (n+1) x (insertBin x' f) |

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

262 | +insert x Empty = singleton x |

263 | + |

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

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

266 | +Empty `union` q = q |

267 | +q `union` Empty = q |

268 | +PQueue n1 x1 f1 `union` PQueue n2 x2 f2 |

269 | + | x1 <= x2 = PQueue (n1 + n2) x1 (carry (<=) (tip x2) f1 f2) |

270 | + | otherwise = PQueue (n1 + n2) x2 (carry (<=) (tip x1) f1 f2) |

271 | + |

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

273 | +unions :: Ord a => [PQueue a] -> PQueue a |

274 | +unions = foldr union Empty |

275 | + |

276 | +-- | /O(n log n + m log m)/. Take the intersection of two priority queues. |

277 | +intersection :: Ord a => PQueue a -> PQueue a -> PQueue a |

278 | +Empty `intersection` _ = Empty |

279 | +_ `intersection` Empty = Empty |

280 | +PQueue _ x1 f1 `intersection` PQueue _ x2 f2 = intersectBin (<=) compare x1 f1 x2 f2 |

281 | + |

282 | +-- Takes the intersection of two binomial heaps. Essentially, this is just the algorithm |

283 | +-- for intersecting two sorted lists, except unconsing is replaced by dequeueing. |

284 | +-- Not particularly necessary, but interesting to have just for grins. |

285 | +intersectBin :: (a -> a -> Bool) -> (a -> a -> Ordering) -> a -> BinomHeap a -> a -> BinomHeap a -> PQueue a |

286 | +intersectBin (<=) cmp = intersect where |

287 | + intersect x1 f1 x2 f2 = case (cmp x1 x2, extractBin (<=) f1, extractBin (<=) f2) of |

288 | + (LT, YesExtract x1' _ f1', _) |

289 | + -> intersect x1' f1' x2 f2 |

290 | + (EQ, YesExtract x1' _ f1', YesExtract x2' _ f2') |

291 | + -> x1 `insertMinQ` intersect x1' f1' x2' f2' |

292 | + (EQ, _, _) |

293 | + -> singleton x1 |

294 | + (GT, _, YesExtract x2' _ f2') |

295 | + -> intersect x1 f1 x2' f2' |

296 | + _ -> Empty |

297 | + |

298 | +-- | /O(n log n + m log m)/. Takes the difference of two priority queues. |

299 | +difference :: Ord a => PQueue a -> PQueue a -> PQueue a |

300 | +queue `difference` Empty |

301 | + = queue |

302 | +Empty `difference` _ |

303 | + = Empty |

304 | +PQueue n1 x1 f1 `difference` PQueue _ x2 f2 |

305 | + = differenceBin (<=) compare n1 x1 f1 x2 f2 |

306 | + |

307 | +-- Takes the difference of two binomial heaps. Essentially, this is just the algorithm |

308 | +-- for the difference of two sorted lists, except unconsing is replaced by dequeueing. |

309 | +-- Not particularly necessary, but interesting to have just for grins. |

310 | +differenceBin :: (a -> a -> Bool) -> (a -> a -> Ordering) -> Int -> a -> BinomHeap a -> a -> BinomHeap a -> PQueue a |

311 | +differenceBin (<=) cmp = diffBin where |

312 | + diffBin n x1 f1 x2 f2 = n `seq` case (cmp x1 x2, extractBin (<=) f1, extractBin (<=) f2) of |

313 | + (LT, YesExtract x1' _ f1', _) |

314 | + -> x1 `insertMinQ` diffBin (n-1) x1' f1' x2 f2 |

315 | + (LT, _, _) |

316 | + -> singleton x1 |

317 | + (EQ, YesExtract x1' _ f1', YesExtract x2' _ f2') |

318 | + -> diffBin (n-1) x1' f1' x2' f2' |

319 | + (EQ, YesExtract x1' _ f1', _) |

320 | + -> PQueue n x1' f1' |

321 | + (EQ, _, _) |

322 | + -> Empty |

323 | + (GT, _, YesExtract x2' _ f2') |

324 | + -> diffBin n x1 f1 x2' f2' |

325 | + (GT, _, _) |

326 | + -> PQueue n x1 f1 |

327 | + |

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

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

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

331 | +tip x = BinomTree x () |

332 | + |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

349 | + |

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

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

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

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

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

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

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

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

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

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

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

361 | + (Skip f1', Cons t2 f2') -> Skip (carry (<=) (t0 `cat` t2) f1' f2') |

362 | + (Cons t1 f1', Skip f2') -> Skip (carry (<=) (t0 `cat` t1) f1' f2') |

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

364 | + -> Cons t0 (carry (<=) (t1 `cat` t2) f1' f2') |

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

366 | + |

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

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

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

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

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

372 | + Nil -> Cons t Nil |

373 | + Skip f -> Cons t f |

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

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

376 | + |

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

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

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

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

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

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

383 | + |

384 | +-- folding |

385 | + |

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

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

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

389 | +mapMonotonic = fmap |

390 | + |

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

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

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

394 | +traverseMonotonic = traverse |

395 | + |

396 | +instance Functor PQueue where |

397 | + fmap _ Empty = Empty |

398 | + fmap f (PQueue n x forest) = PQueue n (f x) (mapForest f (const ()) forest) |

399 | + |

400 | +mapForest :: (a -> b) -> (rk -> rk') -> BinomForest a rk -> BinomForest b rk' |

401 | +mapForest f fCh forest = case forest of |

402 | + Nil -> Nil |

403 | + Skip forest' |

404 | + -> Skip (fF' forest') |

405 | + Cons t forest' |

406 | + -> Cons (fT t) (fF' forest') |

407 | + where fT (BinomTree x ts) = BinomTree (f x) (fCh ts) |

408 | + fCh' (Succ t ts) = Succ (fT t) (fCh ts) |

409 | + fF' = mapForest f fCh' |

410 | + |

411 | +instance Foldable PQueue where |

412 | + foldr _ n Empty = n |

413 | + foldr c n (PQueue _ x f) = x `c` foldrUnord c n (const id) f |

414 | + foldMap _ Empty = mempty |

415 | + foldMap f (PQueue _ x forest) = f x `mappend` foldMap0 mappend mempty f forest |

416 | + |

417 | +-- | The initial level of 'foldMap'. Avoids unnecessary @'mappend' 'mempty'@ computations. |

418 | +foldMap0 :: (m -> m -> m) -> m -> (a -> m) -> BinomHeap a -> m |

419 | +foldMap0 (><) zero f forest = case forest of |

420 | + Nil -> zero |

421 | + Skip forest' |

422 | + -> fF' forest' |

423 | + Cons (BinomTree x _) forest' |

424 | + -> f x >< fF' forest' |

425 | + where fF' = foldMapUnord (><) zero f (\ (Succ (BinomTree x _) _) -> f x) |

426 | + |

427 | +-- | A recursive implementation of 'foldMap' capable of working up to trees of arbitrary rank. |

428 | +-- Does not respect ordering of the elements. |

429 | +foldMapUnord :: (m -> m -> m) -> m -> (a -> m) -> (rk -> m) -> BinomForest a rk -> m |

430 | +foldMapUnord (><) zero f fCh forest = case forest of |

431 | + Nil -> zero |

432 | + Skip forest' -> fF' forest' |

433 | + Cons t forest' -> fT t >< fF' forest' |

434 | + where fT (BinomTree x ts) = f x >< fCh ts |

435 | + fCh' (Succ t tss) = fT t >< fCh tss |

436 | + fF' = foldMapUnord (><) zero f fCh' |

437 | + |

438 | +-- | 'foldr' implementation on the binomial forest. Does not respect ordering of the elements. |

439 | +foldrUnord :: (a -> b -> b) -> b -> (rk -> b -> b) -> BinomForest a rk -> b |

440 | +foldrUnord c n cCh forest = case forest of |

441 | + Nil -> n |

442 | + Skip f' -> cF' f' |

443 | + Cons t f' -> t `cT` cF' f' |

444 | + where cT (BinomTree x ts) = c x . cCh ts |

445 | + cCh' (Succ t tss) = cT t . cCh tss |

446 | + cF' = foldrUnord c n cCh' |

447 | + |

448 | +instance Traversable PQueue where |

449 | + traverse _ Empty = pure Empty |

450 | + traverse f (PQueue n x forest) |

451 | + = PQueue n <$> f x <*> traverseBin f (const (pure ())) forest |

452 | + |

453 | +traverseBin :: Applicative f => (a -> f b) -> (rk -> f rk') -> BinomForest a rk -> f (BinomForest b rk') |

454 | +traverseBin f fCh forest = case forest of |

455 | + Nil -> pure Nil |

456 | + Skip forest' |

457 | + -> Skip <$> fF' forest' |

458 | + Cons t forest' |

459 | + -> Cons <$> fT t <*> fF' forest' |

460 | + where fF' = traverseBin f fCh' |

461 | + fT (BinomTree x ts) = BinomTree <$> f x <*> fCh ts |

462 | + fCh' (Succ t tss) = Succ <$> fT t <*> fCh tss |

463 | + |

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

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

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

467 | +#ifdef __GLASGOW_HASKELL__ |

468 | +toAscList q = build (\ c nil -> foldrQueue c nil q) |

469 | +#else |

470 | +toAscList = foldrQueue (:) [] |

471 | +#endif |

472 | + |

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

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

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

476 | +#ifdef __GLASGOW_HASKELL__ |

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

478 | +#else |

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

480 | +#endif |

481 | + |

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

483 | +foldrQueue :: Ord a => (a -> b -> b) -> b -> PQueue a -> b |

484 | +foldrQueue c n (PQueue _ x f) = x `c` foldrOrd (<=) c n f |

485 | +foldrQueue _ n _ = n |

486 | + |

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

488 | +foldlQueue :: Ord a => (b -> a -> b) -> b -> PQueue a -> b |

489 | +foldlQueue f z (PQueue _ x forest) = foldlOrd (<=) f (z `f` x) forest |

490 | +foldlQueue _ z _ = z |

491 | + |

492 | +-- | Right fold on a binomial forest. Respects order. |

493 | +foldrOrd :: (a -> a -> Bool) -> (a -> b -> b) -> b -> BinomHeap a -> b |

494 | +foldrOrd (<=) c n = foldQ0 where |

495 | + foldQ0 = foldQ1 . extractBin (<=) |

496 | + foldQ1 NoExtract = n |

497 | + foldQ1 (YesExtract x _ f) |

498 | + = x `c` foldQ0 f |

499 | + |

500 | +-- | Left fold on a binomial forest. Respects order. |

501 | +foldlOrd :: (a -> a -> Bool) -> (b -> a -> b) -> b -> BinomHeap a -> b |

502 | +foldlOrd (<=) f z = foldlQ0 z where |

503 | + foldlQ0 z = foldlQ1 z . extractBin (<=) |

504 | + foldlQ1 z NoExtract = z |

505 | + foldlQ1 z (YesExtract x _ f') |

506 | + = foldlQ0 (z `f` x) f' |

507 | + |

508 | + |

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

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

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

512 | +fromAscList = foldr insertMinQ Empty |

513 | + |

514 | +insertMinQ :: a -> PQueue a -> PQueue a |

515 | +insertMinQ x Empty = singleton x |

516 | +insertMinQ x (PQueue n x' f) = PQueue (n+1) x (insertMin (tip x') f) |

517 | + |

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

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

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

521 | +insertMin t Nil = Cons t Nil |

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

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

524 | + |

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

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

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

528 | +fromList = foldr insert Empty |

529 | hunk ./containers.cabal 36 |

530 | Data.Graph |

531 | Data.Sequence |

532 | Data.Tree |

533 | + Data.PQueue |

534 | } |

535 | if impl(ghc) { |

536 | extensions: DeriveDataTypeable, MagicHash, Rank2Types |

537 | } |

538 | |

539 | Context: |

540 | |

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

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

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

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

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

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

547 | ] |

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

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

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

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

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

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

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

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

556 | Ignore-this: 9790e7bf422c4cb528722c03cfa4fed9 |

557 | |

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

559 | |

560 | Please merge to STABLE. |

561 | ] |

562 | [Bump version to 0.3.0.0 |

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

564 | [update base dependency |

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

566 | Ignore-this: ad382ffc6c6a18c15364e6c072f19edb |

567 | |

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

569 | stable branch of base-4. |

570 | ] |

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

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

573 | Ignore-this: 5a39a7d31d39760ed589790b1118d240 |

574 | ] |

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

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

577 | Ignore-this: cf17bedd709a6ab3448fd718dcdf62e7 |

578 | |

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

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

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

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

583 | (by Louis Wasserman) |

584 | ] |

585 | [Fix "Cabal check" warnings |

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

587 | [TAG 2009-06-25 |

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

589 | Patch bundle hash: |

590 | 24d587a71217c65d71c47bdc69214ac3b42b08c2 |