{-# LANGUAGE NoMonomorphismRestriction #-} module MPS where import Prelude hiding ((.), sum, product, maximum, minimum, foldl, foldr, foldl1, foldr1, concat, concatMap, and, or, any, all, elem, (^), (>), (/)) import qualified Prelude as Prelude import Control.Arrow ((&&&), (>>>), (<<<)) import Control.Monad hiding (join) import Control.Parallel import Data.Char import Data.Maybe import Data.Foldable import Data.Time.Clock.POSIX import Data.Time import Data.List (transpose, group, (\\), sortBy, isPrefixOf, isSuffixOf) import qualified Data.Array as A import qualified Data.List as L import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString.Lazy.Char8 as B import System.Locale import System.Posix.Files import System.IO import System.Directory import qualified System.IO.Unsafe as Unsafe import Text.RegexPR import Text.InterpolatedString.QQ import Text.ParserCombinators.Parsec (many, char, many1, digit, (<|>), Parser, anyChar, try) import qualified Text.ParserCombinators.Parsec as P import Codec.Binary.Base64.String as C import qualified Codec.Binary.UTF8.String as Codec import qualified Codec.Compression.GZip as GZip import System.FilePath ((</>)) import Debug.Trace import Numeric -- base DSL (.) :: a -> (a -> b) -> b a . f = f a infixl 9 . (>) = (>>>) infixl 8 > (^) = flip fmap infixl 8 ^ (/) :: FilePath -> FilePath -> FilePath (/) = (</>) infixl 5 / -- List join = L.intercalate join' = concat first = head second = at 1 third = at 2 forth = at 3 fifth = at 4 sixth = at 5 seventh = at 6 eighth = at 7 ninth = at 8 tenth = at 10 -- Set requires Ord instance, so use nub when -- xs is not comparable unique = to_set > to_list is_unique xs = xs.unique.length == xs.length same = unique > length > is 1 times = flip replicate upto = flip enumFromTo 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 = flip (!!) slice l r xs = xs.take r.drop l cherry_pick ids xs = ids.map(xs !!) reduce = foldl1 reduce' f (x:xs) = inject' x f xs reduce' _ _ = error "reduce' takes a list of at least 2 elements" inject init f = foldl f init inject' init f = foldl' f init none_of f = any f > not select = filter reject f = filter(f > not) lookup' i xs = xs.lookup i .fromJust inner_map f = map (map f) inner_reduce f = map(reduce f) inner_inject init f = map(inject init f) label_by f = map(f &&& id) labeling f = 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 = flip f map_send_to x = map(send_to(x)) belongs_to = flip elem has = flip belongs_to indexed = zip([0..]) map_with_index f = 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 = 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 -- BackPorts on :: (b -> b -> c) -> (a -> b) -> a -> a -> c (*) `on` f = \x y -> f x * f y -- Ord compare_by = on compare eq = flip (==) is = eq is_not a b = not (is a b) isn't = is_not aren't = is_not -- Tuple swap (x,y) = (y,x) tuple2 = first &&& last tuple3 xs = (xs.first, xs.second, xs.third) list2 (x,y) = [x,y] list3 (x,y,z) = [x,y,z] filter_fst f = filter(fst > f) filter_snd f = filter(snd > f) only_fst = map fst only_snd = map snd map_fst f = map(\(a,b) -> (f a, b)) map_snd f = map(\(a,b) -> (a, f b)) 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) -- 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 -- 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 Prelude.^ 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 = fromIntegral int_square n = n.fromIntegral.sqrt.round :: Integer -- Fold to_list = toList -- Set to_set = S.fromList -- Array to_a xs = A.listArray (0, xs.length - 1) xs to_a' i xs = A.listArray i xs hist bnds ns = A.accumArray (+) 0 bnds [(n, 1) | n <- ns, A.inRange bnds n] -- Parser parse p s = case (P.parse p "" s) of Left err -> err.show.error Right x -> x -- Debug trace' x = trace (x.show) x -- String lower = map toLower upper = map toUpper starts_with = isPrefixOf ends_with = isSuffixOf capitalize [] = [] capitalize (x:xs) = [x].upper ++ xs.lower camel_case = split "_" > map capitalize > join' snake_case = gsub "\\B[A-Z]" "_\\&" > lower -- XML unescape_unicode_xml s = parse unescape_parser s where unicode_char :: Parser Char unicode_char = do char '&' char '#' word <- many1 digit char ';' return $ chr (read word) unescape_parser :: Parser String unescape_parser = many (try unicode_char <|> anyChar) escape_unicode_xml :: String -> String escape_unicode_xml = concatMap fixChar where fixChar '<' = "<" fixChar '>' = ">" fixChar '&' = "&" fixChar '"' = "\"" fixChar c | ord c < 0x80 = [c] fixChar c = "&#" ++ show (ord c) ++ ";" -- IO purify = Unsafe.unsafePerformIO read_pure x = x.readFile.purify write_pure file c = writeFile file c ls s = getDirectoryContents s ^ (\\ [".", ".."]) file_size :: String -> IO Integer file_size path = withFile (path.u2b) ReadMode hFileSize file_mtime :: String -> IO UTCTime file_mtime path = getFileStatus (path.u2b) ^ modificationTime ^ realToFrac ^ posixSecondsToUTCTime read_binary_file :: String -> IO String read_binary_file path = path.u2b.B.readFile ^ B.unpack get_permissions :: String -> IO Permissions get_permissions path = getPermissions (path.u2b) get_current_directory :: IO String get_current_directory = getCurrentDirectory ^ b2u -- Text filter_comment = lines > map strip > reject null > reject (head > (== '#')) > unlines -- Time now :: IO UTCTime now = getCurrentTime format_time :: String -> UTCTime -> String format_time = formatTime defaultTimeLocale -- UTF8 b2u = Codec.decodeString u2b = Codec.encodeString -- QQ here = istr -- compress zip64, unzip64 :: String -> String zip64 = B.pack > GZip.compress > B.unpack > C.encode unzip64 = C.decode > B.pack > GZip.decompress > B.unpack