Solution for Google Code Jam "Dijkstra" problem (https://code.google.com/codejam/contest/6224486/dashboard#s=p2)

Dijkstra.hs

module Dijkstra where

import Data.Char (isDigit)
import Data.Map (Map)
import qualified Data.Map as M

type Q = String

data Dijkstra = Dijkstra Int [Q] deriving Show

main = do
        t <- getLine
        contents <- getContents
        let problems = (parse $ lines contents)
        mapM_ (putStrLn . presentCase) (zip [1..] . solveAll $ problems)

parse :: [String] -> [Dijkstra]
parse [] = []
parse (nx:l:xs) = (dijk nx l) : (parse xs)
  where
      dijk nx l = let (_, x) = span isDigit nx
                    in Dijkstra (read x) (map (\c -> [c]) l)

presentCase :: (Int, Bool) -> String
presentCase (i, result)  = "Case #" ++ show i ++ ": " ++ presentResult result

presentResult :: Bool -> String
presentResult True  = "YES"
presentResult False = "NO"

solveAll :: [Dijkstra] -> [Bool]
solveAll = map solve

solve :: Dijkstra -> Bool
solve (Dijkstra x l) = let
                           n                = length l
                           xl               = take (myMod x n) . cycle $ l
                           lValue           = reduceQ l
                           xlValue          = powQ lValue x
                           reducesCorrectly = do
                               iBreakIndex <- reduceQLeft xl "i"
                               kBreakIndex <- reduceQRight xl "k"
                               return ((kBreakIndex + iBreakIndex) < (n * x))
                       in
                           xlValue == "-1" &&
                           case reducesCorrectly of
                               Just True -> True
                               _         -> False

reduceQ :: [Q] -> Q
reduceQ = foldl1 multQ

reduceQTarget q' multF i res acc y =
    if res == Nothing
        then
            let
                m = multF acc y
            in
                if m == q'
                    then (i + 1, Just (i + 1), m)
                    else (i + 1, Nothing, m)
        else (i + 1, res, acc)

reduceQLeft :: [Q] -> Q -> Maybe Int
reduceQLeft l q' = let (_, result, _) = foldl f (0, Nothing, "1") $ l in result
  where
      f = \(i, res, acc) y -> reduceQTarget q' multQ i res acc y

reduceQRight :: [Q] -> Q -> Maybe Int
reduceQRight l q' = let (_, result, _) = foldr f (0, Nothing, "1") $ l in result
  where
      f = \y (i, res, acc) -> reduceQTarget q' (flip multQ) i res acc y

powQ :: Q -> Int -> Q
powQ x e = powQ' (e `mod` 4)
  where
      powQ' 0 = "1"
      powQ' 1 = x
      powQ' e = multQ x $ powQ' (e - 1)

multQ :: Q -> Q -> Q
multQ x y = let
                neg = (negQ x) `xor` (negQ y)
            in
                case M.lookup (absQ x) q >>= M.lookup (absQ y) of
                    Nothing -> error $ "Invalid Q " ++ x ++ " " ++ y
                    Just z  -> if neg then flipQ z else z

myMod :: Int -> Int -> Int
myMod x n = min (x * n) (n * 4)

xor :: Bool -> Bool -> Bool
xor True p  = not p
xor False p = p

absQ :: Q -> Q
absQ x = [last x]

flipQ :: Q -> Q
flipQ ('-':q') = q'
flipQ q'       = '-':q'

negQ :: Q -> Bool
negQ q' = head q' == '-'

q :: Map Q (Map Q Q)
q = M.fromList [("1", M.fromList [("1", "1"), ("i",  "i"), ("j",  "j"), ("k",  "k")]),
                ("i", M.fromList [("1", "i"), ("i", "-1"), ("j",  "k"), ("k", "-j")]),
                ("j", M.fromList [("1", "j"), ("i", "-k"), ("j", "-1"), ("k",  "i")]),
                ("k", M.fromList [("1", "k"), ("i",  "j"), ("j", "-i"), ("k", "-1")])]