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.gsub "^\\s*" "" .gsub "\\s*$" ""
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