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 hiding (parse) import Prelude hiding ((.), sum, product, maximum, minimum, foldl, foldr, foldl1, foldr1, concat, concatMap, and, or, any, all, elem) import Data.List (transpose, sort, elemIndex, tails, inits, group, elemIndices, groupBy, (\\), sortBy, nub) -- 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 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 n [] = [] 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 [x] = 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,b) -> a.f) filter_snd f = filter(\(a,b) -> b.f) only_fst = map(\(a,b) -> a) only_snd = map(\(a,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.match("^\\s*(.*?)\\s*$").fromJust.snd.first.snd 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' [] q r = r collapse' (x:xs) q r = collapse' xs (q+1) (r + x * 10^q) collapse xs = collapse' (xs.reverse) 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,w) -> [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,c)-> [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 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 ys = [[]] 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 ] -- Debug trace' x = trace (x.show) x -- Text markdown = from_utf8 >>> readMarkdown defaultParserState >>> writeHtml defaultWriterOptions markdown' = from_utf8 >>> readMarkdown defaultParserState >>> writeHtmlString defaultWriterOptions >>> to_utf8 -- Monad a <^> b = a .liftM b infixl 4 <^> a <.> b = a .liftM b infixl 9 <.> -- String lower = map toLower upper = map toUpper -- 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 from_utf8 = Codec.decodeString to_utf8 = Codec.encodeString