Google Code Jam/The Price is Wrong

import Data.List 
import Data.Function
import Data.Ord
import Data.Maybe

type Price = (String,Int)
type Prices = [(String,Int)]

-- | finding the longest strings 
bests :: [[a]] -> [[a]] 
bests = head . groupBy ((==) `on` length) . sortBy (flip . comparing $ length)

-- | longest sequences of possibly nonconsecutive elements (from IRC help)
longest xs =  bests . foldr (\x bs -> bSW x bs ++ bs) [] $ xs where
	bSW x bs   =  bests $ [x] : (map (x:) . filter ((x <=). head) $ bs)

-- solutions are the complements of the longest sequences
sol xs = map (xs \\) . longest $ xs where

parsePrices :: [String] -> Prices
parsePrices [x,y] = zip (words x) (map read. words $ y)

parseCases :: String -> [Prices]
parseCases x = let (n:ts) = lines x in
	take (read n) . unfoldr (\x -> if null x then Nothing else Just (parsePrices. take 2 $ x, drop 2 x)) $ ts

main = do
	ts <- parseCases `fmap` getContents
	flip mapM_ (zip [1..] ts) $ \(i,t) -> do
		putStr $ "Case #" ++ show i ++ ": "
		let 	(_,n) = unzip t
			r x = fromJust . find ((== x) . snd) $ t
		putStrLn . unwords . map fst . head . sort . map (sort . map r) . sol $ n