# Ticket #3271: new-methods-for-data_sequence.4.dpatch

File new-methods-for-data_sequence.4.dpatch, 48.3 KB (added by , 8 years ago) |
---|

Line | |
---|---|

1 | Mon Jul 20 14:01:11 EDT 2009 wasserman.louis@gmail.com |

2 | * Ticket #3271: New methods for Data.Sequence |

3 | |

4 | New patches: |

5 | |

6 | [Ticket #3271: New methods for Data.Sequence |

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

8 | Ignore-this: fcaaef7ef4a863a045a0bda5a5a12643 |

9 | ] { |

10 | hunk ./Data/Sequence.hs 39 |

11 | -- * Construction |

12 | empty, -- :: Seq a |

13 | singleton, -- :: a -> Seq a |

14 | + replicate, -- :: Int -> a -> Seq a |

15 | (<|), -- :: a -> Seq a -> Seq a |

16 | (|>), -- :: Seq a -> a -> Seq a |

17 | (><), -- :: Seq a -> Seq a -> Seq a |

18 | hunk ./Data/Sequence.hs 44 |

19 | fromList, -- :: [a] -> Seq a |

20 | + -- ** Sequential construction |

21 | + iterateN, -- :: Int -> (a -> a) -> a -> Seq a |

22 | + unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a |

23 | -- * Deconstruction |

24 | -- | Additional functions for deconstructing sequences are available |

25 | -- via the 'Foldable' instance of 'Seq'. |

26 | hunk ./Data/Sequence.hs 59 |

27 | viewl, -- :: Seq a -> ViewL a |

28 | ViewR(..), |

29 | viewr, -- :: Seq a -> ViewR a |

30 | + -- ** Scanning |

31 | + scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a |

32 | + scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a |

33 | + scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b |

34 | + scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a |

35 | + -- ** Sublists |

36 | + tails, -- :: Seq a -> Seq (Seq a) |

37 | + inits, -- :: Seq a -> Seq (Seq a) |

38 | + takeWhile, -- :: (a -> Bool) -> Seq a -> Seq a |

39 | + dropWhile, -- :: (a -> Bool) -> Seq a -> Seq a |

40 | + span, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

41 | + break, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

42 | + partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

43 | + filter, -- :: (a -> Bool) -> Seq a -> Seq a |

44 | + -- ** Sorts |

45 | + sort, -- :: Ord a => Seq a -> Seq a |

46 | + sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a |

47 | + unstableSort, -- :: Ord a => Seq a -> Seq a |

48 | + unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a |

49 | -- ** Indexing |

50 | index, -- :: Seq a -> Int -> a |

51 | adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a |

52 | hunk ./Data/Sequence.hs 87 |

53 | splitAt, -- :: Int -> Seq a -> (Seq a, Seq a) |

54 | -- * Transformations |

55 | reverse, -- :: Seq a -> Seq a |

56 | + -- ** Zips |

57 | + zip, -- :: Seq a -> Seq b -> Seq (a, b) |

58 | + zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c |

59 | + zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c) |

60 | + zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d |

61 | + zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d) |

62 | + zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e |

63 | #if TESTING |

64 | valid, |

65 | #endif |

66 | hunk ./Data/Sequence.hs 100 |

67 | ) where |

68 | |

69 | import Prelude hiding ( |

70 | - null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, |

71 | - reverse) |

72 | -import qualified Data.List (foldl') |

73 | -import Control.Applicative (Applicative(..), (<$>)) |

74 | -import Control.Monad (MonadPlus(..)) |

75 | + null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, span, |

76 | + scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3, |

77 | + takeWhile, dropWhile, break, iterate, reverse, filter, mapM) |

