{-# LANGUAGE MultiParamTypeClasses #-} module Main where import Control.Arrow import Control.Applicative (Applicative(..),(<$>)) import Control.Monad.Trans.State import Data.Array import Data.Bool import Data.Function import Data.Graph import Data.List import qualified Data.Map as M main :: IO () main = interact (show . (bool (-1) <*> (100000 >)) . countPath . read) graph :: Gr -> Graph graph (g,_,_) = g type Nd = Int type Id = Int type Gr = (Graph, Vertex -> (Nd,Id,[Id]), Id -> Maybe Vertex) data Pair a b = Pair a b instance (Eq a) => Eq (Pair a b) where Pair x _ == Pair y _ = x == y instance (Ord a) => Ord (Pair a b) where Pair x _ `compare` Pair y _ = x `compare` y countPath :: Int -> Int countPath = ($ Pair 0 []) . (count . pred <*> graph . graphFromEdges . series) countF :: Vertex -> Graph -> (Pair Vertex [Vertex] -> State (M.Map (Pair Vertex [Vertex]) Int) Int) -> Pair Vertex [Vertex] -> State (M.Map (Pair Vertex [Vertex]) Int) Int countF e g f (Pair s vs) | s == e = pure 1 | otherwise = case g ! s \\ vs of [] -> pure 100000 xs -> succ . minimum <$> mapM (\ x -> f (Pair x (insertBy (flip compare) s vs))) xs count :: Vertex -> Graph -> (Pair Vertex [Vertex]) -> Int count e g = memo (undefined :: Memo M.Map (Pair Vertex [Vertex]) Int) (countF e g) series :: Int -> [(Int,Int,[Int])] series n = take n $ map (rmout n) $ zipWith mkEdge [1..] $ concat $ unfoldr phi [0] where phi xs = Just (ys, zs) where ys = map succ xs zs = xs ++ ys mkEdge :: Int -> Int -> (Int,Int,[Int]) mkEdge k n = (n,k,[k+n,k-n]) rmout :: Int -> (Int,Int,[Int]) -> (Int,Int,[Int]) rmout n (nd,k,es) = (nd,k,filter (uncurry (&&) . ((0<) &&& (<=n))) es) -- memoisation class MemoTable t where emptyMemoTable :: Ord a => t a b lookupMemoTable :: Ord a => a -> t a b -> Maybe b insertMemoTable :: Ord a => a -> b -> t a b -> t a b class (Monad m) => MemoTableT t m where emptyMemoTableT :: Ord a => t a (m b) lookupMemoTableT :: Ord a => a -> t a (m b) -> Maybe (m b) insertMemoTableT :: Ord a => a -> m b -> t a (m b) -> t a (m b) instance MemoTable M.Map where emptyMemoTable = M.empty lookupMemoTable = M.lookup insertMemoTable = M.insert instance MemoTableT M.Map [] where emptyMemoTableT = M.empty lookupMemoTableT = M.lookup insertMemoTableT = M.insert type Memo t a b = a -> State (t a b) b memoise :: (MemoTable t, Ord a) => Memo t a b -> Memo t a b memoise mf x = do prev <- find x case prev of Just y -> return y Nothing -> do y <- mf x ins x y return y where find k = get >>= return . lookupMemoTable k ins k v = get >>= put . insertMemoTable k v evalMemo :: (MemoTable t, Ord a) => (Memo t) a b -> a -> b evalMemo m v = evalState (m v) emptyMemoTable runMemo :: (MemoTable t, Ord a) => t a b -> (Memo t) a b -> a -> (b, t a b) runMemo tb m v = runState (m v) tb gfun :: (b -> c) -> (c -> b) -> c gfun = (fix .) . (.) memoising :: (Ord a, MemoTable t) => ((a -> State (t a b) b) -> Memo t a b) -> a -> State (t a b) b memoising = gfun memoise -- | makes memo function from functional specified by the second argument. -- The first argument is only for imforming type of memo table will be used. memo :: (MemoTable t, Ord a) => (a -> State (t a b) b) -> ((a -> State (t a b) b) -> Memo t a b) -> (a -> b) memo g f = evalMemo (asTypeOf (memoising f) g) -- | makes memo function which also takes and returns memo table -- , which can be reused. memo' :: (MemoTable t, Ord a) => ((a -> State (t a b) b) -> Memo t a b) -> t a b -> (a -> (t a b, b)) memo' = ((swap .) .) . flip runMemo . memoising swap :: (a, b) -> (b, a) swap (x,y) = (y,x)