{-# LANGUAGE RankNTypes #-}
import Control.Applicative
import Control.Monad
import Control.Monad.Fail
import Data.Char
import System.Environment
import System.IO
data C a = R a | F | C (Char -> C a) | B (C a) (C a)
newtype P a = P { getP :: forall b . (a -> C b) -> C b }
instance Functor P where
fmap f (P c) = P (c . (. f))
instance Applicative P where
pure a = P ($ a)
P f <*> P a = P (f . (a . ) . (.))
P a *> P b = P (a . const . b)
P a <* P b = P (a . ((b . const) .))
instance Monad P where
P a >>= f = P (a . flip (getP . f))
instance MonadFail P where
fail _ = empty
instance Alternative P where
empty = P (const F)
P a <|> P b = P (\c -> reduce $ B (a c) (b c))
instance MonadPlus P where
mzero = empty
mplus = (<|>)
reduce (B F b) = b
reduce (B a F) = a
reduce (B (C a) (C b)) = C (\i -> reduce $ B (a i) (b i))
reduce c = c
runP :: P a -> String -> [a]
runP p i = extract $ go (getP p R) i where
extract (R r) = [r]
extract (B a b) = extract a ++ extract b
extract _ = []
go p [] = p
go F _ = F
go p (a:r) = go (step p a) r
step :: C a -> Char -> C a
step (C p) a = p a
step (B a b) i = reduce (B (step a i) (step b i))
step _ _ = F
getC :: P Char
getC = P C
peek :: P Char
peek = P (\c -> C (\i -> step (c i) i))
replace :: Char -> P ()
replace i = P (\c -> step (c ()) i)
eos :: P ()
eos = P (\c -> strip (c ())) where
strip r@(R _) = r
strip F = F
strip (C p) = F
strip (B a b) = reduce (B (strip a) (strip b))
satisfy :: (Char -> Bool) -> P Char
satisfy p = getC >>= \c -> if p c
then return c
else empty
munch :: (Char -> Bool) -> P String
munch p = go id where
go acc = let
r = acc []
in (getC >>= \c -> if p c
then go (acc . (c:))
else r <$ replace c
) <|> (r <$ eos)
char :: Char -> P Char
char c = satisfy (== c)
number :: (Num n) => P n
number = go 0 where
go t = do
d <- (fromIntegral . digitToInt) <$> satisfy isDigit
let t' = t * 10 + d
go t' <|> return (fromInteger t')
countWithSep :: P Bool -> P s -> P Integer
countWithSep i s = let
go n = n `seq` i >>= \i' -> let
n' = if i' then n + 1 else n
in (s *> go n') <|> return n'
in go 0 <|> return 0
range :: P (Integer,Integer)
range = (,) <$> number <*> (char '-' *> number)
line :: Int -> P Bool
line v = do
~(lo,hi) <- range
munch isSpace
c <- getC
char ':'
munch isSpace
case v of
1 -> fmap ((&&) <$> (>= lo) <*> (<= hi)) $
countWithSep (fmap (==c) $ satisfy (not . isSpace)) (return ())
2 -> (==1) <$> cpp c 0 [lo,hi] 1
where
cpp _ n [] _ = n <$ munch (not . isSpace)
cpp x n l@(c:r) p
| c == p = getC >>= \x' -> let
n' = if x' == x
then n + 1
else n
in cpp x n' r (p + 1)
| otherwise = getC *> cpp x n l (p + 1)
problemFile :: Int -> P Integer
problemFile v = countWithSep (line v) (char '\n') <* (return () <|> (() <$ char '\n'))
example :: String
example = "1-3 a: abcde\n1-3 b: cdefg\n2-9 c: ccccccccc"
main = do
~[fn,v] <- getArgs
f <- readFile fn
let (r:_) = runP (problemFile $ read v) f
print r