78 | +import qualified Data.List (foldl', zipWith, sortBy) |

79 | +import Control.Applicative (Applicative(..), (<$>), liftA, liftA2, liftA3) |

80 | +import Control.Monad (MonadPlus(..), ap, liftM, liftM2, liftM3, liftM4) |

81 | import Data.Monoid (Monoid(..)) |

82 | import Data.Foldable |

83 | import Data.Traversable |

84 | hunk ./Data/Sequence.hs 122 |

85 | #endif |

86 | |

87 | #if TESTING |

88 | -import Control.Monad (liftM, liftM3, liftM4) |

89 | -import Test.QuickCheck |

90 | +import Test.QuickCheck hiding ((><)) |

91 | #endif |

92 | |

93 | infixr 5 `consTree` |

94 | hunk ./Data/Sequence.hs 127 |

95 | infixl 5 `snocTree` |

96 | +infixr 5 `consDigitToTree` |

97 | +infixl 6 `snocDigitToTree` |

98 | |

99 | infixr 5 >< |

100 | infixr 5 <|, :< |

101 | hunk ./Data/Sequence.hs 281 |

102 | traverse f sf |

103 | |

104 | {-# INLINE deep #-} |

105 | -{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

106 | -{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

107 | +{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

108 | +{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

109 | deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a |

110 | deep pr m sf = Deep (size pr + size m + size sf) pr m sf |

111 | |

112 | hunk ./Data/Sequence.hs 322 |

113 | fmap = fmapDefault |

114 | |

115 | instance Traversable Digit where |

116 | + {-# INLINE traverse #-} |

117 | traverse f (One a) = One <$> f a |

118 | traverse f (Two a b) = Two <$> f a <*> f b |

119 | traverse f (Three a b c) = Three <$> f a <*> f b <*> f c |

120 | hunk ./Data/Sequence.hs 329 |

121 | traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d |

122 | |

123 | instance Sized a => Sized (Digit a) where |

124 | - {-# SPECIALIZE instance Sized (Digit (Elem a)) #-} |

125 | - {-# SPECIALIZE instance Sized (Digit (Node a)) #-} |

126 | - size xs = foldl (\ i x -> i + size x) 0 xs |

127 | + {-# INLINE size #-} |

128 | + size = foldl1 (+) . fmap size |

129 | |

130 | {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-} |

131 | {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-} |

132 | hunk ./Data/Sequence.hs 357 |

133 | foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c |

134 | |

135 | instance Functor Node where |

136 | + {-# INLINE fmap #-} |

137 | fmap = fmapDefault |

138 | |

139 | instance Traversable Node where |

140 | hunk ./Data/Sequence.hs 361 |

141 | + {-# INLINE traverse #-} |

142 | traverse f (Node2 v a b) = Node2 v <$> f a <*> f b |

143 | traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c |

144 | |

145 | hunk ./Data/Sequence.hs 407 |

146 | showsPrec p (Elem x) = showsPrec p x |

147 | #endif |

148 | |

149 | +-- Applicative construction |

150 | + |

151 | +newtype Id a = Id {runId :: a} |

152 | + |

153 | +instance Functor Id where |

154 | + fmap f (Id x) = Id (f x) |

155 | + |

156 | +instance Monad Id where |

157 | + return = Id |

158 | + m >>= k = k (runId m) |

159 | + |

160 | +instance Applicative Id where |

161 | + pure = return |

162 | + (<*>) = ap |

163 | + |

164 | +-- | This is essentially a clone of Control.Monad.State.Strict. |

165 | +newtype State s a = State {runState :: s -> (s, a)} |

166 | + |

167 | +instance Functor (State s) where |

168 | + fmap = liftA |

169 | + |

170 | +instance Monad (State s) where |

171 | + {-# INLINE return #-} |

172 | + {-# INLINE (>>=) #-} |

173 | + return x = State $ \ s -> (s, x) |

174 | + m >>= k = State $ \ s -> case runState m s of |

175 | + (s', x) -> runState (k x) s' |

176 | + |

177 | +instance Applicative (State s) where |

178 | + pure = return |

179 | + (<*>) = ap |

180 | + |

181 | +execState :: State s a -> s -> a |

182 | +execState m x = snd (runState m x) |

183 | + |

184 | +-- | 'applicativeTree' takes an Applicative-wrapped construction of a piece of a FingerTree, assumed |

185 | +-- to always have the same size (which is put in the second argument), and replicates it as many times |

186 | +-- as specified. This encapsulates the behavior of several procedures, most notably iterate and replicate. |

187 | + |

188 | +{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-} |

189 | +{-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-} |

190 | + -- Special note: the Id specialization automatically does node sharing, reducing memory usage of the |

191 | + -- resulting tree to /O(log n)/. |

192 | +applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a) |

193 | +applicativeTree n mSize m = mSize `seq` case n of |

194 | + 0 -> pure Empty |

195 | + 1 -> liftA Single m |

196 | + 2 -> deepA one empty one |

197 | + 3 -> deepA two empty one |

198 | + 4 -> deepA two empty two |

199 | + 5 -> deepA three empty two |

200 | + 6 -> deepA three empty three |

201 | + 7 -> deepA four empty three |

202 | + 8 -> deepA four empty four |

203 | + _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of |

204 | + 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three |

205 | + 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three |

206 | + _ -> deepA four (applicativeTree (q - 2) mSize' n3) four |

207 | + where one = liftA One m |

208 | + two = liftA2 Two m m |

209 | + three = liftA3 Three m m m |

210 | + four = liftA3 Four m m m <*> m |

211 | + deepA = liftA3 (Deep (n * mSize)) |

212 | + mSize' = 3 * mSize |

213 | + n3 = liftA3 (Node3 mSize') m m m |

214 | + empty = pure Empty |

215 | + |

216 | ------------------------------------------------------------------------ |

217 | -- Construction |

218 | ------------------------------------------------------------------------ |

219 | hunk ./Data/Sequence.hs 486 |

220 | singleton :: a -> Seq a |

221 | singleton x = Seq (Single (Elem x)) |

222 | |

223 | +-- | /O(log n)/. @replicate n x@ is a sequence of length @n@ with @x@ the value of every element. |

224 | +replicate :: Int -> a -> Seq a |

225 | +replicate n x = Seq (runId (applicativeTree n 1 (Id (Elem x)))) |

226 | + |

227 | -- | /O(1)/. Add an element to the left end of a sequence. |

228 | -- Mnemonic: a triangle with the single element at the pointy end. |

229 | (<|) :: a -> Seq a -> Seq a |

230 | hunk ./Data/Sequence.hs 586 |

231 | appendTree1 xs a Empty = |

232 | xs `snocTree` a |

233 | appendTree1 (Single x) a xs = |

234 | - x `consTree` a `consTree` xs |

235 | + Two x a `consDigitToTree` xs |

236 | appendTree1 xs a (Single x) = |

237 | hunk ./Data/Sequence.hs 588 |

238 | - xs `snocTree` a `snocTree` x |

239 | + xs `snocDigitToTree` Two a x |

240 | appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) = |

241 | Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 |

242 | |

243 | hunk ./Data/Sequence.hs 628 |

244 | |

245 | appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a) |

246 | appendTree2 Empty a b xs = |

247 | - a `consTree` b `consTree` xs |

248 | + Two a b `consDigitToTree` xs |

249 | appendTree2 xs a b Empty = |

250 | hunk ./Data/Sequence.hs 630 |

251 | - xs `snocTree` a `snocTree` b |

252 | + xs `snocDigitToTree` Two a b |

253 | appendTree2 (Single x) a b xs = |

254 | hunk ./Data/Sequence.hs 632 |

255 | - x `consTree` a `consTree` b `consTree` xs |

256 | + Three x a b `consDigitToTree` xs |

257 | appendTree2 xs a b (Single x) = |

258 | hunk ./Data/Sequence.hs 634 |

259 | - xs `snocTree` a `snocTree` b `snocTree` x |

260 | + xs `snocDigitToTree` Three a b x |

261 | appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) = |

262 | Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 |

263 | |

264 | hunk ./Data/Sequence.hs 674 |

265 | |

266 | appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a) |

267 | appendTree3 Empty a b c xs = |

268 | - a `consTree` b `consTree` c `consTree` xs |

269 | + Three a b c `consDigitToTree` xs |

270 | appendTree3 xs a b c Empty = |

271 | hunk ./Data/Sequence.hs 676 |

272 | - xs `snocTree` a `snocTree` b `snocTree` c |

273 | + xs `snocDigitToTree` Three a b c |

274 | appendTree3 (Single x) a b c xs = |

275 | hunk ./Data/Sequence.hs 678 |

276 | - x `consTree` a `consTree` b `consTree` c `consTree` xs |

277 | + Four x a b c `consDigitToTree` xs |

278 | appendTree3 xs a b c (Single x) = |

279 | hunk ./Data/Sequence.hs 680 |

280 | - xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x |

281 | + xs `snocDigitToTree` Four a b c x |

282 | appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) = |

283 | Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 |

284 | |

285 | hunk ./Data/Sequence.hs 720 |

286 | |

287 | appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a) |

288 | appendTree4 Empty a b c d xs = |

289 | - a `consTree` b `consTree` c `consTree` d `consTree` xs |

290 | + Four a b c d `consDigitToTree` xs |

291 | appendTree4 xs a b c d Empty = |

292 | hunk ./Data/Sequence.hs 722 |

293 | - xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d |

294 | + xs `snocDigitToTree` Four a b c d |

295 | appendTree4 (Single x) a b c d xs = |

296 | hunk ./Data/Sequence.hs 724 |

297 | - x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs |

298 | + x `consTree` Four a b c d `consDigitToTree` xs |

299 | appendTree4 xs a b c d (Single x) = |

300 | hunk ./Data/Sequence.hs 726 |

301 | - xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x |

302 | + xs `snocDigitToTree` Four a b c d `snocTree` x |

303 | appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) = |

304 | Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 |

305 | |

306 | hunk ./Data/Sequence.hs 764 |

307 | addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = |

308 | appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 |

309 | |

310 | +-- Cons and snoc for entire digits at once. This code was automatically generated. |

311 | +-- |

312 | +-- For general internal use, this is *considerably more efficient* than repeated use of |

313 | +-- consTree or snocTree, which end up case'ing the appropriate digit once for every |

314 | +-- insertion, while this code only does it once. |

315 | + |

316 | +{-# SPECIALIZE consDigitToTree :: Digit (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-} |

317 | +{-# SPECIALIZE consDigitToTree :: Digit (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-} |

318 | +consDigitToTree :: Sized a => Digit a -> FingerTree a -> FingerTree a |

319 | +consDigitToTree dig Empty |

320 | + = digitToTree dig |

321 | +consDigitToTree dig (Single a) |

322 | + = Deep (size dig + size a) dig Empty (One a) |

323 | +consDigitToTree dig@(One a) (Deep n (One x) m sf) |

324 | + = Deep (n + size dig) (Two a x) m sf |

325 | +consDigitToTree dig@(One a) (Deep n (Two x y) m sf) |

326 | + = Deep (n + size dig) (Three a x y) m sf |

327 | +consDigitToTree dig@(One a) (Deep n (Three x y z) m sf) |

328 | + = Deep (n + size dig) (Four a x y z) m sf |

329 | +consDigitToTree dig@(One a) (Deep n (Four x y z w) m sf) |

330 | + = Deep (n + size dig) (Two a x) ((node3 y z w) `consTree` m) sf |

331 | +consDigitToTree dig@(Two a b) (Deep n (One x) m sf) |

332 | + = Deep (n + size dig) (Three a b x) m sf |

333 | +consDigitToTree dig@(Two a b) (Deep n (Two x y) m sf) |

334 | + = Deep (n + size dig) (Four a b x y) m sf |

335 | +consDigitToTree dig@(Two a b) (Deep n (Three x y z) m sf) |

336 | + = Deep (n + size dig) (Two a b) ((node3 x y z) `consTree` m) sf |

337 | +consDigitToTree dig@(Two a b) (Deep n (Four x y z w) m sf) |

338 | + = Deep (n + size dig) (Three a b x) ((node3 y z w) `consTree` m) sf |

339 | +consDigitToTree dig@(Three a b c) (Deep n (One x) m sf) |

340 | + = Deep (n + size dig) (Four a b c x) m sf |

341 | +consDigitToTree dig@(Three a b c) (Deep n (Two x y) m sf) |

342 | + = Deep (n + size dig) (Two a b) ((node3 c x y) `consTree` m) sf |

343 | +consDigitToTree dig@(Three a b c) (Deep n (Three x y z) m sf) |

344 | + = Deep (n + size dig) (Three a b c) ((node3 x y z) `consTree` m) sf |

345 | +consDigitToTree dig@(Three a b c) (Deep n (Four x y z w) m sf) |

346 | + = Deep (n + size dig) (One a) (Two (node3 b c x) (node3 y z w) `consDigitToTree` m) sf |

347 | +consDigitToTree dig@(Four a b c d) (Deep n (One x) m sf) |

348 | + = Deep (n + size dig) (Two a b) ((node3 c d x) `consTree` m) sf |

349 | +consDigitToTree dig@(Four a b c d) (Deep n (Two x y) m sf) |

350 | + = Deep (n + size dig) (Three a b c) ((node3 d x y) `consTree` m) sf |

351 | +consDigitToTree dig@(Four a b c d) (Deep n (Three x y z) m sf) |

352 | + = Deep (n + size dig) (One a) (Two (node3 b c d) (node3 x y z) `consDigitToTree` m) sf |

353 | +consDigitToTree dig@(Four a b c d) (Deep n (Four x y z w) m sf) |

354 | + = Deep (n + size dig) (Two a b) (Two (node3 c d x) (node3 y z w) `consDigitToTree` m) sf |

355 | + |

356 | +{-# SPECIALIZE snocDigitToTree :: FingerTree (Elem a) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

357 | +{-# SPECIALIZE snocDigitToTree :: FingerTree (Node a) -> Digit (Node a) -> FingerTree (Node a) #-} |

358 | +snocDigitToTree :: Sized a => FingerTree a -> Digit a -> FingerTree a |

359 | +snocDigitToTree Empty dig |

360 | + = digitToTree dig |

361 | +snocDigitToTree (Single a) dig |

362 | + = Deep (size a + size dig) (One a) Empty dig |

363 | +snocDigitToTree (Deep n pr m (One a)) dig@(One x) |

364 | + = Deep (n + size dig) pr m (Two a x) |

365 | +snocDigitToTree (Deep n pr m (One a)) dig@(Two x y) |

366 | + = Deep (n + size dig) pr m (Three a x y) |

367 | +snocDigitToTree (Deep n pr m (One a)) dig@(Three x y z) |

368 | + = Deep (n + size dig) pr m (Four a x y z) |

369 | +snocDigitToTree (Deep n pr m (One a)) dig@(Four x y z w) |

370 | + = Deep (n + size dig) pr (m `snocTree` (node3 a x y)) (Two z w) |

371 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(One x) |

372 | + = Deep (n + size dig) pr m (Three a b x) |

373 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(Two x y) |

374 | + = Deep (n + size dig) pr m (Four a b x y) |

375 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(Three x y z) |

376 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Two y z) |

377 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(Four x y z w) |

378 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Three y z w) |

379 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(One x) |

380 | + = Deep (n + size dig) pr m (Four a b c x) |

381 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(Two x y) |

382 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two x y) |

383 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(Three x y z) |

384 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three x y z) |

385 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(Four x y z w) |

386 | + = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 x y z)) (One w) |

387 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(One x) |

388 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two d x) |

389 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Two x y) |

390 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three d x y) |

391 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Three x y z) |

392 | + = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (One z) |

393 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Four x y z w) |

394 | + = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (Two z w) |

395 | + |

396 | +-- | Builds a sequence from a seed value. Takes time linear in the number of generated elements. /WARNING: If the number of generated elements is infinite, this method will not terminate./ |

397 | +unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a |

398 | +unfoldr f b = unfoldr' empty b where |

399 | + -- uses tail recursion rather than, for instance, the List implementation. |

400 | + unfoldr' as b = case f b of |

401 | + Nothing -> as |

402 | + Just (a, b') -> unfoldr' (as |> a) b' |

403 | + |

404 | +-- | /O(n)/. Constructs a sequence by repeated application of a function to a seed value. |

405 | +-- |

406 | +-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x)) |

407 | +iterateN :: Int -> (a -> a) -> a -> Seq a |

408 | +iterateN n f x |

409 | + | n < 0 = error "iterateN takes a nonnegative integer argument" |

410 | + | otherwise = Seq (execState (applicativeTree n 1 run) x) |

411 | + where run = State $ \ x -> (f x, Elem x) |

412 | + |

413 | ------------------------------------------------------------------------ |

414 | -- Deconstruction |

415 | ------------------------------------------------------------------------ |

416 | hunk ./Data/Sequence.hs 1001 |

417 | viewRTree (Deep s pr m (Four w x y z)) = |

418 | Just2 (Deep (s - size z) pr m (Three w x y)) z |

419 | |

420 | +------------------------------------------------------------------------ |

421 | +-- Scans |

422 | +-- |

423 | +-- These are not particularly complex applications of the Traversable |

424 | +-- functor, though making the correspondence with Data.List exact |

425 | +-- requires the use of (<|) and (|>). |

426 | +-- |

427 | +-- Note that save for the single (<|) or (|>), we maintain the original |

428 | +-- structure of the Seq, not having to do any restructuring of our own. |

429 | +-- |

430 | +-- wasserman.louis@gmail.com, 5/23/09 |

431 | +------------------------------------------------------------------------ |

432 | + |

433 | +-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced values from the left: |

434 | +-- |

435 | +-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...] |

