module MPS.Snippets where import Control.Arrow ((&&&), (>>>)) import Control.Monad hiding (join) import Control.Parallel import Data.Char import Data.Maybe import Data.Time.Calendar import Numeric import MPS.Hack.Dot import Test.QuickCheck import Text.RegexPR import qualified Data.Array as A import qualified Data.List as L import qualified Data.Set as S import qualified Data.Graph as G import qualified Data.Map as M import Data.Graph.Inductive (Gr, mkGraph) import qualified System.IO.Unsafe as Unsafe import qualified Text.ParserCombinators.Parsec as P import Data.Foldable import Debug.Trace import Text.Pandoc import qualified Codec.Binary.UTF8.String as Codec import System.Directory import Text.ParserCombinators.Parsec (many, char, many1, digit, (<|>), Parser, anyChar) import qualified Prelude as Prelude import Prelude hiding ((.), sum, product, maximum, minimum, foldl, foldr, foldl1, foldr1, concat, concatMap, and, or, any, all, elem, (^)) import Data.List (transpose, sort, group, (\\), sortBy) import Text.InterpolatedString.QQ -- List join x xs = L.intercalate x xs join' xs = xs.concat first = head -- Set requires Ord instance, so use nub when -- xs is not comparable unique xs = xs.to_set.to_list is_unique xs = xs.unique.length == xs.length same xs = xs.unique.length == 1 times = flip replicate upto m n = flip enumFromTo m n downto m n = [n, n-1.. m] remove_at n xs = xs.take n ++ xs.drop (n+1) insert_at n x xs = splitted.fst ++ [x] ++ splitted.snd where splitted = xs.splitAt n replace_at n x xs = xs.take n ++ [x] ++ xs.drop (n+1) at i xs = xs !! i slice l r xs = xs.take r.drop l cherry_pick ids xs = ids.map(xs !!) reduce f xs = foldl1 f xs reduce' f (x:xs) = inject' x f xs reduce' _ _ = error "reduce' takes a list of at least 2 elements" inject init f xs = foldl f init xs inject' init f xs = foldl' f init xs none_of f xs = not $ any f xs select = filter reject f = filter(not ... f) lookup' i xs = xs.lookup i .fromJust inner_map f xs = xs.map(map f) inner_reduce f xs = xs.map(reduce f) inner_inject init f xs = xs.map(inject init f) label_by f xs = xs.map(f &&& id) labeling f xs = xs.map(id &&& f) in_group_of _ [] = [] in_group_of n xs = h : t.in_group_of(n) where (h, t) = xs.splitAt(n) split_to n xs = xs.in_group_of(size) where l = xs.length size = if l < n then 1 else l `div` n apply x f = f x send_to = apply let_receive f s = flip f s map_send_to x fs = fs.map(send_to(x)) belongs_to xs x = xs.elem x has xs x = flip belongs_to xs x indexed xs = xs.zip([0..]) map_with_index f xs = xs.indexed.map(f) ljust n x xs | n < xs.length = xs | otherwise = ( n.times x ++ xs ).reverse.take n.reverse rjust n x xs | n < xs.length = xs | otherwise = ( xs ++ n.times x ).take n ub = takeWhile lb f = dropWhile ( not ... f ) between a b xs = xs.lb a .ub b not_null xs = xs.null.not powerslice xs = [ xs.slice j (j+i) | i <- l.downto 1, j <- [0..l - i] ] where l = xs.length -- only works for sorted list -- but could be infinite -- e.g. a `common` b `common` c common _ [] = [] common [] _ = [] common a@(x:xs) b@(y:ys) | x .is y = y : common xs b | x < y = common xs b | otherwise = common a ys -- faster reverse sort rsort xs = xs.L.sortBy(\a b -> b `compare` a) encode xs = xs.group.map (length &&& head) decode xs = xs.map(\(l,x) -> l.times x).join' only_one [_] = True only_one _ = False concat_map f xs = concatMap f xs -- Map to_h xs = xs.M.fromList -- QuickCheck quick_check prop = quickCheck prop qc prop = quick_check prop -- BackPorts on :: (b -> b -> c) -> (a -> b) -> a -> a -> c (*) `on` f = \x y -> f x * f y -- Ord compare_by f = on compare f eq b a = (==) a b is a b = eq a b is_not a b = not (is a b) -- Tuple swap (x,y) = (y,x) tuple2 xs = (xs.first, xs.last) tuple3 xs = (xs.first, xs.tail.first, xs.last) list2 (x,y) = [x,y] list3 (x,y,z) = [x,y,z] filter_fst f = filter(\(a,_) -> a.f) filter_snd f = filter(\(_,b) -> b.f) only_fst = map(\(a,_) -> a) only_snd = map(\(_,b) -> b) map_fst f = map(\(a,b) -> (a.f, b)) map_snd f = map(\(a,b) -> (a, b.f)) pair f a b = f (a,b) triple f a b c = f (a,b,c) splash f (a,b) = f a b splash3 f (a,b,c) = f a b c twin x = (x,x) -- Control.Arrow merge f = map (pair f) -- IO purify = Unsafe.unsafePerformIO read_pure x = x.readFile.purify write_pure file c = writeFile file c -- Parallel p_eval xs = xs.par(xs.reduce(par)) p_reduce op xs = xs.p_eval.reduce(op) p_map op xs = xs.map(op).p_eval p_eval' xs = xs.pseq( xs.reduce par ) p_reduce' op xs = xs.p_eval'.reduce op p_map' op xs = xs.map op .p_eval' p_split_to n xs = xs.in_group_of(n).L.transpose p_map_reduce_to n m r xs = xs.split_to n .map m .p_reduce' r p_map_reduce m r xs = p_map_reduce_to 16 m r xs -- Matrix row n i = i `div` n col n i = i `mod` n m !!! i = m.at(row n i) .at(col n i) where n = m.first.length -- Runtime -- eval_with libs s = Eval.unsafeEval s libs.purify.fromJust -- eval s = eval_with s [] -- Date date = fromGregorian splash_date = toGregorian -- String split re xs | xs.match re .isJust = splitRegexPR re xs .reject empty | otherwise = [xs] split' s = s.lines.reject empty sub = subRegexPR gsub = gsubRegexPR match = matchRegexPR strip s = s.sub "^\\s*" "" .reverse .sub "^\\s*" "" .reverse empty s = case s.match("\\S") of Just _ -> False Nothing -> True to_s x = x.show -- Var is_palindrom s = s.reverse.is(s) -- Integer collapse' [] _ r = r collapse' (x:xs) q r = collapse' xs (q+1) (r + x * 10 <^> q) collapse xs = collapse' (xs.reverse.map from_i) 0 0 .fromIntegral explode n = n.show.map digitToInt base p n = showIntAtBase p intToDigit n "" from_i n = fromIntegral n int_square n = n.fromIntegral.sqrt.round :: Integer -- Fold to_list xs = toList xs -- Set to_set xs = xs.S.fromList -- Array to_a xs = xs.A.listArray (0, xs.length - 1) to_a' i xs = A.listArray i xs hist bnds ns = A.accumArray (+) 0 bnds [(n, 1) | n <- ns, A.inRange bnds n] -- Graph1 to_g'' = G.buildG -- Graph2 type GType = Int to_g_with :: Real a => (GType -> c) -> [(GType, GType, a)] -> Gr c a to_g_with mapper xs = mkGraph (xs.label_nodes) xs where node_pair x = (x, mapper x) label_nodes xs = xs.map(\(a,b,_) -> [a,b]) .join' .unique .map node_pair to_g xs = to_g_with id xs graph_map xs = (edges, vertex_map) where vertices = xs.map(\(a,b,_)-> [a,b]).join'.unique.sort vertex_map = vertices.indexed r_vertex_map = vertex_map.map(swap) edges = xs.map(\(a,b,c) -> (r_vertex_map.lookup' a, r_vertex_map.lookup' b, c)) to_g' xs = let (edges, vertex_map) = graph_map xs in edges.to_g_with (vertex_map.flip lookup') -- Parser parse p s = case (P.parse p "" s) of Left err -> err.show.error Right x -> x -- Algorithm -- DP -- OK usage is a bit tricky -- xs.cache block where -- block a list = closure -- The idea is to bound a in your closure -- what is this a anyway? -- It's an array that lazily caches the result -- from your list processing function, i.e. what's -- inside your closure. -- This implies that your processing function -- is of type: [x] -> [x] cache f xs = a.to_list where a = xs.g.to_a g ys = f a ys -- Greedy greedy_count x xs = greedy x xs .length greedy x xs = greedy' x (xs.rsort) where greedy' x _ | x < 0 = [[]] greedy' 0 _ = [[]] greedy' x [y] = if (x `mod` y) .is 0 then [ (x `div` y).from_i .times y ] else [[]] greedy' s (a:as) = [ h ++ t | n <- [0..(div s a)].reverse, let h = n.from_i.times a, t <- greedy' (s - n * a) as, let c = h ++ t, c.sum == s ] greedy' _ _ = error "argument type" -- Debug trace' x = trace (x.show) x -- Text markdown = b2u >>> readMarkdown defaultParserState >>> writeHtml defaultWriterOptions markdown' = b2u >>> readMarkdown defaultParserState >>> writeHtmlString defaultWriterOptions >>> u2b -- Monad a ^ b = a .liftM b infixl 9 ^ (<^>) = (Prelude.^) infixr 8 <^> a <.> b = a .liftM b infixl 9 <.> -- String lower = map toLower upper = map toUpper starts_with _ [] = False starts_with [] _ = True starts_with (x:xs) (y:ys) | x == y = starts_with xs ys | otherwise = False ends_with x y = starts_with (x.reverse) (y.reverse) capitalize [] = [] capitalize (x:xs) = [x].upper ++ xs.lower camel_case = split "_" >>> map capitalize >>> join' snake_case = gsub "\\B[A-Z]" "_\\&" >>> lower -- XML unicode_char :: Parser Char unicode_char = do char '&' char '#' word <- many1 digit char ';' return $ chr (read word) unescape_parser :: Parser String unescape_parser = many (unicode_char <|> anyChar) unescape_unicode_xml s = parse unescape_parser s -- IO ls s = getDirectoryContents s <.> (\\ [".", ".."]) -- Text filter_comment = lines >>> map strip >>> reject null >>> reject (head >>> (== '#')) >>> unlines -- UTF8 b2u = Codec.decodeString u2b = Codec.encodeString -- QQ here = istr