reddit programming problem

bench.hs

import qualified Data.Map as M
import qualified Data.Set as S
import Data.Semigroup
import Control.Applicative
import Data.List
import Data.Maybe
import Criterion.Main
import System.Random
import Data.Char

joshcc4 :: String -> Int
joshcc4 inp = (+1) . minimum . catMaybes $ allAnswers
    where
      allDistinct = S.toList (S.fromList inp)
      mins = map (foldl1 (liftA2 min)) (transpose lastOccOfChar)
      maxs = map (foldl1 (liftA2 max)) (transpose lastOccOfChar)
      allAnswers = zipWith (liftA2 (-)) maxs mins
      lastOccOfChar = map f allDistinct
      f x = res
          where
            res = Nothing:zipWith g res (zip [0..] inp)
            g p (ind, n) | x == n = Just ind
                         | otherwise = p


igastako :: String -> Int
igastako s = minimum . map length . filter valid . substrings $ s
  where
    valid         = (`containsAll` distinctChars)
    distinctChars = S.fromList s
    substrings    = concatMap (tail . inits) . tails
    containsAll   = flip S.isSubsetOf . S.fromList

kuribas :: String -> Int
kuribas [] = 0
kuribas s =
  getMin_ $ foldl' solve1 (M.empty, maxBound, s, 0) s
  where
    getMin_ (_, mn, _, _) = mn
    maxD = S.size $ S.fromList s
    shorten :: M.Map Char Int -> String -> Int -> (M.Map Char Int, String, Int)
    shorten mp (c:cs) len =
      case M.lookup c mp of
        Just n | n > 1 -> shorten (M.adjust (subtract 1) c mp) cs (len-1)
        _ -> (mp, c:cs, len)
    shorten _ _ _ = error "unreachable"
    solve1 (mp, mn, init_, len) c =
      (mp2, mn2, init2, len2)
      where (mp2, init2, len2) =
              shorten (M.insertWith (+) c 1 mp) init_ (len+1)
            mn2 | M.size mp2 == maxD = min mn len2
                | otherwise = mn

kuribas2 :: String -> Int
kuribas2 [] = 0
kuribas2 s =
  getMin_ $ foldl' solve1 (M.empty, maxBound, s, 0, 0) s
  where
    getMin_ (_, mn, _, _, _) = mn
    shorten :: M.Map Char Int -> String -> Int -> (M.Map Char Int, String, Int)
    shorten mp (c:cs) len =
      case M.lookup c mp of
        Just n | n > 1 -> shorten (M.adjust (subtract 1) c mp) cs (len-1)
        _ -> (mp, c:cs, len)
    shorten _ _ _ = error "unreachable"
    solve1 (mp, mn, init_, len, sz) c =
      (mp2, mn2, init2, len2, M.size mp2)
      where (mp2, init2, len2) =
              shorten (M.insertWith (+) c 1 mp) init_ (len+1)
            mn2 | M.size mp2 == sz = min mn len2
                | otherwise = len2
                

penner :: String -> Int
penner s =
  let (ans, allCharMap) = foldl (go allCharMap) (Nothing, M.empty) (zip s [0..])
  in fromMaybe (length s) ans
  where
  go allCharMap (shortestSoFar, acc) (currentChar, currentIndex) =
    let updatedCharMap = M.insert currentChar currentIndex acc
        seenAllChars = M.size updatedCharMap == M.size allCharMap
        earliestInd = minimum $ M.elems updatedCharMap
        diff = (currentIndex - earliestInd) + 1
        smallest = if seenAllChars
                      then case shortestSoFar of
                              Just soFar -> Just $ min diff soFar
                              Nothing -> Nothing
                      else Just diff
      in (smallest, updatedCharMap)

uniqueChars :: String -> String
uniqueChars = sort . nub

halogen :: String -> Int
halogen st = go st
  where
    allChars = uniqueChars st
    go [] = 0
    go s = let fs = drop 1 s
               ls = drop 1 (reverse s)
           in if uniqueChars fs == allChars
                 then if uniqueChars ls == allChars
                         then min (go fs) (go ls)
                         else go fs
                 else if uniqueChars ls == allChars
                         then go ls
                         else length s


-- The function we're benchmarking.
fib m | m < 0     = error "negative!"
      | otherwise = go m
  where
    go 0 = 0
    go 1 = 1
    go n = go (n-1) + go (n-2)

-- Our benchmark harness.
main = do
  gen <- getStdGen
  let tiny40 = take 40 $ randomRs ('a', 't') gen
      small20 = take 100 $ randomRs ('a', 't') gen
      str4 = take 10000 $ randomRs ('a', 'd') gen
      str20 = take 10000 $ randomRs ('a', 't') gen
      str200 = take 10000 $ randomRs (chr 100, chr 200) gen

  defaultMain
    [ bgroup "20 x 40" [ bench "penner"  $ whnf penner tiny40
                       , bench "joshcc4"  $ whnf joshcc4 tiny40
                       , bench "igastako"  $ whnf igastako tiny40
                       , bench "halogen" $ whnf halogen tiny40
                       , bench "kuribas" $ whnf kuribas tiny40
                       , bench "kuribas 2.0" $ whnf kuribas2 tiny40
                        ]

    , bgroup "20 x 100" [ bench "penner"  $ whnf penner small20
                        , bench "joshcc4"  $ whnf joshcc4 small20
                        , bench "igastako"  $ whnf igastako small20
                        , bench "kuribas" $ whnf kuribas small20
                        , bench "kuribas 2.0" $ whnf kuribas2 small20
                        ]
        
    , bgroup "4 x 10000" [ bench "penner"  $ whnf penner str4
                         , bench "joshcc4"  $ whnf joshcc4 str4
                         , bench "kuribas" $ whnf kuribas str4
                         , bench "kuribas 2.0" $ whnf kuribas2 str4
               ]
    , bgroup "20 x 10000" [ bench "penner"  $ whnf penner str20
                          , bench "joshcc4"  $ whnf joshcc4 str20
                          , bench "kuribas" $ whnf kuribas str20
                          , bench "kuribas 2.0" $ whnf kuribas2 str20
               ]
    , bgroup "200 x 10000" [ bench "penner"  $ whnf penner str200
                           , bench "joshcc4"  $ whnf joshcc4 str200
                           , bench "kuribas" $ whnf kuribas str200
                           , bench "kuribas 2.0" $ whnf kuribas2 str200
                           ]
    ]