436 | +scanl :: (a -> b -> a) -> a -> Seq b -> Seq a |

437 | +scanl f z0 xs = z0 <| snd (mapAccumL accum z0 xs) |

438 | + where accum x z = let x' = f x z in (x', x') |

439 | + |

440 | +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: |

441 | +-- |

442 | +-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...] |

443 | +scanl1 :: (a -> a -> a) -> Seq a -> Seq a |

444 | +scanl1 f xs = case viewl xs of |

445 | + EmptyL -> error "scanl1 takes a nonempty sequence as an argument" |

446 | + x :< xs' -> scanl f x xs' |

447 | + |

448 | +-- | 'scanr' is the right-to-left dual of 'scanl'. |

449 | +scanr :: (a -> b -> b) -> b -> Seq a -> Seq b |

450 | +scanr f z0 xs = snd (mapAccumR accum z0 xs) |> z0 |

451 | + where accum z x = let z' = f x z in (z', z') |

452 | + |

453 | +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. |

454 | +scanr1 :: (a -> a -> a) -> Seq a -> Seq a |

455 | +scanr1 f xs = case viewr xs of |

456 | + EmptyR -> error "scanr1 takes a nonempty sequence as an argument" |

457 | + xs' :> x -> scanr f x xs' |

458 | + |

