ジェムストリング問題 ref: http://qiita.com/nobsun/items/efe6a8965f5a5bfe5d41

file1.txt

ghci> :set +s
ghci> patternIndex "abbbbcddddeefggg" "eagcdfbe"
5578864439
(0.05 secs, 28983792 bytes)

gemstring.hs

{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE NPlusKPatterns #-}
module Main where

import Data.List (unfoldr,delete,genericLength,group,foldl1')
import Data.Ratio (numerator,(%))
import Math.Polynomial (Poly,Endianness(..),poly,multPoly,polyCoeffs)
       -- cabal install polynomial

main :: IO ()
main = do
  { gems <- readFile "gems.txt"
  ; princess <- readFile "princess.txt"
  ; print $ patternIndex (head $ words gems) (head $ words princess)
  }

patternIndex :: (Eq a, Ord a) => [a] -> [a] -> Integer
patternIndex xs pat = sum $ unfoldr phi (xs,pat)
  where
    phi (_ ,[]  ) = Nothing
    phi (ys,z:zs) = Just (succ $ ggpermsBefore ys z, (delete z ys,zs))

ggpermsBefore :: (Eq a, Ord a) => [a] -> a -> Integer
ggpermsBefore xs a = genericLength bs + sum [ggperms (delete b xs) | b <- bs]
  where
    gs = group xs
    ks = map head gs
    bs = takeWhile (a>) ks

ggperms :: Eq a => [a] -> Integer        -- 語長ごとの数え上げの和
ggperms xs = sum $ map (gperms xs) [1..length xs]

gperms :: Eq a => [a] -> Int -> Integer  -- 一般順列の数え上げ
gperms xs r = numerator
           $ (* toRational (r !)) 
           $ (!! r) $ polyCoeffs LE 
           $ foldl1' multPoly 
           $ map eg ls
  where
    ls = map length (group xs)

eg :: Int -> Poly Rational               -- 指数型母関数
eg m = poly LE $ map ((1 %) . (!)) [0..m]

(!) :: Integral a => a -> Integer        -- 階乗
(!) 0        = 1
(!) n@(n'+1) = fromIntegral n * (n'!)