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 Prelude hiding ((.), sum, product, maximum, minimum, 
  foldl, foldr, foldl1, foldr1, concat, concatMap, and, or, any, all, elem, (^))
import Data.List (transpose, sort, group, (\\), sortBy)

-- 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) 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
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 = from_utf8 >>> readMarkdown defaultParserState >>> writeHtml defaultWriterOptions
markdown' = from_utf8 >>> readMarkdown defaultParserState >>> writeHtmlString defaultWriterOptions >>> to_utf8


-- Monad
a ^ b = a .liftM b
infixl 9 ^

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
from_utf8 = Codec.decodeString
to_utf8 = Codec.encodeString