459 | -- Indexing |

460 | |

461 | -- | /O(log(min(i,n-i)))/. The element at the specified position, |

462 | hunk ./Data/Sequence.hs 1190 |

463 | splitAt i (Seq xs) = (Seq l, Seq r) |

464 | where (l, r) = split i xs |

465 | |

466 | +-- | /O(n)/. Returns a sequence of all suffixes of this sequence, longest first. For example, |

467 | +-- |

468 | +-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""] |

469 | +-- |

470 | +-- Evaluating the /i/th tail takes /O(log(min(i, n-i)))/, but evaluating every tail in the sequence |

471 | +-- takes /O(n)/ due to sharing. |

472 | +tails :: Seq a -> Seq (Seq a) |

473 | +tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty |

474 | +{- |

475 | +tails xs = iterateN (length xs + 1) tail' xs where |

476 | + tail' ys _ = case viewl ys of |

477 | + _ :< ys' -> ys' |

478 | + _ -> error "Invariant failure in Data.Sequence.tails" -- should never happen |

479 | +-} |

480 | + |

481 | +-- | /O(n)/. Returns a sequence of all prefixes of this sequence, shortest first. For example, |

482 | +-- |

483 | +-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"] |

484 | +-- |

485 | +-- Evaluating the /i/th init takes /O(log(min(i, n-i)))/, but evaluating every init in the sequence |

486 | +-- takes /O(n)/ due to sharing. |

487 | +inits :: Seq a -> Seq (Seq a) |

488 | +inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs) |

489 | +-- inits = scanl (|>) empty |

490 | + |

491 | +-- This implementation of tails (and, analogously, inits) has the following algorithmic advantages: |

492 | +-- Evaluating each tail in the sequence takes linear total time, which is better than we could say for |

493 | +-- @fromList [drop n xs | n <- [0..length xs]]@. |

494 | +-- Evaluating any individual tail takes logarithmic time, which is better than we can say for either |

495 | +-- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@. |

496 | +-- |

497 | +-- Moreover, if we actually look at every tail in the sequence, the following benchmarks demonstrate that |

498 | +-- this implementation is actually slightly faster than any of the above: |

499 | +-- |

500 | +-- Times (ms) min mean +/-sd median max |

501 | +-- Seq.tails: 16.875 20.405 4.247 19.663 47.972 |

502 | +-- scanr: 68.429 76.948 6.505 75.264 99.650 |

503 | +-- iterateN: 17.571 22.231 1.031 22.251 23.917 |

504 | +-- |

505 | +-- The algorithm for tails (and, analogously, inits) is as follows: |

506 | +-- |

507 | +-- A Node in the FingerTree of tails is constructed by evaluating the corresponding tail of the FingerTree |

508 | +-- of Nodes, considering the first Node in this tail, and constructing a Node in which each tail of this |

509 | +-- Node is made to be the prefix of the remaining tree. This ends up working quite elegantly, as the remainder of |

510 | +-- the tail of the FingerTree of Nodes becomes the middle of a new tail, the suffix of the Node is the |

511 | +-- prefix, and the suffix of the original tree is retained. |

512 | +-- |

513 | +-- In particular, evaluating the /i/th tail involves making as many partial evaluations as the Node depth of |

514 | +-- the /i/th element. In addition, when we evaluate the /i/th tail, and we also evaluate the /j/th tail, |

515 | +-- and /m/ Nodes are on the path to both /i/ and /j/, each of those /m/ evaluations are shared between |

516 | +-- the computation of the /i/th and /j/th tails. |

517 | +-- |

518 | +-- wasserman.louis@gmail.com, 7/16/09 |

519 | + |

520 | +-- | Given the size of a digit and the digit itself, efficiently converts it to a FingerTree. |

521 | +digitToTree' :: Int -> Digit a -> FingerTree a |

522 | +digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d) |

523 | +digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c) |

524 | +digitToTree' n (Two a b) = Deep n (One a) Empty (One b) |

525 | +digitToTree' n (One a) = n `seq` Single a |

526 | + |

