├── Array ├── Cumulative.hs └── Syakutori.hs ├── Class.hs ├── Function.hs ├── Graph.hs ├── Graph ├── BFS.hs ├── BellmanFord.hs ├── DFS.hs ├── Dijkstra.hs ├── Kruskal.hs └── WarshallFloyd.hs ├── Heap ├── BinomialHeap.hs ├── BootstrapHeap.hs ├── LazyPairingHeap.hs ├── LeftistHeap.hs ├── PairingHeap.hs ├── SkewBinomialHeap.hs └── SplayHeap.hs ├── LICENSE ├── List ├── Inversion.hs └── LIS.hs ├── Math ├── Mod.hs └── Prime.hs ├── README.md ├── Scanner.hs ├── Tree ├── SegmentTree.hs └── UnionFind.hs └── WeightedGraph.hs /Array/Cumulative.hs: -------------------------------------------------------------------------------- 1 | module Array.Cumulative where 2 | 3 | import Data.List 4 | import qualified Data.Array.Base as A 5 | 6 | type Height = Int 7 | type Width = Int 8 | type Coord = (Height, Width) 9 | type Index = Int 10 | 11 | -- 1-indexed 12 | data IMatrix = M { 13 | _height :: Int, 14 | _width :: Int, 15 | _matrix :: A.UArray Index Int 16 | } deriving (Eq, Show) 17 | 18 | (!) :: IMatrix -> Coord -> Int 19 | (!) m c = A.unsafeAt (_matrix m) (idx (_width m) c - 1) 20 | 21 | idx :: Width -> Coord -> Index 22 | idx w (x, y) = (x - 1) * w + y 23 | 24 | fromList :: Height -> Width -> [[Int]] -> IMatrix 25 | fromList h w = M h w . A.listArray (1, h * w) . concat 26 | 27 | fromListAccum :: Height -> Width -> [[Int]] -> IMatrix 28 | fromListAccum h w = fromList h w . csum2 29 | 30 | csum1 :: Num a => [a] -> [a] 31 | csum1 = scanl1 (+) 32 | 33 | csum2 :: Num a => [[a]] -> [[a]] 34 | csum2 = transpose . map csum1 . transpose . map csum1 35 | 36 | rsum :: IMatrix -> Coord -> Coord -> Int 37 | rsum m (x1,y1) c2@(x2,y2) = a1 - a2 - a3 + a4 38 | where 39 | a1 = m ! c2 40 | a2 = if x1 == 1 then 0 else m ! (x1 - 1, y2) 41 | a3 = if y1 == 1 then 0 else m ! (x2, y1 - 1) 42 | a4 = if x1 == 1 || y1 == 1 then 0 else m ! (x1 - 1, y1 - 1) 43 | -------------------------------------------------------------------------------- /Array/Syakutori.hs: -------------------------------------------------------------------------------- 1 | module Array.Syakutori ( 2 | buildA, 3 | nsum 4 | ) where 5 | 6 | import Data.Array.Unboxed 7 | 8 | type Index = Int 9 | 10 | -- 1-indexed 11 | buildA :: IArray a e => [e] -> a Index e 12 | buildA xs = listArray (1, length xs) xs 13 | 14 | nsum :: (Num e, Ord e, IArray a e) => e -> a Index e -> Int 15 | nsum x arr = go 1 1 (arr ! 1) 16 | where 17 | (_, l) = bounds arr 18 | go i j acc 19 | | i == l && j == l = if acc == x then 1 else 0 20 | | i == j = (if acc == x then 1 else 0) + go i (j + 1) (acc + arr ! (j + 1)) 21 | | j == l = (if acc == x then 1 else 0) + go (i + 1) j (acc - arr ! i) 22 | | acc == x = 1 + go i (j + 1) (acc + arr ! (j + 1)) 23 | | acc < x = go i (j + 1) (acc + arr ! (j + 1)) 24 | | acc > x = go (i + 1) j (acc - arr ! i) 25 | | otherwise = error "nsum: Pattern match failed." 26 | -------------------------------------------------------------------------------- /Class.hs: -------------------------------------------------------------------------------- 1 | module Class where 2 | 3 | -- Chris Okasaki: Purely Functional Data Structure 4 | class Heap h where 5 | empty :: Ord a => h a 6 | isEmpty :: Ord a => h a -> Bool 7 | 8 | singleton :: Ord a => a -> h a 9 | fromList :: Ord a => [a] -> h a 10 | 11 | insert :: Ord a => a -> h a -> h a 12 | merge :: Ord a => h a -> h a -> h a 13 | 14 | findMin :: Ord a => h a -> a 15 | deleteMin :: Ord a => h a -> h a 16 | deleteFindMin :: Ord a => h a -> (a, h a) 17 | -------------------------------------------------------------------------------- /Function.hs: -------------------------------------------------------------------------------- 1 | module Function where 2 | 3 | import Data.List 4 | 5 | untilFix :: Eq t => (t -> t) -> t -> t 6 | untilFix f x = let x1 = f x in if x1 == x then x else untilFix f x1 7 | 8 | apply :: Int -> (a -> a) -> a -> a 9 | apply n f x = foldr ($) x (replicate n f) 10 | 11 | comb :: Integral a => a -> a -> a 12 | comb n r = div (fact n) (fact r * fact (n - r)) 13 | where 14 | fact x = product [1 .. x] 15 | 16 | chunksOf :: Int -> [a] -> [[a]] 17 | chunksOf n = takeWhile (not . null) . unfoldr (return . splitAt n) 18 | 19 | combList :: Int -> [a] -> [[a]] 20 | combList n xs = go n xs [] [] 21 | where 22 | go 0 _ ys zs = reverse ys : zs 23 | go _ [] _ zs = zs 24 | go m (w:ws) ys zs = go (m - 1) ws (w : ys) (go m ws ys zs) 25 | 26 | divides :: [a] -> [[[a]]] 27 | divides [] = [] 28 | divides [x] = [[[x]]] 29 | divides (x:xs) = let dxs = divides xs in map ([x] :) dxs ++ map (\(ys:yss) -> (x:ys):yss) dxs 30 | -------------------------------------------------------------------------------- /Graph.hs: -------------------------------------------------------------------------------- 1 | module Graph where 2 | 3 | import qualified Data.ByteString.Char8 as B 4 | import qualified Data.IntSet as S 5 | import qualified Data.Array.IArray as A 6 | 7 | import Scanner 8 | 9 | --type Height = Int 10 | type Width = Int 11 | type Index = Int 12 | type Bound = (Vertex, Vertex) 13 | 14 | type Vertex = Int 15 | type Vertexes = S.IntSet 16 | type Edge = (Vertex, Vertex) 17 | type Graph = A.Array Vertex Vertexes 18 | 19 | buildG :: Bound -> [Edge] -> Graph 20 | buildG = A.accumArray (flip S.insert) S.empty 21 | 22 | target :: Graph -> Vertex -> Vertexes 23 | target = (A.!) 24 | 25 | size :: Graph -> Int 26 | size g = let (i, j) = A.bounds g in j - i + 1 27 | 28 | readDirectedEdge :: B.ByteString -> [Edge] 29 | readDirectedEdge = map (constructOneWay . map readInt . B.words) . B.lines 30 | 31 | constructOneWay :: [Int] -> Edge 32 | constructOneWay [s, t] = (s, t) 33 | constructOneWay _ = undefined 34 | 35 | readUndirectedEdge :: B.ByteString -> [Edge] 36 | readUndirectedEdge = concatMap (constructTwoWay . map readInt . B.words) . B.lines 37 | 38 | constructTwoWay :: [Int] -> [Edge] 39 | constructTwoWay [s, t] = [(s, t), (t, s)] 40 | constructTwoWay _ = undefined 41 | 42 | readBitmap :: Width -> B.ByteString -> [Edge] 43 | readBitmap w bs = foldr (scout w bs) [] [1 .. B.length bs] 44 | 45 | scout :: Width -> B.ByteString -> Index -> [Edge] -> [Edge] 46 | scout w bs i acc = zip (repeat i) neighbor ++ acc 47 | where 48 | neighbor = filter (\x -> inner x && movable x) [i - 1, i + 1, i - w, i + w] 49 | inner x = 1 <= x && x <= B.length bs 50 | movable x = B.index bs (x - 1) `elem` ".sg" 51 | -------------------------------------------------------------------------------- /Graph/BFS.hs: -------------------------------------------------------------------------------- 1 | module Graph.BFS ( 2 | bfs, 3 | reachable 4 | ) where 5 | 6 | import Graph 7 | 8 | import qualified Data.IntSet as S 9 | 10 | bfs :: Graph -> Vertex -> Vertexes 11 | bfs g v = go (S.singleton v) (S.singleton v) 12 | where 13 | go acc border 14 | | S.null border = acc 15 | | otherwise = go (S.union acc next) next 16 | where 17 | next = S.difference (transMap g border) acc 18 | 19 | transMap :: Graph -> Vertexes -> Vertexes 20 | transMap g = S.unions . map (target g) . S.elems 21 | 22 | reachable :: Graph -> Vertex -> Vertex -> Bool 23 | reachable g v w = S.member w (bfs g v) 24 | -------------------------------------------------------------------------------- /Graph/BellmanFord.hs: -------------------------------------------------------------------------------- 1 | module Graph.BellmanFord ( 2 | bellmanFord 3 | ) where 4 | 5 | import WeightedGraph 6 | 7 | import qualified Data.Set as S 8 | import qualified Data.IntMap.Strict as M 9 | 10 | type Memo = M.IntMap Weight 11 | 12 | bellmanFord :: Graph -> Vertex -> Memo 13 | bellmanFord g s = _bellmanFord g n m0 14 | where 15 | n = size g 16 | m0 = M.singleton s 0 17 | 18 | _bellmanFord :: Graph -> Int -> Memo -> Memo 19 | _bellmanFord g n m 20 | | n == 0 = m 21 | | otherwise = _bellmanFord g (pred n) (M.foldrWithKey (move g) m m) 22 | 23 | move :: Graph -> Vertex -> Weight -> Memo -> Memo 24 | move g s aw m = S.foldr update m (target g s) 25 | where 26 | update (t, w) acc 27 | | M.notMember t acc || acc M.! t < aw + w = M.insert t (aw + w) acc 28 | | otherwise = acc 29 | -------------------------------------------------------------------------------- /Graph/DFS.hs: -------------------------------------------------------------------------------- 1 | -- This implementation has room for consideration 2 | -- In many cases BFS is faster 3 | 4 | module Graph.DFS ( 5 | dfs 6 | ) where 7 | 8 | import Graph 9 | 10 | import qualified Data.IntSet as S 11 | 12 | -- modify according to your purpose 13 | type Acc = Bool 14 |   15 | dfs :: Graph -> (Vertex -> Acc -> Acc) -> Acc -> Vertex -> Acc 16 | dfs g f acc v = fst $ _dfs g f v (acc, visited) 17 | where 18 | visited = S.singleton v 19 |   20 | _dfs :: Graph -> (Vertex -> Acc -> Acc) -> Vertex -> (Acc, Vertexes) -> (Acc, Vertexes) 21 | _dfs g f v (acc, visited) 22 | | S.null next = (acc, visited) 23 | | otherwise = S.foldr (branch g f) (acc, visited) next 24 | where 25 | next = S.difference (target g v) visited 26 |   27 | branch :: Graph -> (Vertex -> Acc -> Acc) -> Vertex -> (Acc, Vertexes) -> (Acc, Vertexes) 28 | branch g f w (aa,avd) = _dfs g f w (f w aa, S.insert w avd) 29 | -------------------------------------------------------------------------------- /Graph/Dijkstra.hs: -------------------------------------------------------------------------------- 1 | module Graph.Dijkstra ( 2 | dijkstra 3 | ) where 4 | 5 | import WeightedGraph 6 | 7 | import qualified Data.Set as S 8 | import qualified Data.IntMap.Strict as M 9 | 10 | type Memo = M.IntMap Weight 11 | 12 | dijkstra :: Graph -> Vertex -> Memo 13 | dijkstra g s = _dijkstra g q0 m0 14 | where 15 | q0 = singleton (0, s) 16 | m0 = M.singleton s 0 17 | 18 | _dijkstra :: Graph -> PriorityQueue -> Memo -> Memo 19 | _dijkstra g q m 20 | | isEmpty q = m 21 | | otherwise = _dijkstra g q2 m1 22 | where 23 | ((w0, s), q1) = deleteFindMin q 24 | m1 = S.foldr (\(t, w) acc -> M.insertWith min t (w0 + w) acc) m vns 25 | q2 = S.foldr (\(t, w) acc -> insert (w0 + w, t) acc) q1 vns 26 | vns = S.filter (\(t, w) -> M.notMember t m || w0 + w <= m M.! t) (target g s) 27 | 28 | type PriorityQueue = S.Set (Weight, Vertex) 29 | 30 | isEmpty :: PriorityQueue -> Bool 31 | isEmpty = S.null 32 | 33 | singleton :: (Weight, Vertex) -> PriorityQueue 34 | singleton = S.singleton 35 | 36 | insert :: (Weight, Vertex) -> PriorityQueue -> PriorityQueue 37 | insert = S.insert 38 | 39 | deleteFindMin :: PriorityQueue -> ((Weight, Vertex), PriorityQueue) 40 | deleteFindMin = S.deleteFindMin 41 | -------------------------------------------------------------------------------- /Graph/Kruskal.hs: -------------------------------------------------------------------------------- 1 | module Graph.Kruskal ( 2 | kruskal 3 | ) where 4 | 5 | import Data.List 6 | 7 | import WeightedGraph 8 | import Tree.UnionFind 9 | 10 | kruskal :: [Edge] -> Int 11 | kruskal = fst . _kruskal initial 0 . sortOn snd 12 | 13 | _kruskal :: UnionFind -> Int -> [Edge] -> (Int, UnionFind) 14 | _kruskal uf acc [] = (acc, uf) 15 | _kruskal uf acc (((a,b),d):abd) 16 | | same uf a b = _kruskal uf acc abd 17 | | otherwise = _kruskal (merge uf a b) (acc + d) abd 18 | -------------------------------------------------------------------------------- /Graph/WarshallFloyd.hs: -------------------------------------------------------------------------------- 1 | module Graph.WarshallFloyd ( 2 | warshallFloyd 3 | ) where 4 | 5 | import qualified Data.Map.Strict as M 6 | 7 | import WeightedGraph 8 | 9 | type Memo = M.Map (Vertex, Vertex) Weight 10 | 11 | -- 0-indexed vertex 12 | warshallFloyd :: Int -> [Edge] -> Memo 13 | warshallFloyd n es = foldl shorten m0 kij 14 | where 15 | m0 = M.fromList es 16 | kij = [(k, i, j) | k <- [0 .. pred n], i <- [0 .. pred n], j <- [0 .. pred n]] 17 | 18 | shorten :: Memo -> (Vertex, Vertex, Vertex) -> Memo 19 | shorten m (k, i, j) = case connect m k i j of 20 | Nothing -> m 21 | Just w -> M.insertWith min (i, j) w m 22 | 23 | connect :: Memo -> Vertex -> Vertex -> Vertex -> Maybe Weight 24 | connect m k i j = do 25 | w1 <- M.lookup (i, k) m 26 | w2 <- M.lookup (k, j) m 27 | return (w1 + w2) 28 | -------------------------------------------------------------------------------- /Heap/BinomialHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.BinomialHeap ( 4 | BinomialHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data Tree a = Node Int a [Tree a] 19 | newtype BinomialHeap a = BH [Tree a] 20 | 21 | rank :: Tree a -> Int 22 | rank (Node r _ _) = r 23 | 24 | root :: Tree a -> a 25 | root (Node _ x _) = x 26 | 27 | link :: Ord a => Tree a -> Tree a -> Tree a 28 | link t1@(Node r x1 c1) t2@(Node _ x2 c2) 29 | | x1 <= x2 = Node (r + 1) x1 (t2 : c1) 30 | | otherwise = Node (r + 1) x2 (t1 : c2) 31 | 32 | insTree :: Ord a => Tree a -> [Tree a] -> [Tree a] 33 | insTree t [] = [t] 34 | insTree t ts@(t' : ts') 35 | | rank t < rank t' = t : ts 36 | | otherwise = insTree (link t t') ts' 37 | 38 | mrg :: Ord a => [Tree a] -> [Tree a] -> [Tree a] 39 | mrg ts1 [] = ts1 40 | mrg [] ts2 = ts2 41 | mrg ts1@(t1 : ts1') ts2@(t2 : ts2') 42 | | rank t1 < rank t2 = t1 : mrg ts1' ts2 43 | | rank t2 < rank t1 = t2 : mrg ts1 ts2' 44 | | otherwise = insTree (link t1 t2) (mrg ts1' ts2') 45 | 46 | removeMinTree :: Ord a => [Tree a] -> (Tree a, [Tree a]) 47 | removeMinTree [] = error "empty heap" 48 | removeMinTree [t] = (t, []) 49 | removeMinTree (t : ts) 50 | | root t < root t' = (t, ts) 51 | | otherwise = (t', t : ts') 52 | where 53 | (t', ts') = removeMinTree ts 54 | 55 | instance Heap BinomialHeap where 56 | empty = BH [] 57 | isEmpty (BH ts) = null ts 58 | 59 | singleton x = insert x empty 60 | fromList = foldr insert empty 61 | 62 | insert x (BH ts) = BH (insTree (Node 0 x []) ts) 63 | merge (BH ts1) (BH ts2) = BH (mrg ts1 ts2) 64 | 65 | findMin (BH ts) = root t 66 | where 67 | (t, _) = removeMinTree ts 68 | 69 | deleteMin (BH ts) = BH (mrg (reverse ts1) ts2) 70 | where 71 | (Node _ _ ts1, ts2) = removeMinTree ts 72 | 73 | deleteFindMin (BH ts) = (root t, BH (mrg (reverse ts1) ts2)) 74 | where 75 | (t@(Node _ _ ts1), ts2) = removeMinTree ts 76 | -------------------------------------------------------------------------------- /Heap/BootstrapHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.BootstrapHeap ( 4 | BootstrapHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data BootstrapHeap h a = E | H a (h (BootstrapHeap h a)) 19 | 20 | instance Eq a => Eq (BootstrapHeap h a) where 21 | H x _ == H y _ = x == y 22 | _ == _ = undefined 23 | 24 | instance Ord a => Ord (BootstrapHeap h a) where 25 | H x _ <= H y _ = x <= y 26 | _ <= _ = undefined 27 | 28 | instance Heap h => Heap (BootstrapHeap h) where 29 | empty = E 30 | 31 | isEmpty E = True 32 | isEmpty _ = False 33 | 34 | singleton x = insert x empty 35 | fromList = foldr insert empty 36 | 37 | insert x = merge (H x empty) 38 | 39 | merge E h = h 40 | merge h E = h 41 | merge h1@(H x p1) h2@(H y p2) 42 | | x <= y = H x (insert h2 p1) 43 | | otherwise = H y (insert h1 p2) 44 | 45 | findMin E = error "empty heap" 46 | findMin (H x _) = x 47 | 48 | deleteMin E = error "empty heap" 49 | deleteMin (H _ p) 50 | | isEmpty p = E 51 | | otherwise = H y (merge p1 p2) 52 | where 53 | H y p1 = findMin p 54 | p2 = deleteMin p 55 | 56 | deleteFindMin E = error "empty heap" 57 | deleteFindMin (H x p) 58 | | isEmpty p = (x, E) 59 | | otherwise = (x, H y (merge p1 p2)) 60 | where 61 | H y p1 = findMin p 62 | p2 = deleteMin p 63 | -------------------------------------------------------------------------------- /Heap/LazyPairingHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.LazyPairingHeap ( 4 | PairingHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data PairingHeap a = E | T a (PairingHeap a) (PairingHeap a) 19 | 20 | link :: Ord a => PairingHeap a -> PairingHeap a -> PairingHeap a 21 | link E _ = undefined 22 | link (T x E m) a = T x a m 23 | link (T x b m) a = T x E (merge (merge a b) m) 24 | 25 | instance Heap PairingHeap where 26 | empty = E 27 | 28 | isEmpty E = True 29 | isEmpty _ = False 30 | 31 | singleton x = insert x empty 32 | fromList = foldr insert empty 33 | 34 | insert x = merge (T x E E) 35 | 36 | merge a E = a 37 | merge E b = b 38 | merge a@(T x _ _) b@(T y _ _) 39 | | x <= y = link a b 40 | | otherwise = link b a 41 | 42 | findMin E = error "empty heap" 43 | findMin (T x _ _) = x 44 | 45 | deleteMin E = error "empty heap" 46 | deleteMin (T _ a m) = merge a m 47 | 48 | deleteFindMin E = error "empty heap" 49 | deleteFindMin (T x a m) = (x, merge a m) 50 | -------------------------------------------------------------------------------- /Heap/LeftistHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.LeftistHeap ( 4 | LeftistHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data LeftistHeap a = E | T Int a (LeftistHeap a) (LeftistHeap a) 19 | 20 | rank :: LeftistHeap a -> Int 21 | rank E = 0 22 | rank (T r _ _ _) = r 23 | 24 | makeT :: a -> LeftistHeap a -> LeftistHeap a -> LeftistHeap a 25 | makeT x a b 26 | | rank a >= rank b = T (rank b + 1) x a b 27 | | otherwise = T (rank a + 1) x b a 28 | 29 | instance Heap LeftistHeap where 30 | empty = E 31 | 32 | isEmpty E = True 33 | isEmpty _ = False 34 | 35 | singleton x = insert x empty 36 | fromList = foldr insert empty 37 | 38 | insert x = merge (T 1 x E E) 39 | 40 | merge h E = h 41 | merge E h = h 42 | merge h1@(T _ x a1 b1) h2@(T _ y a2 b2) 43 | | x <= y = makeT x a1 (merge b1 h2) 44 | | otherwise = makeT y a2 (merge h1 b2) 45 | 46 | findMin E = error "empty heap" 47 | findMin (T _ x _ _) = x 48 | 49 | deleteMin E = error "empty heap" 50 | deleteMin (T _ _ a b) = merge a b 51 | 52 | deleteFindMin E = error "empty heap" 53 | deleteFindMin (T _ x a b) = (x, merge a b) 54 | -------------------------------------------------------------------------------- /Heap/PairingHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.PairingHeap ( 4 | PairingHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data PairingHeap a = E | T a [PairingHeap a] 19 | 20 | mergePairs :: Ord a => [PairingHeap a] -> PairingHeap a 21 | mergePairs [] = E 22 | mergePairs [h] = h 23 | mergePairs (h1 : h2 : hs) = merge (merge h1 h2) (mergePairs hs) 24 | 25 | instance Heap PairingHeap where 26 | empty = E 27 | 28 | isEmpty E = True 29 | isEmpty _ = False 30 | 31 | singleton x = insert x empty 32 | fromList = foldr insert empty 33 | 34 | insert x = merge (T x []) 35 | 36 | merge h E = h 37 | merge E h = h 38 | merge h1@(T x hs1) h2@(T y hs2) 39 | | x < y = T x (h2 : hs1) 40 | | otherwise = T y (h1 : hs2) 41 | 42 | findMin E = error "empty heap" 43 | findMin (T x _) = x 44 | 45 | deleteMin E = error "empty heap" 46 | deleteMin (T _ hs) = mergePairs hs 47 | 48 | deleteFindMin E = error "empty heap" 49 | deleteFindMin (T x hs) = (x, mergePairs hs) 50 | -------------------------------------------------------------------------------- /Heap/SkewBinomialHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.SkewBinomialHeap ( 4 | SkewBinomialHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data Tree a = Node Int a [a] [Tree a] 19 | 20 | newtype SkewBinomialHeap a = SBH [Tree a] 21 | 22 | rank :: Tree a -> Int 23 | rank (Node r _ _ _) = r 24 | 25 | root :: Tree a -> a 26 | root (Node _ x _ _) = x 27 | 28 | link :: Ord a => Tree a -> Tree a -> Tree a 29 | link t1@(Node r x1 xs1 c1) t2@(Node _ x2 xs2 c2) 30 | | x1 <= x2 = Node (r + 1) x1 xs1 (t2 : c1) 31 | | otherwise = Node (r + 1) x2 xs2 (t1 : c2) 32 | 33 | skewLink :: Ord a => a -> Tree a -> Tree a -> Tree a 34 | skewLink x t1 t2 35 | | x <= y = Node r x (y : ys) c 36 | | otherwise = Node r y (x : ys) c 37 | where 38 | Node r y ys c = link t1 t2 39 | 40 | insTree :: Ord a => Tree a -> [Tree a] -> [Tree a] 41 | insTree t [] = [t] 42 | insTree t ts@(t' : ts') 43 | | rank t < rank t' = t : ts 44 | | otherwise = insTree (link t t') ts' 45 | 46 | mrg :: Ord a => [Tree a] -> [Tree a] -> [Tree a] 47 | mrg ts1 [] = ts1 48 | mrg [] ts2 = ts2 49 | mrg ts1@(t1 : ts1') ts2@(t2 : ts2') 50 | | rank t1 < rank t2 = t1 : mrg ts1' ts2 51 | | rank t2 < rank t1 = t2 : mrg ts1 ts2' 52 | | otherwise = insTree (link t1 t2) (mrg ts1' ts2') 53 | 54 | normalize :: Ord a => [Tree a] -> [Tree a] 55 | normalize [] = [] 56 | normalize (t : ts) = insTree t ts 57 | 58 | removeMinTree :: Ord a => [Tree a] -> (Tree a, [Tree a]) 59 | removeMinTree [] = error "empty heap" 60 | removeMinTree [t] = (t, []) 61 | removeMinTree (t : ts) 62 | | root t < root t' = (t, ts) 63 | | otherwise = (t', t : ts') 64 | where 65 | (t', ts') = removeMinTree ts 66 | 67 | instance Heap SkewBinomialHeap where 68 | empty = SBH [] 69 | isEmpty (SBH ts) = null ts 70 | 71 | singleton x = insert x empty 72 | fromList = foldr insert empty 73 | 74 | insert x (SBH (t1 : t2 : ts)) 75 | | rank t1 == rank t2 = SBH (skewLink x t1 t2 : ts) 76 | insert x (SBH ts) = SBH (Node 0 x [] [] : ts) 77 | 78 | merge (SBH ts1) (SBH ts2) = SBH (mrg (normalize ts1) (normalize ts2)) 79 | 80 | findMin (SBH ts) = root t 81 | where 82 | (t, _) = removeMinTree ts 83 | 84 | deleteMin (SBH ts) = foldr insert (SBH ts') xs 85 | where 86 | (Node _ _ xs ts1, ts2) = removeMinTree ts 87 | ts' = mrg (reverse ts1) (normalize ts2) 88 | 89 | deleteFindMin (SBH ts) = (root t, foldr insert (SBH ts') xs) 90 | where 91 | (t, _) = removeMinTree ts 92 | (Node _ _ xs ts1, ts2) = removeMinTree ts 93 | ts' = mrg (reverse ts1) (normalize ts2) 94 | -------------------------------------------------------------------------------- /Heap/SplayHeap.hs: -------------------------------------------------------------------------------- 1 | -- Chris Okasaki: Purely Functional Data Structure 2 | 3 | module Heap.SplayHeap ( 4 | SplayHeap, 5 | empty, 6 | isEmpty, 7 | singleton, 8 | fromList, 9 | insert, 10 | merge, 11 | findMin, 12 | deleteMin, 13 | deleteFindMin 14 | ) where 15 | 16 | import Class 17 | 18 | data SplayHeap a = E | T (SplayHeap a) a (SplayHeap a) 19 | 20 | partition :: Ord a => a -> SplayHeap a -> (SplayHeap a, SplayHeap a) 21 | partition _ E = (E, E) 22 | partition pivot t@(T a x b) 23 | | x <= pivot = case b of 24 | E -> (t, E) 25 | T b1 y b2 26 | | y <= pivot -> let (small,big) = partition pivot b2 in (T (T a x b) y small, big) 27 | | otherwise -> let (small,big) = partition pivot b1 in (T a x small, T big y b2) 28 | | otherwise = case a of 29 | E -> (E, t) 30 | T a1 y a2 31 | | y <= pivot -> let (small,big) = partition pivot a2 in (T a1 y small, T big x b) 32 | | otherwise -> let (small,big) = partition pivot a1 in (small, T big y (T a2 x b)) 33 | 34 | instance Heap SplayHeap where 35 | empty = E 36 | 37 | isEmpty E = True 38 | isEmpty _ = False 39 | 40 | singleton x = insert x empty 41 | fromList = foldr insert empty 42 | 43 | insert x t = T a x b 44 | where 45 | (a, b) = partition x t 46 | 47 | merge E t = t 48 | merge (T a x b) t = T (merge ta a) x (merge tb b) 49 | where 50 | (ta, tb) = partition x t 51 | 52 | findMin E = error "empty heap" 53 | findMin (T E x _) = x 54 | findMin (T a _ _) = findMin a 55 | 56 | deleteMin E = error "empty heap" 57 | deleteMin (T E _ b) = b 58 | deleteMin (T (T E _ b) y c) = T b y c 59 | deleteMin (T (T a x b) y c) = T (deleteMin a) x (T b y c) 60 | 61 | deleteFindMin E = error "empty heap" 62 | deleteFindMin (T E x b) = (x, b) 63 | deleteFindMin (T t@(T E _ b) y c) = (findMin t, T b y c) 64 | deleteFindMin (T t@(T a x b) y c) = (findMin t, T (deleteMin a) x (T b y c)) 65 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /List/Inversion.hs: -------------------------------------------------------------------------------- 1 | module List.Inversion where 2 | 3 | import Tree.SegmentTree 4 | 5 | inversion :: Size -> [Int] -> Int 6 | inversion n = fst . foldl go (0, seg0) . zip [0 .. pred n] 7 | where 8 | seg0 = fromList n (replicate n mempty) 9 | go (acc, seg) (j, a) = (acc + (j - query n seg 1 a), update n seg a succ) 10 | -------------------------------------------------------------------------------- /List/LIS.hs: -------------------------------------------------------------------------------- 1 | module List.LIS where 2 | 3 | import qualified Data.Set as S 4 | 5 | lis :: Ord a => [a] -> [a] 6 | lis = S.toList . snd . foldl go (S.empty, S.empty) 7 | where 8 | go (acc, acc0) x = case S.lookupGT x acc of 9 | Nothing -> let acc1 = S.insert x acc in (acc1, acc1) 10 | Just g -> (S.insert x (S.delete g acc), acc0) 11 | -------------------------------------------------------------------------------- /Math/Mod.hs: -------------------------------------------------------------------------------- 1 | module Math.Mod where 2 | 3 | import qualified Data.Array.IArray as A 4 | 5 | modulus :: Integer 6 | modulus = 1000000007 7 | 8 | (+%) :: Integer -> Integer -> Integer 9 | (+%) x y = mod (x + y) modulus 10 | 11 | (*%) :: Integer -> Integer -> Integer 12 | (*%) x y = mod (x * y) modulus 13 | 14 | powMod :: Integer -> Integer -> Integer 15 | powMod x n 16 | | n == 0 = 1 17 | | odd n = x *% powMod x (n-1) 18 | | otherwise = let y = powMod x (div n 2) in y *% y 19 | 20 | combMod :: FactTable -> Integer -> Integer -> Integer 21 | combMod t n r 22 | | n < r = 0 23 | | otherwise = fst (t ! n) *% snd (t ! r) *% snd (t ! (n - r)) 24 | where 25 | (!) arr i = arr A.! fromIntegral i 26 | 27 | type FactTable = A.Array Int (Integer, Integer) 28 | 29 | factTable :: Int -> FactTable 30 | factTable n = A.listArray (0, n) (zip facts factInvs) 31 | where 32 | facts = scanl (*%) 1 [1 .. fromIntegral n] 33 | factInvs = map (\x -> mod (powMod x (modulus - 2)) modulus) facts 34 | -------------------------------------------------------------------------------- /Math/Prime.hs: -------------------------------------------------------------------------------- 1 | module Math.Prime where 2 | 3 | import Data.List 4 | 5 | primes :: Integral a => [a] 6 | primes = 2 : 3 : [x | i <- [1 ..], j <- [-1, 1], let x = 6 * i + j, isPrime x] 7 | where 8 | isPrime n = null [i | i <- takeWhile (\p -> p * p <= n) primes, mod n i == 0] 9 | 10 | factorization :: Integral a => a -> [a] 11 | factorization n = unfoldr go (n, primes) 12 | where 13 | go (_, []) = Nothing 14 | go (m, pps@(p:ps)) 15 | | m == 1 = Nothing 16 | | p > (floor . (sqrt :: Double -> Double) . fromIntegral) n = Just (m, (1, pps)) 17 | | otherwise = let (q, r) = divMod m p in if r == 0 then Just (p, (q, pps)) else go (m, ps) 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lib-competitive 2 | A library for competitive programming in Haskell 3 | -------------------------------------------------------------------------------- /Scanner.hs: -------------------------------------------------------------------------------- 1 | module Scanner where 2 | 3 | import qualified Data.ByteString.Char8 as B 4 | 5 | readInt :: B.ByteString -> Int 6 | readInt = maybe undefined fst . B.readInt 7 | 8 | readInts :: B.ByteString -> [Int] 9 | readInts = map readInt . B.words 10 | 11 | readIntTuples :: B.ByteString -> [(Int, Int)] 12 | readIntTuples = map ((\[x,y] -> (x,y)) . map readInt . B.words) . B.lines 13 | 14 | readInteger :: B.ByteString -> Integer 15 | readInteger = maybe undefined fst . B.readInteger 16 | 17 | readIntegers :: B.ByteString -> [Integer] 18 | readIntegers = map readInteger . B.words 19 | 20 | readIntegerTuples :: B.ByteString -> [(Integer, Integer)] 21 | readIntegerTuples = map ((\[x,y] -> (x,y)) . map readInteger . B.words) . B.lines 22 | -------------------------------------------------------------------------------- /Tree/SegmentTree.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Tree.SegmentTree where 4 | 5 | import Data.Monoid 6 | 7 | -- modify according to your purpose 8 | instance Monoid Int where 9 | mempty = 0 10 | mappend = (+) 11 | 12 | data SegTree m = 13 | Leaf !m | 14 | Node !m !(SegTree m) !(SegTree m) 15 | deriving (Eq, Show) 16 | 17 | type Index = Int 18 | type Size = Int 19 | 20 | val :: Monoid m => SegTree m -> m 21 | val (Leaf v) = v 22 | val (Node v _ _) = v 23 | 24 | fromList :: Monoid m => Size -> [m] -> SegTree m 25 | fromList 1 [x] = Leaf x 26 | fromList n xs = Node (val left <> val right) left right 27 | where 28 | m = div n 2 29 | (xs1, xs2) = splitAt m xs 30 | left = fromList m xs1 31 | right = fromList (n - m) xs2 32 | 33 | update :: Monoid m => Size -> SegTree m -> Index -> (m -> m) -> SegTree m 34 | update 1 (Leaf v) 1 f = Leaf (f v) 35 | update _ (Leaf _) _ _ = error "update: Pattern match failed." 36 | update n (Node _ l r) i x 37 | | i <= m = Node (val left <> val r) left r 38 | | otherwise = Node (val l <> val right) l right 39 | where 40 | m = div n 2 41 | left = update m l i x 42 | right = update (n - m) r (i - m) x 43 | 44 | query :: Monoid m => Size -> SegTree m -> Index -> Index -> m 45 | query 1 (Leaf v) 1 1 = v 46 | query _ (Leaf _) _ _ = error "query: Pattern match failed." 47 | query n (Node v l r) i j 48 | | (i, j) == (1, n) = v 49 | | j <= m = query m l i j 50 | | i > m = query (n - m) r (i - m) (j - m) 51 | | otherwise = query m l i m <> query (n - m) r 1 (j - m) 52 | where 53 | m = div n 2 54 | -------------------------------------------------------------------------------- /Tree/UnionFind.hs: -------------------------------------------------------------------------------- 1 | module Tree.UnionFind where 2 | 3 | import qualified Data.IntMap.Strict as M 4 | 5 | data UnionFind = UnionFind { 6 | tree :: M.IntMap Point, 7 | rk :: M.IntMap Rank 8 | } deriving (Eq, Show) 9 | 10 | type Point = Int -- greater than 0 11 | type Rank = Int 12 | 13 | initial :: UnionFind 14 | initial = UnionFind M.empty M.empty 15 | 16 | rep :: UnionFind -> Point -> Point 17 | rep uf p 18 | | M.notMember p (tree uf) = p 19 | | tree uf M.! p == p = p 20 | | otherwise = rep uf (tree uf M.! p) 21 | 22 | rank :: UnionFind -> Point -> Rank 23 | rank uf p = M.findWithDefault 1 p (rk uf) 24 | 25 | merge :: UnionFind -> Point -> Point -> UnionFind 26 | merge uf p q 27 | | rp1 == rp2 = uf 28 | | otherwise = UnionFind (M.insert rp2 rp1 (M.insert p2 rp1 (tree uf))) (M.insert rp1 (rk1 + rk2) (rk uf)) 29 | where 30 | p1 = ordBy uf p q 31 | p2 = if p1 == p then q else p 32 | rp1 = rep uf p1 33 | rp2 = rep uf p2 34 | rk1 = rank uf rp1 35 | rk2 = rank uf rp2 36 | 37 | same :: UnionFind -> Point -> Point -> Bool 38 | same uf p1 p2 = rep uf p1 == rep uf p2 39 | 40 | ordBy :: UnionFind -> Point -> Point -> Point 41 | ordBy uf x y 42 | | rx > ry = x 43 | | rx < ry = y 44 | | rep uf x < rep uf y = x 45 | | otherwise = y 46 | where 47 | rx = rank uf x 48 | ry = rank uf y 49 | -------------------------------------------------------------------------------- /WeightedGraph.hs: -------------------------------------------------------------------------------- 1 | module WeightedGraph where 2 | 3 | import qualified Data.Set as S 4 | import qualified Data.ByteString.Char8 as B 5 | import qualified Data.Array.IArray as A 6 | 7 | import Scanner 8 | 9 | type Bound = (Vertex, Vertex) 10 | type Vertex = Int 11 | type Weight = Int 12 | type Edge = ((Vertex, Vertex), Weight) 13 | type Path = [Vertex] 14 | type Graph = A.Array Vertex (S.Set (Vertex, Weight)) 15 | 16 | buildG :: Bound -> [Edge] -> Graph 17 | buildG b = A.accumArray (flip S.insert) S.empty b . map (\((s, t), w) -> (s, (t, w))) 18 | 19 | target :: Graph -> Vertex -> S.Set (Vertex, Weight) 20 | target = (A.!) 21 | 22 | size :: Graph -> Int 23 | size g = let (i,j) = A.bounds g in j - i + 1 24 | 25 | readDirectedEdge :: B.ByteString -> [Edge] 26 | readDirectedEdge = map (constructOneWay . map readInt . B.words) . B.lines 27 | 28 | constructOneWay :: [Int] -> Edge 29 | constructOneWay [s,t,w] = ((s, t), w) 30 | constructOneWay _ = undefined 31 | 32 | readUndirectedEdge :: B.ByteString -> [Edge] 33 | readUndirectedEdge = concatMap (constructTwoWay . map readInt . B.words) . B.lines 34 | 35 | constructTwoWay :: [Int] -> [Edge] 36 | constructTwoWay [s,t,w] = [((s, t), w), ((t, s), w)] 37 | constructTwoWay _ = undefined 38 | --------------------------------------------------------------------------------