『王女様の宝石パターンを見つけよう！』　https://codeiq.jp/ace/yuki_hiroshi/q684

gemstring.hs

import Parsing (parse, line)
import System.IO
import System.Environment
import Data.Char
import Data.Map as M
import Data.Time.Clock
import Control.Monad.State

-- http://d.hatena.ne.jp/mzp/20090308/bench
bench f = do from  <- getCurrentTime
             _     <- f ()
             to    <- getCurrentTime
             return $ to `diffUTCTime` from
toHash :: String -> String
toHash (x:xs) = 'a' : (toHash_ (ord x - ord 'a') 'a' xs)

toHash_ :: Int -> Char -> String -> String
toHash_ offset c [] = []
toHash_ offset c (x:xs) = if c == chr(ord x - offset) then
                            c : (toHash_ offset c xs)
			  else
                            let nc      = chr(ord c + 1)
			    in nc : (toHash_ (ord x - ord nc) nc xs)

type MapM = StateT (Map String Integer) Maybe Integer

count :: String -> String -> MapM
count [] xs = state (\m -> (0, m))
count target@(x:xs) str@(y:ys)
    | str == target = state $ (\m -> (0, m))
    | x == y        = count xs ys
    | otherwise     = do 
                         n0 <- lookupM h
                         n1 <- if n0 == (-1) 
			 then do n' <- count (reverse ys) ys
                                 insertM h n'
			 else return(n0)
		         n2 <- count target (y' : (Main.insert y ys'))
		         return (n1 + n2 + 1 + fromIntegral(length ys))
    where h = toHash ys
          (y', ys') = Main.find (y<) ys


insertM :: String -> Integer -> MapM
insertM h v = state $ (\m -> (v, M.insert h v m))

lookupM :: String -> MapM
lookupM h = state $(\m -> case (M.lookup h m) of
                  Just n  -> (n, m)
		  Nothing -> (-1, m)
		  )

insert :: Ord a => a -> [a] -> [a]
insert v xs = smaller ++ [v] ++ greater
              where
	      smaller = [a| a <- xs, a <  v]
	      greater = [b| b <- xs, b >= v]

find :: Ord a => (a -> Bool) -> [a] -> (a, [a])
find p (x:xs) | p x       = (x, xs)
              | otherwise = let (y, ys) = Main.find p xs
	        in (y, x:ys)

answer :: String -> String -> Integer
answer xs ys = fromIntegral(length ys) + n - fromIntegral(length ys - length xs)
                where Just (n, _) = (runStateT $ count xs ys) empty

-- main
main :: IO ()
main = do
         args <- getArgs
	 elap <- bench (\_ -> (main_ args))
	 print elap
main_ :: [String] -> IO()
main_ args = do
	       gems   <- readFirstLine (args !! 0)
	       target <- readFirstLine (args !! 1)
	       putStrLn ("gems:" ++ gems)
	       putStrLn ("target:" ++ target)
               putStrLn $ show (answer target gems)

-- for test
findIndex :: Eq a => a -> [a] -> Int
findIndex v [] = 0
findIndex v xs = case [i| (x, i) <- zip xs [0..], x == v] of
             [] -> 0
             xs -> head xs

split :: String -> [String]
split [] = [[]]
split xs = (ys : (Main.split zs))
              where (ys, (z:zs)) = splitAt (Main.findIndex '\n' xs) xs

readFirstLine :: String -> IO String
readFirstLine path = do
                    handle <- openFile path ReadMode
		    contents <- hGetLine handle
		    hClose handle
		    return(takeWhile (/= '\n') contents)

test :: IO()
test = do
          contents <- readFile "minilist.txt"
          gems <- readFirstLine "minis.txt"
          putStrLn $ show $ and [(answer xs gems) == (fromIntegral n)| [((n, xs), "")] <- (Prelude.map (parse line) (Main.split contents)) ]

実行方法と結果:
$gemstring.exe gems.txt princess.txt
gems:abbbbcddddeefggg
target:eagcdfbe
5578864439
0.035002s