527 | +{-# INLINE scanlSize #-} |

528 | +scanlSize :: (Traversable f, Sized a) => (b -> Int -> b) -> b -> f a -> f b |

529 | +scanlSize f z d = snd (mapAccumL (\ acc x -> let ans = f acc (size x) in (ans, ans)) z d) |

530 | + |

531 | +{-# INLINE scanrSize #-} |

532 | +scanrSize :: (Traversable f, Sized a) => (Int -> b -> b) -> b -> f a -> f b |

533 | +scanrSize f z d = snd (mapAccumR (\ acc x -> let ans = size x `f` acc in (ans, ans)) z d) |

534 | + |

535 | +{-# INLINE tailPr #-} |

536 | +-- | Given a Deep FingerTree, constructs the prefix of its tree of tails. |

537 | +tailPr :: Sized a => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a) |

538 | +tailPr n pr m sf = n `seq` let t = Deep n pr m sf in case (pr, scanlSize (-) n pr) of |

539 | + (One _, _) -> One t |

540 | + (Two _ b, Two sza _) |

541 | + -> sza `seq` Two t (Deep sza (One b) m sf) |

542 | + (Three _ b c, Three sza szb _) |

543 | + -> szb `seq` Three t (Deep sza (Two b c) m sf) (Deep szb (One c) m sf) |

544 | + (Four _ b c d, Four sza szb szc _) |

545 | + -> szc `seq` Four t (Deep sza (Three b c d) m sf) (Deep szb (Two c d) m sf) |

546 | + (Deep szc (One d) m sf) |

547 | + _ -> error "The flatly impossible has occurred" |

548 | + |

549 | +{-# INLINE initPr #-} |

550 | +-- | Constructs the inits of the specified digits. |

551 | +initPr :: Sized a => Digit a -> Digit (FingerTree a) |

552 | +initPr pr = case (pr, scanlSize (+) 0 pr) of |

553 | + (One a, _) -> One (Single a) |

554 | + (Two a b, Two _ szb) |

555 | + -> szb `seq` Two (Single a) (digitToTree' szb (Two a b)) |

556 | + (Three a b c, Three _ szb szc) |

557 | + -> szc `seq` Three (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c)) |

558 | + (Four a b c d, Four _ szb szc szd) |

559 | + -> szd `seq` Four (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c)) |

560 | + (digitToTree' szd (Four a b c d)) |

561 | + _ -> error "The flatly impossible has occurred" |

562 | + |

563 | +{-# INLINE tailSf #-} |

564 | +-- | Constructs the tails of the specified digit. |

565 | +tailSf :: Sized a => Digit a -> Digit (FingerTree a) |

566 | +tailSf sf = case (sf, scanrSize (+) 0 sf) of |

567 | + (One a, _) -> One (Single a) |

568 | + (Two a b, Two sza _) |

569 | + -> sza `seq` Two (digitToTree' sza (Two a b)) (Single b) |

570 | + (Three a b c, Three sza szb _) |

571 | + -> sza `seq` Three (digitToTree' sza (Three a b c)) (digitToTree' szb (Two b c)) |

572 | + (Single c) |

573 | + (Four a b c d, Four sza szb szc _) |

574 | + -> sza `seq` Four (digitToTree' sza (Four a b c d)) (digitToTree' szb (Three b c d)) |

575 | + (digitToTree' szc (Two c d)) (Single d) |

576 | + _ -> error "The flatly impossible has occurred" |

577 | + |

578 | +{-# INLINE initSf #-} |

579 | +-- | Constructs the suffix of the tree of inits of the specified Deep tree. |

580 | +initSf :: (Sized a) => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a) |

581 | +initSf n pr m sf = n `seq` let t = Deep n pr m sf in case (sf, scanrSize subtract n sf) of |

582 | + (One _, _) -> One t |

583 | + (Two a _, Two sza _) |

584 | + -> sza `seq` Two (Deep sza pr m (One a)) t |

585 | + (Three a b _, Three sza szb _) |

586 | + -> sza `seq` Three (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) t |

587 | + (Four a b c _, Four sza szb szc _) |

588 | + -> sza `seq` Four (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) (Deep szc pr m (Three a b c)) t |

589 | + _ -> error "The flatly impossible has occurred" |

590 | + |

591 | +{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-} |

592 | +{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-} |

593 | +-- | Given a function to apply to tails of a tree, applies that function to every tail of the specified tree. |

594 | +tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b |

595 | +tailsTree _ Empty = Empty |

596 | +tailsTree f (Single x) = Single (f (Single x)) |

597 | +tailsTree f (Deep n pr m sf) = sfSize `seq` |

598 | + Deep n (fmap f (tailPr n pr m sf)) (tailsTree f' m) (fmap f (tailSf sf)) |

599 | + where sfSize = size sf |

600 | + f' ms = case viewLTree ms of |

601 | + Nothing2 -> error "tailsTree should not encounter empty tails" |

602 | + Just2 node@(Node2 n' a b) m' -> let Node2 _ sz2 sz = scanrSize (+) (size m' + sfSize) node in |

603 | + sz2 `seq` Node2 n' (f (Deep sz2 (Two a b) m' sf)) |

604 | + (f (Deep sz (One b) m' sf)) |

605 | + Just2 node@(Node3 n' a b c) m' -> let Node3 _ sz3 sz2 sz = scanrSize (+) (size m' + sfSize) node in |

606 | + sz3 `seq` Node3 n' (f (Deep sz3 (Three a b c) m' sf)) |

607 | + (f (Deep sz2 (Two b c) m' sf)) |

608 | + (f (Deep sz (One c) m' sf)) |

609 | + |

610 | +{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-} |

611 | +{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-} |

612 | +-- | Given a function to apply to inits of a tree, applies that function to every init of the specified tree. |

613 | +initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b |

614 | +initsTree _ Empty = Empty |

615 | +initsTree f (Single x) = Single (f (Single x)) |

616 | +initsTree f (Deep n pr m sf) = prSize `seq` |

617 | + Deep n (fmap f (initPr pr)) (initsTree f' m) (fmap f (initSf n pr m sf)) |

618 | + where prSize = size pr |

619 | + f' ms = case viewRTree ms of |

620 | + Nothing2 -> error "initsTree should not encounter empty inits" |

621 | + Just2 m' node@(Node2 n' a b) -> let Node2 _ sza szb = scanlSize (+) (prSize + size m') node in |

622 | + szb `seq` Node2 n' (f (Deep sza pr m' (One a))) |

623 | + (f (Deep szb pr m' (Two a b))) |

624 | + Just2 m' node@(Node3 n' a b c) -> let Node3 _ sza szb szc = scanlSize (+) (prSize + size m') node in |

625 | + szc `seq` Node3 n' (f (Deep sza pr m' (One a))) |

626 | + (f (Deep szb pr m' (Two a b))) |

627 | + (f (Deep szc pr m' (Three a b c))) |

628 | + |

629 | split :: Int -> FingerTree (Elem a) -> |

630 | (FingerTree (Elem a), FingerTree (Elem a)) |

631 | split i Empty = i `seq` (Empty, Empty) |

632 | hunk ./Data/Sequence.hs 1376 |

633 | Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf) |

634 | | i < spm = case splitTree im m of |

635 | Split ml xs mr -> case splitNode (im - size ml) xs of |

636 | - Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) |

637 | + Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) |

638 | | otherwise = case splitDigit (i - spm) sf of |

639 | hunk ./Data/Sequence.hs 1378 |

640 | - Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) |

641 | + Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) |

642 | where spr = size pr |

643 | spm = spr + size m |

644 | im = i - spr |

645 | hunk ./Data/Sequence.hs 1383 |

646 | |

647 | +{-# SPECIALIZE pullL :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Elem a) #-} |

648 | +{-# SPECIALIZE pullL :: Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node a) #-} |

649 | +pullL :: Sized a => Digit a -> FingerTree (Node a) -> FingerTree a |

650 | +pullL pr m = case viewRTree m of |

651 | + Nothing2 -> digitToTree pr |

652 | + Just2 m' sf -> Deep (size pr + size m) pr m' (nodeToDigit sf) |

653 | + |

654 | +{-# SPECIALIZE pullR :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

655 | +{-# SPECIALIZE pullR :: FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

656 | +pullR :: Sized a => FingerTree (Node a) -> Digit a -> FingerTree a |

657 | +pullR m sf = case viewLTree m of |

658 | + Nothing2 -> digitToTree sf |

659 | + Just2 pr m' -> Deep (size sf + size m) (nodeToDigit pr) m' sf |

660 | + |

661 | {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

662 | {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

663 | deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a |

664 | hunk ./Data/Sequence.hs 1400 |

665 | -deepL Nothing m sf = case viewLTree m of |

666 | - Nothing2 -> digitToTree sf |

667 | - Just2 a m' -> Deep (size m + size sf) (nodeToDigit a) m' sf |

668 | +deepL Nothing m sf = pullR m sf |

669 | deepL (Just pr) m sf = deep pr m sf |

670 | |

671 | {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-} |

672 | hunk ./Data/Sequence.hs 1406 |

673 | {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-} |

674 | deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a |

675 | -deepR pr m Nothing = case viewRTree m of |

676 | - Nothing2 -> digitToTree pr |

677 | - Just2 m' a -> Deep (size pr + size m) pr m' (nodeToDigit a) |

678 | +deepR pr m Nothing = pullL pr m |

679 | deepR pr m (Just sf) = deep pr m sf |

680 | |

681 | {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-} |

682 | hunk ./Data/Sequence.hs 1446 |

683 | sab = sa + size b |

684 | sabc = sab + size c |

685 | |

686 | +-- | /O(i)/ where /i/ is the breakpoint index. 'takeWhile', applied to a predicate @p@ and a sequence @xs@, returns the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@. |

687 | +takeWhile :: (a -> Bool) -> Seq a -> Seq a |

688 | +takeWhile p xs = fst (span p xs) |

689 | +-- takeWhile p = foldr (\ x xs -> if p x then x <| xs else empty) empty |

690 | + |

691 | +-- | /O(i)/ where /i/ is the breakpoint index. @'dropWhile' p xs@ returns the suffix remaining after @takeWhile p xs@. |

692 | +dropWhile :: (a -> Bool) -> Seq a -> Seq a |

693 | +dropWhile p xs = snd (span p xs) |

694 | + |

695 | +-- | /O(i)/ where /i/ is the breakpoint index. 'span', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@ and the second element is the remainder of the sequence. |

696 | +span :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

697 | +-- This doesn't make any more of a traversal than is necessary, exploiting the laziness of foldr and the structure preservation of mapAccumL. |

698 | +span p xs = splitAt (foldr (\ x z n -> n `seq` if p x then z (n+1) else n) (const (length xs)) xs 0) xs |

699 | + |

700 | +-- | /O(i)/ where /i/ is the breakpoint index. 'break', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that /do not satisfy/ @p@ and the second element is the remainder of the sequence. |

701 | +break :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

702 | +break p xs = span (not . p) xs |

703 | + |

704 | +-- | /O(n)/. The 'partition' function takes a predicate @p@ and a sequence @xs@ and returns sequences of those elements which do and do not satisfy the predicate. |

705 | +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

706 | +partition p = foldl partition' (empty, empty) where |

707 | + partition' (xs, ys) x |

708 | + | p x = (xs |> x, ys) |

709 | + | otherwise = (xs, ys |> x) |

710 | + |

711 | +-- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence @xs@ and returns a sequence of those elements which satisfy the predicate. |

712 | +filter :: (a -> Bool) -> Seq a -> Seq a |

713 | +filter p = foldl filter' empty where |

714 | + filter' ys x |

715 | + | p x = ys |> x |

716 | + | otherwise = ys |

717 | + |

718 | ------------------------------------------------------------------------ |

719 | -- Lists |

720 | ------------------------------------------------------------------------ |

721 | hunk ./Data/Sequence.hs 1504 |

722 | (reverseTree (reverseNode f) m) |

723 | (reverseDigit f pr) |

724 | |

725 | +{-# INLINE reverseDigit #-} |

726 | reverseDigit :: (a -> a) -> Digit a -> Digit a |

727 | reverseDigit f (One a) = One (f a) |

728 | reverseDigit f (Two a b) = Two (f b) (f a) |

729 | hunk ./Data/Sequence.hs 1515 |

730 | reverseNode f (Node2 s a b) = Node2 s (f b) (f a) |

731 | reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a) |

732 | |

733 | +------------------------------------------------------------------------ |

734 | +-- Zipping |

735 | +-- |

736 | +-- We implement zipping on sequences by zipping left and right digits simultaneously and |

737 | +-- processing excess appropriately. This allows several elements to be ``zipped'' |

738 | +-- in a single go, which is significantly faster than it might be for a linked-list approach, |

739 | +-- where we'd have to do at least one dereference for each element. |

740 | +------------------------------------------------------------------------ |

741 | + |

742 | +-- | /O(n)/. 'zip' takes two sequences and returns a sequence of corresponding pairs. |

743 | +-- If one input is short, excess elements of the longer sequence are discarded. |

744 | +zip :: Seq a -> Seq b -> Seq (a, b) |

745 | +zip = zipWith (,) |

746 | + |

747 | +-- | /O(n)/. 'zipWith' generalizes 'zip' by zipping with the function given as the first argument, |

748 | +-- instead of a tupling function. For example, @zipWith (+)@ is applied to two sequences to take |

749 | +-- the sequence of corresponding sums. |

750 | +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c |

751 | +zipWith f xs ys |

752 | + | length xs <= length ys = zipWith' f xs ys |

753 | + | otherwise = zipWith' (flip f) ys xs |

754 | + where zipWith' f xs ys = |

755 | + let zipper ys x = case viewl ys of |

756 | + EmptyL -> error "zipper should never encounter an empty second string" |

757 | + y :< ys -> (ys, f x y) |

758 | + in snd (mapAccumL zipper ys xs) |

759 | + |

760 | +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) |

761 | +zip3 = zipWith3 (,,) |

762 | + |

763 | +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d |

764 | +zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3 |

765 | + |

766 | +zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d) |

767 | +zip4 = zipWith4 (,,,) |

768 | + |

769 | +zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e |

770 | +zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4 |

771 | + |

772 | +------------------------------------------------------------------------ |

773 | +-- Sorting |

774 | +-- |

775 | +-- sort and sortBy are implemented by simple deforestations of |

776 | +-- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList |

777 | +-- which does not get deforested automatically, it would appear. |

778 | +-- |

779 | +-- Unstable sorting is performed by a heap sort implementation based on pairing heaps. Because the |

780 | +-- internal structure of sequences is quite varied, it is difficult to get blocks of elements of |

781 | +-- roughly the same length, which would improve merge sort performance. Pairing heaps, on the other |

782 | +-- hand, are relatively resistant to the effects of merging heaps of wildly different sizes, as |

783 | +-- guaranteed by its amortized constant-time merge operation. Moreover, extensive use of SpecConstr |

784 | +-- transformations can be done on pairing heaps, especially when we're only constructing them |

785 | +-- to immediately be unrolled. |

786 | +-- |

787 | +-- On purely random sequences of length 50000, with no RTS options, I get the following statistics, |

788 | +-- in which heapsort is about 42.5% faster: |

789 | +-- |

790 | +-- Times (ms) min mean +/-sd median max |

791 | +-- to/from list: 103.802 108.572 7.487 106.436 143.339 |

792 | +-- unstable heapsort: 60.686 62.968 4.275 61.187 79.151 |

793 | +-- |

794 | +-- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy. The gap is narrowed |

795 | +-- when more memory is available, but heapsort still wins, 15% faster, with +RTS -H128m: |

796 | +-- |

797 | +-- Times (ms) min mean +/-sd median max |

798 | +-- to/from list: 42.692 45.074 2.596 44.600 56.601 |

799 | +-- unstable heapsort: 37.100 38.344 3.043 37.715 55.526 |

800 | +-- |

801 | +-- In addition, on strictly increasing sequences the gap is even wider than normal; heapsort is |

802 | +-- 68.5% faster with no RTS options: |

803 | +-- Times (ms) min mean +/-sd median max |

804 | +-- to/from list: 52.236 53.574 1.987 53.034 62.098 |

805 | +-- unstable heapsort: 16.433 16.919 0.931 16.681 21.622 |

806 | +-- |

807 | +-- This may be attributed to the elegant nature of the pairing heap. |

808 | +-- |

809 | +-- wasserman.louis@gmail.com, 7/20/09 |

810 | +------------------------------------------------------------------------ |

811 | + |

812 | +-- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural ordering of its elements. The sort is stable. |

813 | +-- If a stable sort is not required, 'unstableSort' can be considerably faster, and in particular uses less memory. |

814 | +sort :: Ord a => Seq a -> Seq a |

815 | +sort = sortBy compare |

816 | + |

817 | +-- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the specified comparator. The sort is stable. |

818 | +-- If a stable sort is not required, 'unstableSortBy' can be considerably faster, and in particular uses less memory. |

819 | +sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a |

820 | +-- fromList . Data.List.sortBy cmp . toList doesn't actually deforest well, so I did so manually and got a moderate |

821 | +-- performance boost. |

822 | +sortBy cmp xs = case foldr (\ x -> ([x]:)) [] xs of |

823 | + [] -> empty |

824 | + ys:yss -> fromList2 (length xs) (merger0 ys yss) |

825 | + where xs@(x:xs1) <> ys@(y:ys1) = case cmp x y of |

826 | + GT -> y:(xs <> ys1) |

827 | + _ -> x:(xs1 <> ys) |

828 | + [] <> ys = ys |

829 | + xs <> [] = xs |

830 | + merger (xs1:xs2:xss) = (xs1 <> xs2) : merger xss |

831 | + merger xss = xss |

832 | + merger0 xs1 (xs2:xss) = merger0 (xs1 <> xs2) (merger xss) |

833 | + merger0 xs [] = xs |

834 | + |

835 | +-- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by the natural ordering of its elements, but the sort is not stable. |

836 | +-- This algorithm is frequently faster and uses less memory than 'sort', and performs extremely well -- frequently twice as fast as |

837 | +-- 'sort' -- when the sequence is already nearly sorted. |

838 | +unstableSort :: Ord a => Seq a -> Seq a |

839 | +unstableSort = unstableSortBy compare |

840 | + |

841 | +-- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy' takes an arbitrary comparator and sorts the specified sequence. |

842 | +-- The sort is not stable. This algorithm is frequently faster and uses less memory than 'sortBy', and performs extremely well -- |

843 | +-- frequently twice as fast as 'sortBy' -- when the sequence is already nearly sorted. |

844 | +unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a |

845 | +unstableSortBy cmp (Seq xs) = fromList2 (size xs) $ maybe [] (unrollPQ cmp) $ toPQ cmp (\ (Elem x) -> PQueue x Nil) xs |

846 | + |

847 | +fromList2 :: Int -> [a] -> Seq a |

848 | +-- fromList2, given a list and its length, constructs a completely balanced Seq whose elements are that list |

849 | +-- using the applicativeTree generalization. |

850 | +fromList2 n xs = Seq (execState (applicativeTree n 1 (State run)) xs) where |

851 | + run (x:xs) = (xs, Elem x) |

852 | + run _ = error "The flatly impossible has occurred" |

853 | + |

854 | +-- | A 'PQueue' is a simple pairing heap. |

855 | +data PQueue e = PQueue e (PQL e) |

856 | + |

857 | +data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e |

858 | + -- admittedly a glorified list of PQueues, but nevertheless encourages SpecConstr use |

859 | + |

860 | +infixr 8 :& |

861 | + |

862 | +#if TESTING |

863 | + |

864 | +instance Functor PQueue where |

865 | + fmap f (PQueue x ts) = PQueue (f x) (fmap f ts) |

866 | + |

867 | +instance Functor PQL where |

868 | + fmap f (q :& qs) = fmap f q :& fmap f qs |

869 | + fmap _ Nil = Nil |

870 | + |

871 | +instance Show e => Show (PQueue e) where |

872 | + show = unlines . draw . fmap show |

873 | + |

874 | +-- borrowed wholesale from Data.Tree, as Data.Tree actually depends on Data.Sequence |

875 | +draw :: PQueue String -> [String] |

876 | +draw (PQueue x ts0) = x : drawSubTrees ts0 |

877 | + where drawSubTrees Nil = [] |

878 | + drawSubTrees (t :& Nil) = |

879 | + "|" : shift "`- " " " (draw t) |

880 | + drawSubTrees (t :& ts) = |

881 | + "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts |

882 | + |

883 | + shift first other = Data.List.zipWith (++) (first : repeat other) |

884 | +#endif |

885 | + |

886 | +-- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into a sorted list. |

887 | +unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e] |

888 | +unrollPQ cmp = unrollPQ' where |

889 | + {-# INLINE unrollPQ' #-} |

890 | + unrollPQ' (PQueue x ts) = x:mergePQs0 ts |

891 | + (<>) = mergePQ cmp |

892 | + mergePQs0 Nil = [] |

893 | + mergePQs0 (t :& Nil) = unrollPQ' t |

894 | + mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts |

895 | + mergePQs t ts = t `seq` case ts of |

896 | + Nil -> unrollPQ' t |

897 | + t1 :& Nil -> unrollPQ' (t <> t1) |

898 | + t1 :& t2 :& ts -> mergePQs (t <> (t1 <> t2)) ts |

899 | + |

900 | +-- | 'toPQ', given an ordering function and a mechanism for queueifying elements, converts a 'FingerTree' to a 'PQueue'. |

901 | +toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e) |

902 | +toPQ _ _ Empty = Nothing |

903 | +toPQ _ f (Single x) = Just (f x) |

904 | +toPQ cmp f (Deep _ pr m sf) = Just $ case toPQ cmp fNode m of |

905 | + Nothing -> fDig pr <> fDig sf |

906 | + Just m' -> fDig pr <> m' <> fDig sf |

907 | + where (<>) = mergePQ cmp |

908 | + joinDig (<>) d = case d of One a -> a |

909 | + Two a b -> a <> b |

910 | + Three a b c -> a <> b <> c |

911 | + Four a b c d -> (a <> b) <> (c <> d) |

912 | + fNode = fDig . nodeToDigit |

913 | + {-# INLINE fDig #-} |

914 | + fDig = joinDig (<>) . fmap f |

915 | + |

916 | +-- | 'mergePQ' merges two 'PQueue's. |

917 | +mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a |

918 | +mergePQ cmp (PQueue x1 ts1) (PQueue x2 ts2) |

919 | + | cmp x1 x2 == GT = PQueue x2 (PQueue x1 ts1 :& ts2) |

920 | + | otherwise = PQueue x1 (PQueue x2 ts2 :& ts1) |

921 | + |

922 | #if TESTING |

923 | |

924 | ------------------------------------------------------------------------ |

925 | hunk ./Data/Sequence.hs 1712 |

926 | |

927 | instance Arbitrary a => Arbitrary (Seq a) where |

928 | arbitrary = liftM Seq arbitrary |

929 | - coarbitrary (Seq x) = coarbitrary x |

930 | + shrink (Seq x) = map Seq (shrink x) |

931 | |

932 | instance Arbitrary a => Arbitrary (Elem a) where |

933 | arbitrary = liftM Elem arbitrary |

934 | hunk ./Data/Sequence.hs 1716 |

935 | - coarbitrary (Elem x) = coarbitrary x |

936 | + shrink _ = [] |

937 | |

938 | instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where |

939 | arbitrary = sized arb |

940 | hunk ./Data/Sequence.hs 1725 |

941 | arb 1 = liftM Single arbitrary |

942 | arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary |

943 | |

944 | - coarbitrary Empty = variant 0 |

945 | - coarbitrary (Single x) = variant 1 . coarbitrary x |

946 | - coarbitrary (Deep _ pr m sf) = |

947 | - variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf |

948 | + shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b] |

949 | + shrink (Deep _ pr m sf) = [deep pr' m sf | pr' <- shrink pr] ++ [deep pr m' sf | m' <- shrink m] ++ [deep pr m sf' | sf' <- shrink sf] |

950 | + shrink (Single x) = map Single (shrink x) |

951 | + shrink Empty = [] |

952 | |

953 | instance (Arbitrary a, Sized a) => Arbitrary (Node a) where |

954 | arbitrary = oneof [ |

955 | hunk ./Data/Sequence.hs 1735 |

956 | liftM2 node2 arbitrary arbitrary, |

957 | liftM3 node3 arbitrary arbitrary arbitrary] |

958 | |

959 | - coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b |

960 | - coarbitrary (Node3 _ a b c) = |

961 | - variant 1 . coarbitrary a . coarbitrary b . coarbitrary c |

962 | + shrink (Node2 _ a b) = [node2 a' b | a' <- shrink a] ++ [node2 a b' | b' <- shrink b] |

963 | + shrink (Node3 _ a b c) = [node2 a b, node2 a c, node2 b c] ++ |

964 | + [node3 a' b c | a' <- shrink a] ++ [node3 a b' c | b' <- shrink b] ++ [node3 a b c' | c' <- shrink c] |

965 | |

966 | instance Arbitrary a => Arbitrary (Digit a) where |

967 | arbitrary = oneof [ |

968 | hunk ./Data/Sequence.hs 1745 |

969 | liftM2 Two arbitrary arbitrary, |

970 | liftM3 Three arbitrary arbitrary arbitrary, |

971 | liftM4 Four arbitrary arbitrary arbitrary arbitrary] |

972 | - |

973 | - coarbitrary (One a) = variant 0 . coarbitrary a |

974 | - coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b |

975 | - coarbitrary (Three a b c) = |

976 | - variant 2 . coarbitrary a . coarbitrary b . coarbitrary c |

977 | - coarbitrary (Four a b c d) = |

978 | - variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d |

979 | + |

980 | + shrink (One a) = map One (shrink a) |

981 | + shrink (Two a b) = [One a, One b] |

982 | + shrink (Three a b c) = [Two a b, Two a c, Two b c] |

983 | + shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d] |

984 | |

985 | ------------------------------------------------------------------------ |

986 | -- Valid trees |

987 | hunk ./containers.cabal 23 |

988 | location: http://darcs.haskell.org/packages/containers/ |

989 | |

990 | Library { |

991 | - build-depends: base, array |

992 | + build-depends: base >= 4.0.0.0, array |

993 | exposed-modules: |

994 | Data.Graph |

995 | Data.IntMap |

996 | } |

997 | |

998 | Context: |

999 | |

1000 | [Use left/right rather than old/new to describe the arguments to unionWithKey |

1001 | Ian Lynagh <igloo@earth.li>**20090208192132 |

1002 | Fixes trac #3002. |

1003 | ] |

1004 | [help nhc98 by making import decl more explicit |

1005 | Malcolm.Wallace@cs.york.ac.uk**20090203142144] |

1006 | [Add instance Data.Traversable for IntMap |

1007 | Matti Niemenmaa <matti.niemenmaa+darcs@iki.fi>**20090116190353 |

1008 | Ignore-this: df88a286935926aecec3f8a5dd291699 |

1009 | ] |

1010 | [Require Cabal version >= 1.6 |

1011 | Ian Lynagh <igloo@earth.li>**20090122011256] |

1012 | [Add "bug-reports" and "source-repository" info to the Cabal file |

1013 | Ian Lynagh <igloo@earth.li>**20090121182106] |

1014 | [Fix warnings in containers |

1015 | Ian Lynagh <igloo@earth.li>**20090116200251] |

1016 | [optimize IntMap/IntSet findMin/findMax |

1017 | sedillard@gmail.com**20081002152055] |

1018 | [O(n) fromAscList IntSet / IntMap |

1019 | sedillard@gmail.com**20080521195941 |

1020 | |

1021 | Added algorithm by Scott Dillard and Bertram Felgenhauer to build IntSets and |

1022 | IntMaps from sorted input in linear time. Also changed quickcheck prop_Ordered |

1023 | (no longer a tautology!) to include negative and duplicate keys. |

1024 | |

1025 | ] |

1026 | [correct type for IntMap.intersectionWith[Key] |

1027 | sedillard@gmail.com**20081002144828] |

1028 | [Export mapAccumRWithKey from Map and IntMap (Trac #2769) |

1029 | matti.niemenmaa+darcs@iki.fi**20081210160205] |

1030 | [Bump the version number to 0.2.0.1, to work-around cabal-install problems |

1031 | Ian Lynagh <igloo@earth.li>**20081212201829] |

1032 | [Fix #2760: change mkNorepType to mkNoRepType |

1033 | 'Jose Pedro Magalhaes <jpm@cs.uu.nl>'**20081202083424] |

1034 | [Doc fix, from hackage trac #378 |

1035 | Ian Lynagh <igloo@earth.li>**20081024143949] |

1036 | [import Data.Data instead of Data.Generics.*, eliminating the dependency on syb |

1037 | Ross Paterson <ross@soi.city.ac.uk>**20081005002559] |

1038 | [fixed typo in highestBitMask |

1039 | sedillard@gmail.com**20081002215438] |

1040 | [export Data.Map.toDescList, foldlWithKey, and foldrWithKey (trac ticket 2580) |

1041 | qdunkan@gmail.com**20080922213200 |

1042 | |

1043 | toDescList was previously implemented, but not exported. |

1044 | |

1045 | foldlWithKey was previously implemented, but not exported. It can be used to |

1046 | implement toDescList. |

1047 | |

1048 | foldrWithKey is already exported as foldWithKey, but foldrWithKey is explicitly |

1049 | the mirror of foldlWithKey, and foldWithKey kept for compatibility. |

1050 | ] |

1051 | [Bump version number to 0.2.0.0 |

1052 | Ian Lynagh <igloo@earth.li>**20080920160016] |

1053 | [TAG 6.10 branch has been forked |

1054 | Ian Lynagh <igloo@earth.li>**20080919123438] |

1055 | [Fixed typo in updateMinWithKey / updateMaxWithKey |

1056 | sedillard@gmail.com**20080704054350] |

1057 | [follow library changes |

1058 | Ian Lynagh <igloo@earth.li>**20080903223610] |

1059 | [add include/Typeable.h to extra-source-files |

1060 | Ross Paterson <ross@soi.city.ac.uk>**20080831181402] |

1061 | [fix cabal build-depends for nhc98 |

1062 | Malcolm.Wallace@cs.york.ac.uk**20080828104248] |

1063 | [Add a dep on syb |

1064 | Ian Lynagh <igloo@earth.li>**20080825214314] |

1065 | [add category field |

1066 | Ross Paterson <ross@soi.city.ac.uk>**20080824003013] |

1067 | [we depend on st, now split off from base |

1068 | Ian Lynagh <igloo@earth.li>**20080823223053] |

1069 | [specialize functions that fail in a Monad to Maybe (proposal #2309) |

1070 | Ross Paterson <ross@soi.city.ac.uk>**20080722154812 |

1071 | |

1072 | Specialize functions signatures like |

1073 | |

1074 | lookup :: (Monad m, Ord k) => k -> Map k a -> m a |

1075 | to |

1076 | lookup :: (Ord k) => k -> Map k a -> Maybe a |

1077 | |

1078 | for simplicity and safety. No information is lost, as each of these |

1079 | functions had only one use of fail, which is now changed to Nothing. |

1080 | ] |

1081 | [tighter description of split (addresses #2447) |

1082 | Ross Paterson <ross@soi.city.ac.uk>**20080717064838] |

1083 | [Make warning-clean with GHC again |

1084 | Ian Lynagh <igloo@earth.li>**20080623232023 |

1085 | With any luck we have now converged on a solution that works everywhere! |

1086 | ] |

1087 | [Undo more Data.Typeable-related breakage for non-ghc. |

1088 | Malcolm.Wallace@cs.york.ac.uk**20080623092757] |

1089 | [Placate GHC with explicit import lists |

1090 | Ian Lynagh <igloo@earth.li>**20080620183926] |

1091 | [undo breakage caused by -Wall cleaning |

1092 | Malcolm.Wallace@cs.york.ac.uk**20080620093922 |

1093 | The import of Data.Typeable is still required, at least for non-GHC. |

1094 | ] |

1095 | [Make the package -Wall clean |

1096 | Ian Lynagh <igloo@earth.li>**20080618233627] |

1097 | [List particular extensions rather than -fglasgow-exts |

1098 | Ian Lynagh <igloo@earth.li>**20080616232035] |

1099 | [Avoid using deprecated flags |

1100 | Ian Lynagh <igloo@earth.li>**20080616145241] |

1101 | [TAG 2008-05-28 |

1102 | Ian Lynagh <igloo@earth.li>**20080528004309] |

1103 | Patch bundle hash: |

1104 | 8bcc287dd979f25c06fa0d7923b2a9685db488c5 |