Snippets.hs

module MPS.Snippets where

import MPS.Hack.Dot
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.Graph.Inductive (Gr, mkGraph)
import Data.Foldable
import Data.Time.Clock.POSIX
import Data.Time
import Data.List (transpose, sort, group, (\\), sortBy)

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 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 Test.QuickCheck
import Text.RegexPR
import Text.Pandoc
import Text.Template
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 Debug.Trace
import Numeric








-- 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 [] _ = True
starts_with _ [] = False
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 (try unicode_char <|> anyChar)

unescape_unicode_xml s = parse unescape_parser s

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
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

interpolate :: String -> [(String, String)] -> String
interpolate s params = B.unpack $ substitute (B.pack s) (context params)
  where 
    context = map packPair >>> to_h
    packPair (x, y) = (B.pack x, B.pack y)
    
-- 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